// Concatenate two strings. Now used only internally in the RTS.
Handle strconcatc(TaskData *mdTaskData, Handle y, Handle x)
/* Note: arguments are in the reverse order from Poly */
{
Handle result;
POLYUNSIGNED len, xlen, ylen;
char *from_ptr, *to_ptr;
if (IS_INT(DEREFWORD(x)))
xlen = 1;
else
xlen = DEREFSTRINGHANDLE(x)->length;
/* Don't concatenate with null strings */
if (xlen == 0) return y;
if (IS_INT(DEREFWORD(y)))
ylen = 1;
else
ylen = DEREFSTRINGHANDLE(y)->length;
if (ylen == 0) return x;
len = xlen + ylen;
/* Get store for combined string. Include rounding up to next word and
room for the length word and add in the flag. */
result = alloc_and_save(mdTaskData, (len + sizeof(PolyWord)-1)/sizeof(PolyWord) + 1, F_BYTE_OBJ);
DEREFSTRINGHANDLE(result)->length = len;
/* Copy first string */
to_ptr = DEREFSTRINGHANDLE(result)->chars;
if (xlen == 1)
{
*to_ptr++ = (char)UNTAGGED(DEREFSTRINGHANDLE(x));
}
else
{
from_ptr = DEREFSTRINGHANDLE(x)->chars;
while (xlen-- > 0) (*to_ptr++ = *from_ptr++);
}
/* Add on second */
if (ylen == 1)
{
*to_ptr = (char)UNTAGGED(DEREFSTRINGHANDLE(y));
}
else
{
from_ptr = DEREFSTRINGHANDLE(y)->chars;
while (ylen-- > 0) (*to_ptr++ = *from_ptr++);
}
return(result);
} /* strconcat */
WCHAR *Poly_string_to_U_alloc(PolyWord ps)
{
char iBuff[1];
int iLength = 0;
const char *iPtr;
if (IS_INT(ps))
{
iLength = 1;
iBuff[0] = (char)UNTAGGED(ps);
iPtr = iBuff;
}
else
{
PolyStringObject *str = (PolyStringObject *)ps.AsObjPtr();
iLength = (int)str->length;
if (iLength == 0) return _wcsdup(L"");
iPtr = str->chars;
}
// Find the space required.
int chars = MultiByteToWideChar(codePage, 0, iPtr, iLength, NULL, 0);
if (chars <= 0) return _wcsdup(L"");
WCHAR *res = (WCHAR*)malloc((chars+1) * sizeof(WCHAR));
if (res == 0) return 0;
chars = MultiByteToWideChar(codePage, 0, iPtr, iLength, res, chars);
res[chars] = 0;
return res;
}
static Handle setRegistryKey(TaskData *taskData, Handle args, HKEY hkey)
{
TCHAR valName[MAX_PATH];
LONG lRes;
PolyWord str = args->WordP()->Get(3);
POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), valName, MAX_PATH);
DWORD dwType = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2));
if (length > MAX_PATH)
raise_syscall(taskData, "Value name too long", ENAMETOOLONG);
// The value is binary. Strings will already have had a null added.
if (IS_INT(str))
{
byte b = (byte)UNTAGGED(str);
// Single byte value.
lRes = RegSetValueEx(hkey, valName, 0, dwType, &b, 1);
}
else
{
PolyStringObject *ps = (PolyStringObject*)str.AsObjPtr();
lRes = RegSetValueEx(hkey, valName, 0, dwType,
(CONST BYTE *)ps->chars, (DWORD)ps->length);
}
if (lRes != ERROR_SUCCESS)
raise_syscall(taskData, "RegSetValue failed", -lRes);
return Make_arbitrary_precision(taskData, 0);
}
void print_string(PolyWord s)
{
if (IS_INT(s))
putc((char)UNTAGGED(s), stdout);
else {
PolyStringObject * str = (PolyStringObject *)s.AsObjPtr();
fwrite(str->chars, 1, str->length, stdout);
}
}
void PExport::printValue(PolyWord q)
{
if (IS_INT(q) || q == PolyWord::FromUnsigned(0))
fprintf(exportFile, "%" POLYSFMT, UNTAGGED(q));
else if (OBJ_IS_CODEPTR(q))
printCodeAddr(q.AsCodePtr());
else
printAddress(q.AsAddress());
}
// These functions are used in the interpreter. They are generally replaced by
// hand-coded versions in the assembly code section.
static int string_test(PolyWord x, PolyWord y)
/* Returns -1, 0, +1 if the first string is less, equal to or greater than the
second. These are addresses of the strings because calling
fix_persistent_address could result in a garbage-collection which could
move the other string. */
{
POLYUNSIGNED i;
PolyStringObject *xs, *ys;
/* Deal with single characters. */
if (IS_INT(x))
{
s_test_x.length = 1;
s_test_x.chars[0] = (char)UNTAGGED(x);
xs = &s_test_x;
}
else xs = (PolyStringObject*)x.AsObjPtr();
if (IS_INT(y))
{
s_test_y.length = 1;
s_test_y.chars[0] = (char)UNTAGGED(y);
ys = &s_test_y;
}
else ys = (PolyStringObject*)y.AsObjPtr();
/* Now do the comparison. */
for(i = 0; i < xs->length && i < ys->length; i++)
{
if (xs->chars[i] != ys->chars[i])
return xs->chars[i] < ys->chars[i] ? -1 : 1;
}
/* They must be equal or one must be a leading substring of the other. */
if (i < xs->length)
return 1; /* y must be the substring. */
else if (i < ys->length)
return -1; /* x must be the substring */
else
return 0; /* They must be equal. */
}
POLYUNSIGNED Poly_string_to_C(PolyWord ps, WCHAR *buff, POLYUNSIGNED bufflen)
{
if (IS_INT(ps))
{
buff[0] = (WCHAR)(UNTAGGED(ps));
buff[1] = 0;
return(1);
}
PolyStringObject *str = (PolyStringObject *)ps.AsObjPtr();
POLYUNSIGNED chars = str->length >= bufflen ? bufflen-1 : str->length;
for (POLYUNSIGNED i = 0; i < chars; i++) buff[i] = str->chars[i];
buff[chars] = 0;
return chars;
} /* Poly_string_to_C */
POLYUNSIGNED Poly_string_to_C(PolyWord ps, char *buff, POLYUNSIGNED bufflen)
/* Copies the characters from the string into the destination buffer.
Returns original length of string. */
{
if (IS_INT(ps))
{
buff[0] = (char)(UNTAGGED(ps));
buff[1] = '\0';
return(1);
}
PolyStringObject *str = (PolyStringObject *)ps.AsObjPtr();
POLYUNSIGNED chars = str->length >= bufflen ? bufflen-1 : str->length;
if (chars != 0) strncpy(buff, str->chars, chars);
buff[chars] = '\0';
return chars;
} /* Poly_string_to_C */
WCHAR *Poly_string_to_U_alloc(PolyWord ps)
{
if (IS_INT(ps))
{
WCHAR *res = (WCHAR*)malloc(2 * sizeof(WCHAR));
res[0] = (WCHAR)(UNTAGGED(ps));
res[1] = 0;
return res;
}
else
{
PolyStringObject *str = (PolyStringObject *)ps.AsObjPtr();
POLYUNSIGNED chars = str->length;
WCHAR * res = (WCHAR*)malloc((chars+1) * sizeof(WCHAR));
for (POLYUNSIGNED i = 0; i < chars; i++) res[i] = str->chars[i];
res[chars] = 0;
return res;
}
} /* Poly_string_to_U_alloc */
char *Poly_string_to_C_alloc(PolyWord ps)
/* Similar to Poly_string_to_C except that the string is allocated using
malloc and must be freed by the caller. */
{
char *res;
if (IS_INT(ps))
{
res = (char*)malloc(2);
res[0] = (char)(UNTAGGED(ps));
res[1] = '\0';
}
else
{
PolyStringObject * str = (PolyStringObject *)ps.AsObjPtr();
POLYUNSIGNED chars = str->length;
res = (char*)malloc(chars+1);
if (chars != 0) strncpy(res, str->chars, chars);
res[chars] = '\0';
}
return res;
} /* Poly_string_to_C_alloc */
POLYUNSIGNED Poly_string_to_C(PolyWord ps, WCHAR *buff, POLYUNSIGNED bufflen)
{
char iBuff[1];
int iLength = 0;
const char *iPtr;
if (IS_INT(ps))
{
iLength = 1;
iBuff[0] = (char)UNTAGGED(ps);
iPtr = iBuff;
}
else
{
PolyStringObject *str = (PolyStringObject *)ps.AsObjPtr();
iLength = (int)str->length;
if (iLength == 0)
{
// Null string.
if (bufflen != 0) buff[0] = 0;
return 0;
}
iPtr = str->chars;
}
// We can convert it directly using the maximum string length.
int space = MultiByteToWideChar(codePage, 0, iPtr, iLength, buff, (int)bufflen-1);
if (space <= 0)
{
if (bufflen != 0) buff[0] = 0;
return 0; // Error
}
buff[space] = 0; // Null terminate
return space;
}
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;
}
}
}