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_reverse(CELL * params)
{
CELL * cell;
CELL * list;
CELL * previous;
CELL * next;
char * str;
size_t len, tmp;
char * left;
char * right;
cell = params;
getEvalDefault(params, &list);
if(symbolCheck && isProtected(symbolCheck->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolCheck)));
if(isList(list->type))
{
list->aux = (UINT)nilCell; /* undo last element optimization */
previous = cell = (CELL*)list->contents;
next = cell->next;
cell->next = nilCell;
while(cell!= nilCell)
{
previous = cell;
cell = next;
next = cell->next;
if(cell != nilCell) cell->next = previous;
}
list->contents = (UINT)previous;
}
else if(list->type == CELL_STRING)
{
str = (char *)list->contents;
len = list->aux - 1;
left = str;
right = left + len - 1;
while(left < right)
{
tmp = *left;
*left = *right;
*right = tmp;
left++;
right--;
}
}
else return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, cell));
pushResultFlag = FALSE;
return(list);
}
void collectSymbols(SYMBOL * sPtr, CELL * symbolList)
{
CELL * cell;
if(sPtr != NIL_SYM && sPtr != NULL)
{
collectSymbols(sPtr->left, symbolList);
if(symbolList->contents == (UINT)nilCell)
{
symbolList->contents = (UINT)stuffSymbol(sPtr);
symbolList->aux = symbolList->contents;
}
else
{
cell = (CELL *)symbolList->aux;
cell->next = stuffSymbol(sPtr);
symbolList->aux = (UINT)cell->next;
}
collectSymbols(sPtr->right, symbolList);
}
}
CELL * getRefCheckProtected(CELL * params)
{
CELL * ref;
ref = evaluateExpression(params);
if(ref == nilCell || ref == trueCell)
errorProcExt(ERR_IS_NOT_REFERENCED, ref);
if(symbolCheck != NULL)
{
if(isProtected(symbolCheck->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolCheck)));
}
return(ref);
}
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_pop(CELL * params)
{
CELL * list;
CELL * cell = NULL;
ssize_t index;
int evalFlag = FALSE;
params = getEvalDefault(params, &list);
if(symbolCheck && isProtected(symbolCheck->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolCheck)));
if(!isList(list->type))
{
if(list->type == CELL_STRING)
return(popString(list, params));
else
return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, list));
}
/* leave last element optimization if popping first for queues */
if(params == nilCell)
{
cell = (CELL *)list->contents;
list->contents = (UINT)cell->next;
if(cell->next == nilCell) /* check if only one element in list */
list->aux = (UINT)nilCell; /* undo last element optimization */
cell->next = nilCell;
return(cell);
}
else
{
list->aux = (UINT)nilCell; /* undo last element optimization */
cell = (CELL*)params->next;
params = evaluateExpression(params);
if(isList(params->type))
{
evalFlag = FALSE;
params = getIntegerExt((CELL*)params->contents, (UINT*)&index, FALSE);
}
else
{
evalFlag = TRUE;
getIntegerExt(params, (UINT*)&index, FALSE);
params = cell;
}
}
while(isList(list->type))
{
cell = list;
list = (CELL *)list->contents;
if(index < 0) index = convertNegativeOffset(index, list);
while(index--)
{
cell = list;
list = list->next;
}
if(list == nilCell)
errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
if(params == nilCell || !isList(list->type)) break;
params = getIntegerExt(params, (UINT*)&index, evalFlag);
}
if(list == (CELL*)cell->contents)
cell->contents = (UINT)list->next;
else
cell->next = list->next;
list->next = nilCell;
return(list);
}
CELL * p_push(CELL * params)
{
CELL * newCell;
CELL * list;
CELL * cell = NULL;
CELL * listOrg;
SYMBOL * symbolRef;
int insert = 0, evalFlag = 0;
ssize_t index;
newCell = evaluateExpression(params);
params = getEvalDefault(params->next, &list);
listOrg = list;
if((symbolRef = symbolCheck))
{
if(isProtected(symbolCheck->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolCheck)));
if(isNil((CELL *)symbolCheck->contents))
{
deleteList((CELL*)symbolCheck->contents);
listOrg = makeCell(CELL_EXPRESSION, (UINT)copyCell(newCell));
symbolCheck->contents = (UINT)listOrg;
goto PUSH_RETURN;
}
}
if(!isList(list->type))
{
if(list->type == CELL_STRING)
{
pushOnString(newCell, list, params);
goto PUSH_RETURN;
}
else
return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, list));
}
if(params == nilCell)
index = 0;
else
{
cell = (CELL*)params->next;
params = evaluateExpression(params);
if(isList(params->type))
{
evalFlag = FALSE;
params = getIntegerExt((CELL*)params->contents, (UINT*)&index, FALSE);
}
else
{
evalFlag = TRUE;
getIntegerExt(params, (UINT*)&index, FALSE);
params = cell;
}
}
if(index == -1)
{
if(params == nilCell)
{
newCell = copyCell(newCell);
cell = (CELL*)list->aux;
list->aux = (UINT)newCell;
if(cell != nilCell && cell != trueCell)
cell->next = newCell;
else if(list->contents == (UINT)nilCell)
list->contents = (UINT)newCell;
else
{
cell = (CELL *)list->contents;
while(cell->next != nilCell)
cell = cell->next;
cell->next = newCell;
}
goto PUSH_RETURN;
}
}
list->aux = (UINT)nilCell; /* undo last element optimization */
while(isList(list->type))
{
cell = list;
list = (CELL *)list->contents;
if(index < 0)
{
index = listlen(list) + index;
if(index == -1)
{
index = 0;
insert = INSERT_BEFORE;
}
else if(index >= 0) insert = INSERT_AFTER;
else errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
}
else insert = INSERT_BEFORE;
while(index--)
{
if(list == nilCell)
{
if(index >= 0) errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
insert = INSERT_END;
break;
}
cell = list;
list = list->next;
}
if(params == nilCell || !isList(list->type)) break;
params = getIntegerExt(params, (UINT*)&index, evalFlag);
}
newCell = copyCell(newCell);
if(insert == INSERT_BEFORE || list == nilCell)
{
if(list == (CELL*)cell->contents)
{
cell->contents = (UINT)newCell;
newCell->next = list;
}
else
{
cell->next = newCell;
newCell->next = list;
}
}
else if(insert == INSERT_AFTER || insert == INSERT_END)
{
cell = list->next;
list->next = newCell;
newCell->next = cell;
}
PUSH_RETURN:
symbolCheck = symbolRef;
pushResultFlag = FALSE;
return(listOrg);
}
CELL * p_extend(CELL * params)
{
CELL * target;
CELL * head;
CELL * tail;
SYMBOL * symbolRef;
char * pStr;
size_t size;
params = getEvalDefault(params, &target);
if((symbolRef = symbolCheck))
{
if(isProtected(symbolRef->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolRef)));
if(isNil((CELL *)symbolRef->contents))
{
deleteList((CELL*)symbolRef->contents);
head = evaluateExpression(params);
if(isList(head->type) || head->type == CELL_STRING)
target = copyCell(head);
symbolRef->contents = (UINT)target;
params = params->next;
}
}
if(isList(target->type))
{
tail = (CELL *)target->aux;
target->aux = (UINT)nilCell;
if(tail == nilCell)
{
tail = (CELL *)target->contents;
while(tail->next != nilCell)
tail = tail->next;
}
while(params != nilCell)
{
params = getListHead(params, &head);
if(head == nilCell) continue;
if(target->contents == (UINT)nilCell)
{
target->contents = (UINT)copyList(head);
tail = lastCellCopied;
}
else
{
tail->next = copyList(head);
target->aux = (UINT)lastCellCopied;
tail = (CELL *)target->aux;
}
}
}
else if(target->type == CELL_STRING)
{
while(params != nilCell)
{
params = getStringSize(params, &pStr, &size, TRUE);
appendCellString(target, pStr, size);
}
}
else return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, target));
symbolCheck = symbolRef;
pushResultFlag = FALSE;
return(target);
}
CELL * p_rotate(CELL * params)
{
CELL * cell;
CELL * list;
CELL * previous;
CELL * last = NULL;
size_t length, index;
size_t count;
cell = params;
if(cell->next != nilCell) getInteger(cell->next, (UINT *)&count);
else count = 1;
getEvalDefault(params, &list);
if(symbolCheck && isProtected(symbolCheck->flags))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolCheck)));
if(list->type == CELL_STRING)
{
length = list->aux - 1;
if((count = adjustCount(count, length)) == 0)
{
pushResultFlag = FALSE;
return(list);
}
cell = copyCell(list);
memcpy((char*)cell->contents, (char *)(list->contents + length - count), count);
memcpy((char*)(cell->contents + count), (char *)list->contents, length - count);
memcpy((char*)list->contents, (char*)cell->contents, length);
deleteList(cell);
pushResultFlag = FALSE;
return(list);
}
if(!isList(list->type))
return(errorProcExt(ERR_LIST_EXPECTED, cell));
list->aux = (UINT)nilCell; /* undo last element optimization */
cell = (CELL *)list->contents;
length = 0;
while(cell != nilCell)
{
++length;
last = cell;
cell = cell->next;
}
if((count = adjustCount(count, length))== 0)
{
pushResultFlag = FALSE;
return(list);
}
index = length - count;
previous = cell = (CELL *)list->contents;
while(index--)
{
previous = cell;
cell = cell->next;
}
previous->next = nilCell;
last->next = (CELL *)list->contents;
list->contents = (UINT)cell;
pushResultFlag = FALSE;
return(list);
}
CELL * p_replace(CELL * params)
{
CELL * keyCell;
CELL * repCell;
CELL * funcCell = NULL;
CELL * list;
CELL * cell;
CELL * newList;
char * keyStr;
char * buff;
char * newBuff;
UINT cnt;
size_t newLen;
long options;
UINT * resultIdxSave;
SYMBOL * refSymbol;
keyCell = copyCell(evaluateExpression(params));
pushResult(keyCell);
params = getEvalDefault(params->next, &cell);
newList = cell;
refSymbol = symbolCheck;
if(symbolCheck && (isProtected(symbolCheck->flags) || isBuiltin(symbolCheck->flags)))
return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolCheck)));
cnt = 0;
resultIdxSave = resultStackIdx;
if(isList(cell->type))
{
cell->aux = (UINT)nilCell; /* undo last element optimization */
list = (CELL *)cell->contents;
if(params != nilCell)
{
repCell = params;
if(params->next != nilCell)
funcCell = evaluateExpression(params->next);
}
else
repCell = NULL;
COMPARE_START:
if(compareFunc(keyCell, list, funcCell) == 0)
{
if(repCell != NULL)
{
/* take out usage of sysSymbol0] in 10.2
should only be used for regex replacements
then $it doesn't need to be a copy */
deleteList((CELL*)sysSymbol[0]->contents);
itSymbol->contents = (UINT)copyCell(list);
sysSymbol[0]->contents = itSymbol->contents;
cell->contents = (UINT)copyCell(evaluateExpression(repCell));
cell = (CELL*)cell->contents;
cell->next = list->next;
}
else /* remove mode */
cell->contents = (UINT)list->next;
list->next = nilCell;
deleteList(list);
cnt++;
if(repCell != NULL)
list = cell;
else /* remove mode */
{
list = (CELL*)cell->contents;
if(list != nilCell)
goto COMPARE_START;
}
}
while(list->next != nilCell)
{
if(compareFunc(keyCell, list->next, funcCell) == 0)
{
cell = list->next; /* cell = old elmnt */
if(repCell != NULL)
{
/* take out usage of sysSymbol0] in 10.2
should only be used for regex replacements */
deleteList((CELL*)sysSymbol[0]->contents);
itSymbol->contents = (UINT)copyCell(cell);
sysSymbol[0]->contents = itSymbol->contents;
list->next = copyCell(evaluateExpression(repCell));
list = list->next;
}
list->next = cell->next;
cell->next = nilCell;
deleteList(cell);
cnt++;
}
else
list = list->next;
cleanupResults(resultIdxSave);
}
deleteList((CELL*)sysSymbol[0]->contents);
/* sysSymbol[0] should not be used here, introduce $count */
sysSymbol[0]->contents = (UINT)stuffInteger(cnt);
itSymbol->contents = (UINT)nilCell;
symbolCheck = refSymbol;
pushResultFlag = FALSE;
return(newList);
}
if(cell->type == CELL_STRING)
{
if(keyCell->type != CELL_STRING)
return(errorProc(ERR_STRING_EXPECTED));
keyStr = (char *)keyCell->contents;
buff = (char *)cell->contents;
repCell = params;
if(repCell == nilCell)
return(errorProc(ERR_MISSING_ARGUMENT));
options = -1;
if(repCell->next != nilCell)
getInteger(repCell->next, (UINT*)&options);
newBuff = replaceString(keyStr, keyCell->aux - 1,
buff, (size_t)cell->aux -1, repCell, &cnt, options, &newLen);
if(newBuff != NULL)
{
freeMemory(buff);
cell->contents = (UINT)newBuff;
cell->aux = newLen + 1;
}
deleteList((CELL*)sysSymbol[0]->contents);
sysSymbol[0]->contents = (UINT)stuffInteger(cnt);
symbolCheck = refSymbol;
pushResultFlag = FALSE;
return(cell);
}
return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, cell));
}