Initial commit of newLISP.
[newlisp.git] / nl-symbol.c
blobbb8abcc6d7297374620043fc9532aab0825fcf19
1 /* nl-symbol.c --- symbol handling routines for newLISP
3 Copyright (C) 2008 Lutz Mueller
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
21 #include "newlisp.h"
22 #include "protos.h"
25 extern CELL * cellMemory;
26 extern SYMBOL * trueSymbol;
27 extern SYMBOL * orSymbol;
29 SYMBOL * findInsertSymbol(char * key, int forceCreation);
30 int deleteSymbol(char * key);
31 void deleteContextSymbols(CELL * cell);
32 CELL dumpSymbol(char * name);
33 void collectSymbols(SYMBOL * sPtr, CELL * symbolList, CELL * * nextSymbol);
34 void symbolReferences(SYMBOL * sPtr, CELL * symbolList, CELL * * nextSymbol);
35 static SYMBOL * root; /* root symbol derived from context */
37 /* --------- return a list of all symbols in a context -------------- */
40 CELL * p_symbols(CELL * params)
42 SYMBOL * context;
43 CELL * symbolList;
44 CELL * nextSymbol;
46 symbolList = getCell(CELL_EXPRESSION);
47 nextSymbol = NULL;
49 if(params->type == CELL_NIL)
50 context = currentContext;
51 else
52 getContext(params, &context);
54 if(context) /* check in case we are in debug mode */
55 collectSymbols((SYMBOL *)((CELL *)context->contents)->aux, symbolList, &nextSymbol);
56 return(symbolList);
60 void collectSymbols(SYMBOL * sPtr, CELL * symbolList, CELL * * nextSymbol)
62 if(sPtr != NIL_SYM && sPtr != NULL)
64 collectSymbols(sPtr->left, symbolList, nextSymbol);
65 if(*nextSymbol == NULL)
67 *nextSymbol = getCell(CELL_SYMBOL);
68 (*nextSymbol)->contents = (UINT)sPtr;
69 symbolList->contents = (UINT)*nextSymbol;
71 else
73 (*nextSymbol)->next = getCell(CELL_SYMBOL);
74 *nextSymbol = (*nextSymbol)->next;
75 (*nextSymbol)->contents = (UINT)sPtr;
77 collectSymbols(sPtr->right, symbolList, nextSymbol);
83 /* iterate thru symbol tree for a specific context
86 CELL * p_dotree(CELL * params)
88 SYMBOL * context;
89 SYMBOL * symbol;
90 CELL * symbolList;
91 CELL * nextSymbol;
92 CELL * cell;
93 CELL * list;
94 int resultIdxSave;
96 if(params->type != CELL_EXPRESSION)
97 return(errorProcExt(ERR_LIST_EXPECTED, params));
99 list = (CELL *)params->contents;
100 if(list->type == CELL_SYMBOL)
101 symbol = (SYMBOL *)list->contents;
102 else if(list->type == CELL_DYN_SYMBOL)
103 symbol = getDynamicSymbol(list);
104 else
105 return(errorProcExt(ERR_SYMBOL_EXPECTED, list));
107 if(isProtected(symbol->flags))
108 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
110 pushEnvironment((CELL *)symbol->contents);
111 pushEnvironment((UINT)symbol);
113 symbol->contents = (UINT)copyCell(nilCell);
115 getContext(list->next, &context);
116 if(!context) return(nilCell); /* for debug mode */
117 cell = nilCell;
119 symbolList = getCell(CELL_EXPRESSION);
120 nextSymbol = NULL;
121 collectSymbols((SYMBOL *)((CELL *)context->contents)->aux, symbolList, &nextSymbol);
123 resultIdxSave = resultStackIdx;
124 list = (CELL *)symbolList->contents;
125 while(list != nilCell)
127 cleanupResults(resultIdxSave);
128 deleteList((CELL *)symbol->contents);
129 symbol->contents = (UINT)copyCell(list);
130 cell = evaluateBlock(params->next);
131 list = list->next;
134 cell = copyCell(cell);
135 deleteList((CELL *)symbol->contents);
137 symbol = (SYMBOL*)popEnvironment();
138 symbol->contents = (UINT)popEnvironment();
140 deleteList(symbolList);
142 return(cell);
147 SYMBOL * lookupSymbol(char * token, SYMBOL * context)
149 root = (SYMBOL *)((CELL *)context->contents)->aux;
151 return(findInsertSymbol(token, LOOKUP_ONLY));
157 if forceFlag is TRUE then
158 create the symbol, if not found in the context
159 specified in that context
160 else
161 if not found try to inherit from MAIN as a global
162 or primitive, else create it in context specified
166 SYMBOL * translateCreateSymbol
167 (char * token, int type, SYMBOL * context, int forceFlag)
169 SYMBOL * sPtr;
170 CELL * cell = NULL;
171 size_t len;
173 /* for the first symbol (also a context) context is NULL */
174 if(context == NULL)
175 root = NULL;
176 else
178 cell = (CELL *)context->contents;
179 root = (SYMBOL *)cell->aux;
182 if(forceFlag)
183 sPtr = findInsertSymbol(token, FORCE_CREATION);
184 else /* try to inherit from MAIN, if not here create in current context */
186 sPtr = findInsertSymbol(token, LOOKUP_ONLY);
187 if(sPtr == NULL)
189 if(context != mainContext)
191 root = (SYMBOL *)((CELL *)mainContext->contents)->aux;
192 sPtr = findInsertSymbol(token, LOOKUP_ONLY);
193 /* since 7.2.7 only inherit primitives and other globals */
194 if(sPtr != NULL && !(sPtr->flags & SYMBOL_GLOBAL))
196 if(symbolType(sPtr) != CELL_CONTEXT
197 || (SYMBOL *)((CELL*)sPtr->contents)->contents != sPtr)
198 sPtr = NULL;
200 root = (SYMBOL *)cell->aux;
202 if(sPtr == NULL)
203 sPtr = findInsertSymbol(token, FORCE_CREATION);
207 /* root might have changed, if new symbol was inserted */
208 if(context != NULL)
209 cell->aux = (UINT)root;
211 /* the symbol existed already, return */
212 if(sPtr->contents != 0) return(sPtr);
214 /* a new symbol has been allocated by findInsertSymbol() */
215 if(type != CELL_PRIMITIVE)
217 len = strlen(token);
218 sPtr->name = (char *)allocMemory(len + 1);
219 memcpy(sPtr->name, token, len + 1);
220 cell = copyCell(nilCell);
221 sPtr->contents = (UINT)cell;
222 /* make a new context symbol */
223 if(type == CELL_CONTEXT && context == mainContext)
225 cell->type = CELL_CONTEXT;
226 cell->contents = (UINT)sPtr;
227 cell->aux = 0;
228 sPtr->flags |= (SYMBOL_PROTECTED | SYMBOL_GLOBAL);
231 else
232 sPtr->name = token;
235 sPtr->context = context;
236 return(sPtr);
239 /* ------------------------- dump RB tree info of a symbol -------------------- */
241 #ifdef SYMBOL_DEBUG
242 CELL * p_dumpSymbol(CELL * params)
244 char * name;
245 SYMBOL * sPtr;
247 getString(params, &name);
249 sPtr = findInsertSymbol(name, LOOKUP_ONLY);
251 if(sPtr == NULL)
252 return(nilCell);
254 varPrintf(OUT_DEVICE, "name=%s color=%s parent=%s left=%s right=%s\n",
255 sPtr->name,
256 (sPtr->color == RED) ? "red" : "black",
257 (sPtr->parent) ? sPtr->parent->name : "ROOT",
258 sPtr->left->name,
259 sPtr->right->name);
261 return(trueCell);
263 #endif
267 /* ----------------------------- delete a symbol --------------------------- */
268 int references(SYMBOL * sPtr, int replaceFlag);
270 CELL * p_deleteSymbol(CELL * params)
272 SYMBOL * sPtr;
273 CELL * cell;
275 cell = evaluateExpression(params);
276 if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
277 sPtr = (SYMBOL*)cell->contents;
278 else if(cell->type == CELL_DYN_SYMBOL)
279 sPtr = getDynamicSymbol(cell);
280 else return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, params));
282 if(sPtr == mainContext) return(nilCell);
284 if(symbolType(sPtr) == CELL_CONTEXT)
286 if(cell->type == CELL_SYMBOL)
287 cell = (CELL*)sPtr->contents;
288 sPtr->flags &= ~SYMBOL_PROTECTED;
291 if(sPtr->flags & (SYMBOL_PROTECTED | SYMBOL_BUILTIN) )
292 return(nilCell);
294 if(getFlag(params->next))
296 if(references(sPtr, FALSE) > 1)
297 return(nilCell);
300 if(cell->type == CELL_CONTEXT)
302 deleteContextSymbols(cell);
303 cell->type = CELL_SYMBOL;
304 deleteList((CELL *)sPtr->contents);
305 sPtr->contents = (UINT)nilCell;
307 else
308 deleteFreeSymbol(sPtr);
310 return(trueCell);
314 void deleteContextSymbols(CELL * cell)
316 SYMBOL * context;
317 CELL * symbolList;
318 CELL * nextSymbol;
320 context = (SYMBOL *)cell->contents;
322 symbolList = getCell(CELL_EXPRESSION);
323 nextSymbol = NULL;
324 collectSymbols((SYMBOL *)((CELL *)context->contents)->aux, symbolList, &nextSymbol);
326 nextSymbol = (CELL *)symbolList->contents;
327 while(nextSymbol != nilCell)
329 deleteFreeSymbol((SYMBOL*)nextSymbol->contents);
330 nextSymbol = nextSymbol->next;
333 deleteList(symbolList);
338 void deleteFreeSymbol(SYMBOL * sPtr)
340 SYMBOL * context;
342 context = sPtr->context;
343 root = (SYMBOL *)((CELL *)context->contents)->aux;
345 if(!deleteSymbol(sPtr->name))
346 return;
348 ((CELL *)context->contents)->aux = (UINT)root; /* root may have changed */
350 deleteList((CELL *)sPtr->contents);
352 references(sPtr, TRUE);
353 freeMemory(sPtr->name);
354 freeMemory(sPtr);
359 void makeContextFromSymbol(SYMBOL * symbol, SYMBOL * treePtr)
361 CELL * contextCell;
363 contextCell = getCell(CELL_CONTEXT);
364 contextCell->contents = (UINT)symbol;
365 contextCell->aux = (UINT)treePtr;
366 symbol->contents = (UINT)contextCell;
367 symbol->context = mainContext;
368 symbol->flags |= (SYMBOL_PROTECTED | SYMBOL_GLOBAL);
372 int references(SYMBOL * sPtr, int replaceFlag)
374 CELL * blockPtr;
375 int i, count;
377 blockPtr = cellMemory;
378 count = 0;
379 while(blockPtr != NULL)
381 for(i = 0; i < MAX_BLOCK; i++)
383 if( blockPtr->contents == (UINT)sPtr &&
384 (*(UINT *)blockPtr == CELL_SYMBOL || *(UINT *)blockPtr == CELL_CONTEXT))
386 count++;
387 if(replaceFlag) blockPtr->contents = (UINT)nilSymbol;
389 blockPtr++;
391 blockPtr = blockPtr->next;
394 return(count);
397 CELL * p_name(CELL * params)
399 SYMBOL * sPtr;
400 CELL * cell;
402 cell = evaluateExpression(params);
403 if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
404 sPtr = (SYMBOL *)cell->contents;
405 else
406 return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, cell));
408 if(getFlag(params->next))
409 return(stuffString(((SYMBOL*)sPtr->context)->name));
410 return(stuffString(sPtr->name));
413 /* -------------------------------------------------------------------------
415 Red-Black Balanced Binary Tree Algorithm adapted from:
417 Thomas Niemann thomasn@epaperpress.com
419 See also:
421 http://epaperpress.com/sortsearch/index.html
423 and:
425 Thomas H. Cormen, et al
426 Introduction to Algorithms
427 (MIT Electrical Engineering and Computer Science)
428 (C) 1990 MIT Press
433 #define compLT(a,b) (a < b)
434 #define compEQ(a,b) (a == b)
436 #define BLACK 0
437 #define RED 1
439 #define NIL_SYM &sentinel /* all leafs are sentinels */
441 SYMBOL sentinel = {
442 0, /* pretty print */
443 BLACK, /* color */
444 "NIL", /* name */
445 0, /* contents */
446 NULL, /* context */
447 NULL, /* parent */
448 NIL_SYM, /* left */
449 NIL_SYM /* right */
452 void rotateLeft(SYMBOL* x);
453 void rotateRight(SYMBOL * x);
454 static void insertFixup(SYMBOL * x);
455 void deleteFixup(SYMBOL *x);
457 /* --------------------------------------------------------------------
459 lookup the symbol with name key, if it does not exist and the
460 forceCreation flag is set, create and insert the symbol and
461 return a pointer to the new symbol. If the context passed is empty
462 then it's treePtr (root) will be the new symbol.
467 SYMBOL * findInsertSymbol(char * key, int forceCreation)
469 SYMBOL *current, *parent, *x;
471 /* find future parent */
472 current = (root == NULL) ? NIL_SYM : root;
473 parent = 0;
475 while (current != NIL_SYM)
477 if(strcmp(key, current->name) == 0) /* already exists */
478 return(current);
480 parent = current;
481 current = (strcmp(key, current->name) < 0) ?
482 current->left : current->right;
485 /* if forceCreation not specified just return */
486 if(forceCreation == LOOKUP_ONLY) return(NULL);
488 /* allocate new symbol */
489 x = (SYMBOL *)callocMemory(sizeof(SYMBOL));
491 x->parent = parent;
492 x->left = NIL_SYM;
493 x->right = NIL_SYM;
494 x->color = RED;
496 /* insert node in tree */
497 if(parent)
499 if(strcmp(key, parent->name) < 0)
500 parent->left = x;
501 else
502 parent->right = x;
504 else
505 root = x;
507 insertFixup(x);
510 /* return new node */
512 ++symbolCount;
513 return(x);
517 /* --------------------------------------------------------------------
518 extract symbol in context from tree, return 1 if deleted or 0 if it
519 couldn't be found.
523 int deleteSymbol(char * key)
525 SYMBOL *x, *y, *z;
526 int color;
528 /* find node in tree */
529 z = (root == NULL) ? NIL_SYM : root;
531 while(z != NIL_SYM)
533 if(strcmp(key, z->name) == 0)
534 break;
535 else
536 z = (strcmp(key, z->name) < 0) ? z->left : z->right;
539 if (z == NIL_SYM) return(0); /* key to delete not found */
542 if (z->left == NIL_SYM || z->right == NIL_SYM)
544 /* y has a NIL_SYM node as a child */
545 y = z;
547 else
549 /* find tree successor with a NIL_SYM node as a child */
550 y = z->right;
551 while (y->left != NIL_SYM) y = y->left;
554 /* x is y's only child */
555 if (y->left != NIL_SYM)
556 x = y->left;
557 else
558 x = y->right;
560 /* remove y from the parent chain */
561 x->parent = y->parent;
562 if (y->parent)
564 if (y == y->parent->left)
565 y->parent->left = x;
566 else
567 y->parent->right = x;
569 else
570 root = x;
573 color = y->color;
574 if (y != z)
576 /* swap y and z */
577 y->left = z->left;
578 y->right = z->right;
579 y->parent = z->parent;
581 if(z->parent)
583 if(z->parent->left == z)
584 z->parent->left = y;
585 else
586 z->parent->right = y;
588 else root = y;
590 y->right->parent = y;
591 y->left->parent = y;
593 y->color = z->color;
596 if (color == BLACK)
597 deleteFixup (x);
599 --symbolCount;
600 return TRUE;
605 /* -------------------------------------------------------------------- */
607 void rotateLeft(SYMBOL* x)
609 SYMBOL* y;
611 y = x->right;
613 /* establish x->right link */
614 x->right = y->left;
615 if (y->left != NIL_SYM)
616 y->left->parent = x;
618 /* establish y->parent link */
619 if(y != NIL_SYM)
620 y->parent = x->parent;
622 if (x->parent)
624 if (x == x->parent->left)
625 x->parent->left = y;
626 else
627 x->parent->right = y;
629 else
630 root = y;
633 /* link x and y */
634 y->left = x;
635 if (x != NIL_SYM)
636 x->parent = y;
640 void rotateRight(SYMBOL * x)
642 SYMBOL * y;
644 y = x->left;
646 /* establish x->left link */
647 x->left = y->right;
648 if (y->right != NIL_SYM)
649 y->right->parent = x;
651 /* establish y->parent link */
652 if (y != NIL_SYM)
653 y->parent = x->parent;
655 if (x->parent)
657 if (x == x->parent->right)
658 x->parent->right = y;
659 else
660 x->parent->left = y;
662 else
663 root = y;
665 /* link x and y */
666 y->right = x;
667 if (x != NIL_SYM)
668 x->parent = y;
672 static void insertFixup(SYMBOL * x)
674 SYMBOL * y;
676 /* check Red-Black properties */
677 while (x != root && x->parent->color == RED)
679 /* we have a violation */
680 if (x->parent == x->parent->parent->left)
682 y = x->parent->parent->right;
683 if (y->color == RED)
685 /* uncle is RED */
686 x->parent->color = BLACK;
687 y->color = BLACK;
688 x->parent->parent->color = RED;
689 x = x->parent->parent;
691 else
693 /* uncle is BLACK */
694 if (x == x->parent->right)
696 /* make x a left child */
697 x = x->parent;
698 rotateLeft(x);
701 /* recolor and rotate */
702 x->parent->color = BLACK;
703 x->parent->parent->color = RED;
704 rotateRight(x->parent->parent);
707 else
710 /* mirror image of above code */
711 y = x->parent->parent->left;
712 if (y->color == RED)
714 /* uncle is RED */
715 x->parent->color = BLACK;
716 y->color = BLACK;
717 x->parent->parent->color = RED;
718 x = x->parent->parent;
720 else
722 /* uncle is BLACK */
723 if (x == x->parent->left)
725 x = x->parent;
726 rotateRight(x);
728 x->parent->color = BLACK;
729 x->parent->parent->color = RED;
730 rotateLeft(x->parent->parent);
735 root->color = BLACK;
739 void deleteFixup(SYMBOL *x)
741 SYMBOL * w;
743 while (x != root && x->color == BLACK)
745 if (x == x->parent->left)
747 w = x->parent->right;
748 if (w->color == RED)
750 w->color = BLACK;
751 x->parent->color = RED;
752 rotateLeft (x->parent);
753 w = x->parent->right;
755 if (w->left->color == BLACK && w->right->color == BLACK)
757 w->color = RED;
758 x = x->parent;
760 else
762 if (w->right->color == BLACK)
764 w->left->color = BLACK;
765 w->color = RED;
766 rotateRight (w);
767 w = x->parent->right;
769 w->color = x->parent->color;
770 x->parent->color = BLACK;
771 w->right->color = BLACK;
772 rotateLeft (x->parent);
773 x = root;
776 else
778 w = x->parent->left;
779 if (w->color == RED)
781 w->color = BLACK;
782 x->parent->color = RED;
783 rotateRight (x->parent);
784 w = x->parent->left;
786 if (w->right->color == BLACK && w->left->color == BLACK)
788 w->color = RED;
789 x = x->parent;
791 else
793 if (w->left->color == BLACK)
795 w->right->color = BLACK;
796 w->color = RED;
797 rotateLeft (w);
798 w = x->parent->left;
800 w->color = x->parent->color;
801 x->parent->color = BLACK;
802 w->left->color = BLACK;
803 rotateRight (x->parent);
804 x = root;
809 x->color = BLACK;
813 /* eof */