debian/newlisp
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
newlisp/nl-symbol.c

962 lines
21 KiB
C
Raw Blame History

/* nl-symbol.c --- symbol handling routines for newLISP
Copyright (C) 2016 Lutz Mueller
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#include "newlisp.h"
#include "protos.h"
#ifdef MAC_OSX
#include <sys/mman.h>
#endif
#define str2cmp(s1,s2) \
(( (*(unsigned char *)(s1) << 8) | *((unsigned char *)(s1) + 1) ) - \
( (*(unsigned char *)(s2) << 8) | *((unsigned char *)(s2) + 1) ) )
extern CELL * cellMemory;
extern SYMBOL * trueSymbol;
extern SYMBOL * orSymbol;
SYMBOL * findInsertSymbol(char * key, int forceCreation);
int deleteSymbol(char * key);
void deleteContextSymbols(CELL * cell, int checkReferences);
void changeContextCells(SYMBOL * contextPtr);
CELL dumpSymbol(char * name);
void collectSymbols(SYMBOL * sPtr, CELL * symbolList);
void collectSymbolAssocs(SYMBOL * sPtr, CELL * assocList);
static SYMBOL * root; /* root symbol derived from context */
/* --------- return a list of all symbols in a context -------------- */
CELL * p_symbols(CELL * params)
{
SYMBOL * context;
CELL * symbolList;
symbolList = getCell(CELL_EXPRESSION);
if(params->type == CELL_NIL)
context = currentContext;
else
getContext(params, &context);
if(context) /* check in case we are in debug mode */
collectSymbols((SYMBOL *)((CELL *)context->contents)->aux, symbolList);
return(symbolList);
}
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 * associationsFromTree(SYMBOL * context)
{
CELL * assocsList;
assocsList = getCell(CELL_EXPRESSION);
collectSymbolAssocs((SYMBOL *)((CELL *)context->contents)->aux, assocsList);
return(assocsList);
}
/* 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);
}
}
SYMBOL * lookupSymbol(char * token, SYMBOL * context)
{
root = (SYMBOL *)((CELL *)context->contents)->aux;
return(findInsertSymbol(token, LOOKUP_ONLY));
}
SYMBOL * makeSafeSymbol(CELL * cell, SYMBOL * context, int flag)
{
char * token;
UINT number;
if(isNumber(cell->type))
{
token = alloca(32);
getIntegerExt(cell, &number, FALSE);
snprintf(token, 31, "_%"PRIdPTR, number);
}
else
{
token = alloca(cell->aux + 1);
*token = '_';
memcpy(token + 1, (char *)cell->contents, cell->aux);
}
if(flag)
return(translateCreateSymbol(token, CELL_NIL, context, TRUE));
root = (SYMBOL *)((CELL *)context->contents)->aux;
return(findInsertSymbol(token, LOOKUP_ONLY));
}
/*
if forceFlag is TRUE then
create the symbol, if not found in the context
specified in that context
else
if not found try to inherit from MAIN as a global
or primitive, else create it in context specified
*/
SYMBOL * translateCreateSymbol
(char * token, int type, SYMBOL * context, int forceFlag)
{
SYMBOL * sPtr;
CELL * cell = NULL;
size_t len;
cell = (CELL *)context->contents;
root = (SYMBOL *)cell->aux;
if(forceFlag)
sPtr = findInsertSymbol(token, FORCE_CREATION);
else /* try to inherit from MAIN, if not here create in current context */
{
sPtr = findInsertSymbol(token, LOOKUP_ONLY);
if(sPtr == NULL)
{
if(context != mainContext)
{
root = (SYMBOL *)((CELL *)mainContext->contents)->aux;
sPtr = findInsertSymbol(token, LOOKUP_ONLY);
/* since 7.2.7 only inherit primitives and other globals */
if(sPtr != NULL && !(sPtr->flags & SYMBOL_GLOBAL))
{
if(symbolType(sPtr) != CELL_CONTEXT
|| (SYMBOL *)((CELL*)sPtr->contents)->contents != sPtr)
sPtr = NULL;
}
root = (SYMBOL *)cell->aux;
}
if(sPtr == NULL)
sPtr = findInsertSymbol(token, FORCE_CREATION);
}
}
/* the symbol existed already, return */
if(sPtr->contents != 0)
return(sPtr);
/* root might have changed, after symbol insertion */
cell->aux = (UINT)root;
/* a new symbol has been allocated by findInsertSymbol() */
if(type != CELL_PRIMITIVE)
{
len = strlen(token);
sPtr->name = (char *)allocMemory(len + 1);
memcpy(sPtr->name, token, len + 1);
cell = copyCell(nilCell);
sPtr->contents = (UINT)cell;
/* make a new context symbol */
if(type == CELL_CONTEXT && context == mainContext)
{
cell->type = CELL_CONTEXT;
cell->contents = (UINT)sPtr;
cell->aux = 0;
sPtr->flags |= (SYMBOL_PROTECTED | SYMBOL_GLOBAL);
}
}
else
{
sPtr->name = token;
sPtr->contents = (UINT)nilCell;
}
sPtr->context = context;
return(sPtr);
}
CELL * assignSymbol(SYMBOL * sPtr, CELL * content)
{
deleteList((CELL*)sPtr->contents);
sPtr->contents = (UINT)content;
return(content);
}
/* ------------------------- dump RB tree info of a symbol -------------------- */
#ifdef SYMBOL_DEBUG
CELL * p_dumpSymbol(CELL * params)
{
char * name;
SYMBOL * sPtr;
getString(params, &name);
sPtr = findInsertSymbol(name, LOOKUP_ONLY);
if(sPtr == NULL)
return(nilCell);
varPrintf(OUT_DEVICE, "name=%s color=%s parent=%s left=%s right=%s\n",
sPtr->name,
(sPtr->color == RED) ? "red" : "black",
(sPtr->parent) ? sPtr->parent->name : "ROOT",
sPtr->left->name,
sPtr->right->name);
return(trueCell);
}
#endif
/* ----------------------------- delete a symbol --------------------------- */
int references(SYMBOL * sPtr, int replaceFlag);
int externalContextReferences(SYMBOL * contextPtr, int replaceFlag);
CELL * p_deleteSymbol(CELL * params)
{
SYMBOL * sPtr = NULL;
CELL * cell;
CELL * ctx;
int checkReferences = TRUE;
cell = evaluateExpression(params);
if(cell->type != CELL_SYMBOL)
return(errorProcExt(ERR_SYMBOL_EXPECTED, params));
sPtr = (SYMBOL*)cell->contents;
if(sPtr == mainContext) return(nilCell);
if(symbolType(sPtr) == CELL_CONTEXT)
{
ctx = (CELL*)sPtr->contents;
if(ctx->contents == (UINT)sPtr)
{
sPtr->flags &= ~SYMBOL_PROTECTED;
cell = ctx;
}
}
if(sPtr->flags & (SYMBOL_PROTECTED | SYMBOL_BUILTIN))
return(nilCell);
/* nil as extra parameter deletes without reference checking.
true as extra parameter deletes only if no references are found,
No extra parameter assumes reference checking is on and if
a reference is found it is replaced with nil.
*/
params = params->next;
/* extra parameter is specified as nil */
if(params != nilCell && !getFlag(params))
checkReferences = FALSE;
/* extra parameter is specified as true */
else if(getFlag(params))
{
if(cell->type == CELL_CONTEXT)
{
if(externalContextReferences(sPtr, FALSE) > 1)
{
sPtr->flags |= SYMBOL_PROTECTED;
return(nilCell);
}
checkReferences = FALSE;
}
else
{
if(references(sPtr, FALSE) > 1)
return(nilCell);
checkReferences = FALSE;
}
}
if(cell->type == CELL_CONTEXT)
{
deleteContextSymbols(cell, checkReferences);
deleteList((CELL *)sPtr->contents);
sPtr->contents = (UINT)copyCell(nilCell);
}
else
{
deleteAndFreeSymbol(sPtr, checkReferences);
}
return(trueCell);
}
void deleteContextSymbols(CELL * cell, int checkReferences)
{
SYMBOL * context;
CELL * symbolList;
CELL * nextSymbol;
context = (SYMBOL *)cell->contents;
if(checkReferences)
externalContextReferences(context, TRUE);
symbolList = getCell(CELL_EXPRESSION);
collectSymbols((SYMBOL *)((CELL *)context->contents)->aux, symbolList);
nextSymbol = (CELL *)symbolList->contents;
while(nextSymbol != nilCell)
{
deleteAndFreeSymbol((SYMBOL*)nextSymbol->contents, FALSE);
nextSymbol = nextSymbol->next;
}
if(checkReferences)
changeContextCells(context);
deleteList(symbolList);
}
void deleteAndFreeSymbol(SYMBOL * sPtr, int checkReferences)
{
SYMBOL * context;
context = sPtr->context;
root = (SYMBOL *)((CELL *)context->contents)->aux;
if(!deleteSymbol(sPtr->name))
return;
((CELL *)context->contents)->aux = (UINT)root; /* root may have changed */
deleteList((CELL *)sPtr->contents);
if(checkReferences) references(sPtr, TRUE);
freeMemory(sPtr->name);
freeMemory(sPtr);
}
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))
{
symbol->contents = (UINT)copyCell(nilCell);
errorProcExt2(ERR_CANNOT_PROTECT_LOCAL, stuffSymbol(symbol));
}
--idx;
}
if(!isLegalSymbol(symbol->name))
{
symbol->contents = (UINT)copyCell(nilCell);
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);
}
/* only used when S in (delete 'S) is not a context */
int references(SYMBOL * sPtr, int replaceFlag)
{
CELL * blockPtr;
int i, count;
blockPtr = cellMemory;
count = 0;
while(blockPtr != NULL)
{
for(i = 0; i < MAX_BLOCK; i++)
{
if( (blockPtr->contents == (UINT)sPtr &&
(*(UINT *)blockPtr == CELL_SYMBOL || *(UINT *)blockPtr == CELL_CONTEXT))
||
( *(UINT *)blockPtr == CELL_DYN_SYMBOL && blockPtr->aux == (UINT)sPtr ) )
{
count++;
if(replaceFlag)
{
blockPtr->type = CELL_SYMBOL;
blockPtr->aux = (UINT)nilCell;
if(*(UINT *)blockPtr == CELL_DYN_SYMBOL)
free((void *)blockPtr->contents);
blockPtr->contents = (UINT)nilSymbol;
}
}
blockPtr++;
}
blockPtr = blockPtr->next;
}
return(count);
}
int externalContextReferences(SYMBOL * contextPtr, int replaceFlag)
{
CELL * blockPtr;
int i, count = 0;
SYMBOL * sPtr;
blockPtr = cellMemory;
while(blockPtr != NULL)
{
for(i = 0; i < MAX_BLOCK; i++)
{
if(blockPtr->type == CELL_SYMBOL)
{
sPtr = (SYMBOL *)blockPtr->contents;
if(sPtr->context == contextPtr)
{
count++;
if(replaceFlag)
blockPtr->contents = (UINT)nilSymbol;
}
}
if(blockPtr->type == CELL_CONTEXT)
{
if((SYMBOL *)blockPtr->contents == contextPtr)
count++;
}
blockPtr++;
}
blockPtr = blockPtr->next;
}
return(count);
}
void changeContextCells(SYMBOL * contextPtr)
{
CELL * blockPtr;
int i;
blockPtr = cellMemory;
while(blockPtr != NULL)
{
for(i = 0; i < MAX_BLOCK; i++)
{
if (blockPtr->type == CELL_CONTEXT)
{
if((SYMBOL *)blockPtr->contents == contextPtr)
{
blockPtr->type = CELL_NIL;
blockPtr->contents = (UINT)nilCell;
blockPtr->aux = (UINT)nilCell;
}
}
blockPtr++;
}
blockPtr = blockPtr->next;
}
}
/* 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));
}
CELL * p_prefix(CELL * params)
{
SYMBOL * sPtr;
getSymbol(params, &sPtr);
return(makeCell(CELL_CONTEXT, (UINT)sPtr->context));
}
/* -------------------------------------------------------------------------
Red-Black Balanced Binary Tree Algorithm adapted from:
Thomas Niemann thomasn@epaperpress.com
See also:
http://epaperpress.com/sortsearch/index.html
and:
Thomas H. Cormen, et al
Introduction to Algorithms
(MIT Electrical Engineering and Computer Science)
(C) 1990 MIT Press
*/
#define compLT(a,b) (a < b)
#define compEQ(a,b) (a == b)
#define BLACK 0
#define RED 1
#define NIL_SYM &sentinel /* all leafs are sentinels */
SYMBOL sentinel = {
0, /* pretty print */
BLACK, /* color */
"NIL", /* name */
0, /* contents */
NULL, /* context */
NULL, /* parent */
NIL_SYM, /* left */
NIL_SYM /* right */
};
void rotateLeft(SYMBOL* x);
void rotateRight(SYMBOL * x);
static void insertFixup(SYMBOL * x);
void deleteFixup(SYMBOL *x);
SYMBOL * createRootContext(char * token)
{
SYMBOL * sPtr;
root = NULL;
mainContext = sPtr = findInsertSymbol(token, TRUE);
sPtr->name = token;
makeContextFromSymbol(sPtr, sPtr);
return(sPtr);
}
/* --------------------------------------------------------------------
lookup the symbol with name key, if it does not exist and the
forceCreation flag is set, create and insert the symbol and
return a pointer to the new symbol. If the context passed is empty
then it's treePtr (root) will be the new symbol.
*/
SYMBOL * findInsertSymbol(char * key, int forceCreation)
{
SYMBOL *current, *parent, *x;
int c;
/* find future parent */
current = (root == NULL) ? NIL_SYM : root;
parent = 0;
while (current != NIL_SYM)
{
if( ((c = str2cmp(key, current->name)) == 0) && ((c = strcmp(key, current->name)) == 0) )
return(current);
parent = current;
current = (c < 0) ? current->left : current->right;
}
/* if forceCreation not specified just return */
if(forceCreation == LOOKUP_ONLY) return(NULL);
/* allocate new symbol */
x = (SYMBOL *)callocMemory(sizeof(SYMBOL));
x->parent = parent;
x->left = NIL_SYM;
x->right = NIL_SYM;
x->color = RED;
/* insert node in tree */
if(parent)
{
if( (c = str2cmp(key, parent->name)) < 0)
parent->left = x;
else if(c > 0)
parent->right = x;
else if(strcmp(key, parent->name) < 0)
parent->left = x;
else
parent->right = x;
}
else
root =x;
insertFixup(x);
/* return new node */
++symbolCount;
return(x);
}
/* --------------------------------------------------------------------
extract symbol in context from tree, return 1 if deleted or 0 if it
couldn't be found.
*/
int deleteSymbol(char * key)
{
SYMBOL *x, *y, *z;
int color, c;
/* find node in tree */
z = (root == NULL) ? NIL_SYM : root;
while(z != NIL_SYM)
{
if( ((c = str2cmp(key, z->name)) == 0) && ((c = strcmp(key, z->name)) == 0) )
break;
else
z = (c < 0) ? z->left : z->right;
}
if (z == NIL_SYM) return(0); /* key to delete not found */
if (z->left == NIL_SYM || z->right == NIL_SYM)
{
/* y has a NIL_SYM node as a child */
y = z;
}
else
{
/* find tree successor with a NIL_SYM node as a child */
y = z->right;
while (y->left != NIL_SYM) y = y->left;
}
/* x is y's only child */
if (y->left != NIL_SYM)
x = y->left;
else
x = y->right;
/* remove y from the parent chain */
x->parent = y->parent;
if (y->parent)
{
if (y == y->parent->left)
y->parent->left = x;
else
y->parent->right = x;
}
else
root = x;
color = y->color;
if (y != z)
{
/* swap y and z */
y->left = z->left;
y->right = z->right;
y->parent = z->parent;
if(z->parent)
{
if(z->parent->left == z)
z->parent->left = y;
else
z->parent->right = y;
}
else root = y;
y->right->parent = y;
y->left->parent = y;
y->color = z->color;
}
if (color == BLACK)
deleteFixup (x);
--symbolCount;
return TRUE;
}
/* -------------------------------------------------------------------- */
void rotateLeft(SYMBOL* x)
{
SYMBOL* y;
y = x->right;
/* establish x->right link */
x->right = y->left;
if (y->left != NIL_SYM)
y->left->parent = x;
/* establish y->parent link */
if(y != NIL_SYM)
y->parent = x->parent;
if (x->parent)
{
if (x == x->parent->left)
x->parent->left = y;
else
x->parent->right = y;
}
else
root = y;
/* link x and y */
y->left = x;
if (x != NIL_SYM)
x->parent = y;
}
void rotateRight(SYMBOL * x)
{
SYMBOL * y;
y = x->left;
/* establish x->left link */
x->left = y->right;
if (y->right != NIL_SYM)
y->right->parent = x;
/* establish y->parent link */
if (y != NIL_SYM)
y->parent = x->parent;
if (x->parent)
{
if (x == x->parent->right)
x->parent->right = y;
else
x->parent->left = y;
}
else
root = y;
/* link x and y */
y->right = x;
if (x != NIL_SYM)
x->parent = y;
}
static void insertFixup(SYMBOL * x)
{
SYMBOL * y;
/* check Red-Black properties */
while (x != root && x->parent->color == RED)
{
/* we have a violation */
if (x->parent == x->parent->parent->left)
{
y = x->parent->parent->right;
if (y->color == RED)
{
/* uncle is RED */
x->parent->color = BLACK;
y->color = BLACK;
x->parent->parent->color = RED;
x = x->parent->parent;
}
else
{
/* uncle is BLACK */
if (x == x->parent->right)
{
/* make x a left child */
x = x->parent;
rotateLeft(x);
}
/* recolor and rotate */
x->parent->color = BLACK;
x->parent->parent->color = RED;
rotateRight(x->parent->parent);
}
}
else
{
/* mirror image of above code */
y = x->parent->parent->left;
if (y->color == RED)
{
/* uncle is RED */
x->parent->color = BLACK;
y->color = BLACK;
x->parent->parent->color = RED;
x = x->parent->parent;
}
else
{
/* uncle is BLACK */
if (x == x->parent->left)
{
x = x->parent;
rotateRight(x);
}
x->parent->color = BLACK;
x->parent->parent->color = RED;
rotateLeft(x->parent->parent);
}
}
}
root->color = BLACK;
}
void deleteFixup(SYMBOL *x)
{
SYMBOL * w;
while (x != root && x->color == BLACK)
{
if (x == x->parent->left)
{
w = x->parent->right;
if (w->color == RED)
{
w->color = BLACK;
x->parent->color = RED;
rotateLeft (x->parent);
w = x->parent->right;
}
if (w->left->color == BLACK && w->right->color == BLACK)
{
w->color = RED;
x = x->parent;
}
else
{
if (w->right->color == BLACK)
{
w->left->color = BLACK;
w->color = RED;
rotateRight (w);
w = x->parent->right;
}
w->color = x->parent->color;
x->parent->color = BLACK;
w->right->color = BLACK;
rotateLeft (x->parent);
x = root;
}
}
else
{
w = x->parent->left;
if (w->color == RED)
{
w->color = BLACK;
x->parent->color = RED;
rotateRight (x->parent);
w = x->parent->left;
}
if (w->right->color == BLACK && w->left->color == BLACK)
{
w->color = RED;
x = x->parent;
}
else
{
if (w->left->color == BLACK)
{
w->right->color = BLACK;
w->color = RED;
rotateLeft (w);
w = x->parent->left;
}
w->color = x->parent->color;
x->parent->color = BLACK;
w->left->color = BLACK;
rotateRight (x->parent);
x = root;
}
}
}
x->color = BLACK;
}
/* eof */
Reference in a new issue View git blame Copy permalink