void makeContextFromSymbol(SYMBOL * symbol, SYMBOL * treePtr)
{
CELL * contextCell;
UINT * idx = envStackIdx;
/* make sure symbol is not used as local in call hierachy
and symbol is legal */
while(idx > envStack)
{
if(symbol == (SYMBOL *)*(--idx))
errorProcExt2(ERR_CANNOT_PROTECT_LOCAL, stuffSymbol(symbol));
--idx;
}
if(!isLegalSymbol(symbol->name))
errorProcExt2(ERR_INVALID_PARAMETER, stuffString(symbol->name));
contextCell = makeCell(CELL_CONTEXT, (UINT)symbol);
contextCell->aux = (UINT)treePtr;
symbol->contents = (UINT)contextCell;
symbol->context = mainContext;
symbol->flags |= (SYMBOL_PROTECTED | SYMBOL_GLOBAL);
}
CELL * p_member(CELL * params)
{
CELL * key;
CELL * list;
long options = -1;
char * ptr;
ssize_t pos;
key = evaluateExpression(params);
params = getEvalDefault(params->next, &list);
if(params != nilCell)
getInteger(params, (UINT *)&options);
if(isList(list->type))
list = (CELL *)list->contents;
else if (list->type == CELL_STRING)
{
if(key->type != CELL_STRING)
return(errorProcExt(ERR_STRING_EXPECTED, key));
if(options == -1)
{
ptr = strstr((char *)list->contents, (char *) key->contents);
if(ptr) return(stuffString(ptr));
}
else
{
pos = searchBufferRegex((char*)list->contents, 0, (char *)key->contents, list->aux - 1, options, 0);
if(pos != -1) return(stuffString((char *)list->contents + pos));
}
return(nilCell);
}
else
return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params->next));
while(list != nilCell)
{
if(compareCells(key, list) == 0) break;
list = list->next;
}
if(list == nilCell) return(nilCell);
return(makeCell(CELL_EXPRESSION, (UINT)copyList(list)));
}
CELL * popString(CELL * str, CELL * params)
{
char * ptr;
char * newPtr;
ssize_t index = 0;
ssize_t len = 1;
ssize_t size;
CELL * result;
ptr = (char *)str->contents;
#ifdef SUPPORT_UTF8
size = utf8_wlen(ptr);
#else
size = str->aux - 1;
#endif
if(str->aux < 2)
return(stuffString(""));
if(params != nilCell)
{
params = getInteger(params, (UINT*)&index);
if(params != nilCell)
{
getInteger(params, (UINT*)&len);
if(len < 1) len = 0;
}
}
index = adjustNegativeIndex(index, size);
if((index + len) > size)
len = size - index;
#ifdef SUPPORT_UTF8
newPtr = ptr;
while(index--) /* recalculate index in bytes */
newPtr += utf8_1st_len(newPtr);
index = newPtr - ptr;
while(len--) /* recalculate len in bytes */
newPtr += utf8_1st_len(newPtr);
len = (newPtr - ptr) - index;
#endif
newPtr = callocMemory(str->aux - len);
memcpy(newPtr, ptr, index);
memcpy(newPtr + index, ptr + index + len, str->aux - len - index);
str->aux = str->aux - len;
str->contents = (UINT)newPtr;
result = stuffStringN(ptr + index, len);
free(ptr);
return(result);
}
/* renamed to 'term' in v.10.1.11 */
CELL * p_term(CELL * params)
{
SYMBOL * sPtr;
params = evaluateExpression(params);
if(params->type == CELL_SYMBOL || params->type == CELL_CONTEXT)
sPtr = (SYMBOL *)params->contents;
else
return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, params));
return(stuffString(sPtr->name));
}
/* only for symbols starting with underscore character _ */
void collectSymbolAssocs(SYMBOL * sPtr, CELL * assocList)
{
CELL * cell;
if(sPtr != NIL_SYM && sPtr != NULL)
{
collectSymbolAssocs(sPtr->left, assocList);
if(*sPtr->name == '_')
{
cell = makeCell(CELL_EXPRESSION, (UINT)stuffString(sPtr->name + 1));
((CELL *)cell->contents)->next = copyCell((CELL *)sPtr->contents);
if(assocList->contents == (UINT)nilCell)
assocList->contents = (UINT)cell;
else
((CELL *)assocList->aux)->next = cell;
assocList->aux = (UINT)cell;
}
collectSymbolAssocs(sPtr->right, assocList);
}
}
CELL * p_join(CELL * params)
{
char * joint = NULL;
CELL * list;
size_t jointLen = 0;
int trailJoint = 0;
params = getListHead(params, &list);
if(list == nilCell)
return(stuffString(""));
if(list->type != CELL_STRING)
return(errorProcExt(ERR_STRING_EXPECTED, list));
if(params != nilCell)
{
params = getStringSize(params, &joint, &jointLen, TRUE);
trailJoint = getFlag(params);
}
return(appendString(list, list->next, joint, jointLen, trailJoint, FALSE));
}
CELL * p_importLib(CELL * params)
{
char * libName;
char * funcName;
char * options = NULL;
HINSTANCE hLibrary;
CELL * pCell;
SYMBOL * symbol;
FARPROC initProc;
int type = CELL_IMPORT_DLL;
params = getString(params, &libName);
params = getString(params, &funcName);
if(params != nilCell)
{
if(params->next == nilCell)
params = getString(params, &options);
#ifdef FFI
else
type = CELL_IMPORT_FFI;
#endif
}
if( (UINT)(hLibrary = LoadLibrary(libName)) < 32)
return(errorProcExt2(ERR_IMPORT_LIB_NOT_FOUND, stuffString(libName)));
if(options != NULL && strcmp(options, "cdecl") == 0)
type = CELL_IMPORT_CDECL;
symbol = translateCreateSymbol(funcName, type, currentContext, TRUE);
if(isFFIsymbol(symbol->flags)) /* don't redefine return current def */
return (copyCell((CELL *)symbol->contents));
if(isProtected(symbol->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
pCell = getCell(type);
deleteList((CELL *)symbol->contents);
symbol->contents = (UINT)pCell;
if((pCell->contents = (UINT)GetProcAddress(hLibrary, (LPCSTR)funcName)) == 0)
return(errorProcExt2(ERR_IMPORT_FUNC_NOT_FOUND, stuffString(funcName)));
/* put name of imported DLL into DLLs space for loadStartup() */
initProc = GetProcAddress(hLibrary, (LPCSTR)"dllName");
if(initProc != 0) (*initProc)(libName);
#ifdef FFI
symbol->flags |= SYMBOL_FFI | SYMBOL_PROTECTED;
if(pCell->type == CELL_IMPORT_FFI)
{
pCell->aux = (UINT)calloc(sizeof(FFIMPORT), 1);
((FFIMPORT *)pCell->aux)->name = symbol->name;
return(copyCell(ffiPreparation(pCell, params, FFI_FUNCTION)));
}
#endif
pCell->aux = (UINT)symbol->name;
return(copyCell(pCell));
}
CELL * p_importLib(CELL * params)
{
char * libName;
char * funcName;
void * hLibrary;
CELL * pCell;
SYMBOL * symbol;
char * error;
#ifdef CYGWIN
char * options = NULL;
int type = CELL_IMPORT_DLL;
#else
int type = CELL_IMPORT_CDECL;
#endif
params = getString(params, &libName);
if(params != nilCell)
params = getString(params, &funcName);
else funcName = NULL;
#ifdef CYGWIN
if(params != nilCell)
{
if(params->next == nilCell)
{
params = getString(params, &options);
if(strcmp(options, "cdecl") == 0)
type = CELL_IMPORT_CDECL;
}
#ifdef FFI
else type = CELL_IMPORT_FFI;
#endif
}
#else
if(params->next != nilCell)
type = CELL_IMPORT_FFI;
#endif
hLibrary = 0;
#ifdef TRU64
if((hLibrary = dlopen(libName, RTLD_LAZY)) == 0)
#else
if((hLibrary = dlopen(libName, RTLD_GLOBAL|RTLD_LAZY)) == 0)
#endif
return(errorProcExt2(ERR_IMPORT_LIB_NOT_FOUND, stuffString((char *)dlerror())));
if(funcName == NULL)
return(trueCell);
symbol = translateCreateSymbol(funcName, type, currentContext, TRUE);
if(isFFIsymbol(symbol->flags)) /* don't redefine */
return (copyCell((CELL *)symbol->contents));
if(isProtected(symbol->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
pCell = getCell(type);
deleteList((CELL *)symbol->contents);
symbol->contents = (UINT)pCell;
dlerror(); /* clear potential error */
pCell->contents = (UINT)dlsym(hLibrary, funcName);
if((error = (char *)dlerror()) != NULL)
return(errorProcExt2(ERR_IMPORT_FUNC_NOT_FOUND, stuffString(error)));
#ifdef FFI
symbol->flags |= SYMBOL_FFI | SYMBOL_PROTECTED;
if(pCell->type == CELL_IMPORT_FFI)
{
pCell->aux = (UINT)calloc(sizeof(FFIMPORT), 1);
((FFIMPORT *)pCell->aux)->name = symbol->name;
return(copyCell(ffiPreparation(pCell, params, FFI_FUNCTION)));
}
#endif
pCell->aux = (UINT)symbol->name;
return(copyCell(pCell));
}
CELL * p_select(CELL * params)
{
size_t n = 0, idx = 0;
ssize_t index;
CELL * list, * cell;
CELL * result = NULL;
CELL * head;
int evalFlag = TRUE;
char * str, * newStr;
#ifdef SUPPORT_UTF8
int * wstr;
int * wnewStr;
size_t len;
#endif
params = getEvalDefault(params, &head);
cell = evaluateExpression(params);
if(isList(cell->type))
{
evalFlag = FALSE;
cell = params = (CELL *)cell->contents;
}
if(head->type == CELL_STRING)
{
if((n = listlen(params)) == 0) return(stuffString(""));
str = (char *)head->contents;
#ifndef SUPPORT_UTF8
newStr = (char *)allocMemory(n + 1);
idx = 0;
while(params->type != CELL_NIL)
{
if(idx == 0)
{
getIntegerExt(cell, (UINT *)&index, FALSE);
params = params->next;
}
else
params = getIntegerExt(params, (UINT *)&index, evalFlag);
index = adjustNegativeIndex(index, head->aux -1);
*(newStr + idx++) = *(str + index);
}
*(newStr + n) = 0;
#else
wstr = allocMemory(head->aux * sizeof(int));
len = utf8_wstr(wstr, str, head->aux - 1);
wnewStr = allocMemory((n + 1) * sizeof(int));
idx = 0;
while(params->type != CELL_NIL)
{
if(idx == 0)
{
getIntegerExt(cell, (UINT *)&index, FALSE);
params = params->next;
}
else
params = getIntegerExt(params, (UINT *)&index, evalFlag);
index = adjustNegativeIndex(index, len);
*(wnewStr + idx++) = *(wstr + index);
}
*(wnewStr + n) = 0;
newStr = allocMemory(UTF8_MAX_BYTES * n + 1);
n = wstr_utf8(newStr, wnewStr, UTF8_MAX_BYTES * n);
newStr = reallocMemory(newStr, n + 1);
free(wstr); free(wnewStr);
#endif
result = getCell(CELL_STRING);
result->aux = n + 1;
result->contents = (UINT)newStr;
return(result);
}
if(!isList(head->type))
return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, head));
head = (CELL *)head->contents;
list = head;
n = 0;
while(params->type != CELL_NIL)
{
if(n++ == 0)
{
getIntegerExt(cell, (UINT *)&index, FALSE);
params = params->next;
}
else
params = getIntegerExt(params, (UINT *)&index, evalFlag);
if(index < 0) index = convertNegativeOffset(index, head);
if(index < idx) list = head, idx = 0;
while(idx < index && list != nilCell) list = list->next, idx++;
if(list == nilCell)
errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
if(result == NULL)
{
result = getCell(CELL_EXPRESSION);
cell = copyCell(list);
result->contents = (UINT)cell;
}
else
{
cell->next = copyCell(list);
cell = cell->next;
}
}
return((result == NULL) ? getCell(CELL_EXPRESSION) : result);
}