CELL * p_trace(CELL * params)
{
if(params != nilCell)
{
params = evaluateExpression(params);
if(isNumber(params->type))
{
traceFlag |= TRACE_PRINT_EVAL;
getIntegerExt(params, &tracePrintDevice, FALSE);
return(stuffInteger(tracePrintDevice));
}
if(!isNil(params))
{
openTrace();
traceFlag |= TRACE_IN_DEBUG;
}
else
closeTrace();
}
if(traceFlag & TRACE_IN_DEBUG) return(trueCell);
if(traceFlag & TRACE_PRINT_EVAL) return(stuffInteger(tracePrintDevice));
return(nilCell);
}
CELL * p_find(CELL * params)
{
char * key;
char * str;
ssize_t found;
CELL * next;
CELL * keyCell;
CELL * funcCell;
size_t size;
long options = -1;
size_t offset = 0;
UINT * resultIdxSave;
keyCell = evaluateExpression(params);
params = getEvalDefault(params->next, &next);
if(keyCell->type == CELL_STRING && next->type == CELL_STRING)
{
key = (char *)keyCell->contents;
str = (char *)next->contents;
size = next->aux - 1;
if(params != nilCell)
{
if(params->next != nilCell)
getInteger(params->next, (UINT*)&offset);
if(offset > size) offset = size;
params = evaluateExpression(params);
if(!isNil(params))
getIntegerExt(params, (UINT *)&options, FALSE);
}
if(options == -1)
found = searchBuffer(str + offset, size - offset, key, keyCell->aux - 1, TRUE);
else
found = searchBufferRegex(str, (int)offset, key, (int)size, options, NULL) - offset;
if(found < 0) return(nilCell);
}
else
{
/* list mode with optional functor */
if(!isList(next->type)) return(nilCell);
next = (CELL *)next->contents;
found = 0;
if(params != nilCell)
funcCell = evaluateExpression(params);
else funcCell = NULL;
/* do regex when first arg is string and option# is present */
if(funcCell && isNumber(funcCell->type) && keyCell->type == CELL_STRING)
{
getIntegerExt(funcCell, (UINT*)&options, FALSE);
key = (char *)keyCell->contents;
while(next != nilCell)
{
if(next->type == CELL_STRING)
{
if(searchBufferRegex((char *)next->contents, 0,
key, next->aux - 1 , options, NULL) != -1) break;
}
found++;
next = next->next;
}
if(next == nilCell) return(nilCell);
else return(stuffInteger(found));
}
resultIdxSave = resultStackIdx;
while(next != nilCell)
{
if(compareFunc(keyCell, next, funcCell) == 0)
{
if(funcCell)
{
deleteList((CELL*)sysSymbol[0]->contents);
sysSymbol[0]->contents = (UINT)copyCell(next);
}
break;
}
found++;
next = next->next;
cleanupResults(resultIdxSave);
}
if(next == nilCell) return(nilCell);
}
return(stuffInteger(found + offset));
}
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);
}
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 * startsEndsWith(CELL * params, int type)
{
char * string;
char * key;
char * keydollar;
long options = -1;
size_t slen, pos;
int klen;
CELL * cell, * list;
cell = params->next;
getEvalDefault(params, &list);
if(list->type == CELL_STRING)
{
string = (char *)list->contents;
getString(cell, &key);
}
else
{
if(!isList(list->type))
errorProcExt(ERR_LIST_OR_STRING_EXPECTED, params);
cell = evaluateExpression(cell);
list = (CELL *)list->contents;
if(type == ENDS_WITH)
while(list->next != nilCell) list = list->next;
if(compareCells(list, cell) == 0) return(trueCell);
else return(nilCell);
}
if(cell->next != nilCell)
{
cell = evaluateExpression(cell->next);
getIntegerExt(cell, (UINT*)&options, FALSE);
}
klen = strlen(key);
slen = strlen(string);
if(type == STARTS_WITH)
{
if(options == -1)
{
if(strncmp(string, key, (size_t)klen) == 0)
return(trueCell);
}
else
{
if(searchBufferRegex(string, 0, key, slen, options, 0) == 0)
return(trueCell);
}
return(nilCell);
}
if((options == -1) && (klen > slen)) return(nilCell);
if(options == -1)
{
if(strncmp(string + slen - klen, key, klen) == 0)
return(trueCell);
}
else
{
/* append $ to the pattern for anchoring at the end */
keydollar = malloc(klen + 4);
*keydollar = '(';
memcpy(keydollar + 1, key, klen);
memcpy(keydollar + 1 + klen, ")$", 2);
*(keydollar + klen + 3) = 0;
klen = klen + 3;
if((pos = searchBufferRegex(string, 0, keydollar, slen, options, &klen)) != -1)
{
if(pos + klen == slen)
{
free(keydollar);
return(trueCell);
}
}
free(keydollar);
}
return(nilCell);
}
