// ShareData. This is the main entry point.
// Because this can recurse deeply it needs to be run by the main thread.
// Also it manipulates the heap in ways that could mess up other threads
// so we need to stop them before executing this.
void ShareData(TaskData *taskData, Handle root)
{
if (! root->Word().IsDataPtr())
return; // Nothing to do. We could do handle a code pointer but it shouldn't occur.
// Request the main thread to do the sharing.
ShareRequest request(root);
processes->MakeRootRequest(taskData, &request);
// Raise an exception if it failed.
if (! request.result)
raise_exception_string(taskData, EXC_Fail, "Insufficient memory");
}
/* CALL_IO1(Real_conv, REF, NOIND) */
Handle Real_convc(TaskData *mdTaskData, Handle str) /* string to real */
{
double result;
int i;
char *finish;
char *string_buffer = Poly_string_to_C_alloc(DEREFHANDLE(str));
/* Scan the string turning '~' into '-' */
for(i = 0; string_buffer[i] != '\0'; i ++)
{
if (string_buffer[i] == '~') string_buffer[i] = '-';
}
/* Now convert it */
result = poly_strtod(string_buffer, &finish);
bool isError = *finish != '\0'; // Test before deallocating
free(string_buffer);
// We no longer detect overflow and underflow and instead return
// (signed) zeros for underflow and (signed) infinities for overflow.
if (isError) raise_exception_string(mdTaskData, EXC_conversion, "");
return real_result(mdTaskData, result);
}/* Real_conv */
Handle OS_spec_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORD(code));
switch (c)
{
case 0: /* Return our OS type. Not in any structure. */
return Make_arbitrary_precision(taskData, 1); /* 1 for Windows. */
/* Windows-specific functions. */
case 1000: /* execute */
return execute(taskData, args);
case 1001: /* Get input stream as text. */
return openProcessHandle(taskData, args, TRUE, TRUE);
case 1002: /* Get output stream as text. */
return openProcessHandle(taskData, args, FALSE, TRUE);
case 1003: /* Get input stream as binary. */
return openProcessHandle(taskData, args, TRUE, FALSE);
case 1004: /* Get output stream as binary. */
return openProcessHandle(taskData, args, FALSE, FALSE);
case 1005: /* Get result of process. */
{
PHANDLETAB hnd = get_handle(DEREFWORD(args), HE_PROCESS);
if (hnd == 0)
raise_syscall(taskData, "Process is closed", EINVAL);
// Close the streams. Either of them may have been
// passed to the stream package.
if (hnd->entry.process.hInput != INVALID_HANDLE_VALUE)
CloseHandle(hnd->entry.process.hInput);
hnd->entry.process.hInput = INVALID_HANDLE_VALUE;
if (hnd->entry.process.hEvent)
CloseHandle(hnd->entry.process.hEvent);
hnd->entry.process.hEvent = NULL;
if (hnd->entry.process.readToken)
{
PIOSTRUCT strm =
get_stream(hnd->entry.process.readToken);
if (strm != NULL) close_stream(strm);
}
hnd->entry.process.readToken = 0;
if (hnd->entry.process.hOutput != INVALID_HANDLE_VALUE)
CloseHandle(hnd->entry.process.hOutput);
hnd->entry.process.hOutput = INVALID_HANDLE_VALUE;
if (hnd->entry.process.writeToken)
{
PIOSTRUCT strm =
get_stream(hnd->entry.process.writeToken);
if (strm != NULL) close_stream(strm);
}
hnd->entry.process.writeToken = 0;
// See if it's finished.
while (true) {
DWORD dwResult;
if (GetExitCodeProcess(hnd->entry.process.hProcess, &dwResult) == 0)
raise_syscall(taskData, "GetExitCodeProcess failed",
-(int)GetLastError());
if (dwResult != STILL_ACTIVE) {
/* Finished - return the result. */
/* Note: we haven't closed the handle because we might want to ask
for the result again. We only close it when we've garbage-collected
the token. Doing this runs the risk of running out of handles.
Maybe change it and remember the result in ML. */
return Make_arbitrary_precision(taskData, dwResult);
}
// Block and try again.
WaitHandle waiter(hnd->entry.process.hProcess);
processes->ThreadPauseForIO(taskData, &waiter);
}
}
case 1006: /* Return a constant. */
{
unsigned i = get_C_unsigned(taskData, DEREFWORD(args));
if (i >= sizeof(winConstVec)/sizeof(winConstVec[0]))
raise_syscall(taskData, "Invalid index", 0);
return Make_arbitrary_precision(taskData, winConstVec[i]);
}
/* Registry functions. */
case 1007: // Open a key within one of the roots.
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return openRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1008: // Open a subkey of an opened key.
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return openRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1009: // Create a subkey within one of the roots.
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return createRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1010: // Create a subkey within an opened key.
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return createRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1011: // Close a registry handle.
{
PHANDLETAB hnd = get_handle(DEREFWORD(args), HE_REGISTRY);
if (hnd != 0) close_handle(hnd);
return Make_arbitrary_precision(taskData, 0);
}
case 1012: // Get a value
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return queryRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1013: // Get a value
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return queryRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1014: // Delete a subkey
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return deleteRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1015: // Delete a subkey
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return deleteRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1016: // Set a value
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return setRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1017: // Set a value
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return setRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1018: // Enumerate a key in the predefined keys
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return enumerateRegistry(taskData, args, hkPredefinedKeyTab[keyIndex], TRUE);
}
case 1019: // Enumerate a key in an opened key
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return enumerateRegistry(taskData, args, hnd->entry.hKey, TRUE);
}
case 1020: // Enumerate a value in the predefined keys
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return enumerateRegistry(taskData, args, hkPredefinedKeyTab[keyIndex], FALSE);
}
case 1021: // Enumerate a value in an opened key
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return enumerateRegistry(taskData, args, hnd->entry.hKey, FALSE);
}
case 1022: // Delete a value
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return deleteRegistryValue(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1023: // Delete a value
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return deleteRegistryValue(taskData, args, hnd->entry.hKey);
}
case 1030: // Convert UTC time values to local time. -- No longer used??
{
FILETIME ftUTC, ftLocal;
/* Get the file time. */
getFileTimeFromArb(taskData, args, &ftUTC);
if (! FileTimeToLocalFileTime(&ftUTC, &ftLocal))
raise_syscall(taskData, "FileTimeToLocalFileTime failed",
-(int)GetLastError());
return Make_arb_from_Filetime(taskData, ftLocal);
}
case 1031: // Convert local time values to UTC. -- No longer used??
{
FILETIME ftUTC, ftLocal;
/* Get the file time. */
getFileTimeFromArb(taskData, args, &ftLocal);
if (! LocalFileTimeToFileTime(&ftLocal, &ftUTC))
raise_syscall(taskData, "LocalFileTimeToFileTime failed",
-(int)GetLastError());
return Make_arb_from_Filetime(taskData, ftUTC);
}
case 1032: // Get volume information.
{
TCHAR rootName[MAX_PATH], volName[MAX_PATH], sysName[MAX_PATH];
DWORD dwVolSerial, dwMaxComponentLen, dwFlags;
Handle volHandle, sysHandle, serialHandle, maxCompHandle;
Handle resultHandle;
POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), rootName, MAX_PATH);
if (length > MAX_PATH)
raise_syscall(taskData, "Root name too long", ENAMETOOLONG);
if (!GetVolumeInformation(rootName, volName, MAX_PATH,
&dwVolSerial, &dwMaxComponentLen, &dwFlags,
sysName, MAX_PATH))
raise_syscall(taskData, "GetVolumeInformation failed",
-(int)GetLastError());
volHandle = SAVE(C_string_to_Poly(taskData, volName));
sysHandle = SAVE(C_string_to_Poly(taskData, sysName));
serialHandle = Make_arbitrary_precision(taskData, dwVolSerial);
maxCompHandle = Make_arbitrary_precision(taskData, dwMaxComponentLen);
resultHandle = alloc_and_save(taskData, 4);
DEREFHANDLE(resultHandle)->Set(0, DEREFWORDHANDLE(volHandle));
DEREFHANDLE(resultHandle)->Set(1, DEREFWORDHANDLE(sysHandle));
DEREFHANDLE(resultHandle)->Set(2, DEREFWORDHANDLE(serialHandle));
DEREFHANDLE(resultHandle)->Set(3, DEREFWORDHANDLE(maxCompHandle));
return resultHandle;
}
case 1033:
{
TCHAR fileName[MAX_PATH], execName[MAX_PATH];
POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), fileName, MAX_PATH);
HINSTANCE hInst;
if (length > MAX_PATH)
raise_syscall(taskData, "File name too long", ENAMETOOLONG);
hInst = FindExecutable(fileName, NULL, execName);
if ((POLYUNSIGNED)hInst <= 32)
{
raise_syscall(taskData, "FindExecutable failed", -(int)(POLYUNSIGNED)hInst);
}
return SAVE(C_string_to_Poly(taskData, execName));
}
case 1034: // Open a document
{
SHELLEXECUTEINFO shellEx;
memset(&shellEx, 0, sizeof(shellEx));
shellEx.cbSize = sizeof(shellEx);
shellEx.lpVerb = _T("open");
shellEx.lpFile = Poly_string_to_T_alloc(DEREFWORD(args));
shellEx.hwnd = hMainWindow;
shellEx.nShow = SW_SHOWNORMAL;
BOOL fRes = ShellExecuteEx(&shellEx);
free((void*)shellEx.lpFile);
if (! fRes)
raise_syscall(taskData, "ShellExecuteEx failed", 0-GetLastError());
return Make_arbitrary_precision(taskData, 0);
}
case 1035: // Launch an application.
{
SHELLEXECUTEINFO shellEx;
memset(&shellEx, 0, sizeof(shellEx));
shellEx.cbSize = sizeof(shellEx);
shellEx.lpVerb = _T("open");
shellEx.lpFile = Poly_string_to_T_alloc(args->WordP()->Get(0));
shellEx.lpParameters = Poly_string_to_T_alloc(args->WordP()->Get(1));
shellEx.nShow = SW_SHOWNORMAL;
BOOL fRes = ShellExecuteEx(&shellEx);
free((void*)shellEx.lpFile);
free((void*)shellEx.lpParameters);
if (! fRes)
raise_syscall(taskData, "ShellExecuteEx failed", 0-GetLastError());
return Make_arbitrary_precision(taskData, 0);
}
case 1036: // Does the process have its own console?
return Make_arbitrary_precision(taskData, hMainWindow != NULL ? 1: 0);
case 1037: // Simple execute.
return simpleExecute(taskData, args);
// DDE
case 1038: // Start DDE dialogue.
{
Handle handToken;
PHANDLETAB pTab;
HCONV hcDDEConv;
TCHAR *serviceName = Poly_string_to_T_alloc(args->WordP()->Get(0));
TCHAR *topicName = Poly_string_to_T_alloc(args->WordP()->Get(1));
/* Send a request to the main thread to do the work. */
hcDDEConv = StartDDEConversation(serviceName, topicName);
free(serviceName); free(topicName);
if (hcDDEConv == 0) raise_syscall(taskData, "DdeConnect failed", 0);
// Create an entry to return the conversation.
handToken = make_handle_entry(taskData);
pTab = &handleTable[STREAMID(handToken)];
pTab->entryType = HE_DDECONVERSATION;
pTab->entry.hcDDEConv = hcDDEConv;
return handToken;
}
case 1039: // Send DDE execute request.
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_DDECONVERSATION);
LRESULT res;
char *command;
if (hnd == NULL)
{
raise_syscall(taskData, "DDE Conversation is closed", 0);
}
command = Poly_string_to_C_alloc(args->WordP()->Get(1));
/* Send a request to the main thread to do the work. */
res = ExecuteDDE(command, hnd->entry.hcDDEConv);
free(command);
if (res == -1) raise_syscall(taskData, "DdeClientTransaction failed", 0);
else return Make_arbitrary_precision(taskData, res);
}
case 1040: // Close a DDE conversation.
{
PHANDLETAB hnd = get_handle(args->Word(), HE_DDECONVERSATION);
if (hnd != 0) close_handle(hnd);
return Make_arbitrary_precision(taskData, 0);
}
// Configuration functions.
case 1050: // Get version data
{
OSVERSIONINFO osver;
ZeroMemory(&osver, sizeof(OSVERSIONINFO));
osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
// GetVersionEx is deprecated in Windows 8.1
if (! GetVersionEx(&osver))
raise_syscall(taskData, "GetVersionEx failed", -(int)GetLastError());
Handle major = Make_arbitrary_precision(taskData, osver.dwMajorVersion);
Handle minor = Make_arbitrary_precision(taskData, osver.dwMinorVersion);
Handle build = Make_arbitrary_precision(taskData, osver.dwBuildNumber);
Handle platform = Make_arbitrary_precision(taskData, osver.dwPlatformId);
Handle version = SAVE(C_string_to_Poly(taskData, osver.szCSDVersion));
Handle resVal = alloc_and_save(taskData, 5);
DEREFHANDLE(resVal)->Set(0, DEREFWORDHANDLE(major));
DEREFHANDLE(resVal)->Set(1, DEREFWORDHANDLE(minor));
DEREFHANDLE(resVal)->Set(2, DEREFWORDHANDLE(build));
DEREFHANDLE(resVal)->Set(3, DEREFWORDHANDLE(platform));
DEREFHANDLE(resVal)->Set(4, DEREFWORDHANDLE(version));
return resVal;
}
case 1051: // Get windows directory
{
TCHAR path[MAX_PATH+1];
if (GetWindowsDirectory(path, sizeof(path)/sizeof(TCHAR)) == 0)
raise_syscall(taskData, "GetWindowsDirectory failed", -(int)GetLastError());
return SAVE(C_string_to_Poly(taskData, path));
}
case 1052: // Get system directory
{
TCHAR path[MAX_PATH+1];
if (GetSystemDirectory(path, sizeof(path)/sizeof(TCHAR)) == 0)
raise_syscall(taskData, "GetSystemDirectory failed", -(int)GetLastError());
return SAVE(C_string_to_Poly(taskData, path));
}
case 1053: // Get computer name
{
TCHAR name[MAX_COMPUTERNAME_LENGTH +1];
DWORD dwSize = MAX_COMPUTERNAME_LENGTH +1;
if (GetComputerName(name, &dwSize) == 0)
raise_syscall(taskData, "GetComputerName failed", -(int)GetLastError());
return SAVE(C_string_to_Poly(taskData, name));
}
case 1054: // Get user name
{
TCHAR name[UNLEN +1];
DWORD dwSize = UNLEN +1;
if (GetUserName(name, &dwSize) == 0)
raise_syscall(taskData, "GetUserName failed", -(int)GetLastError());
return SAVE(C_string_to_Poly(taskData, name));
}
case 1100: // Get the error result from the last call.
// This is saved when we make a call to a foreign function.
{
return(SAVE(TAGGED(taskData->lastError)));
}
case 1101: // Wait for a message.
{
HWND hwnd = *(HWND*)(DEREFWORDHANDLE(args)->Get(0).AsCodePtr());
UINT wMsgFilterMin = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1));
UINT wMsgFilterMax = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2));
while (1)
{
MSG msg;
processes->ThreadReleaseMLMemory(taskData);
// N.B. PeekMessage may directly call the window proc resulting in a
// callback to ML. For this to work a callback must not overwrite "args".
BOOL result = PeekMessage(&msg, hwnd, wMsgFilterMin, wMsgFilterMax, PM_NOREMOVE);
processes->ThreadUseMLMemory(taskData);
if (result) return Make_arbitrary_precision(taskData, 0);
// Pause until a message arrives.
processes->ThreadPause(taskData);
}
}
// case 1102: // Return the address of the window callback function.
case 1103: // Return the application instance.
{
Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ);
*(HINSTANCE*)(result->Word().AsCodePtr()) = hApplicationInstance;
return result;
}
case 1104: // Return the main window handle
{
Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ);
*(HWND*)(result->Word().AsCodePtr()) = hMainWindow;
return result;
}
// case 1105: // Set the callback function
default:
{
char msg[100];
sprintf(msg, "Unknown windows-specific function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}
Handle poly_ffi(TaskData *taskData, Handle args, Handle code)
{
raise_exception_string(taskData, EXC_foreign, "The foreign function interface is not available on this platform");
}
Handle poly_ffi(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, code->Word());
switch (c)
{
case 0: // malloc
{
POLYUNSIGNED size = getPolyUnsigned(taskData, args->Word());
return toSysWord(taskData, malloc(size));
}
case 1: // free
{
void *mem = *(void**)(args->WordP());
free(mem);
return taskData->saveVec.push(TAGGED(0));
}
case 2: // Load library
{
TempString libName(args->Word());
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HINSTANCE lib = LoadLibrary(libName);
if (lib == NULL)
{
char buf[256];
#if (defined(UNICODE))
_snprintf(buf, sizeof(buf), "Loading <%S> failed. Error %lu", libName, GetLastError());
#else
_snprintf(buf, sizeof(buf), "Loading <%s> failed. Error %lu", libName, GetLastError());
#endif
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#else
void *lib = dlopen(libName, RTLD_LAZY);
if (lib == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "Loading <%s> failed: %s", (const char *)libName, dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, lib);
}
case 3: // Load address of executable.
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HINSTANCE lib = hApplicationInstance;
#else
void *lib = dlopen(NULL, RTLD_LAZY);
if (lib == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "Loading address of executable failed: %s", dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, lib);
}
case 4: // Unload library - Is this actually going to be used?
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HMODULE hMod = *(HMODULE*)(args->WordP());
if (! FreeLibrary(hMod))
raise_syscall(taskData, "FreeLibrary failed", -(int)GetLastError());
#else
void *lib = *(void**)(args->WordP());
if (dlclose(lib) != 0)
{
char buf[256];
snprintf(buf, sizeof(buf), "dlclose failed: %s", dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return taskData->saveVec.push(TAGGED(0));
}
case 5: // Load the address of a symbol from a library.
{
TempCString symName(args->WordP()->Get(1));
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HMODULE hMod = *(HMODULE*)(args->WordP()->Get(0).AsAddress());
void *sym = (void*)GetProcAddress(hMod, symName);
if (sym == NULL)
{
char buf[256];
_snprintf(buf, sizeof(buf), "Loading symbol <%s> failed. Error %lu", symName, GetLastError());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#else
void *lib = *(void**)(args->WordP()->Get(0).AsAddress());
void *sym = dlsym(lib, symName);
if (sym == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "load_sym <%s> : %s", (const char *)symName, dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, sym);
}
// Libffi functions
case 50: // Return a list of available ABIs
return makeList(taskData, sizeof(abiTable)/sizeof(abiTable[0]),
(char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab);
case 51: // A constant from the table
{
unsigned index = get_C_unsigned(taskData, args->Word());
if (index >= sizeof(constantTable) / sizeof(constantTable[0]))
raise_exception_string(taskData, EXC_foreign, "Index out of range");
return Make_arbitrary_precision(taskData, constantTable[index]);
}
case 52: // Return an FFI type
{
unsigned index = get_C_unsigned(taskData, args->Word());
if (index >= sizeof(ffiTypeTable) / sizeof(ffiTypeTable[0]))
raise_exception_string(taskData, EXC_foreign, "Index out of range");
return toSysWord(taskData, ffiTypeTable[index]);
}
case 53: // Extract fields from ffi type.
{
ffi_type *ffit = *(ffi_type**)(args->WordP());
Handle sizeHandle = Make_arbitrary_precision(taskData, ffit->size);
Handle alignHandle = Make_arbitrary_precision(taskData, ffit->alignment);
Handle typeHandle = Make_arbitrary_precision(taskData, ffit->type);
Handle elemHandle = toSysWord(taskData, ffit->elements);
Handle resHandle = alloc_and_save(taskData, 4);
resHandle->WordP()->Set(0, sizeHandle->Word());
resHandle->WordP()->Set(1, alignHandle->Word());
resHandle->WordP()->Set(2, typeHandle->Word());
resHandle->WordP()->Set(3, elemHandle->Word());
return resHandle;
}
case 54: // Construct an ffi type.
{
// This is probably only used to create structs.
size_t size = getPolyUnsigned(taskData, args->WordP()->Get(0));
unsigned short align = get_C_ushort(taskData, args->WordP()->Get(1));
unsigned short type = get_C_ushort(taskData, args->WordP()->Get(2));
unsigned nElems = 0;
for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
nElems++;
size_t space = sizeof(ffi_type);
// If we need the elements add space for the elements plus
// one extra for the zero terminator.
if (nElems != 0) space += (nElems+1) * sizeof(ffi_type *);
ffi_type *result = (ffi_type*)malloc(space);
// Raise an exception rather than returning zero.
if (result == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
ffi_type **elem = 0;
if (nElems != 0) elem = (ffi_type **)(result+1);
memset(result, 0, sizeof(ffi_type)); // Zero it in case they add fields
result->size = size;
result->alignment = align;
result->type = type;
result->elements = elem;
if (elem != 0)
{
for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
{
PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h;
*elem++ = *(ffi_type**)(e.AsAddress());
}
*elem = 0;
}
return toSysWord(taskData, result);
}
case 55: // Create a CIF. This contains all the types and some extra information.
// The result is in allocated memory followed immediately by the argument type vector.
{
ffi_abi abi = (ffi_abi)get_C_ushort(taskData, args->WordP()->Get(0));
ffi_type *rtype = *(ffi_type **)args->WordP()->Get(1).AsAddress();
unsigned nArgs = 0;
for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
nArgs++;
// Allocate space for the cif followed by the argument type vector
size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*);
ffi_cif *cif = (ffi_cif *)malloc(space);
if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
ffi_type **atypes = (ffi_type **)(cif+1);
// Copy the arguments types.
ffi_type **at = atypes;
for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
{
PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h;
*at++ = *(ffi_type**)(e.AsAddress());
}
ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes);
if (status == FFI_BAD_TYPEDEF)
raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif");
else if (status == FFI_BAD_ABI)
raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif");
else if (status != FFI_OK)
raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif");
return toSysWord(taskData, cif);
}
case 56: // Call a function.
{
ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(0).AsAddress();
void *f = *(void**)args->WordP()->Get(1).AsAddress();
void *res = *(void**)args->WordP()->Get(2).AsAddress();
void **arg = *(void***)args->WordP()->Get(3).AsAddress();
// We release the ML memory across the call so a GC can occur
// even if this thread is blocked in the C code.
processes->ThreadReleaseMLMemory(taskData);
ffi_call(cif, FFI_FN(f), res, arg);
processes->ThreadUseMLMemory(taskData);
return taskData->saveVec.push(TAGGED(0));
}
case 57: // Create a callback.
{
#ifdef INTERPRETED
raise_exception_string(taskData, EXC_foreign, "Callbacks are not implemented in the byte code interpreter");
#endif
Handle mlFunction = taskData->saveVec.push(args->WordP()->Get(0));
ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(1).AsAddress();
void *resultFunction;
// Allocate the memory. resultFunction is set to the executable address in or related to
// the memory.
ffi_closure *closure = (ffi_closure *)ffi_closure_alloc(sizeof(ffi_closure), &resultFunction);
if (closure == 0)
raise_exception_string(taskData, EXC_foreign, "Callbacks not implemented or insufficient memory");
PLocker pLocker(&callbackTableLock);
// Find a free entry in the table if there is one.
unsigned entryNo = 0;
while (entryNo < callBackEntries && callbackTable[entryNo].closureSpace != 0) entryNo++;
if (entryNo == callBackEntries)
{
// Need to grow the table.
struct _cbStructEntry *newTable =
(struct _cbStructEntry*)realloc(callbackTable, (callBackEntries+1)*sizeof(struct _cbStructEntry));
if (newTable == 0)
raise_exception_string(taskData, EXC_foreign, "Unable to allocate memory for callback table");
callbackTable = newTable;
callBackEntries++;
}
callbackTable[entryNo].mlFunction = mlFunction->Word();
callbackTable[entryNo].closureSpace = closure;
callbackTable[entryNo].resultFunction = resultFunction;
if (ffi_prep_closure_loc(closure, cif, callbackEntryPt, (void*)((uintptr_t)entryNo), resultFunction) != FFI_OK)
raise_exception_string(taskData, EXC_foreign,"libffi error: ffi_prep_closure_loc failed");
return toSysWord(taskData, resultFunction);
}
case 58: // Free an existing callback.
{
// The address returned from call 57 above is the executable address that can
// be passed as a callback function. The writable memory address returned
// as the result of ffi_closure_alloc may or may not be the same. To be safe
// we need to search the table.
void *resFun = *(void**)args->Word().AsAddress();
PLocker pLocker(&callbackTableLock);
unsigned i = 0;
while (i < callBackEntries)
{
if (callbackTable[i].resultFunction == resFun)
{
ffi_closure_free(callbackTable[i].closureSpace);
callbackTable[i].closureSpace = 0;
callbackTable[i].resultFunction = 0;
callbackTable[i].mlFunction = TAGGED(0); // Release the ML function
return taskData->saveVec.push(TAGGED(0));
}
}
raise_exception_string(taskData, EXC_foreign, "Invalid callback entry");
}
default:
{
char msg[100];
sprintf(msg, "Unknown ffi function: %d", c);
raise_exception_string(taskData, EXC_foreign, msg);
return 0;
}
}
}
/* Functions added for Standard Basis Library are all indirected through here. */
Handle Real_dispatchc(TaskData *mdTaskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(mdTaskData, DEREFWORDHANDLE(code));
switch (c)
{
case 0: /* tan */ return real_result(mdTaskData, tan(real_arg(args)));
case 1: /* asin */
{
double x = real_arg(args);
if (x < -1.0 || x > 1.0)
return real_result(mdTaskData, notANumber);
else return real_result(mdTaskData, asin(x));
}
case 2: /* acos */
{
double x = real_arg(args);
if (x < -1.0 || x > 1.0)
return real_result(mdTaskData, notANumber);
else return real_result(mdTaskData, acos(x));
}
case 3: /* atan2 */ return real_result(mdTaskData, atan2(real_arg1(args), real_arg2(args)));
case 4: /* pow */ return powerOf(mdTaskData, args);
case 5: /* log10 */
{
double x = real_arg(args);
/* Make sure the result conforms to the definition. */
if (x < 0.0)
return real_result(mdTaskData, notANumber); /* Nan. */
else if (x == 0.0) /* x may be +0.0 or -0.0 */
return real_result(mdTaskData, negInf); /* -infinity. */
else return real_result(mdTaskData, log10(x));
}
case 6: /* sinh */ return real_result(mdTaskData, sinh(real_arg(args)));
case 7: /* cosh */ return real_result(mdTaskData, cosh(real_arg(args)));
case 8: /* tanh */ return real_result(mdTaskData, tanh(real_arg(args)));
case 9: /* setroundingmode */
setrounding(mdTaskData, args);
return mdTaskData->saveVec.push(TAGGED(0)); /* Unit */
case 10: /* getroundingmode */
return mdTaskData->saveVec.push(TAGGED(getrounding(mdTaskData)));
/* Floating point representation queries. */
#ifdef _DBL_RADIX
case 11: /* Value of radix */ return mdTaskData->saveVec.push(TAGGED(_DBL_RADIX));
#else
case 11: /* Value of radix */ return mdTaskData->saveVec.push(TAGGED(FLT_RADIX));
#endif
case 12: /* Value of precision */ return mdTaskData->saveVec.push(TAGGED(DBL_MANT_DIG));
case 13: /* Maximum number */ return real_result(mdTaskData, DBL_MAX);
/* float.h describes DBL_MIN as the minimum positive number.
In fact this is the minimum NORMALISED number. The smallest
number which can be represented is DBL_MIN*2**(-DBL_MANT_DIG) */
case 14: /* Minimum normalised number. */
return real_result(mdTaskData, DBL_MIN);
case 15: /* Is finite */ /* No longer used - implemented in ML. */
return mdTaskData->saveVec.push(finite(real_arg(args)) ? TAGGED(1) : TAGGED(0));
case 16: /* Is Nan */ /* No longer used - implemented in ML. */
return mdTaskData->saveVec.push(isnan(real_arg(args)) ? TAGGED(1) : TAGGED(0));
case 17: /* Get sign bit. There may be better ways to find this. */
return mdTaskData->saveVec.push(copysign(1.0, real_arg(args)) < 0.0 ? TAGGED(1) : TAGGED(0));
case 18: /* Copy sign. */
return real_result(mdTaskData, copysign(real_arg1(args), real_arg2(args)));
case 19: /* Return largest integral value (as a real) <= x. */
return real_result(mdTaskData, floor(real_arg(args)));
case 20: /* Return smallest integral value (as a real) >= x */
return real_result(mdTaskData, ceil(real_arg(args)));
case 21:
{ /* Truncate towards zero */
double dx = real_arg(args);
if (dx >= 0.0) return real_result(mdTaskData, floor(dx));
else return real_result(mdTaskData, ceil(dx));
}
case 22: /* Round to nearest integral value. */
{
double dx = real_arg(args);
double drem = fmod(dx, 2.0);
if (drem == 0.5 || drem == -1.5)
/* If the value was exactly positive even + 0.5 or
negative odd -0.5 round it down, otherwise round it up. */
return real_result(mdTaskData, ceil(dx-0.5));
else return real_result(mdTaskData, floor(dx+0.5));
}
case 23: /* Compute ldexp */
{
int exp = get_C_int(mdTaskData, DEREFHANDLE(args)->Get(1));
return real_result(mdTaskData, ldexp(real_arg1(args), exp));
}
case 24: /* Get mantissa. */
{
int exp;
return real_result(mdTaskData, frexp(real_arg(args), &exp));
}
case 25: /* Get exponent. */
{
int exp;
(void)frexp(real_arg(args), &exp);
return mdTaskData->saveVec.push(TAGGED(exp));
}
case 26: /* Return the mantissa from a Nan as a real number. */
// I think this is no longer used.
{
union db r_arg_x, r_arg_y;
/* We want to simply replace the exponent by the exponent
value for 0.5<=x<1.
I think there may be a more portable way of doing this. */
r_arg_x.dble = posInf; /* Positive infinity. */
r_arg_y.dble = 0.5;
/* Use the infinity value as a mask, removing any bits set
and replace by the exponent from 0.5. */
byte *barg = DEREFBYTEHANDLE(args);
for(unsigned i = 0; i < DBLE; i++)
{
r_arg_x.bytes[i] = (barg[i] & ~r_arg_x.bytes[i]) | r_arg_y.bytes[i];
}
return real_result(mdTaskData, r_arg_x.dble);
}
case 27: /* Construct a Nan from a given mantissa. */
// I think this is no longer used.
{
union db r_arg;
r_arg.dble = posInf; /* Positive infinity. */
/* OR in the exponent. */
byte *barg = DEREFBYTEHANDLE(args);
for(unsigned i = 0; i < DBLE; i++)
{
r_arg.bytes[i] = r_arg.bytes[i] | barg[i];
}
return real_result(mdTaskData, r_arg.dble);
}
case 28: /* Return the number of bytes for a real. */
return mdTaskData->saveVec.push(TAGGED(sizeof(double)));
default:
{
char msg[100];
sprintf(msg, "Unknown real arithmetic function: %d", c);
raise_exception_string(mdTaskData, EXC_Fail, msg);
return 0;
}
}
}
static void setrounding(TaskData *mdTaskData, Handle)
{
raise_exception_string(mdTaskData, EXC_Fail, "Unable to set floating point rounding control");
}
// Give up.
static int getrounding(TaskData *mdTaskData)
{
raise_exception_string(mdTaskData, EXC_Fail, "Unable to get floating point rounding control");
}
Handle process_env_dispatch_c(TaskData *mdTaskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(mdTaskData, DEREFWORDHANDLE(code));
switch (c)
{
case 0: /* Return the program name. */
return SAVE(C_string_to_Poly(mdTaskData, userOptions.programName));
case 1: /* Return the argument list. */
return convert_string_list(mdTaskData, userOptions.user_arg_count, userOptions.user_arg_strings);
case 14: /* Return a string from the environment. */
{
TempString buff(args->Word());
if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", ENOMEM);
TCHAR *res = _tgetenv(buff);
if (res == NULL) raise_syscall(mdTaskData, "Not Found", 0);
else return SAVE(C_string_to_Poly(mdTaskData, res));
}
case 21: // Return the whole environment. Only available in Posix.ProcEnv.
{
/* Count the environment strings */
int env_count = 0;
while (environ[env_count] != NULL) env_count++;
return convert_string_list(mdTaskData, env_count, environ);
}
case 15: /* Return the success value. */
return Make_arbitrary_precision(mdTaskData, EXIT_SUCCESS);
case 16: /* Return a failure value. */
return Make_arbitrary_precision(mdTaskData, EXIT_FAILURE);
case 17: /* Run command. */
{
TempString buff(args->Word());
if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", ENOMEM);
int res = -1;
#if (defined(_WIN32) && ! defined(__CYGWIN__))
// Windows.
TCHAR *argv[4];
argv[0] = _tgetenv(_T("COMSPEC")); // Default CLI.
if (argv[0] == 0) argv[0] = (TCHAR*)_T("cmd.exe"); // Win NT etc.
argv[1] = (TCHAR*)_T("/c");
argv[2] = buff;
argv[3] = NULL;
// If _P_NOWAIT is given the result is the process handle.
// spawnvp does any necessary path searching if argv[0]
// does not contain a full path.
intptr_t pid = _tspawnvp(_P_NOWAIT, argv[0], argv);
if (pid == -1)
raise_syscall(mdTaskData, "Function system failed", errno);
#else
// Cygwin and Unix
char *argv[4];
argv[0] = (char*)"sh";
argv[1] = (char*)"-c";
argv[2] = buff;
argv[3] = NULL;
#if (defined(__CYGWIN__))
CygwinSpawnRequest request(argv);
processes->MakeRootRequest(mdTaskData, &request);
int pid = request.pid;
if (pid < 0)
raise_syscall(mdTaskData, "Function system failed", errno);
#else
// We need to break this down so that we can unblock signals in the
// child process.
// The Unix "system" function seems to set SIGINT and SIGQUIT to
// SIG_IGN in the parent so that the wait will not be interrupted.
// That may make sense in a single-threaded application but is
// that right here?
int pid = vfork();
if (pid == -1)
raise_syscall(mdTaskData, "Function system failed", errno);
else if (pid == 0)
{ // In child
sigset_t sigset;
sigemptyset(&sigset);
sigprocmask(SIG_SETMASK, &sigset, 0);
// Reset other signals?
execve("/bin/sh", argv, environ);
_exit(1);
}
#endif
#endif
while (true)
{
try
{
// Test to see if the child has returned.
#if (defined(_WIN32) && ! defined(__CYGWIN__))
switch (WaitForSingleObject((HANDLE)pid, 0))
{
case WAIT_OBJECT_0:
{
DWORD result;
BOOL fResult = GetExitCodeProcess((HANDLE)pid, &result);
if (! fResult)
raise_syscall(mdTaskData, "Function system failed", -(int)GetLastError());
CloseHandle((HANDLE)pid);
return Make_arbitrary_precision(mdTaskData, result);
}
case WAIT_FAILED:
raise_syscall(mdTaskData, "Function system failed", -(int)GetLastError());
}
// Wait for the process to exit or for the timeout
WaitHandle waiter((HANDLE)pid);
processes->ThreadPauseForIO(mdTaskData, &waiter);
#else
int wRes = waitpid(pid, &res, WNOHANG);
if (wRes > 0)
break;
else if (wRes < 0)
{
raise_syscall(mdTaskData, "Function system failed", errno);
}
// In Unix the best we can do is wait. This may be interrupted
// by SIGCHLD depending on where signals are processed.
// One possibility is for the main thread to somehow wake-up
// the thread when it processes a SIGCHLD.
processes->ThreadPause(mdTaskData);
#endif
}
catch (...)
{
// Either IOException or KillException.
// We're abandoning the wait. This will leave
// a zombie in Unix.
#if (defined(_WIN32) && ! defined(__CYGWIN__))
CloseHandle((HANDLE)pid);
#endif
throw;
}
}
return Make_arbitrary_precision(mdTaskData, res);
}
case 18: /* Register function to run at exit. */
{
PLocker locker(&atExitLock);
if (! exiting)
{
PolyObject *cell = alloc(mdTaskData, 2);
cell->Set(0, at_exit_list);
cell->Set(1, DEREFWORD(args));
at_exit_list = cell;
}
return Make_arbitrary_precision(mdTaskData, 0);
}
case 19: /* Return the next function in the atExit list and set the
"exiting" flag to true. */
{
PLocker locker(&atExitLock);
Handle res;
exiting = true; /* Ignore further calls to atExit. */
if (at_exit_list == TAGGED(0))
raise_syscall(mdTaskData, "List is empty", 0);
PolyObject *cell = at_exit_list.AsObjPtr();
res = SAVE(cell->Get(1));
at_exit_list = cell->Get(0);
return res;
}
case 20: /* Terminate without running the atExit list or flushing buffers. */
{
/* I don't like terminating without some sort of clean up
but we'll do it this way for the moment. */
int i = get_C_int(mdTaskData, DEREFWORDHANDLE(args));
_exit(i);
}
/************ Error codes **************/
case 2: /* Get the name of a numeric error message. */
{
char buff[40];
int e = get_C_int(mdTaskData, DEREFWORDHANDLE(args));
Handle res;
/* First look to see if we have the name in
the error table. They should generally all be
there. */
const char *errorMsg = stringFromErrorCode(e);
if (errorMsg != NULL)
return SAVE(C_string_to_Poly(mdTaskData, errorMsg));
/* We get here if there's an error which isn't in the table. */
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* In the Windows version we may have both errno values
and also GetLastError values. We convert the latter into
negative values before returning them. */
if (e < 0)
{
sprintf(buff, "WINERROR%0d", -e);
res = SAVE(C_string_to_Poly(mdTaskData, buff));
return res;
}
else
#endif
{
sprintf(buff, "ERROR%0d", e);
res = SAVE(C_string_to_Poly(mdTaskData, buff));
}
return res;
}
case 3: /* Get the explanatory message for an error. */
{
return errorMsg(mdTaskData, get_C_int(mdTaskData, DEREFWORDHANDLE(args)));
}
case 4: /* Try to convert an error string to an error number. */
{
char buff[40];
/* Get the string. */
Poly_string_to_C(DEREFWORD(args), buff, sizeof(buff));
/* Look the string up in the table. */
int err = 0;
if (errorCodeFromString(buff, &err))
return Make_arbitrary_precision(mdTaskData, err);
/* If we don't find it then it may have been a constructed
error name. */
if (strncmp(buff, "ERROR", 5) == 0)
{
int i = atoi(buff+5);
if (i > 0) return Make_arbitrary_precision(mdTaskData, i);
}
#if (defined(_WIN32) && ! defined(__CYGWIN__))
if (strncmp(buff, "WINERROR", 8) == 0)
{
int i = atoi(buff+8);
if (i > 0) return Make_arbitrary_precision(mdTaskData, -i);
}
#endif
return Make_arbitrary_precision(mdTaskData, 0);
}
/************ Directory/file paths **************/
case 5: /* Return the string representing the current arc. */
return SAVE(C_string_to_Poly(mdTaskData, "."));
case 6: /* Return the string representing the parent arc. */
/* I don't know that this exists in MacOS. */
return SAVE(C_string_to_Poly(mdTaskData, ".."));
case 7: /* Return the string representing the directory separator. */
return SAVE(C_string_to_Poly(mdTaskData, DEFAULTSEPARATOR));
case 8: /* Test the character to see if it matches a separator. */
{
int e = get_C_int(mdTaskData, DEREFWORDHANDLE(args));
if (ISPATHSEPARATOR(e))
return Make_arbitrary_precision(mdTaskData, 1);
else return Make_arbitrary_precision(mdTaskData, 0);
}
case 9: /* Are names case-sensitive? */
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* Windows - no. */
return Make_arbitrary_precision(mdTaskData, 0);
#else
/* Unix - yes. */
return Make_arbitrary_precision(mdTaskData, 1);
#endif
// These are no longer used. The code is handled entirely in ML.
case 10: /* Are empty arcs redundant? */
/* Unix and Windows - yes. */
return Make_arbitrary_precision(mdTaskData, 1);
case 11: /* Match the volume name part of a path. */
{
const TCHAR *volName = NULL;
int isAbs = 0;
int toRemove = 0;
PolyWord path = DEREFHANDLE(args);
/* This examines the start of a string and determines
how much of it represents the volume name and returns
the number of characters to remove, the volume name
and whether it is absolute.
One would assume that if there is a volume name then it
is absolute but there is a peculiar form in Windows/DOS
(e.g. A:b\c) which means the file b\c relative to the
currently selected directory on the volume A.
*/
#if (defined(_WIN32) && ! defined(__CYGWIN__))
TempString buff(path);
if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", ENOMEM);
size_t length = _tcslen(buff);
if (length >= 2 && buff[1] == ':')
{ /* Volume name? */
if (length >= 3 && ISPATHSEPARATOR(buff[2]))
{
/* Absolute path. */
toRemove = 3; isAbs = 1;
}
else { toRemove = 2; isAbs = 0; }
volName = buff; buff[2] = '\0';
}
else if (length > 3 &&
ISPATHSEPARATOR(buff[0]) &&
ISPATHSEPARATOR(buff[1]) &&
! ISPATHSEPARATOR(buff[2]))
{ /* UNC name? */
int i;
/* Skip the server name. */
for (i = 3; buff[i] != 0 && !ISPATHSEPARATOR(buff[i]); i++);
if (ISPATHSEPARATOR(buff[i]))
{
i++;
/* Skip the share name. */
for (; buff[i] != 0 && !ISPATHSEPARATOR(buff[i]); i++);
toRemove = i;
if (buff[i] != 0) toRemove++;
isAbs = 1;
volName = buff;
buff[i] = '\0';
}
}
else if (ISPATHSEPARATOR(buff[0]))
/* \a\b strictly speaking is relative to the
current drive. It's much easier to treat it
as absolute. */
{ toRemove = 1; isAbs = 1; volName = _T(""); }
#else
/* Unix - much simpler. */
char toTest = 0;
if (IS_INT(path)) toTest = UNTAGGED(path);
else {
PolyStringObject * ps = (PolyStringObject *)path.AsObjPtr();
if (ps->length > 1) toTest = ps->chars[0];
}
if (ISPATHSEPARATOR(toTest))
{ toRemove = 1; isAbs = 1; volName = ""; }
#endif
/* Construct the result. */
{
Handle sVol = SAVE(C_string_to_Poly(mdTaskData, volName));
Handle sRes = ALLOC(3);
DEREFWORDHANDLE(sRes)->Set(0, TAGGED(toRemove));
DEREFHANDLE(sRes)->Set(1, DEREFWORDHANDLE(sVol));
DEREFWORDHANDLE(sRes)->Set(2, TAGGED(isAbs));
return sRes;
}
}
case 12: /* Construct a name from a volume and whether it is
absolute. */
{
unsigned isAbs = get_C_unsigned(mdTaskData, DEREFHANDLE(args)->Get(1));
PolyWord volName = DEREFHANDLE(args)->Get(0);
/* In Unix the volume name will always be empty. */
if (isAbs == 0)
return SAVE(volName);
/* N.B. The arguments to strconcatc are in reverse. */
else return strconcatc(mdTaskData,
SAVE(C_string_to_Poly(mdTaskData, DEFAULTSEPARATOR)),
SAVE(volName));
}
case 13: /* Is the string a valid file name? */
{
PolyWord volName = DEREFWORD(args);
// First check for NULL. This is not allowed in either Unix or Windows.
if (IS_INT(volName))
{
if (volName == TAGGED(0))
return Make_arbitrary_precision(mdTaskData, 0);
}
else
{
PolyStringObject * volume = (PolyStringObject *)(volName.AsObjPtr());
for (POLYUNSIGNED i = 0; i < volume->length; i++)
{
if (volume->chars[i] == '\0')
return Make_arbitrary_precision(mdTaskData, 0);
}
}
#if (defined(_WIN32) && ! defined(__CYGWIN__))
// We need to look for certain invalid characters but only after
// we've converted it to Unicode if necessary.
TempString name(volName);
for (const TCHAR *p = name; *p != 0; p++)
{
switch (*p)
{
case '<': case '>': case ':': case '"':
case '\\': case '|': case '?': case '*': case '\0':
#if (0)
// This currently breaks the build.
case '/':
#endif
return Make_arbitrary_precision(mdTaskData, 0);
}
if (*p >= 0 && *p <= 31) return Make_arbitrary_precision(mdTaskData, 0);
}
// Should we check for special names such as aux, con, prn ??
return Make_arbitrary_precision(mdTaskData, 1);
#else
// That's all we need for Unix.
// TODO: Check for /. It's invalid in a file name arc.
return Make_arbitrary_precision(mdTaskData, 1);
#endif
}
// A group of calls have now been moved to poly_specific.
// This entry is returned for backwards compatibility.
case 100: case 101: case 102: case 103: case 104: case 105:
return poly_dispatch_c(mdTaskData, args, code);
default:
{
char msg[100];
sprintf(msg, "Unknown environment function: %d", c);
raise_exception_string(mdTaskData, EXC_Fail, msg);
return 0;
}
}
}
static POLYUNSIGNED rtsProperties(TaskData *taskData, int i)
{
switch (i) {
case POLY_SYS_exit: return 0;
case POLY_SYS_chdir: return 0;
case POLY_SYS_alloc_store:
case POLY_SYS_alloc_uninit:
// Allocating memory doesn't have any visible effect on the state. It can raise Size.
// Two allocations return different addresses.
return PROPWORD_NOUPDATE;
case POLY_SYS_raisex: return 0;
case POLY_SYS_get_length: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_get_flags:
// This isn't quite true. It is possible to clear the mutable flag on a mutable segment.
return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_str_compare: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_teststrgtr: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_teststrlss: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_teststrgeq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_teststrleq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_exception_trace_fn: return 0;
case POLY_SYS_give_ex_trace_fn: return 0;
case POLY_SYS_lockseg: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_emptystring: return 0; // Not a function
case POLY_SYS_nullvector: return 0; // Not a function
case POLY_SYS_network: return 0;
case POLY_SYS_os_specific: return 0;
case POLY_SYS_eq_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_neq_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_geq_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_leq_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_gt_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_lt_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_io_dispatch: return 0;
case POLY_SYS_signal_handler: return 0;
case POLY_SYS_atomic_reset: return PROPWORD_NORAISE;
case POLY_SYS_atomic_incr: return PROPWORD_NORAISE;
case POLY_SYS_atomic_decr: return PROPWORD_NORAISE;
case POLY_SYS_thread_self: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_thread_dispatch: return 0;
case POLY_SYS_plus_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_minus_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_mul_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_div_longword: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_mod_longword: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_andb_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_orb_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_xorb_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_kill_self: return 0;
case POLY_SYS_shift_left_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_shift_right_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_shift_right_arith_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_profiler: return 0;
case POLY_SYS_longword_to_tagged: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_signed_to_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_unsigned_to_longword: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_full_gc: return PROPWORD_NORAISE; // Effectively has a side-effect
case POLY_SYS_stack_trace: return 0;
case POLY_SYS_timing_dispatch: return 0;
case POLY_SYS_objsize: return PROPWORD_NORAISE;
case POLY_SYS_showsize: return PROPWORD_NORAISE;
case POLY_SYS_quotrem: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_is_short: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_aplus: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_aminus: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_amul: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_adiv: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_amod: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_aneg: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_xora: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_equala: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_ora: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_anda: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_str: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_geq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_leq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_gtr: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_lss: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_eq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_neq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Real_Dispatch: return 0;
case POLY_SYS_Add_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Sub_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Mul_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Div_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Abs_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_Neg_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_conv_real: return PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_real_to_int: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_to_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_sqrt_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_sin_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_cos_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_arctan_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_exp_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_ln_real: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_stdin: return 0; // Not a function
case POLY_SYS_stdout: return 0; // Not a function
case POLY_SYS_process_env: return 0;
case POLY_SYS_set_string_length: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_get_first_long_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_poly_specific: return 0;
case POLY_SYS_bytevec_eq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_cmem_load_8: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_load_16: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_load_32: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_load_float: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_load_double: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_store_8: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_cmem_store_16: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_cmem_store_32: return PROPWORD_NORAISE|PROPWORD_NODEREF;
#if (SIZEOF_VOIDP == 8)
case POLY_SYS_cmem_load_64: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_cmem_store_64: return PROPWORD_NORAISE|PROPWORD_NODEREF;
#else
// These aren't implemented in 32-bit mode.
case POLY_SYS_cmem_load_64: return 0;
case POLY_SYS_cmem_store_64: return 0;
#endif
case POLY_SYS_cmem_store_float: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_cmem_store_double: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_io_operation: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_ffi: return 0;
case POLY_SYS_set_code_constant: return 0;
case POLY_SYS_move_words: return PROPWORD_NORAISE;
case POLY_SYS_move_words_overlap: return PROPWORD_NORAISE;
case POLY_SYS_shift_right_arith_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_to_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_move_bytes: return PROPWORD_NORAISE;
case POLY_SYS_move_bytes_overlap: return PROPWORD_NORAISE;
case POLY_SYS_code_flags: return 0;
case POLY_SYS_shrink_stack: return 0;
case POLY_SYS_stderr: return 0; // Not a function
case POLY_SYS_callcode_tupled: return 0;
case POLY_SYS_foreign_dispatch: return 0;
case POLY_SYS_XWindows: return 0;
case POLY_SYS_is_big_endian: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_bytes_per_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_offset_address: return 0;
case POLY_SYS_shift_right_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_neq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_not_bool: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_touch_final: return PROPWORD_NORAISE; // We need to treat this as though it had side-effects.
case POLY_SYS_string_length: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_geq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_leq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_gtr: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_int_lss: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
// Load_byte/word_immut are the same as load_byte/word except that they can only
// be applied to immutables so will always return the same result.
case POLY_SYS_load_byte_immut: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_load_word_immut: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_mul_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_plus_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_minus_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_div_word: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_or_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_and_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_xor_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_shift_left_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_mod_word: return PROPWORD_NOUPDATE|PROPWORD_NODEREF; // Can raise Divide
case POLY_SYS_word_geq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_leq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_gtr: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_lss: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_word_eq: return PROPWORD_NORAISE|PROPWORD_NOUPDATE|PROPWORD_NODEREF;
case POLY_SYS_load_byte: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_load_word: return PROPWORD_NORAISE|PROPWORD_NOUPDATE;
case POLY_SYS_assign_byte: return PROPWORD_NORAISE|PROPWORD_NODEREF;
case POLY_SYS_assign_word: return PROPWORD_NORAISE|PROPWORD_NODEREF;
default: raise_exception_string(taskData, EXC_Fail, "Unknown IO operation");
}
}
Handle poly_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORDHANDLE(code));
switch (c)
{
case 1:
return exportNative(taskData, args); // Export
case 2:
raise_syscall(taskData, "C Export has been withdrawn", 0);
return 0;
case 3:
return exportPortable(taskData, args); // Export as portable format
case 9: // Return the GIT version if appropriate
{
return SAVE(C_string_to_Poly(taskData, GitVersion));
}
case 10: // Return the RTS version string.
{
const char *version;
switch (machineDependent->MachineArchitecture())
{
case MA_Interpreted: version = "Portable-" TextVersion; break;
case MA_I386: version = "I386-" TextVersion; break;
case MA_X86_64: version = "X86_64-" TextVersion; break;
default: version = "Unknown-" TextVersion; break;
}
return SAVE(C_string_to_Poly(taskData, version));
}
case 11: // Return the RTS copyright string
return SAVE(C_string_to_Poly(taskData, poly_runtime_system_copyright));
case 12: // Return the architecture
{
const char *arch;
switch (machineDependent->MachineArchitecture())
{
case MA_Interpreted: arch = "Interpreted"; break;
case MA_I386: arch = "I386"; break;
case MA_X86_64: arch = "X86_64"; break;
default: arch = "Unknown"; break;
}
return SAVE(C_string_to_Poly(taskData, arch));
}
case 13: // Share common immutable data.
{
ShareData(taskData, args);
return SAVE(TAGGED(0));
}
// ObjSize and ShowSize have their own IO vector entries but really they don't
// need them. Include them here and add ObjProfile.
case 14:
return ObjSize(taskData, args);
case 15:
return ShowSize(taskData, args);
case 16:
return ObjProfile(taskData, args);
/* 17 and 18 are no longer used. */
case 19: // Return the RTS argument help string.
return SAVE(C_string_to_Poly(taskData, RTSArgHelp()));
case 20: // Write a saved state file.
return SaveState(taskData, args);
case 21: // Load a saved state file and any ancestors.
return LoadState(taskData, false, args);
case 22: // Show the hierarchy.
return ShowHierarchy(taskData);
case 23: // Change the name of the immediate parent stored in a child
return RenameParent(taskData, args);
case 24: // Return the name of the immediate parent stored in a child
return ShowParent(taskData, args);
case 25: // Old statistics - now removed
case 26:
raise_exception_string(taskData, EXC_Fail, "No statistics available");
case 27: // Get number of user statistics available
return Make_arbitrary_precision(taskData, N_PS_USER);
case 28: // Set an entry in the user stats table.
{
unsigned index = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(0));
if (index >= N_PS_USER)
raise_exception0(taskData, EXC_subscript);
POLYSIGNED value = getPolySigned(taskData, DEREFHANDLE(args)->Get(1));
globalStats.setUserCounter(index, value);
Make_arbitrary_precision(taskData, 0);
}
case 29: // Get local statistics.
return globalStats.getLocalStatistics(taskData);
case 30: // Get remote statistics. The argument is the process ID to get the statistics.
return globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, DEREFHANDLE(args)));
case 31: // Store a module
return StoreModule(taskData, args);
case 32: // Load a module
return LoadModule(taskData, args);
case 33: // Load hierarchy. This provides a complete list of children and parents.
return LoadState(taskData, true, args);
case 34: // Return the system directory for modules. This is configured differently
// in Unix and in Windows.
#if (defined(MODULEDIR))
return SAVE(C_string_to_Poly(taskData, Xstr(MODULEDIR)));
#elif (defined(_WIN32) && ! defined(__CYGWIN__))
{
// This registry key is configured when Poly/ML is installed using the installer.
// It gives the path to the Poly/ML installation directory. We return the
// Modules subdirectory.
HKEY hk;
if (RegOpenKeyEx(HKEY_LOCAL_MACHINE,
_T("SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\PolyML.exe"), 0,
KEY_QUERY_VALUE, &hk) == ERROR_SUCCESS)
{
DWORD valSize;
if (RegQueryValueEx(hk, _T("Path"), 0, NULL, NULL, &valSize) == ERROR_SUCCESS)
{
#define MODULEDIR _T("Modules")
TempString buff((TCHAR*)malloc(valSize + (_tcslen(MODULEDIR) + 1)*sizeof(TCHAR)));
DWORD dwType;
if (RegQueryValueEx(hk, _T("Path"), 0, &dwType, (LPBYTE)(LPTSTR)buff, &valSize) == ERROR_SUCCESS)
{
RegCloseKey(hk);
// The registry entry should end with a backslash.
_tcscat(buff, MODULEDIR);
return SAVE(C_string_to_Poly(taskData, buff));
}
}
RegCloseKey(hk);
}
return SAVE(C_string_to_Poly(taskData, ""));
}
#else
return SAVE(C_string_to_Poly(taskData, ""));
#endif
case 50: // GCD
return gcd_arbitrary(taskData, SAVE(DEREFHANDLE(args)->Get(0)), SAVE(DEREFHANDLE(args)->Get(1)));
case 51: // LCM
return lcm_arbitrary(taskData, SAVE(DEREFHANDLE(args)->Get(0)), SAVE(DEREFHANDLE(args)->Get(1)));
// These next ones were originally in process_env and have now been moved here,
case 100: /* Return the maximum word segment size. */
return taskData->saveVec.push(TAGGED(MAX_OBJECT_SIZE));
case 101: /* Return the maximum string size (in bytes).
It is the maximum number of bytes in a segment
less one word for the length field. */
return taskData->saveVec.push(TAGGED((MAX_OBJECT_SIZE)*sizeof(PolyWord) - sizeof(PolyWord)));
case 102: /* Test whether the supplied address is in the io area.
This was previously done by having get_flags return
256 but this was changed so that get_flags simply
returns the top byte of the length word. */
{
PolyWord *pt = (PolyWord*)DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
return Make_arbitrary_precision(taskData, 1);
else return Make_arbitrary_precision(taskData, 0);
}
case 103: /* Return the register mask for the given function.
This is used by the code-generator to find out
which registers are modified by the function and
so need to be saved if they are used by the caller. */
{
PolyObject *pt = DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
{
/* IO area. We need to get this from the vector. */
int i;
for (i=0; i < POLY_SYS_vecsize; i++)
{
if (pt == (PolyObject*)IoEntry(i))
{
int regMask = taskData->GetIOFunctionRegisterMask(i);
POLYUNSIGNED props = rtsProperties(taskData, i);
return taskData->saveVec.push(TAGGED(regMask | props));
}
}
raise_exception_string(taskData, EXC_Fail, "Io pointer not found");
}
else
{
/* We may have a pointer to the code or a pointer to
a closure. If it's a closure we have to find the
code. */
if (! pt->IsCodeObject() && ! pt->IsByteObject())
pt = pt->Get(0).AsObjPtr();
/* Should now be a code object. */
if (pt->IsCodeObject())
{
/* Compiled code. This is the second constant in the
constant area. */
PolyWord *codePt = pt->ConstPtrForCode();
PolyWord mask = codePt[1];
// A real mask will be an integer.
if (IS_INT(mask)) return SAVE(mask);
else raise_exception_string(taskData, EXC_Fail, "Invalid mask");
}
else raise_exception_string(taskData, EXC_Fail, "Not a code pointer");
}
}
case 104: return Make_arbitrary_precision(taskData, POLY_version_number);
case 105: /* Get the name of the function. */
{
PolyObject *pt = DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
{
/* IO area. */
int i;
for (i=0; i < POLY_SYS_vecsize; i++)
{
if (pt == (PolyObject*)IoEntry(i))
{
char buff[8];
sprintf(buff, "RTS%d", i);
return SAVE(C_string_to_Poly(taskData, buff));
}
}
raise_syscall(taskData, "Io pointer not found", 0);
}
else if (pt->IsCodeObject()) /* Should now be a code object. */
{
/* Compiled code. This is the first constant in the constant area. */
PolyWord *codePt = pt->ConstPtrForCode();
PolyWord name = codePt[0];
/* May be zero indicating an anonymous segment - return null string. */
if (name == PolyWord::FromUnsigned(0))
return SAVE(C_string_to_Poly(taskData, ""));
else return SAVE(name);
}
else raise_syscall(taskData, "Not a code pointer", 0);
}
default:
{
char msg[100];
sprintf(msg, "Unknown poly-specific function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}
Handle timing_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORDHANDLE(code));
switch (c)
{
case 0: /* Get ticks per microsecond. */
return Make_arbitrary_precision(taskData, TICKS_PER_MICROSECOND);
case 1: /* Return time since the time base. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ft;
GetSystemTimeAsFileTime(&ft);
return Make_arb_from_Filetime(taskData, ft);
#else
struct timeval tv;
if (gettimeofday(&tv, NULL) != 0)
raise_syscall(taskData, "gettimeofday failed", errno);
return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000);
#endif
}
case 2: /* Return the base year. This is the year which corresponds to
zero in the timing sequence. */
#if (defined(_WIN32) && ! defined(__CYGWIN__))
return Make_arbitrary_precision(taskData, 1601);
#else
return Make_arbitrary_precision(taskData, 1970);
#endif
case 3: /* In both Windows and Unix the time base is 1st of January
in the base year. This function is provided just in case
we are running on a system with a different base. It
returns the number of seconds after 1st January of the
base year that corresponds to zero of the time base. */
return Make_arbitrary_precision(taskData, 0);
case 4: /* Return the time offset which applied/will apply at the
specified time (in seconds). */
{
int localoff = 0;
time_t theTime;
int day = 0;
#if (defined(HAVE_GMTIME_R) || defined(HAVE_LOCALTIME_R))
struct tm result;
#endif
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* Although the offset is in seconds it is since 1601. */
FILETIME ftSeconds; // Not really a file-time because it's a number of seconds.
getFileTimeFromArb(taskData, args, &ftSeconds); /* May raise exception. */
ULARGE_INTEGER liTime;
liTime.HighPart = ftSeconds.dwHighDateTime;
liTime.LowPart = ftSeconds.dwLowDateTime;
theTime = (long)(liTime.QuadPart - SECSSINCE1601);
#else
theTime = get_C_long(taskData, DEREFWORDHANDLE(args)); /* May raise exception. */
#endif
{
#ifdef HAVE_GMTIME_R
struct tm *loctime = gmtime_r(&theTime, &result);
#else
PLocker lock(&timeLock);
struct tm *loctime = gmtime(&theTime);
#endif
if (loctime == NULL) raise_exception0(taskData, EXC_size);
localoff = (loctime->tm_hour*60 + loctime->tm_min)*60 + loctime->tm_sec;
day = loctime->tm_yday;
}
{
#ifdef HAVE_LOCALTIME_R
struct tm *loctime = localtime_r(&theTime, &result);
#else
PLocker lock(&timeLock);
struct tm *loctime = localtime(&theTime);
#endif
if (loctime == NULL) raise_exception0(taskData, EXC_size);
localoff -= (loctime->tm_hour*60 + loctime->tm_min)*60 + loctime->tm_sec;
if (loctime->tm_yday != day)
{
// Different day - have to correct it. We can assume that there
// is at most one day to correct.
if (day == loctime->tm_yday+1 || (day == 0 && loctime->tm_yday >= 364))
localoff += 24*60*60;
else localoff -= 24*60*60;
}
}
return Make_arbitrary_precision(taskData, localoff);
}
case 5: /* Find out if Summer Time (daylight saving) was/will be in effect. */
{
time_t theTime;
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ftSeconds; // Not really a file-time because it's a number of seconds.
getFileTimeFromArb(taskData, args, &ftSeconds); /* May raise exception. */
ULARGE_INTEGER liTime;
liTime.HighPart = ftSeconds.dwHighDateTime;
liTime.LowPart = ftSeconds.dwLowDateTime;
theTime = (long)(liTime.QuadPart - SECSSINCE1601);
#else
theTime = get_C_long(taskData, DEREFWORDHANDLE(args)); /* May raise exception. */
#endif
int isDst = 0;
#ifdef HAVE_LOCALTIME_R
struct tm result;
struct tm *loctime = localtime_r(&theTime, &result);
isDst = loctime->tm_isdst;
#else
{
PLocker lock(&timeLock);
struct tm *loctime = localtime(&theTime);
if (loctime == NULL) raise_exception0(taskData, EXC_size);
isDst = loctime->tm_isdst;
}
#endif
return Make_arbitrary_precision(taskData, isDst);
}
case 6: /* Call strftime. It would be possible to do much of this in
ML except that it requires the current locale. */
{
struct tm time;
char *format, buff[2048];
Handle resString;
/* Get the format string. */
format = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0));
/* Copy the time information. */
time.tm_year = get_C_int(taskData, DEREFHANDLE(args)->Get(1)) - 1900;
time.tm_mon = get_C_int(taskData, DEREFHANDLE(args)->Get(2));
time.tm_mday = get_C_int(taskData, DEREFHANDLE(args)->Get(3));
time.tm_hour = get_C_int(taskData, DEREFHANDLE(args)->Get(4));
time.tm_min = get_C_int(taskData, DEREFHANDLE(args)->Get(5));
time.tm_sec = get_C_int(taskData, DEREFHANDLE(args)->Get(6));
time.tm_wday = get_C_int(taskData, DEREFHANDLE(args)->Get(7));
time.tm_yday = get_C_int(taskData, DEREFHANDLE(args)->Get(8));
time.tm_isdst = get_C_int(taskData, DEREFHANDLE(args)->Get(9));
#if (defined(_WIN32) && ! defined(__CYGWIN__))
_tzset(); /* Make sure we set the current locale. */
#else
setlocale(LC_TIME, "");
#endif
/* It would be better to dynamically allocate the string rather
than use a fixed size but Unix unlike Windows does not distinguish
between an error in the input and the buffer being too small. */
if (strftime(buff, sizeof(buff), format, &time) <= 0)
{
/* Error */
free(format);
raise_exception0(taskData, EXC_size);
}
resString = taskData->saveVec.push(C_string_to_Poly(taskData, buff));
free(format);
return resString;
}
case 7: /* Return User CPU time since the start. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ut, ct, et, kt;
if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut))
raise_syscall(taskData, "GetProcessTimes failed", 0-GetLastError());
return Make_arb_from_Filetime(taskData, ut);
#else
struct rusage rusage;
if (getrusage(RUSAGE_SELF, &rusage) != 0)
raise_syscall(taskData, "getrusage failed", errno);
return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec,
rusage.ru_utime.tv_usec, 1000000);
#endif
}
case 8: /* Return System CPU time since the start. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ct, et, kt, ut;
if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut))
raise_syscall(taskData, "GetProcessTimes failed", 0-GetLastError());
return Make_arb_from_Filetime(taskData, kt);
#else
struct rusage rusage;
if (getrusage(RUSAGE_SELF, &rusage) != 0)
raise_syscall(taskData, "getrusage failed", errno);
return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec,
rusage.ru_stime.tv_usec, 1000000);
#endif
}
case 9: /* Return GC time since the start. */
return gHeapSizeParameters.getGCUtime(taskData);
case 10: /* Return real time since the start. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ft;
GetSystemTimeAsFileTime(&ft);
subFiletimes(&ft, &startTime);
return Make_arb_from_Filetime(taskData, ft);
#else
struct timeval tv;
if (gettimeofday(&tv, NULL) != 0)
raise_syscall(taskData, "gettimeofday failed", errno);
subTimevals(&tv, &startTime);
return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000);
#endif
}
/* These next two are used only in the Posix structure. */
case 11: /* Return User CPU time used by child processes. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
return Make_arbitrary_precision(taskData, 0);
#else
struct rusage rusage;
if (getrusage(RUSAGE_CHILDREN, &rusage) != 0)
raise_syscall(taskData, "getrusage failed", errno);
return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec,
rusage.ru_utime.tv_usec, 1000000);
#endif
}
case 12: /* Return System CPU time used by child processes. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
return Make_arbitrary_precision(taskData, 0);
#else
struct rusage rusage;
if (getrusage(RUSAGE_CHILDREN, &rusage) != 0)
raise_syscall(taskData, "getrusage failed", errno);
return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec,
rusage.ru_stime.tv_usec, 1000000);
#endif
}
case 13: /* Return GC system time since the start. */
return gHeapSizeParameters.getGCStime(taskData);
default:
{
char msg[100];
sprintf(msg, "Unknown timing function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}