static Handle queryRegistryKey(TaskData *taskData, Handle args, HKEY hkey)
{
TCHAR valName[MAX_PATH];
byte *keyValue = 0;
LONG lRes;
DWORD valSize;
Handle result, resVal, resType;
DWORD dwType;
POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), valName, MAX_PATH);
if (length > MAX_PATH)
raise_syscall(taskData, "Value name too long", ENAMETOOLONG);
// How long is the entry?
lRes = RegQueryValueEx(hkey, valName, 0, NULL, NULL, &valSize);
// When opening HKEY_PERFORMANCE_DATA we don't get a sensible
// answer here.
if (lRes == ERROR_MORE_DATA) valSize = 1024; // Guess
else if (lRes != ERROR_SUCCESS)
raise_syscall(taskData, "RegQueryValueEx failed", -lRes);
// Allocate that much store and get the value. We could
// try reading directly into ML store to save copying but
// it hardly seems worthwhile.
// Note: It seems that valSize can be zero for some items.
if (valSize == 0) resVal = SAVE(C_string_to_Poly(taskData, "", 0));
else
{
do {
byte *newAlloc = (byte*)realloc(keyValue, valSize);
if (newAlloc == 0)
{
free(keyValue);
raise_syscall(taskData, "Insufficient memory", ENOMEM);
}
keyValue = newAlloc;
lRes = RegQueryValueEx(hkey, valName, 0, &dwType, keyValue, &valSize);
// In the special case of HKEY_PERFORMANCE_DATA we may need to keep
// growing the buffer.
if (lRes == ERROR_MORE_DATA) valSize = valSize + 1024;
} while (lRes == ERROR_MORE_DATA);
if (lRes != ERROR_SUCCESS)
{
free(keyValue);
raise_syscall(taskData, "RegQueryValue failed", -lRes);
}
// If we have a string we have to convert this to ANSI/utf-8.
if (dwType == REG_SZ || dwType == REG_MULTI_SZ || dwType == REG_EXPAND_SZ)
resVal = SAVE(C_string_to_Poly(taskData, (TCHAR*)keyValue, valSize / sizeof(TCHAR)));
else resVal = SAVE(C_string_to_Poly(taskData, (char*)keyValue, valSize));
free(keyValue);
}
/* Create a pair containing the type and the value. */
resType = Make_arbitrary_precision(taskData, dwType);
result = alloc_and_save(taskData, 2);
DEREFHANDLE(result)->Set(0, DEREFWORDHANDLE(resType));
DEREFHANDLE(result)->Set(1, DEREFWORDHANDLE(resVal));
return result;
}
/* convert_string_list return a list of strings. */
Handle convert_string_list(TaskData *mdTaskData, int count, char **strings)
{
Handle saved = mdTaskData->saveVec.mark();
Handle list = SAVE(ListNull);
/* It's simplest to process the strings in reverse order */
for (int i = count - 1; 0 <= i; i--)
{
/*
The order of these declarations is important, becaue we don't
want to have make to make the cons cell mutable. This is only
safe if we promise to initialise it fully before the next
ML heap allocation. SPF 29/11/96
*/
Handle value = SAVE(C_string_to_Poly(mdTaskData, strings[i]));
Handle next = alloc_and_save(mdTaskData, SIZEOF(ML_Cons_Cell));
DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value);
DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list);
/* reset save vector to stop it overflowing */
mdTaskData->saveVec.reset(saved);
list = SAVE(DEREFHANDLE(next));
}
return list;
}
// Enumerate a key or a value. Returns a string option containing NONE if
// no key/value could be found or SOME s where s is the name of the key/value.
static Handle enumerateRegistry(TaskData *taskData, Handle args, HKEY hkey, BOOL isKey)
{
DWORD num = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1));
LONG lRes;
TCHAR keyName[MAX_PATH];
DWORD dwLength = sizeof(keyName)/sizeof(keyName[0]);
Handle result, resVal;
if (isKey)
{
FILETIME ftMod;
lRes = RegEnumKeyEx(hkey, num, keyName, &dwLength, NULL, NULL, NULL, &ftMod);
if (lRes != ERROR_SUCCESS && lRes != ERROR_NO_MORE_ITEMS)
raise_syscall(taskData, "RegEnumKeyEx failed", -lRes);
}
else
{
lRes = RegEnumValue(hkey, num, keyName, &dwLength, NULL, NULL, NULL, NULL);
if (lRes != ERROR_SUCCESS && lRes != ERROR_NO_MORE_ITEMS)
raise_syscall(taskData, "RegEnumValue failed", -lRes);
}
if (lRes == ERROR_NO_MORE_ITEMS)
return SAVE(NONE_VALUE); /* NONE. */
resVal = SAVE(C_string_to_Poly(taskData, keyName));
result = alloc_and_save(taskData, 1);
DEREFHANDLE(result)->Set(0, DEREFWORDHANDLE(resVal));
return result;
}
Handle ShowParent(TaskData *taskData, Handle hFileName)
// Return the name of the immediate parent stored in a child
{
TCHAR fileNameBuff[MAXPATHLEN+1];
POLYUNSIGNED length =
Poly_string_to_C(DEREFHANDLE(hFileName), fileNameBuff, MAXPATHLEN);
if (length > MAXPATHLEN)
raise_syscall(taskData, "File name too long", ENAMETOOLONG);
AutoClose loadFile(_tfopen(fileNameBuff, _T("rb")));
if ((FILE*)loadFile == NULL)
{
char buff[MAXPATHLEN+1+23];
#if (defined(_WIN32) && defined(UNICODE))
sprintf(buff, "Cannot open load file: %S", fileNameBuff);
#else
sprintf(buff, "Cannot open load file: %s", fileNameBuff);
#endif
raise_syscall(taskData, buff, errno);
}
SavedStateHeader header;
// Read the header and check the signature.
if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1)
raise_fail(taskData, "Unable to load header");
if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0)
raise_fail(taskData, "File is not a saved state");
if (header.headerVersion != SAVEDSTATEVERSION ||
header.headerLength != sizeof(SavedStateHeader) ||
header.segmentDescrLength != sizeof(SavedStateSegmentDescr))
{
raise_fail(taskData, "Unsupported version of saved state file");
}
// Does this have a parent?
if (header.parentNameEntry != 0)
{
TCHAR parentFileName[MAXPATHLEN+1];
size_t toRead = header.stringTableSize-header.parentNameEntry;
if (MAXPATHLEN < toRead) toRead = MAXPATHLEN;
if (header.parentNameEntry >= header.stringTableSize /* Bad entry */ ||
fseek(loadFile, header.stringTable + header.parentNameEntry, SEEK_SET) != 0 ||
fread(parentFileName, 1, toRead, loadFile) != toRead)
{
raise_fail(taskData, "Unable to read parent file name");
}
parentFileName[toRead] = 0; // Should already be null-terminated, but just in case.
// Convert the name into a Poly string and then build a "Some" value.
// It's possible, although silly, to have the empty string as a parent name.
Handle resVal = SAVE(C_string_to_Poly(taskData, parentFileName));
Handle result = alloc_and_save(taskData, 1);
DEREFHANDLE(result)->Set(0, DEREFWORDHANDLE(resVal));
return result;
}
else return SAVE(NONE_VALUE);
}
// Construct an entry in the ABI table.
static Handle mkAbitab(TaskData *taskData, void *arg, char *p)
{
struct _abiTable *ab = (struct _abiTable *)p;
// Construct a pair of the string and the code
Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName));
Handle code = Make_arbitrary_precision(taskData, ab->abiCode);
Handle result = alloc_and_save(taskData, 2);
result->WordP()->Set(0, name->Word());
result->WordP()->Set(1, code->Word());
return result;
}
Handle ShowHierarchy(TaskData *taskData)
// Return the list of files in the hierarchy.
{
Handle saved = taskData->saveVec.mark();
Handle list = SAVE(ListNull);
// Process this in reverse order.
for (unsigned i = hierarchyDepth; i > 0; i--)
{
Handle value = SAVE(C_string_to_Poly(taskData, hierarchyTable[i-1]->fileName));
Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell)/sizeof(PolyWord));
DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value);
DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list);
taskData->saveVec.reset(saved);
list = SAVE(DEREFHANDLE(next));
}
return list;
}
// convert_string_list return a list of strings.
// This converts Unicode strings.
Handle convert_string_list(TaskData *mdTaskData, int count, WCHAR **strings)
{
Handle saved = mdTaskData->saveVec.mark();
Handle list = SAVE(ListNull);
// It's simplest to process the strings in reverse order */
for (int i = count - 1; 0 <= i; i--)
{
Handle value = SAVE(C_string_to_Poly(mdTaskData, strings[i]));
Handle next = alloc_and_save(mdTaskData, SIZEOF(ML_Cons_Cell));
DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value);
DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list);
// reset save vector to stop it overflowing
mdTaskData->saveVec.reset(saved);
list = SAVE(DEREFHANDLE(next));
}
return list;
}
Handle Real_strc(TaskData *mdTaskData, Handle hDigits, Handle hMode, Handle arg)
{
double dx = real_arg(arg);
int decpt, sign;
int mode = get_C_int(mdTaskData, DEREFWORDHANDLE(hMode));
int digits = get_C_int(mdTaskData, DEREFWORDHANDLE(hDigits));
/* Compute the shortest string which gives the required value. */
/* */
char *chars = poly_dtoa(dx, mode, digits, &decpt, &sign, NULL);
/* We have to be careful in case an allocation causes a
garbage collection. */
PolyWord pStr = C_string_to_Poly(mdTaskData, chars);
poly_freedtoa(chars);
Handle ppStr = mdTaskData->saveVec.push(pStr);
/* Allocate a triple for the results. */
PolyObject *result = alloc(mdTaskData, 3);
result->Set(0, DEREFWORDHANDLE(ppStr));
result->Set(1, TAGGED(decpt));
result->Set(2, TAGGED(sign));
return mdTaskData->saveVec.push(result);
}
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;
}
}
}
/* CALL_IO1(Real_repr, REF, NOIND) */
Handle Real_reprc(TaskData *mdTaskData, Handle val) /* real to string */
{
char string_buffer[30];
Real_Rep(mdTaskData, real_arg(val), string_buffer);
return mdTaskData->saveVec.push(C_string_to_Poly(mdTaskData, string_buffer));
} /* Real_reprc */
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;
}
}
}
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;
}
}
}
