From c5fd67dc59e328d2197016b7c044a00d4d9fb777 Mon Sep 17 00:00:00 2001 From: ketmar Date: Mon, 21 Apr 2008 21:53:00 +0000 Subject: [PATCH] new, smaller, faster and untested version of KLISP FossilOrigin-Name: f5f6c66b0a2832c2ca2985fda3b3621e56f80db76b326c60741dba3d0840744a --- ChangeLog | 2 + src/Jamfile | 10 +- src/klisp/klisp.h | 183 ++-- src/klisp/klisp_core.c | 2402 ++++++++-------------------------------------- src/klisp/klisp_prim.c | 576 ++--------- src/klisp/klisp_rbtree.c | 42 +- src/syren.lsp | 112 --- src/syren_script.c | 4 +- 8 files changed, 678 insertions(+), 2653 deletions(-) rewrite src/klisp/klisp_core.c (84%) delete mode 100644 src/syren.lsp diff --git a/ChangeLog b/ChangeLog index ca22182..820a1f3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -166,3 +166,5 @@ v0.0.6 (atomic alien) [*] preparing for scripting; script now prints "syren.lsp loaded." %-) [+] stupid script for sf.net is working! %-) + + [*] new version of KLISP; not teted yet diff --git a/src/Jamfile b/src/Jamfile index 3aad1a2..91a3461 100644 --- a/src/Jamfile +++ b/src/Jamfile @@ -43,9 +43,17 @@ if $(NO_HTTPS) { } libklispsources = + klisp/klisp_rbtree.c klisp/klisp_core.c + klisp/klisp_core_gc.c + klisp/klisp_core_lib.c + klisp/klisp_core_stack.c + klisp/klisp_core_sym.c + klisp/klisp_core_parser.c + klisp/klisp_core_util.c + klisp/klisp_core_print.c + klisp/klisp_core_eval.c klisp/klisp_prim.c - klisp/klisp_rbtree.c ; diff --git a/src/klisp/klisp.h b/src/klisp/klisp.h index 0607371..5b2a385 100644 --- a/src/klisp/klisp.h +++ b/src/klisp/klisp.h @@ -59,18 +59,37 @@ extern void *KLISP_MEMREALLOC (void *ptr, size_t size); /***************************************************************** debug macroses *****************************************************************/ + /* WRITE THIS!!! */ #ifdef KLISP_DEBUG_EVAL #define KLISP_DEBUG_PRCELL(msg,cell) if (klispOptPrintStack) { KLispPrintF("%s", msg); KLispPrintCell(KLISP_POOL_ARG cell); KLispPrintF("\n"); } #define KLISP_DEBUG_PRFRAMES(msg) \ - if (klispOptPrintStack) { KLispPrintF("%s", msg); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->frames); KLispPrintF("\n"); } + if (klispOptPrintStack) { \ + int _zz; \ + KLispPrintF("%s", msg); \ + for (_zz = KLISP_POOL->frames.sp-1; _zz >= 0; _zz--) { \ + KLispPrintF("\n | "); \ + KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->frames.data[_zz].data); \ + } \ + KLispPrintF("\n"); \ + } #define KLISP_DEBUG_PRSTACK(msg) \ - if (klispOptPrintStack) { KLispPrintF("%s", msg); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->stack); KLispPrintF("\n"); } -#define KLISP_DEBUG_PRINTSTR(msg) if (klispOptPrintStack) { KLispPrintF("%s", msg); } + if (klispOptPrintStack) { \ + int _zz; \ + KLispPrintF("%s", msg); \ + for (_zz = KLISP_POOL->stack.sp-1; _zz >= 0; _zz--) { \ + KLispPrintF("\n | "); \ + KLispPrintF("<(%i)%s:", KLISP_POOL->stack.data[_zz].info, klispSPNames[KLISP_POOL->stack.data[_zz].info]); \ + KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->stack.data[_zz].data); \ + KLispPrintF(">"); \ + } \ + KLispPrintF("\n"); \ + } +#define KLISP_DEBUG_PRINTSTR(...) if (klispOptPrintStack) { KLispPrintF(__VA_ARGS__); } #else #define KLISP_DEBUG_PRCELL(msg,cell) #define KLISP_DEBUG_PRFRAMES(msg) #define KLISP_DEBUG_PRSTACK(msg) -#define KLISP_DEBUG_PRINTSTR(msg) +#define KLISP_DEBUG_PRINTSTR(...) #endif @@ -100,40 +119,47 @@ extern void *KLISP_MEMREALLOC (void *ptr, size_t size); /* WARNING: DON'T CHANGE KLISP_TYPE_CONS VALUE! */ #define KLISP_TYPE_CONS 0x00 #define KLISP_TYPE_NUM 0x01 -#define KLISP_TYPE_STR 0x02 -#define KLISP_TYPE_SYM 0x03 +#define KLISP_TYPE_SYM 0x02 /* primitive; args evaluated */ -#define KLISP_TYPE_PRIM 0x04 +#define KLISP_TYPE_PRIM 0x03 /* primitive; args not evaluated */ -#define KLISP_TYPE_MPRIM 0x05 +#define KLISP_TYPE_MPRIM 0x04 /* internal prim for ICALL */ -#define KLISP_TYPE_IPRIM 0x06 -#define KLISP_TYPE_IMPRIM 0x07 +#define KLISP_TYPE_IPRIM 0x05 +#define KLISP_TYPE_IMPRIM 0x06 /* car: opaque pointer; cdr: list of methods; list of methods: car: symbol (name . xPRIM); cdr: next mathod args: (udata_obj ...) call: (udata method ...) */ -#define KLISP_TYPE_UDATA 0x08 +#define KLISP_TYPE_UDATA 0x07 -#define KLISP_TYPE_SPEC 0x10 +/* run stack info commands */ typedef enum { - KLISP_SPECT_NIL, /* unused */ - KLISP_SPECT_T, /* unused */ - KLISP_SPEC_STOP_EVAL, + KLISP_SPEC_DROP, /* drop next rstack cell */ + KLISP_SPEC_NO_EVAL, /* don't eval data cell */ + KLISP_SPEC_EVAL, /* eval data cell */ + KLISP_SPEC_STOP_EVAL, /* end of eval */ KLISP_SPEC_ARG_EVAL, /* evaluating args for function call */ KLISP_SPEC_FN_EVAL, /* evaluating fn for function call */ KLISP_SPEC_CALL, /* call primitive */ - KLISP_SPEC_ICALL, /* call internal primitive: doesn't remove icall from the stack (iprim will manage the stack) */ - KLISP_SPEC_SCOPE, - - KLISP_SPEC_LMD_CALL, /* lambda call; noop */ + KLISP_SPEC_ICALL, /* call internal primitive: don't remove icall from the stack (iprim will manage the stack) */ + KLISP_SPEC_SCOPE, /* new scope pushed */ + KLISP_SPEC_E_SCOPE, /* eval scope */ + KLISP_SPEC_PROG, /* (prog ...) */ + KLISP_SPEC_COND, /* (cond ...) */ + KLISP_SPEC_LAMBDA, /* lambda call */ KLISP_SPEC_MAX } TKLispSpecs; +#ifdef KLISP_DEBUG_EVAL +extern const char *klispSPNames[]; +#endif + + /***************************************************************** special prim return value: don't touch VM stack *****************************************************************/ @@ -143,9 +169,9 @@ typedef enum { /***************************************************************** GC flags *****************************************************************/ -#define KLISP_FFLAG 0x01 -#define KLISP_SFLAG 0x02 -#define KLISP_MFLAG 0x04 +#define KLISP_FFLAG 0x010 +#define KLISP_SFLAG 0x020 +#define KLISP_MFLAG 0x040 typedef double TKLispNumber; @@ -176,11 +202,20 @@ typedef struct _TKLispCell TKLispCell; #define KLISP_GC_FREEZE KLISP_POOL->gcfrozen++ #define KLISP_GC_UNFREEZE KLISP_POOL->gcfrozen-- -#define KLISP_RSET(idx,cell) KLispRSet(KLISP_POOL_ARG idx, cell) -#define KLISP_RSWAP(idx0,idx1) KLispRSwap(KLISP_POOL_ARG idx0, idx1) -#define KLISP_RDROP(cnt) KLispRDrop(KLISP_POOL_ARG cnt) -#define KLISP_RPOP KLispRPop(KLISP_POOL_ARG0) -#define KLISP_RPEEK(idx) KLispRPeek(KLISP_POOL_ARG idx) +#define KLISP_RSET(idx,cell,info) KLispSet(&KLISP_POOL->stack, idx, cell, info) +#define KLISP_RSETDATA(idx,cell) KLispSetData(&KLISP_POOL->stack, idx, cell) +#define KLISP_RSETINFO(idx,info) KLispSetInfo(&KLISP_POOL->stack, idx, info) +#define KLISP_RPUSH(cell,info) KLispPush(&KLISP_POOL->stack, cell, info) +#define KLISP_RSWAP(idx0,idx1) KLispSwap(&KLISP_POOL->stack, idx0, idx1) +#define KLISP_RDROP(cnt) KLispDrop(&KLISP_POOL->stack, cnt) +#define KLISP_RPOP(cell,info) KLispPop(&KLISP_POOL->stack, cell, info) +#define KLISP_RPEEK(idx) KLispPeek(&KLISP_POOL->stack, idx) +#define KLISP_RPEEKDATA(idx) KLispPeekData(&KLISP_POOL->stack, idx) +#define KLISP_RPEEKINFO(idx) KLispPeekInfo(&KLISP_POOL->stack, idx) + +#define KLISP_RPEEKEX(idx,cellp,infop) KLispPeekEx(&KLISP_POOL->stack, idx, cellp, infop) +/* rpeek, assert info */ +#define KLISP_RPEEKCHK(idx,cinfo) KLispPeekExCheckInfo(&KLISP_POOL->stack, idx, cinfo) /***************************************************************** @@ -202,7 +237,7 @@ struct _TKLispRBTNode { TKLispRBTNode *link[2]; // 0: left; 1: right uint32_t hash; char *str; - int value0, value1; + int value0; int freeIt; TKLispRBTNode *nextFree; }; @@ -240,7 +275,7 @@ void KLispRBTClearTree (TKLispRBTree *tree); TKLispRBTree *KLispRBTNewTree (void); void KLispRBTFreeTree (TKLispRBTree *tree); -TKLispRBTNode *KLispRBTInsert (TKLispRBTree *tree, const char *str, int value0, int value1, int freeIt, int *newnode); +TKLispRBTNode *KLispRBTInsert (TKLispRBTree *tree, const char *str, int value0, int freeIt, int *newnode); int KLispRBTDelete (TKLispRBTree *tree, const char *str); TKLispRBTNode *KLispRBTFind (TKLispRBTree *tree, const char *str); @@ -285,6 +320,54 @@ typedef int (*TKLispEvalChecker) (KLISP_POOL_DEF0); /***************************************************************** + stacks + *****************************************************************/ +typedef struct { + int data; + int info; +} TKLispStackItem; + +typedef struct { + TKLispStackItem *data; + int dataCount; + int sp; /* first free item; sp==0: empty stack */ + int growCount; + int stackMax; /* do not grow more */ +} TKLispStack; + + +int KLispInitStack (TKLispStack *stack, int init, int grow, int max); +void KLispDeinitStack (TKLispStack *stack); +/* return 0 on failure */ +int KLispPush (TKLispStack *stack, int data, int info); +/* return 0 on failure */ +int KLispDrop (TKLispStack *stack, int count); +/* return NULL on failure + WARNING: item pointer can be invalid after next push! */ +TKLispStackItem *KLispPeek (TKLispStack *stack, int depth); +/* return 0 on failure; data and info can be NULL */ +int KLispPeekEx (TKLispStack *stack, int depth, int *data, int *info); +/* return -1 on failure */ +int KLispPeekData (TKLispStack *stack, int depth); +/* return -1 on failure */ +int KLispPeekInfo (TKLispStack *stack, int depth); +/* return -1 on failure; data and info can be NULL + return -1 if info != cinfo +*/ +int KLispPeekExCheckInfo (TKLispStack *stack, int depth, int cinfo); +/* return 0 on failure; data and info can be NULL */ +int KLispPop (TKLispStack *stack, int *data, int *info); +/* return 0 on failure */ +int KLispSwap (TKLispStack *stack, int d0, int d1); +/* return 0 on failure */ +int KLispSet (TKLispStack *stack, int depth, int data, int info); +/* return 0 on failure */ +int KLispSetData (TKLispStack *stack, int depth, int data); +/* return 0 on failure */ +int KLispSetInfo (TKLispStack *stack, int depth, int info); + + +/***************************************************************** cell *****************************************************************/ struct _TKLispCell { @@ -295,8 +378,6 @@ struct _TKLispCell { TKLispPrimFn fn; TKLispFinalizeFn finalizer; int car, cdr; - int gcFlags; /* KLISP_xFLAG */ - int tmp; /* used in GC! */ }; @@ -309,14 +390,14 @@ struct _TKLispPool { TKLispCell *cells; /* array; 0: NIL; 1: T */ int free; /* first free cell */ - int frames; /* stack of frames */ - int stack; /* eval() stack */ + TKLispStack frames; /* stack of frames; data: symbol list; info: no meaning yet */ + TKLispStack stack; /* eval() stack; data: cell/0; info: special action */ + TKLispStack roots; /* gc roots */ TKLispRBTree *primitives; /* primitive list; v0:symcell */ TKLispRBTree *globals; /* globals list; v0:symcell */ TKLispRBTree *strpool; /* string pool; v0:strcell, v1:symcell */ - int roots; /* gc roots */ int tempRootGC0, tempRootGC1; int gcfrozen; @@ -325,9 +406,10 @@ struct _TKLispPool { char *error; int errorStatic; - int specs[KLISP_SPEC_MAX]; /* special symbols */ - int chars[256]; /* 1-character strings */ int syms[256]; /* 1-character symbols */ + + /* built-in primitives */ + int prog, cond, lambda, mlambda, quote, defun, defmac, invoke; }; @@ -376,8 +458,8 @@ extern void KLispPrintF (const char *fmt, ...); /***************************************************************** constant-space GC (based on the code ny Nils M. Holm) *****************************************************************/ +void KLispInvokeFinalizer (KLISP_POOL_DEF int udatacell); void KLispGC (KLISP_POOL_DEF0); - /* must be used only in finalizer! */ void KLispGCMark (KLISP_POOL_DEF int cell); @@ -401,7 +483,6 @@ int KLispNewSpecial (KLISP_POOL_DEF int spType); int KLispNewCons (KLISP_POOL_DEF int car, int cdr); int KLispNewNum (KLISP_POOL_DEF TKLispNumber value); int KLispNewSym (KLISP_POOL_DEF const char *value); -int KLispNewStr (KLISP_POOL_DEF const char *value); int KLispNewXPrim (KLISP_POOL_DEF int prtype, TKLispPrimFn fn, const char *name); @@ -446,7 +527,11 @@ int KLispFindSymbol (KLISP_POOL_DEF int list, const char *name); /* get symbol pair; search all frames and globals return symbol pair or -1 */ int KLispGetSymbol (KLISP_POOL_DEF const char *name); +/* get symbol pair; search all frames and globals + return symbol pair or -1 */ +int KLispGetSymbolByCell (KLISP_POOL_DEF int symNameCell, const char *name); /* set symbol value (add it to upper frame or globals if necessary) + nodig: check only upper frame return symbol pair or -1 */ int KLispSetSymbolValue (KLISP_POOL_DEF const char *name, int valueCell, int nodig); @@ -462,28 +547,18 @@ int KLispSetPrims (KLISP_POOL_DEF0); /***************************************************************** utilities *****************************************************************/ -/* is list a correct list? return bool (0|1) */ +/* is list a correct list? return bool (-1 or list length; 0: empty list) */ int KLispIsList (KLISP_POOL_DEF int n); +/* return bool (0|1) */ +int KLispCheckSymTable (KLISP_POOL_DEF int n); + /* return success flag */ int KLispPushRoot (KLISP_POOL_DEF int n); void KLispPopRoots (KLISP_POOL_DEF int cnt); + /* frame==0: create empty frame; return success flag */ int KLispNewFrame (KLISP_POOL_DEF int frame); -void KLispPopFrame (KLISP_POOL_DEF0); -/* return bool (0|1) */ -int KLispCheckSymTable (KLISP_POOL_DEF int n); - -/* return success flag */ -int KLispRPush (KLISP_POOL_DEF int n); -/* -1: stack is empty; else cell */ -int KLispRPop (KLISP_POOL_DEF0); -void KLispRDrop (KLISP_POOL_DEF int cnt); -/* -1: no such cell; else cell */ -int KLispRPeek (KLISP_POOL_DEF int depth); -/* return success flag */ -int KLispRSet (KLISP_POOL_DEF int depth, int valueCell); -/* return success flag */ -int KLispRSwap (KLISP_POOL_DEF int depth0, int depth1); +void KLispDropFrame (KLISP_POOL_DEF0); /***************************************************************** diff --git a/src/klisp/klisp_core.c b/src/klisp/klisp_core.c dissimilarity index 84% index 0c6f766..0cba12e 100644 --- a/src/klisp/klisp_core.c +++ b/src/klisp/klisp_core.c @@ -1,1980 +1,422 @@ -#ifndef _KLISP_CORE_MODULE_BODY_ -#define _KLISP_CORE_MODULE_BODY_ - -#include "klisp.h" - - -#ifdef KLISP_DEBUG_EVAL -int klispOptPrintStack = 1; -#endif - - -#ifdef KLISP_ALLOW_DL -char *klispLibPath = NULL; - - -static int KLispLoadLib (KLISP_POOL_DEF const char *path) { - void *lib, *sym; - int res; - - lib = dlopen(path, RTLD_NOW); - if (!lib) { - fprintf(stderr, "dlopen(): %s\n", dlerror()); - - return 0; - } - sym = dlsym(lib, "KLispInitLibrary"); - if (!sym) { - dlclose(lib); - fprintf(stderr, "dlopen(): %s\n", "init not found"); - - return 0; - } - - res = ((TKLispDLFn)(sym))(KLISP_POOL_ARG KLISP_ENGINE_API_VERSION); - if (res <= 0) { - dlclose(lib); - fprintf(stderr, "dlopen(): %s\n", "init error"); - - return 0; - } - - return res; -} - - -int KLispFindAndLoadLib (KLISP_POOL_DEF const char *name) { - const char *pp; - char *buf, *t; - int res, bufsz; - - if (!name || !*name) return 0; - pp = klispLibPath?klispLibPath:"./"; - bufsz = (strlen(pp)+strlen(name)+strlen(KLISP_DL_EXT)+4)*sizeof(char); - buf = KLISP_MEMALLOC(bufsz); - if (!buf) return 0; - while (*pp) { - while (*pp && *pp == ':') pp++; - /* copy path */ - for (t = buf; *pp && *pp != ':'; pp++) *t++ = *pp; - if (*pp) pp++; /* skip ':' */ - if (t == buf) continue; - if (*(t-1) != '/') *t++ = '/'; - *t = '\0'; - strcat(buf, name); - strcat(buf, KLISP_DL_EXT); - fprintf(stderr, "checking: '%s'\n", buf); - res = KLispLoadLib(KLISP_POOL_ARG buf); - if (res > 0) { KLISP_MEMFREE(buf); return res; } - fprintf(stderr, " failed: '%s'\n", buf); - } - KLISP_MEMFREE(buf); - - return 0; -} -#endif - - -/*static char *klEmptyStr = "";*/ - - -/***************************************************************** - constant-space GC (based on the code by Nils M. Holm) - *****************************************************************/ -/* - * mark nodes which can be accessed through N. - * this routine uses the Deutsch/Schorr/Waite algorithm - * (aka pointer reversal algorithm) which marks the - * nodes of a pool in constant space. - * it uses the MFLAG and SFLAG to keep track of the - * state of the current node. - * Each visited node goes through these states: - * M==0 S==0 unvisited, process CAR - * M==1 S==1 CAR visited, process CDR - * M==1 S==0 completely visited, return to parent - */ -static void DSWMark (KLISP_POOL_DEF int n) { - int parent, p, t/*, st = n*/; - TKLispCell *plst; - - if (n < 0 || n >= KLISP_POOL->cellCount) return; - /*printf("**DSWMark: enter (%i) (%i)\n", n, KLISP_POOL->cellCount);*/ -#ifndef NDEBUG - if (KLISP_CELL(n).gcFlags & KLISP_FFLAG) { - fprintf(stderr, "free free %i\n", n); - } -#endif - assert((KLISP_CELL(n).gcFlags & KLISP_FFLAG) == 0); - plst = KLISP_POOL->cells; - if (plst[n].gcFlags & KLISP_MFLAG) return; /* already marked */ - /* mark it instantly if this is an atom */ - if (n <= 1 || (plst[n].ctype != KLISP_TYPE_CONS && plst[n].ctype != KLISP_TYPE_UDATA)) { - plst[n].gcFlags |= KLISP_MFLAG; - return; - } - /*printf("DSWMark: enter (%i) (%i)\n", n, KLISP_POOL->cellCount);*/ - parent = 0; /* initially, there is no parent node */ - while (1) { - /* reached a leaf? */ - if (n <= 0 || plst[n].gcFlags & KLISP_MFLAG) { - /* if the current node is a leaf and there is no parent, the entire tree is marked */ - if (!parent) break; - if (plst[parent].gcFlags & KLISP_SFLAG) { - /* state 2: the CDR of the parent has not yet been marked (S of parent set) */ - /* swap CAR and CDR pointers and proceed with CDR; set state=3 */ - p = plst[parent].cdr; - plst[parent].cdr = plst[parent].car; - plst[parent].car = n; - plst[parent].gcFlags &= ~KLISP_SFLAG; /* S=0 */ - plst[parent].gcFlags |= KLISP_MFLAG; /* M=1 */ - n = p; - } else { - /* state 3: CAR and CDR of parent done */ - /* return to the parent and restore parent of parent */ - p = parent; - parent = plst[p].cdr; - plst[p].cdr = n; - n = p; - } - } else { - /* state 1: the current node has not yet been visited */ - /* t: 'atom' flag */ - t = (n <= 1); /* nil, t: atoms */ - if (!t) { - /* not a known atom? check type */ - t = plst[n].ctype; /* type */ - /*if (t == KLISP_TYPE_UDATA) { - printf("**DSWMark: udata from %i\n", st); - KLispPrintCell(n); printf("\n"); - }*/ - t = (t != KLISP_TYPE_CONS && t != KLISP_TYPE_UDATA); /* not cons, not udata: atom */ - } - /*if (plst[n].ctype & KLISP_TYPE_MASK) {*/ - if (t) { - /* if the node is an atom, go directly to state 3: save the parent in CDR, */ - /* make the current node the new parent and move to its CDR */ - p = plst[n].cdr; - plst[n].cdr = parent; - /* S is already 0 */ - /*Tag[cell] &= ~SFLAG;*/ /* S=0 */ - parent = n; - n = p; - plst[parent].gcFlags |= KLISP_MFLAG; /* M=1 */ - } else { - /* go to state 2: like above, but save the parent in CAR and proceed to CAR */ - p = plst[n].car; - plst[n].car = parent; - plst[n].gcFlags |= KLISP_MFLAG; /* M=1 */ - parent = n; - n = p; - plst[parent].gcFlags |= KLISP_SFLAG; /* S=1 */ - } - } - } - /*printf("DSWMark: exit (%i)\n", n);*/ -} - - -void KLispGCMark (KLISP_POOL_DEF int cell) { - assert(KLISP_POOL->gcPhase); - if (!KLISP_POOL->gcPhase) return; /* ERROR! */ - DSWMark(KLISP_POOL_ARG cell); -} - - -static void InvokeFinalizer (KLISP_POOL_DEF int udatacell) { - TKLispFinalizeFn finalizer; - int cell; - - finalizer = KLISP_CELL(udatacell).finalizer; - if (!finalizer) return; - KLISP_GC_FREEZE; - cell = finalizer(KLISP_POOL_ARG KLISP_CELL(udatacell).udata, udatacell); - KLISP_GC_UNFREEZE; - KLISP_CELL(udatacell).finalizer = NULL; /* don't call it second time */ - if (cell <= 1) return; - DSWMark(KLISP_POOL_ARG cell); /* revive possible collected cells */ - - return; -} - - -static void MarkRBTree (KLISP_POOL_DEF TKLispRBTree *tree) { - TKLispRBTWalker walker; - TKLispRBTNode *item; - - if (!tree) return; - KLispRBTInitWalker(tree, &walker); - while ((item = KLispRBTWalkerNext(&walker))) { - /*fprintf(stderr, "sym: '%s' (str=%i; sym=%i); freeIt=%i\n", item->str, item->value0, item->value1, item->freeIt);*/ - if (item->value0) DSWMark(KLISP_POOL_ARG item->value0); - if (item->value1) DSWMark(KLISP_POOL_ARG item->value1); - } - KLispRBTDeinitWalker(&walker); -} - - -static void DumpRBTree (KLISP_POOL_DEF TKLispRBTree *tree) { - TKLispRBTWalker walker; - TKLispRBTNode *item; - - if (!tree) return; - KLispRBTInitWalker(tree, &walker); - while ((item = KLispRBTWalkerNext(&walker))) { - fprintf(stderr, "sym: '%s' (str=%i; sym=%i; hash=0x%08x); freeIt=%i\n", - item->str, item->value0, item->value1, item->hash, item->freeIt); - } - KLispRBTDeinitWalker(&walker); -} - - -/*#define KLISP_SUPERSAFE_GC*/ -void KLispGC (KLISP_POOL_DEF0) { - TKLispRBTNode *sp; - TKLispCell *cell; - int f, used, p1fin, t; -#ifdef KLISP_SUPERSAFE_GC - char *tmpbuf = NULL, *ttt; int tmpBufSize = 0; - char xbuf[128]; -#endif - - if (!KLISP_POOL) return; - if (KLISP_POOL->gcfrozen || KLISP_POOL->gcPhase) return; - KLISP_POOL->gcPhase++; - /* mark nil, t and specials */ - for (f = 0; f < KLISP_SPEC_MAX; f++) KLISP_CELL(KLISP_POOL->specs[f]).gcFlags = KLISP_MFLAG; - /* mark one-char cells and symbols */ - for (f = 1; f < 256; f++) { - KLISP_CELL(KLISP_POOL->chars[f]).gcFlags = KLISP_MFLAG; - KLISP_CELL(KLISP_POOL->syms[f]).gcFlags = KLISP_MFLAG; - } - /* various lists */ - MarkRBTree(KLISP_POOL_ARG KLISP_POOL->primitives); - MarkRBTree(KLISP_POOL_ARG KLISP_POOL->globals); - DSWMark(KLISP_POOL_ARG KLISP_POOL->frames); - DSWMark(KLISP_POOL_ARG KLISP_POOL->stack); - /* process roots */ - DSWMark(KLISP_POOL_ARG KLISP_POOL->roots); - DSWMark(KLISP_POOL_ARG KLISP_POOL->tempRootGC0); - DSWMark(KLISP_POOL_ARG KLISP_POOL->tempRootGC1); - /* first pass: check free cells, call userdata finalizers, register free cell list */ - cell = &(KLISP_POOL->cells[KLISP_POOL->cellCount-1]); - p1fin = 0; /* first cell to finalize */ - for (f = KLISP_POOL->cellCount-1; f > 2; f--, cell--) { - t = cell->gcFlags; - if (t & KLISP_FFLAG) continue; /* already free */ - if (t & KLISP_MFLAG) continue; /* don't collected */ - if (cell->ctype != KLISP_TYPE_UDATA) continue; /* not user-data */ - /* - KLispPrintF("udata down\n"); - KLispPrintF(" stack: "); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->stack); KLispPrintF("\n"); - KLispPrintF(" frames: "); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->frames); KLispPrintF("\n"); - */ - if (!cell->finalizer) continue; /* no finalizer */ - /* remember this cell */ - cell->tmp = p1fin; - p1fin = f; - } - /* second pass: call finalizers */ - while (p1fin) { - f = p1fin; - p1fin = KLISP_CELL(p1fin).tmp; /* next cell to finalizer */ - InvokeFinalizer(KLISP_POOL_ARG f); - } - /* third pass: rebuild free list */ - cell = (KLISP_POOL->cells); - (cell++)->ctype = KLISP_TYPE_NUM; - (cell++)->ctype = KLISP_TYPE_NUM; - used = 2; - for (f = 2; f < KLISP_POOL->cellCount; f++, cell++) { - t = cell->gcFlags; - if (t & KLISP_FFLAG) continue; /* already free */ - if (t & KLISP_MFLAG) { used++; cell->gcFlags = 0; } /* marked */ - else { - /* new free */ - if (f <= KLISP_POOL->chars[255]) fprintf(stderr, "fuckin shit! %i\n", f); - assert(f > KLISP_POOL->chars[255]); - cell->gcFlags = KLISP_FFLAG; - cell->car = 0; - cell->cdr = KLISP_POOL->free; - KLISP_POOL->free = f; - switch (cell->ctype) { - case KLISP_TYPE_SYM: - case KLISP_TYPE_STR: - /*if (!cell->str) { fprintf(stderr, "FUCKSHIT! %i\n", f); }*/ - assert(cell->str); - sp = KLispRBTFind(KLISP_POOL->strpool, cell->str); - if (!sp) { - fprintf(stderr, "fuck: '%s' not found in tree!\n", cell->str); - DumpRBTree(KLISP_POOL_ARG KLISP_POOL->strpool); - } - assert(sp); -#ifdef KLISP_DEBUG_SGC - fprintf(stderr, "str2kill: '%s' (str=%i; sym=%i) (%s) (free:%i)\n", cell->str, sp->value0, sp->value1, sp->str, sp->freeIt); -#endif - if (cell->ctype == KLISP_TYPE_STR) sp->value0 = 0; else sp->value1 = 0; -#ifdef KLISP_DEBUG_SGC - fprintf(stderr, "*str2kill: '%s' (str=%i; sym=%i) (%s) (free:%i)\n", cell->str, sp->value0, sp->value1, sp->str, sp->freeIt); -#endif - if (!sp->value0 && !sp->value1) { -#ifdef KLISP_SUPERSAFE_GC - t = strlen(cell->str)+1; - if (t <= 128) strcpy(xbuf, cell->str); - else { - if (tmpBufSize < t) { - ttt = KLISP_MEMREALLOC(tmpbuf, t*sizeof(char)); - if (!ttt) { fprintf(stderr, "***GC: memory!"); abort(); } - tmpbuf = ttt; - } - strcpy(tmpbuf, cell->str); - t = 0; - } - KLispRBTDelete(KLISP_POOL->strpool, t?xbuf:tmpbuf); -#else - /* it is safe to pass string reference, - 'cause it will be freed in very end */ - KLispRBTDelete(KLISP_POOL->strpool, sp->str); -#endif - } - break; - default: ; - } - cell->str = NULL; - cell->car = cell->ctype; - cell->ctype = KLISP_TYPE_NUM; - } - } - KLISP_POOL->usedCount = used; -#ifdef KLISP_SUPERSAFE_GC - if (tmpbuf) KLISP_MEMFREE(tmpbuf); -#endif - KLISP_POOL->gcPhase--; -} - - -/***************************************************************** - error messages - *****************************************************************/ -void KLispFreeError (KLISP_POOL_DEF0) { - if (!KLISP_POOL || KLISP_POOL->errorStatic || !KLISP_POOL->error) return; - KLISP_MEMFREE(KLISP_POOL->error); - KLISP_POOL->error = NULL; -} - - -int KLispError (KLISP_POOL_DEF const char *fmt, ...) { - static char *sErrorMem = "fatal out of memory!"; - int n, size = 256; - va_list ap; - char *p, *np; - - if (!KLISP_POOL) return -1; - KLispFreeError(KLISP_POOL_ARG0); - if (!fmt || !*fmt) return -1; - - KLISP_POOL->errorStatic = 1; KLISP_POOL->error = sErrorMem; - if ((p = KLISP_MEMALLOC(size*sizeof(char))) == NULL) return -1; - while (1) { - memset(p, 0, size); - va_start(ap, fmt); - n = vsnprintf(p, size, fmt?fmt:"", ap); - va_end(ap); - if (n > -1 && n < size) break; - if (n > -1) size = n+1; else size *= 2; - if ((np = KLISP_MEMREALLOC(p, size*sizeof(char))) == NULL) { KLISP_MEMFREE(p); return -1; } - p = np; - } - KLISP_POOL->errorStatic = 0; KLISP_POOL->error = p; - - return -1; -} - - -int KLispErrorMem (KLISP_POOL_DEF0) { - return KLispError(KLISP_POOL_ARG "out of memory"); -} - - -/***************************************************************** - initializers/allocators - *****************************************************************/ -void KLispFreePool (KLISP_POOL_DEF0) { - TKLispCell *cell; - int f; - - if (!KLISP_POOL) return; - KLISP_POOL->gcPhase++; - for (f = 0; f < KLISP_POOL->cellCount; f++) { - cell = &(KLISP_POOL->cells[f]); - if (cell->gcFlags & KLISP_FFLAG) continue; - if (cell->ctype == KLISP_TYPE_UDATA && cell->finalizer) InvokeFinalizer(KLISP_POOL_ARG f); - } - KLISP_POOL->gcPhase--; - KLispRBTFreeTree(KLISP_POOL->primitives); - KLispRBTFreeTree(KLISP_POOL->globals); - KLispRBTFreeTree(KLISP_POOL->strpool); - KLISP_MEMFREE(KLISP_POOL->cells); - KLispFreeError(KLISP_POOL_ARG0); - KLISP_MEMFREE(KLISP_POOL); -} - - -static void InitPool (KLISP_POOL_DEF int from) { - TKLispCell *cell; - int f; - - if (KLISP_POOL->free) KLISP_CELL(KLISP_POOL->free).cdr = from; - KLISP_POOL->free = from; - cell = &(KLISP_CELL(from)); - for (f = from; f < KLISP_POOL->cellCount; f++, cell++) { - cell->ctype = KLISP_TYPE_NUM; - cell->num = 0; - cell->str = NULL; - cell->car = cell->tmp = 0; - cell->cdr = f+1; - cell->gcFlags = KLISP_FFLAG; - } - KLISP_CELL(KLISP_POOL->cellCount-1).cdr = 0; /* end of free list */ -} - - -TKLispPool *KLispNewPool (void) { - TKLispRBTNode *ci; - TKLispPool *pool; - TKLispCell *cell; - int f, initPS; - char buf[2]; - - KLISP_POOL = KLISP_MEMALLOC(sizeof(TKLispPool)); - if (!KLISP_POOL) goto errexit; - memset(KLISP_POOL, 0, sizeof(TKLispPool)); - initPS = KLISP_INIT_POOL_SIZE; - if (initPS < KLISP_SPEC_MAX+16) initPS = KLISP_INIT_POOL_SIZE+16; - KLISP_POOL->cellCount = initPS; - KLISP_POOL->cells = KLISP_MEMALLOC(KLISP_POOL->cellCount*sizeof(TKLispCell)); - if (!KLISP_POOL->cells) goto errexit; - memset(KLISP_POOL->cells, 0, KLISP_POOL->cellCount*sizeof(TKLispCell)); - KLISP_POOL->primitives = KLispRBTNewTree(); - if (!KLISP_POOL->primitives) goto errexit; - KLISP_POOL->globals = KLispRBTNewTree(); - if (!KLISP_POOL->globals) goto errexit; - KLISP_POOL->strpool = KLispRBTNewTree(); - if (!KLISP_POOL->strpool) goto errexit; - - buf[1] = '\0'; - /* fill strpool with chars */ - for (f = 1; f < 256; f++) { - buf[0] = f; - if (!KLispRBTInsert(KLISP_POOL->strpool, buf, 0, 0, 1, NULL)) goto errexit; - } - - KLISP_POOL->usedCount = 0; - /* init specials */ - cell = KLISP_POOL->cells; - for (f = 0; f < KLISP_SPEC_MAX; f++, cell++) { - KLISP_POOL->usedCount++; - KLISP_POOL->specs[f] = f; - if (f == 0 || f == 1) { - cell->num = f; - cell->ctype = KLISP_TYPE_NUM; - cell->car = 0; - } else { - cell->num = 0; - cell->ctype = KLISP_TYPE_SPEC; - cell->car = f; /* special type */ - } - cell->str = NULL; - cell->cdr = cell->gcFlags = 0; - } - /* 1-char strings */ - for (f = 1; f < 256; f++, cell++) { - KLISP_POOL->chars[f] = KLISP_POOL->usedCount; - KLISP_POOL->usedCount++; - cell->num = 0; - cell->ctype = KLISP_TYPE_STR; - cell->car = 0; - buf[0] = f; - ci = KLispRBTFind(KLISP_POOL->strpool, buf); - assert(ci); - ci->value0 = KLISP_POOL->chars[f]; - cell->str = ci->str; - cell->cdr = cell->gcFlags = 0; - } - /* 1-char symbols */ - for (f = 1; f < 256; f++, cell++) { - KLISP_POOL->syms[f] = KLISP_POOL->usedCount; - KLISP_POOL->usedCount++; - cell->num = 0; - cell->ctype = KLISP_TYPE_SYM; - cell->car = 0; - buf[0] = f; - ci = KLispRBTFind(KLISP_POOL->strpool, buf); - assert(ci); - ci->value1 = KLISP_POOL->syms[f]; - cell->str = ci->str; - cell->cdr = cell->gcFlags = 0; - } - - InitPool(KLISP_POOL_ARG KLISP_POOL->usedCount); - - return pool; - -errexit: - if (KLISP_POOL->cells) KLISP_MEMFREE(KLISP_POOL->cells); - KLispRBTFreeTree(KLISP_POOL->primitives); - KLispRBTFreeTree(KLISP_POOL->globals); - KLispRBTFreeTree(KLISP_POOL->strpool); - KLISP_MEMFREE(KLISP_POOL); - return NULL; -} - - -static int AllocCell (KLISP_POOL_DEF0) { - TKLispCell *newcp; - int f, newSz; - -#ifdef KLISP_DEBUG_VERY_AGRESSIVE_GC - KLispGC(KLISP_POOL_ARG0); -#endif - if (!KLISP_POOL->free || KLISP_POOL->cellCount-KLISP_POOL->usedCount < KLISP_GROW_POOL_SIZE/4) { - /* gc */ - KLispGC(KLISP_POOL_ARG0); - if (!KLISP_POOL->free) { - /* grow */ - newSz = KLISP_POOL->cellCount+KLISP_GROW_POOL_SIZE; - newcp = KLISP_MEMREALLOC(KLISP_POOL->cells, sizeof(TKLispCell)*newSz); - if (!newcp) return KLispErrorMem(KLISP_POOL_ARG0); - KLISP_POOL->cells = newcp; - f = KLISP_POOL->cellCount; - KLISP_POOL->cellCount = newSz; - InitPool(KLISP_POOL_ARG f); - } - } - - if (!KLISP_POOL->free) return KLispErrorMem(KLISP_POOL_ARG0); - f = KLISP_POOL->free; - newcp = &(KLISP_POOL->cells[f]); - KLISP_POOL->free = newcp->cdr; - newcp->ctype = KLISP_TYPE_NUM; - newcp->car = newcp->cdr = newcp->gcFlags = 0; - KLISP_POOL->usedCount++; - - return f; -} - - -int KLispNewCons (KLISP_POOL_DEF int car, int cdr) { - int cell; - - if (car < 0 || cdr < 0) return -1; - assert(!KLISP_POOL->tempRootGC0 && !KLISP_POOL->tempRootGC1); - KLISP_POOL->tempRootGC0 = car; - KLISP_POOL->tempRootGC1 = cdr; - cell = AllocCell(KLISP_POOL_ARG0); - KLISP_POOL->tempRootGC0 = KLISP_POOL->tempRootGC1 = 0; - if (cell >= 0) { - KLISP_CTYPE(cell) = KLISP_TYPE_CONS; - KLISP_CAR(cell) = car; - KLISP_CDR(cell) = cdr; - } - - return cell; -} - - -int KLispNewNum (KLISP_POOL_DEF TKLispNumber value) { - int cell; - - if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1; - KLISP_CTYPE(cell) = KLISP_TYPE_NUM; - KLISP_CELL(cell).num = value; - - return cell; -} - - -int KLispNewSym (KLISP_POOL_DEF const char *value) { - int cell; - TKLispRBTNode *sp; - - assert(value); - - if (*value && !value[1]) return KLISP_POOL->syms[*((unsigned char *)value)]; - - sp = KLispRBTFind(KLISP_POOL->strpool, value); - if (sp && sp->value1) return sp->value1; - - if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1; - if (!sp) { - if (!(sp = KLispRBTInsert(KLISP_POOL->strpool, value, 0, cell, 1, NULL))) return -1; - } else sp->value1 = cell; - - KLISP_CTYPE(cell) = KLISP_TYPE_SYM; - KLISP_CELL(cell).str = sp->str; - - return cell; -} - - -int KLispNewStr (KLISP_POOL_DEF const char *value) { - TKLispRBTNode *sp; - int cell; - - assert(value); - - if (*value && !value[1]) return KLISP_POOL->chars[*((unsigned char *)value)]; - - sp = KLispRBTFind(KLISP_POOL->strpool, value); - if (sp && sp->value0) return sp->value0; - - if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1; - if (!sp) { - if (!(sp = KLispRBTInsert(KLISP_POOL->strpool, value, cell, 0, 1, NULL))) return -1; - } else sp->value0 = cell; - - KLISP_CTYPE(cell) = KLISP_TYPE_STR; - KLISP_CELL(cell).str = sp->str; - - return cell; -} - - -int KLispNewXPrim (KLISP_POOL_DEF int prtype, TKLispPrimFn fn, const char *name) { - TKLispRBTNode *sp; - int cell; - - assert(name && *name); - switch (prtype) { - case KLISP_TYPE_PRIM: case KLISP_TYPE_MPRIM: - case KLISP_TYPE_IPRIM: case KLISP_TYPE_IMPRIM: - break; - default: return KLispError(KLISP_POOL_ARG "KLispNewXPrim: invalid prim type"); - } - - sp = KLispRBTFind(KLISP_POOL->primitives, name); - if (!sp) { - if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1; - if (!(sp = KLispRBTInsert(KLISP_POOL->primitives, name, cell, 0, 1, NULL))) return -1; - KLISP_CELL(cell).str = sp->str; - } else cell = sp->value0; - - KLISP_CTYPE(cell) = prtype; - KLISP_CELL(cell).fn = fn; - - return cell; -} - - -int KLispNewSymbolPair (KLISP_POOL_DEF const char *name, int valueCell) { - int sym; - - KLISP_GC_FREEZE; - sym = KLispNewSym(KLISP_POOL_ARG name); - if (sym > 0) sym = KLispNewCons(KLISP_POOL_ARG sym, valueCell); - KLISP_GC_UNFREEZE; - - return sym; -} - - -/* UDATA: - car: ptr to cell with some data or nil; cdr: list of methods; - list of methods: car: symbol (name . xPRIM); cdr: next - method args: (udata_obj ...) - call: (udata method ...) -*/ -int KLispNewUData (KLISP_POOL_DEF void *ptr, TKLispFinalizeFn finalizer) { - int cell; - - if ((cell = KLispNewCons(KLISP_POOL_ARG 0, 0)) < 0) return -1; - KLISP_CTYPE(cell) = KLISP_TYPE_UDATA; - KLISP_CELL(cell).finalizer = finalizer; - KLISP_CELL(cell).udata = ptr; - - return cell; -} - - -/* return 0 or method cell */ -static int KLispUDataFindMethod (KLISP_POOL_DEF int udata, const char *name) { - int mcell; - - if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return -1; - mcell = KLispFindSymbol(KLISP_POOL_ARG KLISP_CDR(udata), name); - - return mcell<=0?0:mcell; -} - - -int KLispUDataGetMethod (KLISP_POOL_DEF int udata, const char *name) { - int sym; - - if ((sym = KLispUDataFindMethod(KLISP_POOL_ARG udata, name)) <= 0) return -1; - - return KLISP_CDR(sym); -} - - -int KLispUDataSetMethod (KLISP_POOL_DEF int udata, int methodcell, const char *name) { - int sym, t; - - if (methodcell < 0) return -1; - sym = KLispUDataFindMethod(KLISP_POOL_ARG udata, name); - if (sym < 0) return -1; - if (!sym) { - /* create new symbol */ - if ((sym = KLispNewSymbolPair(KLISP_POOL_ARG name, methodcell)) < 0) return -1; - /* add it to method list */ - KLISP_GC_FREEZE; - t = KLispNewCons(KLISP_POOL_ARG sym, KLISP_CDR(udata)); - KLISP_GC_UNFREEZE; - if (t < 0) return -1; - KLISP_CDR(udata) = t; - } else KLISP_CDR(sym) = methodcell; - - return sym; -} - - -void *KLispUDataGetPtr (KLISP_POOL_DEF int udata) { - if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return NULL; - - return KLISP_CELL(udata).udata; -} - - -int KLispUDataSetPtr (KLISP_POOL_DEF int udata, void *ptr) { - if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return 0; - - KLISP_CELL(udata).udata = ptr; - - return 1; -} - - -int KLispRegisterMethods (KLISP_POOL_DEF int udatacell, struct _TKLispPrimItem *list) { - int methodcell, res = 0; - - KLISP_GC_FREEZE; - /*if (!KLispPushRoot(KLISP_POOL_ARG udatacell)) return -1;*/ - while (list && list->name) { - methodcell = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, list->fn, list->name); - if (methodcell < 0) goto done; - if (KLispUDataSetMethod(KLISP_POOL_ARG udatacell, methodcell, list->name) < 0) goto done; - list++; - } - res = 1; -done: - KLISP_GC_UNFREEZE; - /*KLispPopRoots(KLISP_POOL_ARG 1);*/ - - return res; -} - - -static const char *klSpecNames[] = { - "", "", - "STOP_EVAL", - "ARG_EVAL", - "FN_EVAL", - "CALL", - "ICALL", - "SCOPE", - - "LMD_CALL", - - NULL, -}; - - -/***************************************************************** - symbol table manipulation - *****************************************************************/ -/* find global symbol - return symbol pair or -1 */ -int KLispFindGlobal (KLISP_POOL_DEF const char *name) { - TKLispRBTNode *sp; - - sp = KLispRBTFind(KLISP_POOL->globals, name); - return sp?sp->value0:-1; -} - - -/* set global symbol (add it if necessary) - return symbol pair or -1 */ -int KLispSetGlobal (KLISP_POOL_DEF const char *name, int valueCell) { - TKLispRBTNode *sp; - int cell; - - if (valueCell < 0) return -1; - sp = KLispRBTFind(KLISP_POOL->globals, name); - if (!sp) { - if ((cell = KLispNewSymbolPair(KLISP_POOL_ARG name, valueCell)) < 0) return -1; - if (!(sp = KLispRBTInsert(KLISP_POOL->globals, KLISP_CELL(KLISP_CAR(cell)).str, cell, 0, 0, NULL))) return -1; - } else { - cell = sp->value0; - KLISP_CDR(cell) = valueCell; - } - - return cell; -} - - -/* delete global symbol - return symbol pair or -1 */ -int KLispDeleteGlobal (KLISP_POOL_DEF const char *name) { - TKLispRBTNode *sp; - int cell; - - sp = KLispRBTFind(KLISP_POOL->globals, name); - if (sp) { - cell = sp->value0; - KLispRBTDelete(KLISP_POOL->globals, name); - - return cell; - } - - return -1; -} - - -/* find symbol in symbol list - return symbol pair or -1 */ -int KLispFindSymbolByCell (KLISP_POOL_DEF int list, int symNameCell) { - int cell; - - if (symNameCell < 1) return -1; - while (list) { - cell = KLISP_CAR_EX(list); - if (KLISP_CAR_EX(cell) == symNameCell) return cell; - list = KLISP_CDR_EX(list); - } - - return -1; -} - - -/* find symbol in symbol list - return symbol pair or -1 */ -int KLispFindSymbol (KLISP_POOL_DEF int list, const char *name) { - TKLispRBTNode *sp; - - sp = KLispRBTFind(KLISP_POOL->strpool, name); - if (!sp || !sp->value1) return -1; - - return KLispFindSymbolByCell(KLISP_POOL_ARG list, sp->value1); -} - - -/* get symbol pair; search all frames and globals - return symbol pair or -1 */ -int KLispGetSymbol (KLISP_POOL_DEF const char *name) { - TKLispRBTNode *sp; - int list, sym; - - list = KLISP_POOL->frames; - if (list) { - sp = KLispRBTFind(KLISP_POOL->strpool, name); - if (!sp || !sp->value1) return -1; - while (list) { - if ((sym = KLispFindSymbolByCell(KLISP_POOL_ARG KLISP_CAR_EX(list), sp->value1)) > 0) return sym; - list = KLISP_CDR_EX(list); - } - } - - return KLispFindGlobal(KLISP_POOL_ARG name); -} - - -/* set symbol value (add it to upper frame or globals if necessary) - return symbol pair or -1 */ -int KLispSetSymbolValue (KLISP_POOL_DEF const char *name, int valueCell, int nodig) { - int sym, t; - - if (valueCell < 0) return -1; - if (KLISP_POOL->frames && nodig) sym = KLispFindSymbol(KLISP_POOL_ARG KLISP_CAR(KLISP_POOL->frames), name); - else sym = KLispGetSymbol(KLISP_POOL_ARG name); - if (sym > 0) { - /*if (sym < 0) fprintf(stderr, "sym: %i\n", sym);*/ - KLISP_CDR(sym) = valueCell; - } else { - if (KLISP_POOL->frames) { - /*if (sym < 0) fprintf(stderr, "%s\n", "frames?");*/ - if ((sym = KLispNewSymbolPair(KLISP_POOL_ARG name, valueCell)) < 0) return -1; - if ((t = KLispNewCons(KLISP_POOL_ARG sym, KLISP_CAR(KLISP_POOL->frames))) < 0) return -1; - KLISP_CAR(KLISP_POOL->frames) = t; - } else { - sym = KLispSetGlobal(KLISP_POOL_ARG name, valueCell); - /*if (sym < 0) fprintf(stderr, "%s\n", "!@#$%%!%!%!%");*/ - } - } - - return sym; -} - - -int KLispRegisterPrim (KLISP_POOL_DEF int evalargs, TKLispPrimFn fn, const char *name) { - int sym; - - if ((sym = KLispNewXPrim(KLISP_POOL_ARG evalargs?KLISP_TYPE_PRIM:KLISP_TYPE_MPRIM, fn, name)) < 0) return 0; - if (KLispSetGlobal(KLISP_POOL_ARG name, sym) < 0) return 0; - - return 1; -} - - -int KLispRegisterPrims (KLISP_POOL_DEF struct _TKLispPrimItem *list) { - while (list && list->name) { - if (!KLispRegisterPrim(KLISP_POOL_ARG list->evalargs, list->fn, list->name)) return 0; - list++; - } - - return 1; -} - - -/***************************************************************** - utilities - *****************************************************************/ -int KLispIsList (KLISP_POOL_DEF int n) { - int cnt = 0; - - if (n < 0) return 0; - while (n > 0) { - if (KLISP_CTYPE(n)) return 0; /* not a cons */ - n = KLISP_CDR(n); - cnt++; - } - - return cnt; -} - - -/* should be: list of dotted pairs: ( name . value ) */ -int KLispCheckSymTable (KLISP_POOL_DEF int n) { - int nv; - - if (n < 0) return 0; - while (n > 0) { - if (KLISP_CTYPE(n)) return 0; /* not a cons */ - nv = KLISP_CAR(n); - if (!nv || KLISP_CTYPE(nv)) return 0; /* not a dotted pair */ - if (KLISP_CTYPE(KLISP_CAR(nv)) != KLISP_TYPE_SYM) return 0; - n = KLISP_CDR(n); - } - - return 1; -} - - -int KLispPushRoot (KLISP_POOL_DEF int n) { - int newc; - - if (n < 0) return 0; - newc = KLispNewCons(KLISP_POOL_ARG n, KLISP_POOL->roots); - if (newc < 0) return 0; - KLISP_POOL->roots = newc; - - return 1; -} - - -void KLispPopRoots (KLISP_POOL_DEF int cnt) { - while (cnt-- > 0 && KLISP_POOL->roots) KLISP_POOL->roots = KLISP_CDR(KLISP_POOL->roots); -} - - -int KLispNewFrame (KLISP_POOL_DEF int frame) { - int newc; - - if (frame && !KLispCheckSymTable(KLISP_POOL_ARG frame)) { - KLispError(KLISP_POOL_ARG "KLispNewFrame: invalid frame"); - return 0; - } - newc = KLispNewCons(KLISP_POOL_ARG frame, KLISP_POOL->frames); - if (newc < 0) return 0; - KLISP_POOL->frames = newc; - - return 1; -} - - -void KLispPopFrame (KLISP_POOL_DEF0) { - if (KLISP_POOL->frames) KLISP_POOL->frames = KLISP_CDR(KLISP_POOL->frames); -} - - -int KLispRPush (KLISP_POOL_DEF int n) { - int newc; - - if (n < 0) return 0; - newc = KLispNewCons(KLISP_POOL_ARG n, KLISP_POOL->stack); - if (newc < 0) return 0; - KLISP_POOL->stack = newc; - - return 1; -} - - -int KLispRPop (KLISP_POOL_DEF0) { - int n; - - if (KLISP_POOL->stack <= 0) return -1; - n = KLISP_CAR(KLISP_POOL->stack); - KLISP_POOL->stack = KLISP_CDR(KLISP_POOL->stack); - - return n; -} - - -void KLispRDrop (KLISP_POOL_DEF int cnt) { - while (cnt-- > 0 && KLISP_POOL->stack) KLISP_POOL->stack = KLISP_CDR(KLISP_POOL->stack); -} - - -int KLispRPeek (KLISP_POOL_DEF int depth) { - int n = KLISP_POOL->stack; - - while (depth-- > 0 && n) n = KLISP_CDR(n); - if (n <= 0) return -1; - - return KLISP_CAR(n); -} - - -/* WARNING: this should accept ANY valueCell! */ -int KLispRSet (KLISP_POOL_DEF int depth, int valueCell) { - int n = KLISP_POOL->stack; - - while (depth-- > 0 && n) n = KLISP_CDR(n); - if (n <= 0) return 0; - - KLISP_CAR(n) = valueCell; - - return 1; -} - - -int KLispRSwap (KLISP_POOL_DEF int depth0, int depth1) { - int n = KLISP_POOL->stack, d0 = -1, d1 = -1, level = 0; - - if (depth0 < 0 || depth1 < 0) return 0; - if (depth0 == depth1) return 1; - while (n && (d0 < 0 || d1 < 0)) { - if (level == depth0) d0 = n; - else if (level == depth1) d1 = n; - n = KLISP_CDR(n); - level++; - } - if (d0 < 0 || d1 < 0) return 0; - - n = KLISP_CAR(d0); - KLISP_CAR(d0) = KLISP_CAR(d1); - KLISP_CAR(d1) = n; - - return 1; -} - - -/***************************************************************** - simple printer - *****************************************************************/ -static void PrintStr (const char *s, int doQuoting) { - int needQ = 0; - const unsigned char *t = (unsigned char *)s; - - if (!s) return; - if (doQuoting || *t == '\x27') needQ = 1; - while (*t && !needQ) { - if (*t < ' ' || *t == '"' || *t == '`') needQ = 1; - t++; - } - - if (!needQ) { KLispPrintF("%s", s); return; } - switch (doQuoting) { - case 0: break; - case 1: KLispPrintF("\x22"); break; - default: KLispPrintF("`"); break; - } - t = (unsigned char *)s; - while (*t) { - if (*t < ' ') { - switch (*t) { - case '\t': KLispPrintF("\\t"); break; - case '\r': KLispPrintF("\\r"); break; - case '\n': KLispPrintF("\\n"); break; - case ' ': case '"': case '\\': case '`': KLispPrintF("\\%c", *t); break; - default: KLispPrintF("\\x%02x", *t); break; - } - } else KLispPrintF("%c", *t); - t++; - } - switch (doQuoting) { - case 0: break; - case 1: KLispPrintF("\x22"); break; - default: KLispPrintF("`"); break; - } -} - - -static void PrintCell (KLISP_POOL_DEF int n, int prType) { - int addspace = 0, f; - const char *s = NULL; - TKLispNumber num; - - if (n < 0 || n >= KLISP_POOL->cellCount) { KLispPrintF(""); return; } - if (KLISP_CELL(n).gcFlags & KLISP_FFLAG) { - KLispPrintF("", KLISP_CAR(n)); - return; - } - if (n == 0) { if (prType) KLispPrintF("#"); KLispPrintF("nil"); return; } - if (n == 1) { if (prType) KLispPrintF("#"); KLispPrintF("t"); return; } - switch (KLISP_CTYPE(n)) { - case KLISP_TYPE_NUM: - if (prType) KLispPrintF("{num}"); - num = KLISP_CELL(n).num; - if (trunc(num) == num) KLispPrintF("%.f", num); else KLispPrintF("%f", num); - return; - case KLISP_TYPE_SYM: - if (prType) KLispPrintF("{sym}"); - PrintStr(KLISP_CELL(n).str, 2); - return; - case KLISP_TYPE_STR: - if (prType) KLispPrintF("{str}"); - PrintStr(KLISP_CELL(n).str, 1); - return; - case KLISP_TYPE_PRIM: - KLispPrintF(""); - return; - case KLISP_TYPE_MPRIM: - KLispPrintF(""); - return; - case KLISP_TYPE_IPRIM: - KLispPrintF(""); - return; - case KLISP_TYPE_IMPRIM: - KLispPrintF(""); - return; - case KLISP_TYPE_UDATA: - KLispPrintF("", (unsigned long)(KLISP_CELL(n).udata)); - return; - case KLISP_TYPE_SPEC: - f = KLISP_CAR(n); - if (f >= 0) { - for (f = 0; f < KLISP_CAR(n) && klSpecNames[f]; f++) ; - s = klSpecNames[f]; - } - KLispPrintF(""); - return; - case KLISP_TYPE_CONS: - KLispPrintF("("); - while (n) { - if (addspace) KLispPrintF(" "); else addspace = 1; - PrintCell(KLISP_POOL_ARG KLISP_CAR(n), prType); - if (KLISP_CDR_EX(n) && KLISP_CTYPE(KLISP_CDR_EX(n))) { - /* seems to be a dotted pair */ - KLispPrintF(" . "); - PrintCell(KLISP_POOL_ARG KLISP_CDR(n), prType); - KLispPrintF(")"); - return; - } - n = KLISP_CDR(n); - } - KLispPrintF(")"); - break; - default: - KLispPrintF(" ' ') break; - } - *str = s; - - return *s?1:0; -} - - -char *KLispParseString (const char **str, unsigned char terminator, int doSpecial) { - unsigned char *s = (unsigned char *)(*str); - unsigned char *e, *t; - int len = 0, wasSpecial = 0, f; - - e = s; - while (*e) { - if (doSpecial && *e == '\\') { wasSpecial = 1; len++; e += 2; continue; } - if ((terminator == ' ' && (*e <= ' ' || *e == '(' || *e == ')')) || *e == terminator) break; - len++; e++; - } - if (terminator != ' ' && *e) e++; - *str = (char *)e; - if (!len) { - t = KLISP_MEMALLOC(sizeof(char)); - if (t) *t = '\0'; - return (char *)t; - } - f = (len+1)*sizeof(char); - e = KLISP_MEMALLOC(f); - if (!e) return NULL; - memset(e, 0, f); - if (!wasSpecial) memcpy(e, s, sizeof(char)*len); - else { - /* process string with specials */ - t = e; - while (len--) { - if (*s == '\\') { - s++; - switch (*s) { - case 't': *t++ = '\t'; break; - case 'n': *t++ = '\n'; break; - case 'r': *t++ = '\r'; break; - default: *t++ = *s; break; - } - s++; - } else *t++ = *s++; - } - } - - return (char *)e; -} - - -int KLispParseNum (const char **str, int onlyNum, int skipSpaces, TKLispNumber *res) { - TKLispNumber num, frnum, div; - const unsigned char *s; - int neg = 0; - - *res = 0; - if (skipSpaces) KLispSkipSpaces(str); - - s = (unsigned char *)(*str); - if (*s == '-') { neg = 1; s++;} else if (*s == '+') s++; - - if (*s < '0' || *s > '9') return 0; - num = 0; - while (*s >= '0' && *s <= '9') num = (num*10)+((*s++)-'0'); - if (*s == '.') { - s++; frnum = 0; div = 1; - while (*s >= '0' && *s <= '9') { frnum = (frnum*10)+((*s++)-'0'); div *= 10; } - num += frnum/div; - } - if (num != 0 && neg) num = -num; - *res = num; - - /*KLispPrintF("ParseNum: <%s>\n", *str);*/ - if (onlyNum) { - /*KLispPrintF(" onlynum\n");*/ - if (skipSpaces) while (*s && *s <= ' ') s++; - if (*s) return 0; - } else { - /*KLispPrintF(" ins\n");*/ - if (*s > ' ' && *s != '(' && *s != ')') return 0; - if (skipSpaces) while (*s && *s <= ' ') s++; - } - - /*KLispPrintF("ParseNum: ok <%s>\n", s);*/ - *str = (char *)s; - - return 1; -} - - -int KLispParsePrim (KLISP_POOL_DEF const char **str, int *special) { - int res, sptmp; - const unsigned char *s; - char *t; - TKLispNumber num; - - if (!KLispSkipSpaces(str)) return KLispError(KLISP_POOL_ARG "KLispParsePrim: unexpected end of input"); - if (special) *special = 0; - - /* number? */ - if (KLispParseNum(str, 0, 1, &num)) { - /*KLISP_GC_FREEZE;*/ - res = KLispNewNum(KLISP_POOL_ARG num); - /*KLISP_GC_UNFREEZE;*/ - return res>=0?res:-1; - } - - s = (unsigned char *)(*str); - if (!*s) return KLispError(KLISP_POOL_ARG "KLispParsePrim: token expected"); - - /* dotted pair? */ - if (*s == '.') { - s++; - if (*s == '(' || *s == ')' || *s <= ' ') { - if (special) *special = 1; - return -1; - } - s--; - } - - switch (*s) { - case '(': - (*str)++; - res = KLispParseList(KLISP_POOL_ARG str); - return KLISP_POOL->error?-1:res; - case ')': - /*KLispPrintF("SPEC)\n");*/ - if (special) *special = 1; - return -1; - case '\x27': /* build (quote sym) */ - s++; /* skip ' */ - *str = (char *)s; - if (*s == '(') { - /* quote list */ - s++; /* skip '(' */ - *str = (char *)s; - res = KLispParseList(KLISP_POOL_ARG str); - if (KLISP_POOL->error) return -1; - } else { - res = KLispParsePrim(KLISP_POOL_ARG str, &sptmp); - if (KLISP_POOL->error) return -1; - if (sptmp) return KLispError(KLISP_POOL_ARG "KLispParsePrim: quoting special char is not allowed (yet?)"); - } - /* args for "quote" */ - if ((res = KLispNewCons(KLISP_POOL_ARG res, 0)) < 0) return -1; - /* (quote ...) */ - KLISP_GC_FREEZE; - res = KLispNewCons(KLISP_POOL_ARG KLispNewSym(KLISP_POOL_ARG "quote"), res); - KLISP_GC_UNFREEZE; - if (res >= 0) KLispSkipSpaces(str); - return res; - case '"': /* string */ - s++; *str = (char *)s; - /* get string */ - t = KLispParseString(str, '"', 1); - if (!t) return -1; - /* check for very special strings */ - if (*t && !t[1]) res = KLISP_POOL->chars[*((unsigned char *)t)]; else res = KLispNewStr(KLISP_POOL_ARG t); -/* - if (res >= 0) { - fprintf(stderr, "parser string: '%s'=='%s' (%i)\n", t, KLISP_CELL(res).str, res); - } else { - fprintf(stderr, "parser string fuck: '%s'\n", t); - } -*/ - KLISP_MEMFREE(t); - if (res >= 0) KLispSkipSpaces(str); - return res; - default: /* identifier */ - *str = (char *)s; - sptmp = *s=='`'; /* `...`? */ - t = KLispParseString(str, sptmp?'`':' ', sptmp); - if (!t) return KLispErrorMem(KLISP_POOL_ARG0); - /* two very special primitives %-) */ - if (!strcmp(t, "nil")) { KLISP_MEMFREE(t); return 0; } - if (!strcmp(t, "t")) { KLISP_MEMFREE(t); return 1; } - if (*t && !t[1]) res = KLISP_POOL->syms[*((unsigned char *)t)]; else res = KLispNewSym(KLISP_POOL_ARG t); - KLISP_MEMFREE(t); - if (res >= 0) KLispSkipSpaces(str); - return res; - } -} - - -int KLispParseList (KLISP_POOL_DEF const char **str) { - int res, cell, plast = 0; - int special; - - if ((res = KLispNewCons(KLISP_POOL_ARG 0, 0)) < 0) return -1; - if (!KLispPushRoot(KLISP_POOL_ARG res)) return -1; - /*KLispPrintF("lst: %s|\n", *str);*/ - while (**str) { - if (!KLispSkipSpaces(str)) { KLispError(KLISP_POOL_ARG "KLispParseList: unexpected end of list!"); goto xerr; } - cell = KLispParsePrim(KLISP_POOL_ARG str, &special); - if (KLISP_POOL->error) goto xerr; - if (special) { - switch (**str) { - case ')': - (*str)++; - if (!plast) { KLispError(KLISP_POOL_ARG "KLispParseList: list without elements"); goto xerr; } - KLispSkipSpaces(str); - KLispPopRoots(KLISP_POOL_ARG 1); - return res; - case '.': - if (!plast) { KLispError(KLISP_POOL_ARG "KLispParseList: dotted pair without first element"); goto xerr; } - (*str)++; - if (!KLispSkipSpaces(str)) { KLispError(KLISP_POOL_ARG "KLispParseList: unexpected end of dotted pair"); goto xerr; } - KLISP_CDR(plast) = KLispParsePrim(KLISP_POOL_ARG str, &special); - if (KLISP_POOL->error) goto xerr; - if (special) { KLispError(KLISP_POOL_ARG "KLispParseList: invalid dotted pair"); goto xerr; } - KLispSkipSpaces(str); - if (**str == ')') { - (*str)++; - KLispSkipSpaces(str); - KLispPopRoots(KLISP_POOL_ARG 1); - return res; - } - KLispError(KLISP_POOL_ARG "KLispParseList: '\x29' expected after dotted pair"); - goto xerr; - default: - KLispError(KLISP_POOL_ARG "KLispParseList: wtf?!"); - goto xerr; - } - } - if (!plast) { - KLISP_CAR(res) = cell; - plast = res; - } else { - if ((cell = KLispNewCons(KLISP_POOL_ARG cell, 0)) < 0) goto xerr; - KLISP_CDR(plast) = cell; - plast = cell; - } - } - KLispError(KLISP_POOL_ARG "KLispParseList: unexpected end of list (wtf?)"); -xerr: - KLispPopRoots(KLISP_POOL_ARG 1); - return -1; -} - - -int KLispParseSExpr (KLISP_POOL_DEF const char **str) { - int res; - int special; - - if (!KLISP_POOL || !str || !*str) return -1; - if (!KLispSkipSpaces(str)) return -1; - KLISP_GC_FREEZE; - res = KLispParsePrim(KLISP_POOL_ARG str, &special); - KLISP_GC_UNFREEZE; - if (KLISP_POOL->error) return -1; - if (special) return KLispError(KLISP_POOL_ARG "KLispParseSExpr: invalid charactes in s-expr: '%c'", **str); - - return res; -} - - -/***************************************************************** - arglist checker - *****************************************************************/ -const char *KLispTypeName (KLISP_POOL_DEF int cell) { - const char *s; - - if (!cell) s = "nil"; - else if (cell == 1) s = "t"; - else - switch (KLISP_CTYPE(cell)) { - case KLISP_TYPE_CONS: s = "cons"; break; - case KLISP_TYPE_NUM: s = "number"; break; - case KLISP_TYPE_SYM: s = "symbol"; break; - case KLISP_TYPE_STR: s = "string"; break; - case KLISP_TYPE_PRIM: s = "primitive"; break; - case KLISP_TYPE_MPRIM: s = "m-primitive"; break; - case KLISP_TYPE_IPRIM: s = "i-primitive"; break; - case KLISP_TYPE_IMPRIM: s = "im-primitive"; break; - case KLISP_TYPE_UDATA: s = "udata"; break; - case KLISP_TYPE_SPEC: s = "special"; break; - default: s = "unknown"; break; - } - - return s; -} - - -/* types: - (n)umber, - (s)ymbol, - (S)tring, - ($)tring, - (p)rimitive, - (c)ons, - (l)list, - (t)rue, - (N)il, - (a)ny(but not nil), - (A)ny(nil too), - (T)ymbol table - (u)serdata -*/ -int KLispCheckCellType (KLISP_POOL_DEF int cell, char type) { - int ctype; - - if (cell < 0) return 0; - switch (type) { - case 'A': return 1; - case 'N': return cell==0; - case 'T': return KLispCheckSymTable(KLISP_POOL_ARG cell); - case 'a': return cell>0; - case 'l': return KLispIsList(KLISP_POOL_ARG cell); - case 't': return cell==1; - default: ; - } - /* nil will not pass! %-) */ - if (!cell) return 0; - ctype = KLISP_CTYPE(cell); - switch (type) { - case 'c': return ctype == KLISP_TYPE_CONS; - case 'n': return ctype == KLISP_TYPE_NUM; - case 'p': return (ctype == KLISP_TYPE_PRIM || ctype == KLISP_TYPE_MPRIM); - case 's': return ctype == KLISP_TYPE_SYM; - case 'S': case '$': return ctype == KLISP_TYPE_STR; - case 'u': return ctype == KLISP_TYPE_UDATA; - default: ; - } - - return 0; -} - - -/* check arglist; see KLispCheckCellType() for types; this function supports type sets [...]; - strict!=0: there can't be more args then *types checks %-) - raiseError==0: don't call KLispError - this function assumes valid list or nil in args; -*/ -int KLispCheckArgs (KLISP_POOL_DEF int args, int strict, const char *types, const char *fnname, int raiseError) { - int argno = 1, ok; - int cell; - char buf[64]; - const char *st = types; - - while (*types) { - cell = KLISP_CAR_EX(args); - st = types; - if (*types == '[') { - types++; ok = 0; - while (*types && *types != ']') { - if (KLispCheckCellType(KLISP_POOL_ARG cell, *types++)) { ok = 1; break; } - } - if (!ok) goto error; - while (*types && *types != ']') types++; - if (*types) types++; - } else if (!KLispCheckCellType(KLISP_POOL_ARG cell, *types++)) goto error; - args = KLISP_CDR_EX(args); - argno++; - } - if (strict && args) { - if (raiseError) KLispError(KLISP_POOL_ARG "%s: too many argumens", fnname); - return 0; - } - return 1; -error: - types--; - if (*types == '[') { - ok = 0; - while (ok < 60 && *types && *types != ']') buf[ok++] = *types++; - if (*types && *types != ']') { - buf[ok++] = '.'; - buf[ok++] = '.'; - buf[ok++] = '.'; - } - buf[ok] = '\0'; - } else { buf[0] = *types; buf[1] = '\0'; } - if (raiseError) KLispError(KLISP_POOL_ARG "%s: invalid argument #%i (%s!=%s)", fnname, argno, KLispTypeName(KLISP_POOL_ARG cell), buf); - return 0; -} - - -/***************************************************************** - evaluators - *****************************************************************/ -static int KLispRPushCall (KLISP_POOL_DEF int fnCell, int args) { - int argAtom; - - if (fnCell < 0 || args < 0) return 0; - argAtom = (KLISP_CTYPE(args) != KLISP_TYPE_CONS); - if (args && !KLispIsList(KLISP_POOL_ARG args)) { KLispError(KLISP_POOL_ARG "invalid call arglist"); return 0; } - - /* push eval-fn-symbol */ - KLISP_GC_FREEZE; - if (!KLispRPush(KLISP_POOL_ARG args)) goto error; /* args */ - if (!KLispRPush(KLISP_POOL_ARG KLISP_POOL->specs[KLISP_SPEC_FN_EVAL])) goto error; - if (!KLispRPush(KLISP_POOL_ARG fnCell)) goto error; - KLISP_GC_UNFREEZE; - - return 1; -error: - KLISP_GC_UNFREEZE; - return 0; -} - - -void KLispEvalCleanupForced (KLISP_POOL_DEF0) { - int cur; - - while (KLISP_POOL->stack) { - if ((cur = KLISP_RPOP) < 0) break; - if (KLISP_CTYPE(cur) != KLISP_TYPE_SPEC) continue; - switch (KLISP_CAR(cur)) { - case KLISP_SPEC_STOP_EVAL: break; - case KLISP_SPEC_SCOPE: - assert(KLISP_POOL->frames); - KLispPopFrame(KLISP_POOL_ARG0); - break; - default: ; - } - } -} - - -void KLispEvalCleanup (KLISP_POOL_DEF0) { - if (KLISP_POOL->error) KLispEvalCleanupForced(KLISP_POOL_ARG0); -} - - -/* return -1 for error or maxStep expiration; DOESN'T cleanup on error! - check for KLISP_POOL->error to see if there was error */ -int KLispEvalRun (KLISP_POOL_DEF int *maxSteps, TKLispEvalChecker checker) { - int cur, sym, t, item; - - while (!KLISP_POOL->error) { - if (maxSteps) { - if (*maxSteps <= 0) return -1; /* done */ - (*maxSteps)--; - } - if (checker && !checker(KLISP_POOL_ARG0)) return -1; /* checker */ - KLISP_DEBUG_PRSTACK("eval stack: "); - cur = KLISP_RPEEK(0); - assert(cur >= 0); - switch (KLISP_CTYPE(cur)) { - case KLISP_TYPE_SPEC: /* special command */ - KLISP_DEBUG_PRINTSTR("eval: special\n"); - switch (KLISP_CAR(cur)) { - case KLISP_SPEC_STOP_EVAL: /* done */ - KLISP_DEBUG_PRINTSTR(" special: STOP\n"); - KLISP_RDROP(1); - if ((cur = KLISP_RPOP) < 0) { - KLispError(KLISP_POOL_ARG "internal bug (stopeval)"); goto error; - } - return cur; - case KLISP_SPEC_ARG_EVAL: - KLISP_DEBUG_PRINTSTR(" special: ARG_EVAL\n"); - /* stack: resargs, fn, resargs-last, args-left, value, KLISP_SPEC_ARG_EVAL */ - cur = KLISP_RPEEK(1); /* value */ - assert(cur >= 0); - item = KLISP_RPEEK(3); /* resargs-last */ - assert(item >= 0); - if ((t = KLispNewCons(KLISP_POOL_ARG cur, 0)) < 0) goto error; - if (item) KLISP_CDR(item) = t; else KLISP_RSET(5, t); - item = t; - KLISP_RSET(3, item); - t = KLISP_RPEEK(2); - if (!t) { - /* all args evaluated; transform to call: evaledargs, fn, KLISP_SPEC_CALL */ - KLISP_RDROP(3); - KLISP_RSET(0, KLISP_POOL->specs[KLISP_SPEC_CALL]); - } else { - /* eval next arg */ - assert(!KLISP_CTYPE(t)); /* must be cons! */ - KLISP_RSET(2, KLISP_CDR(t)); /* update args-left */ - KLISP_RSET(1, KLISP_CAR(t)); /* set value to eval */ - KLISP_RSWAP(0, 1); /* swap command and value */ - } - break; - case KLISP_SPEC_FN_EVAL: /* function symbol evaluated */ - KLISP_DEBUG_PRINTSTR(" special: FN_EVAL\n"); - /* stack: args, fn, KLISP_SPEC_FN_EVAL */ - item = KLISP_RPEEK(1); /* function */ - t = KLISP_RPEEK(2); /* args */ - cur = t?KLISP_CTYPE(item):KLISP_TYPE_MPRIM; - switch (cur) { - case KLISP_TYPE_MPRIM: case KLISP_TYPE_IMPRIM: - /* macro or noargs, just call it */ - KLISP_RSET(0, KLISP_POOL->specs[KLISP_SPEC_CALL]); - break; - case KLISP_TYPE_UDATA: - /* userdata; transform list to (invoke udata args) and eval */ - /*if (!t || KLISP_CTYPE(t)) { KLispError(KLISP_POOL_ARG "invalid userdata call"); goto error; }*/ - if (t) { - /* quote first args item */ - cur = KLispNewCons(KLISP_POOL_ARG KLISP_CAR(t), 0); - if (cur < 0) goto error; - KLISP_GC_FREEZE; - cur = KLispNewCons(KLISP_POOL_ARG KLispNewSym(KLISP_POOL_ARG "quote"), cur); - KLISP_GC_UNFREEZE; - if (cur < 0) goto error; - t = KLispNewCons(KLISP_POOL_ARG cur, KLISP_CDR(t)); - if (t < 0) goto error; - } - t = KLispNewCons(KLISP_POOL_ARG item, t); /* append udata to args */ - if (t < 0) goto error; - KLISP_RSET(2, t); /* set new args */ - t = KLispNewSym(KLISP_POOL_ARG "invoke"); - if (t < 0) goto error; - KLISP_RSET(1, t); /* set method */ - KLISP_RSWAP(0, 1); /* swap command and value; so method will be evaluated */ - break; - case KLISP_TYPE_CONS: /* ((...) ...) */ - /* check if car.car is symbol, do something */ - sym = KLISP_CAR(item); /* (...) */ - if (sym) sym = KLISP_CAR(item); - if (sym) { - cur = KLISP_CTYPE(sym); - if (cur == KLISP_TYPE_SYM) { - /*KLispPrintF("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n");*/ - if (!strcmp(KLISP_CELL(sym).str, "mlambda")) cur = KLISP_TYPE_IMPRIM; - } - if (cur == KLISP_TYPE_MPRIM || cur == KLISP_TYPE_IMPRIM) { - KLISP_RSET(0, KLISP_POOL->specs[KLISP_SPEC_CALL]); - break; - } - } - /* fallthru */ - case KLISP_TYPE_PRIM: - /* normal function, start args evaluating */ - /* transform stack to: resargs, fn, resargs-last, args-left, KLISP_SPEC_ARG_EVAL, value */ - KLISP_RSET(0, 0); /* resargs-last */ - if (!KLispRPush(KLISP_POOL_ARG 0)) goto error; /* args-left */ - if (!KLispRPush(KLISP_POOL_ARG KLISP_POOL->specs[KLISP_SPEC_ARG_EVAL])) goto error; - if (!KLispRPush(KLISP_POOL_ARG 0)) goto error; /* value */ - KLISP_RSET(0, KLISP_CAR(t)); /* set value */ - KLISP_RSET(2, KLISP_CDR(t)); /* set args-left */ - KLISP_RSET(5, 0); /* nullify resargs */ - break; - default: - KLispError(KLISP_POOL_ARG "internal bug <%i> (die, die!)", cur); - KLispPrintF("DIE: item="); PrintCell(KLISP_POOL_ARG item, 1); KLispPrintF("\n"); - KLispPrintF("DIE: t="); PrintCell(KLISP_POOL_ARG t, 1); KLispPrintF("\n"); - KLispPrintF("DIE: stack="); PrintCell(KLISP_POOL_ARG t, KLISP_POOL->stack); KLispPrintF("\n"); - goto error; - } - break; - case KLISP_SPEC_CALL: /* call primitive */ - KLISP_DEBUG_PRINTSTR(" special: CALL\n"); - /* stack: evaledargs, fn, KLISP_SPEC_CALL */ - item = KLISP_RPEEK(1); /* fn */ - switch (KLISP_CTYPE(item)) { - case KLISP_TYPE_CONS: - KLISP_DEBUG_PRCELL(" xfn: ", item); - /* lambda or so; result of ((iprim ...) args) */ - /* build something like: args iprim ... KLISP_SPEC_ICALL */ - t = KLISP_CAR(item); /* (iprim ...) */ - assert(t); - switch (KLISP_CTYPE(t)) { - case KLISP_TYPE_SYM: - KLISP_DEBUG_PRSTACK(" prep0: "); - KLISP_RSWAP(0, 1); /* swap command and value */ - KLISP_RDROP(1); /* drop list */ - if (!KLispRPushCall(KLISP_POOL_ARG t, KLISP_CDR(item))) goto error; - KLISP_DEBUG_PRSTACK(" prep: "); - break; - /*case KLISP_TYPE_MPRIM: - break; - case KLISP_TYPE_PRIM: - break;*/ - case KLISP_TYPE_IPRIM: case KLISP_TYPE_IMPRIM: - /* set ... */ - KLISP_RSET(0, KLISP_CDR(item)); - /* set iprim */ - KLISP_RSET(1, t); /* args fn-iprim */ - /* push special */ - if (!KLispRPush(KLISP_POOL_ARG KLISP_POOL->specs[KLISP_SPEC_ICALL])) goto error; - KLISP_DEBUG_PRSTACK(" LMB CALL: "); - break; - default: KLispError(KLISP_POOL_ARG "internal bug (CALL with CONS)"); goto error; - } - /*assert(t && KLISP_CTYPE(t) == KLISP_TYPE_IPRIM);*/ - /*exit(0);*/ - break; - case KLISP_TYPE_MPRIM: case KLISP_TYPE_PRIM: - assert(KLISP_CELL(item).fn); - KLISP_RDROP(1); /* special */ - /*KLispPrintF(" prim call: "); KLispPrintCell(KLISP_POOL_ARG item); KLispPrintF("\n");*/ - t = KLISP_CELL(item).fn(KLISP_POOL_ARG KLISP_RPEEK(1)); - if (KLISP_POOL->error) goto error; -#ifdef KLISP_DEBUG_EVAL -if (klispOptPrintStack) { - if (t == KLISP_DONT_TOUCH_STACK) { - KLispPrintF(" don't touch res: "); - KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->stack); - KLispPrintF("\n"); - } -} -#endif - /*KLispPrintF(" prim call res: %i\n", t);*/ - if (t == KLISP_DONT_TOUCH_STACK) break; - /*assert(t>=0);*/ - if (t < 0) goto error; - KLISP_RDROP(1); /* fn */ - KLISP_RSET(0, t); - assert(KLISP_CTYPE(KLISP_RPEEK(1)) == KLISP_TYPE_SPEC); - KLISP_RSWAP(0, 1); /* result already evaluated */ - break; - default: KLispError(KLISP_POOL_ARG "KLISP_SPEC_CALL: not a primitive"); goto error; - } - break; - case KLISP_SPEC_ICALL: - KLISP_DEBUG_PRINTSTR(" special: ICALL\n"); - /* stack: args (unevaled), fn, tmp, KLISP_SPEC_ICALL */ - item = KLISP_RPEEK(2); /* fn */ - switch (KLISP_CTYPE(item)) { - case KLISP_TYPE_IPRIM: case KLISP_TYPE_IMPRIM: - assert(KLISP_CELL(item).fn); - KLISP_CELL(item).fn(KLISP_POOL_ARG KLISP_RPEEK(3)); - if (KLISP_POOL->error) goto error; - break; - default: KLispError(KLISP_POOL_ARG "KLISP_SPEC_ICALL: not a primitive"); goto error; - } - break; - case KLISP_SPEC_SCOPE: - KLISP_DEBUG_PRINTSTR(" special: SCOPE\n"); - /* end of function, drop out the scope, swap and continue */ - KLispPopFrame(KLISP_POOL_ARG0); - KLISP_RDROP(1); /* special */ - KLISP_RSWAP(0, 1); /* swap command and value, 'cause value already evaluated */ - break; - case KLISP_SPEC_LMD_CALL: - KLISP_RDROP(1); /* drop it, it's noop */ - break; - default: KLispError(KLISP_POOL_ARG "internal bug (spectype)"); goto error; - } /* KLISP_CAR(cur) */ - break; - /* non-specials */ - case KLISP_TYPE_SYM: /* symbol */ - KLISP_DEBUG_PRINTSTR(" SYMBOL: '"); KLISP_DEBUG_PRINTSTR(KLISP_CELL(cur).str); KLISP_DEBUG_PRINTSTR("'\n"); - sym = KLispGetSymbol(KLISP_POOL_ARG KLISP_CELL(cur).str); - if (sym < 0) { - KLispError(KLISP_POOL_ARG "undefined symbol: '%s'", KLISP_CELL(cur).str); - KLISP_DEBUG_PRFRAMES(" frames: "); - goto error; - } - KLISP_DEBUG_PRCELL(" value: ", KLISP_CDR(sym)); - KLISP_RSET(0, KLISP_CDR(sym)); /* set value */ - KLISP_RSWAP(0, 1); /* swap value and command */ - break; - case KLISP_TYPE_CONS: /* list */ - KLISP_DEBUG_PRCELL(" CONS: ", cur); - if (!KLispIsList(KLISP_POOL_ARG cur)) { KLispError(KLISP_POOL_ARG "non-list call"); goto error; } - /* call */ - t = KLISP_CAR(cur); - switch (KLISP_CTYPE(t)) { - case KLISP_TYPE_CONS: /* ((...) ...) */ - if (!KLispIsList(KLISP_POOL_ARG t)) { - KLispPrintF("**INVALID CALL: "); KLispPrintCell(KLISP_POOL_ARG cur); KLispPrintF("\n"); - KLispPrintF("++INVALID CALL: "); KLispPrintCell(KLISP_POOL_ARG t); KLispPrintF("\n"); - KLispError(KLISP_POOL_ARG "invalid call"); - goto error; - } - break; - case KLISP_TYPE_SYM: case KLISP_TYPE_UDATA: case KLISP_TYPE_PRIM: case KLISP_TYPE_MPRIM: /* sym/primitive are ok */ - break; - default: KLispError(KLISP_POOL_ARG "invalid function type"); goto error; - } /* KLISP_CTYPE(t) */ - KLISP_DEBUG_PRINTSTR(" call ok\n"); - cur = KLISP_RPOP; - if (!KLispRPushCall(KLISP_POOL_ARG KLISP_CAR(cur), KLISP_CDR(cur))) goto error; - break; - /* atoms are ok */ - case KLISP_TYPE_NUM: case KLISP_TYPE_STR: - case KLISP_TYPE_PRIM: case KLISP_TYPE_MPRIM: - case KLISP_TYPE_IPRIM: case KLISP_TYPE_IMPRIM: - case KLISP_TYPE_UDATA: - KLISP_DEBUG_PRCELL(" ATOM: ", cur); - KLISP_RSWAP(0, 1); /* swap value and command */ - break; - default: - KLISP_DEBUG_PRCELL("BAD ATOM: ", cur); - KLispError(KLISP_POOL_ARG "invalid atom type"); goto error; - } /* KLISP_CTYPE(cur) */ - } /* while */ -error: -#ifdef KLISP_DEBUG_EVAL -if (klispOptPrintStack) { KLispPrintF(" **ERROR: %s\n", KLISP_POOL->error); } -#endif - - return -1; -} - - -/* resilt!=0 on success; check KLISP_POOL->error on error */ -int KLispEvalPepapare (KLISP_POOL_DEF int cell) { - assert(KLISP_POOL); - KLispFreeError(KLISP_POOL_ARG0); - if (cell < 0 && !KLISP_POOL->error) KLispError(KLISP_POOL_ARG "invalid eval() cell"); - if (KLISP_POOL->error) return 0; - /* push eval list; must be the 1st or we can loose it in GC */ - if (!KLispRPush(KLISP_POOL_ARG cell)) return 0; - /* push end marker */ - if (!KLispRPush(KLISP_POOL_ARG KLISP_POOL->specs[KLISP_SPEC_STOP_EVAL])) { - KLISP_RDROP(1); - return 0; - } - /* swap 'em */ - KLISP_RSWAP(0, 1); - - return 1; -} - - -int KLispEval (KLISP_POOL_DEF int cell, int *maxSteps, TKLispEvalChecker checker) { - int res; - - if (!KLispEvalPepapare(KLISP_POOL_ARG cell)) return -1; - res = KLispEvalRun(KLISP_POOL_ARG maxSteps, checker); - if (res < 0) { - if (!KLISP_POOL->error) KLispError(KLISP_POOL_ARG "evaluation terminated"); - } - KLispEvalCleanup(KLISP_POOL_ARG0); - - return res; -} - - -int KLispEvalStringEx (KLISP_POOL_DEF const char *str, int *printParsed, int *printResult, int *printError) { - int res = 0, code; - - KLispFreeError(KLISP_POOL_ARG0); - if (!str) return 0; - - while (KLispSkipSpaces(&str)) { - KLispFreeError(KLISP_POOL_ARG0); -#ifdef KLISP_DEBUG_AGRESSIVE_GC - KLispGC(KLISP_POOL_ARG0); -#endif - /*KLispPrintF("input: %s|\n", str);*/ - code = KLispParseSExpr(KLISP_POOL_ARG &str); - /*KLispPrintF("output: %s|\n", str);*/ - if (KLISP_POOL->error) { - if (printError && *printError) KLispPrintF("PARSE ERROR: %s\n", KLISP_POOL->error); - return 0; - } - if (printParsed && *printParsed) { KLispPrintF("parsed: "); KLispPrintCell(KLISP_POOL_ARG code); KLispPrintF("\n"); } - res = KLispEval(KLISP_POOL_ARG code, NULL, NULL); - if (KLISP_POOL->error) { - if (printError && *printError) KLispPrintF("ERROR: %s\n", KLISP_POOL->error); - return 0; - } - if (printResult && *printResult) { KLispPrintCell(KLISP_POOL_ARG res); KLispPrintF("\n"); } - } - - return res; -} - -#endif /* _KLISP_CORE_MODULE_BODY_ */ +#ifndef _KLISP_CORE_MODULE_BODY_ +#define _KLISP_CORE_MODULE_BODY_ + +#include "klisp.h" + + +#ifdef KLISP_DEBUG_EVAL +int klispOptPrintStack = 1; +#endif + + +/***************************************************************** + error messages + *****************************************************************/ +void KLispFreeError (KLISP_POOL_DEF0) { + if (!KLISP_POOL || KLISP_POOL->errorStatic || !KLISP_POOL->error) return; + KLISP_MEMFREE(KLISP_POOL->error); + KLISP_POOL->error = NULL; +} + + +int KLispError (KLISP_POOL_DEF const char *fmt, ...) { + static char *sErrorMem = "fatal out of memory!"; + int n, size = 256; + va_list ap; + char *p, *np; + + if (!KLISP_POOL) return -1; + KLispFreeError(KLISP_POOL_ARG0); + if (!fmt || !*fmt) return -1; + + KLISP_POOL->errorStatic = 1; KLISP_POOL->error = sErrorMem; + if ((p = KLISP_MEMALLOC(size*sizeof(char))) == NULL) return -1; + while (1) { + memset(p, 0, size); + va_start(ap, fmt); + n = vsnprintf(p, size, fmt?fmt:"", ap); + va_end(ap); + if (n > -1 && n < size) break; + if (n > -1) size = n+1; else size *= 2; + if ((np = KLISP_MEMREALLOC(p, size*sizeof(char))) == NULL) { KLISP_MEMFREE(p); return -1; } + p = np; + } + KLISP_POOL->errorStatic = 0; KLISP_POOL->error = p; + + return -1; +} + + +int KLispErrorMem (KLISP_POOL_DEF0) { + return KLispError(KLISP_POOL_ARG "out of memory"); +} + + +/***************************************************************** + initializers/allocators + *****************************************************************/ +void KLispFreePool (KLISP_POOL_DEF0) { + TKLispCell *cell; + int f; + + if (!KLISP_POOL) return; + KLISP_POOL->gcPhase++; + for (f = 0; f < KLISP_POOL->cellCount; f++) { + cell = &(KLISP_POOL->cells[f]); + if (cell->ctype & KLISP_FFLAG) continue; + if (cell->ctype == KLISP_TYPE_UDATA && cell->finalizer) KLispInvokeFinalizer(KLISP_POOL_ARG f); + } + KLISP_POOL->gcPhase--; + KLispDeinitStack(&KLISP_POOL->roots); + KLispDeinitStack(&KLISP_POOL->stack); + KLispDeinitStack(&KLISP_POOL->frames); + KLispRBTFreeTree(KLISP_POOL->primitives); + KLispRBTFreeTree(KLISP_POOL->globals); + KLispRBTFreeTree(KLISP_POOL->strpool); + KLISP_MEMFREE(KLISP_POOL->cells); + KLispFreeError(KLISP_POOL_ARG0); + KLISP_MEMFREE(KLISP_POOL); +} + + +static void InitPool (KLISP_POOL_DEF int from) { + TKLispCell *cell; + int f; + + if (KLISP_POOL->free) KLISP_CELL(KLISP_POOL->free).cdr = from; + KLISP_POOL->free = from; + cell = &(KLISP_CELL(from)); + for (f = from; f < KLISP_POOL->cellCount; f++, cell++) { + cell->ctype = KLISP_TYPE_NUM | KLISP_FFLAG; + cell->num = 0; + cell->str = NULL; + cell->car = 0; + cell->cdr = f+1; + } + KLISP_CELL(KLISP_POOL->cellCount-1).cdr = 0; /* end of free list */ +} + + +TKLispPool *KLispNewPool (void) { + TKLispRBTNode *ci; + TKLispPool *pool; + TKLispCell *cell; + int f, initPS; + char buf[4]; + + /* alloc pool */ + KLISP_POOL = KLISP_MEMALLOC(sizeof(TKLispPool)); + if (!KLISP_POOL) goto errexit; + memset(KLISP_POOL, 0, sizeof(TKLispPool)); + /* alloc cells */ + initPS = KLISP_INIT_POOL_SIZE; + if (initPS < KLISP_SPEC_MAX+16) initPS = KLISP_INIT_POOL_SIZE+16; + KLISP_POOL->cellCount = initPS; + KLISP_POOL->cells = KLISP_MEMALLOC(KLISP_POOL->cellCount*sizeof(TKLispCell)); + if (!KLISP_POOL->cells) goto errexit; + memset(KLISP_POOL->cells, 0, KLISP_POOL->cellCount*sizeof(TKLispCell)); + /* alloc primlist */ + KLISP_POOL->primitives = KLispRBTNewTree(); + if (!KLISP_POOL->primitives) goto errexit; + /* alloc globals */ + KLISP_POOL->globals = KLispRBTNewTree(); + if (!KLISP_POOL->globals) goto errexit; + /* alloc stringling */ + KLISP_POOL->strpool = KLispRBTNewTree(); + if (!KLISP_POOL->strpool) goto errexit; + /* stacks */ + if (!KLispInitStack(&KLISP_POOL->frames, 128, 64, 4096) || + !KLispInitStack(&KLISP_POOL->stack, 128, 64, 4096) || + !KLispInitStack(&KLISP_POOL->roots, 16, 8, 4096)) goto errexit; + + buf[0] = buf[1] = buf[2] = '.'; buf[3] = '\0'; + if (!KLispRBTInsert(KLISP_POOL->strpool, buf, 0, 1, NULL)) goto errexit; + buf[1] = '\0'; + /* fill strpool with chars */ + for (f = 1; f < 256; f++) { + buf[0] = f; + if (!KLispRBTInsert(KLISP_POOL->strpool, buf, 0, 1, NULL)) goto errexit; + } + + KLISP_POOL->usedCount = 0; + /* init nil and t */ + cell = KLISP_POOL->cells; + for (f = 0; f < 2; f++, cell++) { + KLISP_POOL->usedCount++; + cell->num = f; + cell->ctype = KLISP_TYPE_NUM; + cell->car = 0; + cell->str = NULL; + cell->cdr = 0; + } + /* 1-char symbols */ + for (f = 0; f < 256; f++, cell++) { + if (f) { buf[0] = f; buf[1] = '\0'; } else { buf[0] = buf[1] = buf[2] = '.'; buf[3] = '\0'; } + KLISP_POOL->syms[f] = KLISP_POOL->usedCount; + KLISP_POOL->usedCount++; + cell->num = 0; + cell->ctype = KLISP_TYPE_SYM; + cell->car = 0; + ci = KLispRBTFind(KLISP_POOL->strpool, buf); + assert(ci); + ci->value0 = KLISP_POOL->syms[f]; + cell->str = ci->str; + cell->cdr = 0; + } + + InitPool(KLISP_POOL_ARG KLISP_POOL->usedCount); + + KLISP_POOL->prog = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "prog"); + KLISP_POOL->cond = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "cond"); + KLISP_POOL->lambda = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "lambda"); + KLISP_POOL->mlambda = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "mlambda"); + KLISP_POOL->quote = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "quote"); + KLISP_POOL->defun = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "defun"); + KLISP_POOL->defmac = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "defmac"); + KLISP_POOL->invoke = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_PRIM, NULL, "invoke"); + + KLispSetGlobal(KLISP_POOL_ARG "prog", KLISP_POOL->prog); + KLispSetGlobal(KLISP_POOL_ARG "cond", KLISP_POOL->cond); + KLispSetGlobal(KLISP_POOL_ARG "lambda", KLISP_POOL->lambda); + KLispSetGlobal(KLISP_POOL_ARG "mlambda", KLISP_POOL->mlambda); + KLispSetGlobal(KLISP_POOL_ARG "quote", KLISP_POOL->quote); + KLispSetGlobal(KLISP_POOL_ARG "defun", KLISP_POOL->defun); + KLispSetGlobal(KLISP_POOL_ARG "defmac", KLISP_POOL->defmac); + KLispSetGlobal(KLISP_POOL_ARG "invoke", KLISP_POOL->invoke); + + return pool; + +errexit: + if (KLISP_POOL->cells) KLISP_MEMFREE(KLISP_POOL->cells); + KLispDeinitStack(&KLISP_POOL->roots); + KLispDeinitStack(&KLISP_POOL->stack); + KLispDeinitStack(&KLISP_POOL->frames); + KLispRBTFreeTree(KLISP_POOL->primitives); + KLispRBTFreeTree(KLISP_POOL->globals); + KLispRBTFreeTree(KLISP_POOL->strpool); + KLISP_MEMFREE(KLISP_POOL); + return NULL; +} + + +static int AllocCell (KLISP_POOL_DEF0) { + TKLispCell *newcp; + int f, newSz; + +#ifdef KLISP_DEBUG_VERY_AGRESSIVE_GC + KLispGC(KLISP_POOL_ARG0); +#endif + if (!KLISP_POOL->free || KLISP_POOL->cellCount-KLISP_POOL->usedCount < KLISP_GROW_POOL_SIZE/4) { + /* gc */ + KLispGC(KLISP_POOL_ARG0); + if (!KLISP_POOL->free) { + /* grow */ + newSz = KLISP_POOL->cellCount+KLISP_GROW_POOL_SIZE; + newcp = KLISP_MEMREALLOC(KLISP_POOL->cells, sizeof(TKLispCell)*newSz); + if (!newcp) return KLispErrorMem(KLISP_POOL_ARG0); + KLISP_POOL->cells = newcp; + f = KLISP_POOL->cellCount; + KLISP_POOL->cellCount = newSz; + InitPool(KLISP_POOL_ARG f); + } + } + + if (!KLISP_POOL->free) return KLispErrorMem(KLISP_POOL_ARG0); + f = KLISP_POOL->free; + newcp = &(KLISP_POOL->cells[f]); + KLISP_POOL->free = newcp->cdr; + newcp->ctype = KLISP_TYPE_NUM; + newcp->car = newcp->cdr = 0; + KLISP_POOL->usedCount++; + + return f; +} + + +int KLispNewCons (KLISP_POOL_DEF int car, int cdr) { + int cell; + + if (car < 0 || cdr < 0) return -1; + assert(!KLISP_POOL->tempRootGC0 && !KLISP_POOL->tempRootGC1); + KLISP_POOL->tempRootGC0 = car; + KLISP_POOL->tempRootGC1 = cdr; + cell = AllocCell(KLISP_POOL_ARG0); + KLISP_POOL->tempRootGC0 = KLISP_POOL->tempRootGC1 = 0; + if (cell >= 0) { + KLISP_CTYPE(cell) = KLISP_TYPE_CONS; + KLISP_CAR(cell) = car; + KLISP_CDR(cell) = cdr; + } + + return cell; +} + + +int KLispNewNum (KLISP_POOL_DEF TKLispNumber value) { + int cell; + + if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1; + KLISP_CTYPE(cell) = KLISP_TYPE_NUM; + KLISP_CELL(cell).num = value; + + return cell; +} + + +int KLispNewSym (KLISP_POOL_DEF const char *value) { + int cell; + TKLispRBTNode *sp; + + assert(value); + + if (*value && !value[1]) return KLISP_POOL->syms[*((unsigned char *)value)]; + + sp = KLispRBTFind(KLISP_POOL->strpool, value); + if (sp && sp->value0) return sp->value0; + + if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1; + if (!sp) { + if (!(sp = KLispRBTInsert(KLISP_POOL->strpool, value, cell, 1, NULL))) return -1; + } else sp->value0 = cell; + + KLISP_CTYPE(cell) = KLISP_TYPE_SYM; + KLISP_CELL(cell).str = sp->str; + + return cell; +} + + +int KLispNewXPrim (KLISP_POOL_DEF int prtype, TKLispPrimFn fn, const char *name) { + TKLispRBTNode *sp; + int cell; + + assert(name && *name); + switch (prtype) { + case KLISP_TYPE_PRIM: case KLISP_TYPE_MPRIM: + case KLISP_TYPE_IPRIM: case KLISP_TYPE_IMPRIM: + break; + default: return KLispError(KLISP_POOL_ARG "KLispNewXPrim: invalid prim type"); + } + + sp = KLispRBTFind(KLISP_POOL->primitives, name); + if (!sp) { + if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1; + if (!(sp = KLispRBTInsert(KLISP_POOL->primitives, name, cell, 1, NULL))) return -1; + KLISP_CELL(cell).str = sp->str; + } else cell = sp->value0; + + KLISP_CTYPE(cell) = prtype; + KLISP_CELL(cell).fn = fn; + + return cell; +} + + +int KLispNewSymbolPair (KLISP_POOL_DEF const char *name, int valueCell) { + int sym; + + KLISP_GC_FREEZE; + sym = KLispNewSym(KLISP_POOL_ARG name); + if (sym > 0) sym = KLispNewCons(KLISP_POOL_ARG sym, valueCell); + KLISP_GC_UNFREEZE; + + return sym; +} + + +/* UDATA: + car: ptr to cell with some data or nil; cdr: list of methods; + list of methods: car: symbol (name . xPRIM); cdr: next + method args: (udata_obj ...) + call: (udata method ...) +*/ +int KLispNewUData (KLISP_POOL_DEF void *ptr, TKLispFinalizeFn finalizer) { + int cell; + + if ((cell = KLispNewCons(KLISP_POOL_ARG 0, 0)) < 0) return -1; + KLISP_CTYPE(cell) = KLISP_TYPE_UDATA; + KLISP_CELL(cell).finalizer = finalizer; + KLISP_CELL(cell).udata = ptr; + + return cell; +} + + +/* return 0 or method cell */ +static int KLispUDataFindMethod (KLISP_POOL_DEF int udata, const char *name) { + int mcell; + + if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return -1; + mcell = KLispFindSymbol(KLISP_POOL_ARG KLISP_CDR(udata), name); + + return mcell<=0?0:mcell; +} + + +int KLispUDataGetMethod (KLISP_POOL_DEF int udata, const char *name) { + int sym; + + if ((sym = KLispUDataFindMethod(KLISP_POOL_ARG udata, name)) <= 0) return -1; + + return KLISP_CDR(sym); +} + + +int KLispUDataSetMethod (KLISP_POOL_DEF int udata, int methodcell, const char *name) { + int sym, t; + + if (methodcell < 0) return -1; + sym = KLispUDataFindMethod(KLISP_POOL_ARG udata, name); + if (sym < 0) return -1; + if (!sym) { + /* create new symbol */ + if ((sym = KLispNewSymbolPair(KLISP_POOL_ARG name, methodcell)) < 0) return -1; + /* add it to method list */ + KLISP_GC_FREEZE; + t = KLispNewCons(KLISP_POOL_ARG sym, KLISP_CDR(udata)); + KLISP_GC_UNFREEZE; + if (t < 0) return -1; + KLISP_CDR(udata) = t; + } else KLISP_CDR(sym) = methodcell; + + return sym; +} + + +void *KLispUDataGetPtr (KLISP_POOL_DEF int udata) { + if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return NULL; + + return KLISP_CELL(udata).udata; +} + + +int KLispUDataSetPtr (KLISP_POOL_DEF int udata, void *ptr) { + if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return 0; + + KLISP_CELL(udata).udata = ptr; + + return 1; +} + + +int KLispRegisterMethods (KLISP_POOL_DEF int udatacell, struct _TKLispPrimItem *list) { + int methodcell, res = 0; + + KLISP_GC_FREEZE; + /*if (!KLispPushRoot(KLISP_POOL_ARG udatacell)) return -1;*/ + while (list && list->name) { + methodcell = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, list->fn, list->name); + if (methodcell < 0) goto done; + if (KLispUDataSetMethod(KLISP_POOL_ARG udatacell, methodcell, list->name) < 0) goto done; + list++; + } + res = 1; +done: + KLISP_GC_UNFREEZE; + /*KLispPopRoots(KLISP_POOL_ARG 1);*/ + + return res; +} + + +#endif /* _KLISP_CORE_MODULE_BODY_ */ diff --git a/src/klisp/klisp_prim.c b/src/klisp/klisp_prim.c index e4ee960..cbc493e 100644 --- a/src/klisp/klisp_prim.c +++ b/src/klisp/klisp_prim.c @@ -7,20 +7,6 @@ /***************************************************************** primitives *****************************************************************/ -/* (noop [...]) */ -int KLPrim_Noop (KLISP_POOL_DEF int args) { - return KLispNewCons(KLISP_POOL_ARG KLispNewSym(KLISP_POOL_ARG "noop"), args); -} - - -/* (quote ) */ -int KLPrim_Quote (KLISP_POOL_DEF int args) { - if (!KLispCheckArgs(KLISP_POOL_ARG args, 1, "a", "quote", 1)) return 0; - - return KLISP_CAR(args); -} - - /* (cons ) */ int KLPrim_Cons (KLISP_POOL_DEF int args) { if (!KLispCheckArgs(KLISP_POOL_ARG args, 1, "aa", "cons", 1)) return 0; @@ -69,22 +55,6 @@ int KLPrim_Bool (KLISP_POOL_DEF int args) { } -/* ($->sym str) */ -int KLPrim_StrToSym (KLISP_POOL_DEF int args) { - if (!KLispCheckArgs(KLISP_POOL_ARG args, 1, "$", "$->sym", 1)) return 0; - - return KLispNewSym(KLISP_POOL_ARG KLISP_CELL(KLISP_CAR(args)).str); -} - - -/* (sym->$ str) */ -int KLPrim_SymToStr (KLISP_POOL_DEF int args) { - if (!KLispCheckArgs(KLISP_POOL_ARG args, 1, "s", "sym->$", 1)) return 0; - - return KLispNewStr(KLISP_POOL_ARG KLISP_CELL(KLISP_CAR(args)).str); -} - - /* (type$ ) */ int KLPrim_Type (KLISP_POOL_DEF int args) { const char *s; @@ -92,7 +62,7 @@ int KLPrim_Type (KLISP_POOL_DEF int args) { if (!KLispCheckArgs(KLISP_POOL_ARG args, 1, "a", "type", 1)) return 0; s = KLispTypeName(KLISP_POOL_ARG KLISP_CAR(args)); - return KLispNewStr(KLISP_POOL_ARG s); + return KLispNewSym(KLISP_POOL_ARG s); } @@ -107,7 +77,7 @@ int KLPrim_Print (KLISP_POOL_DEF int args) { break; } else { res = KLISP_CAR(args); - if (res && KLISP_CTYPE(res) == KLISP_TYPE_STR) KLispPrintF("%s", KLISP_CELL(res).str); + if (res && KLISP_CTYPE(res) == KLISP_TYPE_SYM) KLispPrintF("%s", KLISP_CELL(res).str); else KLispPrintCell(KLISP_POOL_ARG res); } args = KLISP_CDR(args); @@ -142,6 +112,7 @@ int KLPrim_Set (KLISP_POOL_DEF int args) { int cnt; int name, value = 0, sym; + /*KLISP_DEBUG_PRCELL(" set: ", args);*/ cnt = KLispIsList(KLISP_POOL_ARG args); if (cnt < 2 || cnt%2 != 0) return KLispError(KLISP_POOL_ARG "set: invalid arglist"); cnt = 0; @@ -149,8 +120,7 @@ int KLPrim_Set (KLISP_POOL_DEF int args) { name = KLISP_CAR(args); args = KLISP_CDR(args); cnt++; - if (!name || KLISP_CTYPE(name) != KLISP_TYPE_SYM) - return KLispError(KLISP_POOL_ARG "set: invalid argument #%i (symbol expected)", cnt); + if (!name || KLISP_CTYPE(name) != KLISP_TYPE_SYM) return KLispError(KLISP_POOL_ARG "set: invalid argument #%i (symbol expected)", cnt); value = KLISP_CAR(args); args = KLISP_CDR(args); cnt++; @@ -172,7 +142,8 @@ int KLPrim_Set (KLISP_POOL_DEF int args) { /* (set-up-n level 'sym value ...) */ int KLPrim_SetUpN (KLISP_POOL_DEF int args) { - int cnt, sym, t, level, frame = 0, fcar; + TKLispStackItem *item = NULL; + int cnt, sym, level, frame = 0; int name, value = 0; if (!KLispCheckArgs(KLISP_POOL_ARG args, 0, "nsa", "set-up-n", 1)) return 0; @@ -180,30 +151,29 @@ int KLPrim_SetUpN (KLISP_POOL_DEF int args) { if (cnt < 2 || cnt%2 != 0) return KLispError(KLISP_POOL_ARG "set-up-n: invalid arglist"); /* go down to the necessary frame; -1: set globals */ level = (int)KLISP_CELL(KLISP_CAR(args)).num; - if (level >= 0) { - frame = KLISP_POOL->frames; - while (frame && level-- >= 0) frame = KLISP_CDR(frame); + if (level >= 0 && level < KLISP_POOL->frames.sp) { + item = KLispPeek(&KLISP_POOL->frames, level); + if (item) frame = item->data; } - fcar = KLISP_CAR_EX(frame); - args = KLISP_CDR(args); + args = KLISP_CDR(args); /* skip level */ cnt = 0; while (args) { name = KLISP_CAR(args); args = KLISP_CDR(args); cnt++; - if (!name || KLISP_CTYPE(name) != KLISP_TYPE_SYM) - return KLispError(KLISP_POOL_ARG "set-up-n: invalid argument #%i (symbol expected)", cnt); + if (!name || KLISP_CTYPE(name) != KLISP_TYPE_SYM) return KLispError(KLISP_POOL_ARG "set-up-n: invalid argument #%i (symbol expected)", cnt); value = KLISP_CAR(args); args = KLISP_CDR(args); cnt++; - if (frame) { - sym = KLispFindSymbolByCell(KLISP_POOL_ARG fcar, name); + sym = KLispFindSymbolByCell(KLISP_POOL_ARG frame, name); if (sym > 0) KLISP_CDR(sym) = value; else { + /* create symbol pair */ if ((sym = KLispNewCons(KLISP_POOL_ARG name, value)) < 0) return -1; - if ((t = KLispNewCons(KLISP_POOL_ARG sym, fcar)) < 0) return -1; - KLISP_CAR(frame) = t; + /* attach symbol to frame */ + if ((frame = KLispNewCons(KLISP_POOL_ARG sym, frame)) < 0) return -1; + item->data = frame; /* update frame */ } } else { sym = KLispSetGlobal(KLISP_POOL_ARG KLISP_CELL(name).str, value); @@ -237,7 +207,9 @@ static int KLDoMath (KLISP_POOL_DEF int args, TKLispMathFn fn, const char *name) f = KLISP_CAR(args); if (KLISP_CTYPE(f) != KLISP_TYPE_NUM) return KLispError(KLISP_POOL_ARG "%s: invalid argument #%i", name, cnt); args = KLISP_CDR(args); + /*printf("\nmath (%s %f %f)=", name, op0, KLISP_CELL(f).num);*/ op0 = fn(KLISP_POOL_ARG op0, KLISP_CELL(f).num); + /*printf("%f\n", op0);*/ if (KLISP_POOL->error) return 0; } @@ -315,7 +287,7 @@ static int KLDoComp (KLISP_POOL_DEF int args, TKLispCompFn fn, TKLispCompSFn sfn f = KLISP_CAR(args); args = KLISP_CDR(args); if (sfn) { - if (KLISP_CTYPE(f) != KLISP_TYPE_STR) return KLispError(KLISP_POOL_ARG "%s: invalid argument #%i", name, cnt); + if (KLISP_CTYPE(f) != KLISP_TYPE_SYM) return KLispError(KLISP_POOL_ARG "%s: invalid argument #%i", name, cnt); res = sfn(KLISP_POOL_ARG sop0, KLISP_CELL(f).str); sop0 = KLISP_CELL(f).str; } else { @@ -384,7 +356,7 @@ static int KLDoStrComp (KLISP_POOL_DEF int args, int doEq, const char *name) { cnt++; f = KLISP_CAR(args); args = KLISP_CDR(args); - if (KLISP_CTYPE(f) != KLISP_TYPE_STR) return KLispError(KLISP_POOL_ARG "%s: invalid argument #%i", name, cnt); + if (KLISP_CTYPE(f) != KLISP_TYPE_SYM) return KLispError(KLISP_POOL_ARG "%s: invalid argument #%i", name, cnt); if ((doEq && f != sop0) || (!doEq && f == sop0)) return 0; /* get out */ } @@ -425,7 +397,9 @@ static TKLispNumber KLMath_Round (KLISP_POOL_DEF TKLispNumber op0) { return roun static TKLispNumber KLMath_Frac (KLISP_POOL_DEF TKLispNumber op0) { return op0-trunc(op0); } static TKLispNumber KLMath_Sin (KLISP_POOL_DEF TKLispNumber op0) { return sin(op0); } static TKLispNumber KLMath_Cos (KLISP_POOL_DEF TKLispNumber op0) { return cos(op0); } -static TKLispNumber KLMath_Abs (KLISP_POOL_DEF TKLispNumber op0) { return abs(op0); } +static TKLispNumber KLMath_Abs (KLISP_POOL_DEF TKLispNumber op0) { + return op0>=0.0?op0:-op0; +} static TKLispNumber KLMath_Sign (KLISP_POOL_DEF TKLispNumber op0) { return op0<0?-1:op0>0?1:0; } static TKLispNumber KLMath_BitNot (KLISP_POOL_DEF TKLispNumber op0) { return (TKLispNumber)(~((long long)(op0))); } @@ -451,7 +425,7 @@ int KLPrim_Eval (KLISP_POOL_DEF int args) { if (!KLispCheckArgs(KLISP_POOL_ARG args, 1, "a[TN]", "eval", 1)) return 0; - /* stack: */ + /* stack: */ body = KLISP_CAR(args); scope = KLISP_CAR_EX(KLISP_CDR(args)); @@ -459,7 +433,7 @@ int KLPrim_Eval (KLISP_POOL_DEF int args) { /* create new scope */ KLispNewFrame(KLISP_POOL_ARG scope>1?scope:0); /* set 'new scope' flag */ - KLISP_RSET(0, KLISP_POOL->specs[KLISP_SPEC_SCOPE]); + KLISP_RSET(0, 0, KLISP_SPEC_E_SCOPE); /* pull args */ KLISP_RSWAP(0, 1); } else { @@ -468,376 +442,12 @@ int KLPrim_Eval (KLISP_POOL_DEF int args) { KLISP_RDROP(1); } /* set body */ - KLISP_RSET(0, body); - - return KLISP_DONT_TOUCH_STACK; /* special mark: don't touch the stack */ -} - - -/*#define KLISP_DEBUG_COND*/ -/* push for checking - args, phase, fn, value ICALL -*/ -static int KLIPrim_CondCheck (KLISP_POOL_DEF int phase) { - int tc, args; - - args = KLISP_RPEEK(4); - if (!args) { - /* done */ - KLISP_RDROP(4); - KLISP_RSET(0, 0); /* result: nil */ - return 0; - } - tc = KLISP_CAR(args); /* cond or body */ -#ifdef KLISP_DEBUG_COND - printf("phase=%s\n", phase?"body":"cond"); - printf(" tc="); KLispPrintCell(tc); printf("\n"); - printf(" args="); KLispPrintCell(args); printf("\n"); -#endif - if (phase) { - /* cond evaluated; is it true? */ -#ifdef KLISP_DEBUG_COND - printf(" val="); KLispPrintCell(KLISP_RPEEK(1)); printf("\n"); -#endif - if (KLISP_RPEEK(1)) { - /* do body */ -#ifdef KLISP_DEBUG_COND - printf("doitnow!\n"); -#endif - KLISP_RDROP(4); - KLISP_RSET(0, tc); - return 0; - } - } else { - /* set cond to evaluate */ - KLISP_RSET(1, tc); - } - /* toggle phase flag */ - KLISP_RSET(3, phase?0:1); - /* skip cond or body */ - KLISP_RSET(4, KLISP_CDR(args)); - /* swap command and value to evaluate value */ - KLISP_RSWAP(0, 1); - - return 0; -} - - -/* (cond ...) */ -int KLPrim_Cond (KLISP_POOL_DEF int args) { - int cnt; - - cnt = KLispIsList(KLISP_POOL_ARG args); - if (cnt < 2 || cnt%2 != 0) return KLispError(KLISP_POOL_ARG "cond: invalid arglist"); - - /* stack: */ - KLISP_RSET(0, 0); /* phase; nil: getting cond; t: checking cond */ - if (!KLispRPush(KLISP_POOL_ARG KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_IPRIM, KLIPrim_CondCheck, "(cond)"))) return -1; - if (!KLispRPush(KLISP_POOL_ARG 0)) return -1; /* value (dummy for now) */ - if (!KLispRPush(KLISP_POOL_ARG KLISP_POOL->specs[KLISP_SPEC_ICALL])) return -1; - - return KLISP_DONT_TOUCH_STACK; /* special mark: don't touch the stack */ -} - - -/* push for checking - args, 0:and|1:or, fn, value ICALL -*/ -static int KLIPrim_DoOrAnd (KLISP_POOL_DEF int optype) { - int tc, args, flag = optype?0:1; - - args = KLISP_RPEEK(4); - flag = KLISP_RPEEK(1); - if (!args) { - /* done */ - if (flag < 0) flag = optype?0:1; -retflag: - KLISP_RDROP(4); - KLISP_RSET(0, flag); /* result: nil */ - return 0; - } - tc = KLISP_CAR(args); /* next arg */ - if (flag >= 0) { - switch (optype) { - case 0: /* and */ - if (!flag) goto retflag; - break; - case 1: /* or */ - if (flag) goto retflag; - break; - default: ; - } - } - /* set next arg */ - KLISP_RSET(1, tc); - /* skip arg */ - KLISP_RSET(4, KLISP_CDR(args)); - /* swap command and value to evaluate value */ - KLISP_RSWAP(0, 1); - - return 0; -} - - -static int PrepareOrAnd (KLISP_POOL_DEF int args, int optype, const char *name) { - if (!KLispCheckArgs(KLISP_POOL_ARG args, 0, "a", name, 1)) return 0; - - /* stack: */ - KLISP_RSET(0, optype); - if (!KLispRPush(KLISP_POOL_ARG KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_IPRIM, KLIPrim_DoOrAnd, "(orand)"))) return -1; - if (!KLispRPush(KLISP_POOL_ARG 0)) return -1; /* value (dummy for now) */ - KLISP_RSET(0, -1); /* hack: KLispRPush will fail with -1 */ - if (!KLispRPush(KLISP_POOL_ARG KLISP_POOL->specs[KLISP_SPEC_ICALL])) return -1; - - return KLISP_DONT_TOUCH_STACK; /* special mark: don't touch the stack */ -} - - -/* (or arglist) */ -int KLPrim_Or (KLISP_POOL_DEF int args) { - return PrepareOrAnd(KLISP_POOL_ARG args, 1, "or"); -} - - -/* (and arglist) */ -int KLPrim_And (KLISP_POOL_DEF int args) { - return PrepareOrAnd(KLISP_POOL_ARG args, 0, "and"); -} - - -static int KLPrim_Xor (KLISP_POOL_DEF int args) { - int flag; - - if (!KLispCheckArgs(KLISP_POOL_ARG args, 0, "a", "xor", 1)) return 0; - flag = KLISP_CAR(args)!=0; - while ((args = KLISP_CDR(args))) if (KLISP_CAR(args) != 0) flag = !flag; - - return flag?1:0; -} - - -/* push for checking - args, fn, value ICALL -*/ -static int KLIPrim_ProgBody (KLISP_POOL_DEF int args) { - int tc; - - if (args) { - /* next operator */ - tc = KLISP_CAR(args); - args = KLISP_CDR(args); - /* evaluate next */ - KLISP_RSET(1, tc); - } - if (!args) { - /* done */ - /* move latest value to args */ - KLISP_RSWAP(1, 3); - /* drop all the shit */ - KLISP_RDROP(3); - tc = KLISP_RPEEK(0); - /*KLispPrintF(" prog res="); KLispPrintCell(tc); KLispPrintF("\n");*/ - } else { - /* skip operator */ - KLISP_RSET(3, args); - /* swap command and value, to evaluate value */ - KLISP_RSWAP(0, 1); - } - - return 0; -} - - -/* (prog ...) */ -int KLPrim_Prog (KLISP_POOL_DEF int args) { - int cnt; - - cnt = KLispIsList(KLISP_POOL_ARG args); - if (cnt < 0) return KLispError(KLISP_POOL_ARG "prog: invalid arglist"); - - /* stack: */ - KLISP_RSET(0, KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_IPRIM, KLIPrim_ProgBody, "(prog)")); - if (!KLispRPush(KLISP_POOL_ARG KLISP_POOL->specs[KLISP_SPEC_ICALL])) return -1; - if (!KLispRPush(KLISP_POOL_ARG KLISP_CAR(args))) return -1; /* first operator */ - KLISP_RSET(3, KLISP_CDR(args)); /* rest */ - - return KLISP_DONT_TOUCH_STACK; /* special mark: don't touch the stack */ -} - - -/* push for checking - args, phase, fn, value ICALL -*/ -static int KLIPrim_WhileBody (KLISP_POOL_DEF int phase) { - int tc, args; - - args = KLISP_RPEEK(4); - if (phase) { - /* body evaluated; set cond */ - args = KLISP_CAR(args); - phase = 0; - } else { - /* cond evaluated; check and set body */ - tc = KLISP_RPEEK(1); /* cond value */ - if (!tc) { - /* that's all, folks! */ - KLISP_RDROP(4); - KLISP_RSET(0, 0); /* result is always nil */ - - return 0; - } - args = KLISP_CAR(KLISP_CDR(args)); - phase = 1; - } - KLISP_RSET(1, args); /* new value to eval */ - KLISP_RSET(3, phase); - /* swap command and value to evaluate value */ - KLISP_RSWAP(0, 1); - - return 0; -} - - -/* (while ) */ -int KLPrim_While (KLISP_POOL_DEF int args) { - int cnt; - - cnt = KLispIsList(KLISP_POOL_ARG args); - if (cnt != 2) return KLispError(KLISP_POOL_ARG "while: invalid arglist"); - - /* stack: */ - KLISP_RSET(0, 0); /* phase; nil: evaluating cond; t: evaluating body */ - if (!KLispRPush(KLISP_POOL_ARG KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_IPRIM, KLIPrim_WhileBody, "(while)"))) return -1; - if (!KLispRPush(KLISP_POOL_ARG KLISP_POOL->specs[KLISP_SPEC_ICALL])) return -1; - if (!KLispRPush(KLISP_POOL_ARG KLISP_CAR(args))) return -1; /* cond */ + KLISP_RSET(0, body, KLISP_SPEC_EVAL); return KLISP_DONT_TOUCH_STACK; /* special mark: don't touch the stack */ } -/*#define KLISP_DEBUG_BETA -#define KLISP_DEBUG_BETA_EX*/ -/* args iprim ( ) KLISP_SPEC_ICALL */ -int KLIPrim_Lambda (KLISP_POOL_DEF int args) { - int vars, f, t, tail = 0, val; - const char *s; - - /* first we should create arglist (if any) */ - /* here we can do tail-call optz: check if the prev op is scope too and combine two scopes */ - /* traverse the stack */ -#ifdef KLISP_DEBUG_BETA -#ifdef KLISP_DEBUG_BETA_EX - KLispPrintF("we: "); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->stack); KLispPrintF("\n"); -#endif -#endif - t = KLISP_RPEEK(4); - if (t > 0 && KLISP_CTYPE(t) == KLISP_TYPE_SPEC && KLISP_CAR(t) == KLISP_SPEC_SCOPE) { -#ifdef KLISP_DEBUG_BETA - KLispPrintF("beta!\n"); - if (KLISP_POOL->frames) { - KLispPrintF(" frames: "); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->frames); KLispPrintF("\n"); - } -#endif - tail = 1; - } - /* create new scope if this is not a tail-call */ - if (!tail) { - if (!KLispNewFrame(KLISP_POOL_ARG 0)) return -1; - } - /* set vars */ - vars = KLISP_CAR(KLISP_RPEEK(1)); - while (args && vars) { - s = KLISP_CELL(KLISP_CAR(vars)).str; -#ifdef KLISP_DEBUG_BETA - KLispPrintF(" argname: %s\n", s); -#endif - if (!strcmp(s, "...")) { - /* '...' takes all other args */ - val = args; args = 0; - } else { - val = KLISP_CAR(args); - args = KLISP_CDR(args); - } - if (KLispSetSymbolValue(KLISP_POOL_ARG s, val, 1) < 0) goto error; - vars = KLISP_CDR(vars); - } - /* init locals to nil */ - while (vars) { - s = KLISP_CELL(KLISP_CAR(vars)).str; -#ifdef KLISP_DEBUG_BETA - KLispPrintF(" locname: %s\n", s); -#endif - if (KLispSetSymbolValue(KLISP_POOL_ARG s, 0, 1) < 0) goto error; - vars = KLISP_CDR(vars); - } - /* prepare new frame */ - if (tail) { - /* drop scope & LMD_CALL */ - t = KLISP_RPEEK(5); - if (t > 0 && KLISP_CTYPE(t) == KLISP_TYPE_SPEC && KLISP_CAR(t) == KLISP_SPEC_LMD_CALL) f = 5; - else f = 4; - for (t = 3; t >= 0; t--, f--) KLISP_RSET(f, KLISP_RPEEK(t)); - /*fprintf(stderr, "%i\n", f);*/ - KLISP_RDROP(f+1); -#ifdef KLISP_DEBUG_BETA -#ifdef KLISP_DEBUG_BETA_EX - KLispPrintF(" shrinked: "); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->stack); KLispPrintF("\n"); -#endif -#endif - } -#ifdef KLISP_DEBUG_BETA - KLispPrintF(" new frame: "); KLispPrintCell(KLISP_POOL_ARG KLISP_CAR(KLISP_POOL->frames)); KLispPrintF("\n"); -#endif -#ifdef KLISP_DEBUG_BETA - KLispPrintF(" result frames: "); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->frames); KLispPrintF("\n"); -#endif - /* done, now prepare body for evaluation */ - KLISP_RSET(3, KLISP_POOL->specs[KLISP_SPEC_LMD_CALL]); /* mark lambda call */ - KLISP_RSET(2, KLISP_POOL->specs[KLISP_SPEC_SCOPE]); /* we have new scope */ - args = KLISP_CDR(KLISP_RPEEK(1)); - if (args) args = KLISP_CAR(args); - KLISP_RSET(1, args); /* lambda body */ - KLISP_RDROP(1); /* drop spec and lmb */ - /* done; don't touch the stack! %-) */ - - return KLISP_DONT_TOUCH_STACK; - -error: /* barf! */ - if (!tail) KLispPopFrame(KLISP_POOL_ARG0); - - return -1; -} - - -static int PrepareLambda (KLISP_POOL_DEF int args, int evalargs, const char *name) { - int cnt; - -#ifdef KLISP_DEBUG_EVAL -if (klispOptPrintStack) { - printf("lmb: "); KLispPrintCell(KLISP_POOL_ARG args); printf("\n"); -} -#endif - cnt = KLispIsList(KLISP_POOL_ARG args); - if (cnt != 2) return KLispError(KLISP_POOL_ARG "%s: invalid arglist", name); - - return KLispNewCons(KLISP_POOL_ARG KLispNewXPrim(KLISP_POOL_ARG - evalargs?KLISP_TYPE_IPRIM:KLISP_TYPE_IMPRIM, - KLIPrim_Lambda, evalargs?"(lmb)":"(mlmb)"), args); -} - - -/* (lambda |nil ) */ -int KLPrim_Lambda (KLISP_POOL_DEF int args) { - return PrepareLambda(KLISP_POOL_ARG args, 1, "lambda"); -} - - -/* ([m]lambda |nil ) */ -int KLPrim_MLambda (KLISP_POOL_DEF int args) { - return PrepareLambda(KLISP_POOL_ARG args, 0, "mlambda"); -} - - int KLPrim_Concat (KLISP_POOL_DEF int args) { int cnt = 0, total = 0, aa = args, f; char *dest = NULL; @@ -849,7 +459,7 @@ int KLPrim_Concat (KLISP_POOL_DEF int args) { while (args) { cnt++; f = KLISP_CAR(args); - if (KLISP_CTYPE(f) != KLISP_TYPE_STR) return KLispError(KLISP_POOL_ARG "$+: invalid argument #%i", cnt); + if (KLISP_CTYPE(f) != KLISP_TYPE_SYM) return KLispError(KLISP_POOL_ARG "$+: invalid argument #%i", cnt); args = KLISP_CDR(args); s = KLISP_CELL(f).str; total += strlen(s); @@ -863,7 +473,7 @@ int KLPrim_Concat (KLISP_POOL_DEF int args) { s = KLISP_CELL(f).str; strcat(dest, s); } - f = KLispNewStr(KLISP_POOL_ARG dest); + f = KLispNewSym(KLISP_POOL_ARG dest); KLISP_MEMFREE(dest); return f; @@ -887,7 +497,7 @@ int KLPrim_Char (KLISP_POOL_DEF int args) { op0 = KLISP_CELL(KLISP_CAR(args)).num; if (op0 < 1 || op0 > 255) ch = 32; else { ch = (int)op0; if (!ch) ch = 1; } - return KLISP_POOL->chars[(unsigned char)ch]; + return KLISP_POOL->syms[(unsigned char)ch]; } @@ -915,13 +525,13 @@ int KLPrim_SubStr (KLISP_POOL_DEF int args) { if (!(r = KLISP_MEMALLOC((end+1)*sizeof(char)))) return KLispErrorMem(KLISP_POOL_ARG0); t = r; while (*s && end--) *t++ = *s++; *t = '\0'; - cell = KLispNewStr(KLISP_POOL_ARG r); + cell = KLispNewSym(KLISP_POOL_ARG r); KLISP_MEMFREE(r); return cell; } - return KLispNewStr(KLISP_POOL_ARG ""); + return KLispNewSym(KLISP_POOL_ARG ""); } @@ -954,7 +564,7 @@ int KLPrim_NtoA (KLISP_POOL_DEF int args) { snprintf(buf, 128, trunc(op0)==op0?"%.f":"%f", op0); buf[127] = '\0'; - return KLispNewStr(KLISP_POOL_ARG buf); + return KLispNewSym(KLISP_POOL_ARG buf); } return args; @@ -984,44 +594,82 @@ int KLPrim_GC (KLISP_POOL_DEF int args) { } -int KLPrim_Invoke (KLISP_POOL_DEF int args) { - int udata, mt; - const char *s; +/* push for checking + args, 0:and|1:or, fn, value ICALL +*/ +static int KLIPrim_DoOrAnd (KLISP_POOL_DEF int optype) { + int tc, args, flag = optype?0:1; - /*KLispPrintF("invoke: "); KLispPrintCell(KLISP_POOL_ARG args); KLispPrintF("\n");*/ -#ifdef KLISP_DEBUG_EVAL -if (klispOptPrintStack) { - KLispPrintF("invoke: "); KLispPrintCell(KLISP_POOL_ARG args); KLispPrintF("\n"); -} -#endif - /* - KLispPrintF(" invoke: "); KLispPrintCell(KLISP_POOL_ARG args); KLispPrintF("\n"); - KLispPrintF(" stack: "); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->stack); KLispPrintF("\n"); - KLispPrintF(" frames: "); KLispPrintCell(KLISP_POOL_ARG KLISP_POOL->frames); KLispPrintF("\n"); - */ - if (!KLispCheckArgs(KLISP_POOL_ARG args, 0, "us", "invoke", 1)) return 0; - /* get args */ - udata = KLISP_CAR(args); - args = KLISP_CDR(args); - s = KLISP_CELL(KLISP_CAR(args)).str; - args = KLISP_CDR(args); - /* find method */ - mt = KLispUDataGetMethod(KLISP_POOL_ARG udata, s); - if (mt <= 0) return KLispError(KLISP_POOL_ARG "invoke: method '%s' not found", s); - switch (KLISP_CTYPE(mt)) { - case KLISP_TYPE_PRIM: case KLISP_TYPE_MPRIM: - if (!KLISP_CELL(mt).fn) return KLispError(KLISP_POOL_ARG "invoke: method '%s' is empty", s); - args = KLispNewCons(KLISP_POOL_ARG udata, args); - /* stack: */ - KLISP_RSET(1, args); - return KLISP_CELL(mt).fn(KLISP_POOL_ARG args); - default: return KLispError(KLISP_POOL_ARG "invoke: method '%s' isn't prim", s); + args = KLISP_RPEEKDATA(4); + if (args < 0) return KLispError(KLISP_POOL_ARG "DoOrAnd internal: args"); + flag = KLISP_RPEEKDATA(1); + if (flag < 0) return KLispError(KLISP_POOL_ARG "DoOrAnd internal: flag"); + if (!args) { + /* done */ + if (flag < 0) flag = optype?0:1; +retflag: + KLISP_RDROP(4); + KLISP_RSET(0, flag, KLISP_SPEC_NO_EVAL); /* result: nil/t */ + return 0; + } + tc = KLISP_CAR(args); /* next arg */ + switch (optype) { + case 0: /* and */ + if (!flag) goto retflag; + break; + case 1: /* or */ + if (flag) goto retflag; + break; + default: ; } + /* set next arg */ + KLISP_RSET(1, tc, KLISP_SPEC_EVAL); + /* skip arg */ + KLISP_RSET(4, KLISP_CDR(args), KLISP_SPEC_NO_EVAL); + /* swap command and value to evaluate value */ + KLISP_RSWAP(0, 1); + + return 0; +} + + +static int PrepareOrAnd (KLISP_POOL_DEF int args, int optype, const char *name) { + if (!KLispCheckArgs(KLISP_POOL_ARG args, 0, "a", name, 1)) return 0; + + /* stack: */ + KLISP_RSET(0, optype, KLISP_SPEC_NO_EVAL); + if (!KLISP_RPUSH(KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_IPRIM, KLIPrim_DoOrAnd, "(orand)"), KLISP_SPEC_NO_EVAL)) return -1; + if (!KLISP_RPUSH(optype, KLISP_SPEC_NO_EVAL)) return -1; /* initial value */ + if (!KLISP_RPUSH(2, KLISP_SPEC_ICALL)) return -1; + + return KLISP_DONT_TOUCH_STACK; /* special mark: don't touch the stack */ +} + + +/* (or arglist) */ +int KLPrim_Or (KLISP_POOL_DEF int args) { + return PrepareOrAnd(KLISP_POOL_ARG args, 1, "or"); +} + + +/* (and arglist) */ +int KLPrim_And (KLISP_POOL_DEF int args) { + return PrepareOrAnd(KLISP_POOL_ARG args, 0, "and"); +} + + +int KLPrim_Xor (KLISP_POOL_DEF int args) { + int flag; + + if (!KLispCheckArgs(KLISP_POOL_ARG args, 0, "a", "xor", 1)) return 0; + flag = KLISP_CAR(args)!=0; + while ((args = KLISP_CDR(args))) if (KLISP_CAR(args) != 0) flag = !flag; + + return flag?1:0; } struct _TKLispPrimItem klispPrimList[] = { - {0, KLPrim_Quote, "quote"}, {1, KLPrim_Cons, "cons"}, {1, KLPrim_List, "list"}, {1, KLPrim_Car, "car"}, @@ -1033,14 +681,9 @@ struct _TKLispPrimItem klispPrimList[] = { {1, KLPrim_Type, "type$"}, {1, KLPrim_Eval, "eval"}, - {0, KLPrim_Noop, "noop"}, - - {0, KLPrim_Prog, "prog"}, - {0, KLPrim_While, "while"}, - - {0, KLPrim_Lambda, "lambda"}, - {0, KLPrim_MLambda, "mlambda"}, - + {1, KLPrim_Xor, "xor"}, + {0, KLPrim_Or, "or"}, + {0, KLPrim_And, "and"}, {1, KLPrim_Add, "+"}, {1, KLPrim_Sub, "-"}, @@ -1078,16 +721,9 @@ struct _TKLispPrimItem klispPrimList[] = { {1, KLPrim_SEq, "$="}, {1, KLPrim_SNe, "$<>"}, - {1, KLPrim_Xor, "xor"}, - {0, KLPrim_Or, "or"}, - {0, KLPrim_And, "and"}, {1, KLPrim_Not, "not"}, {1, KLPrim_Bool, "bool"}, - {0, KLPrim_Cond, "cond"}, - - {1, KLPrim_StrToSym, "$->sym"}, - {1, KLPrim_SymToStr, "sym->$"}, {1, KLPrim_Concat, "$+"}, {1, KLPrim_StrLen, "$len"}, @@ -1100,8 +736,6 @@ struct _TKLispPrimItem klispPrimList[] = { {1, KLPrim_GC, "gc"}, - {1, KLPrim_Invoke, "invoke"}, - {0, NULL, NULL} }; diff --git a/src/klisp/klisp_rbtree.c b/src/klisp/klisp_rbtree.c index 51deadc..6774e9c 100644 --- a/src/klisp/klisp_rbtree.c +++ b/src/klisp/klisp_rbtree.c @@ -161,22 +161,12 @@ static TKLispRBTNode *rbtNodeFree = NULL; void KLispRBTCleanup (void) { TKLispRBTNode *node; - /*int f;*/ - /*if (!rbtNodePool) return; - for (f = 0; f < rbtNodeCount; f++) rbtNodePool[f].value1 = 0;*/ while (rbtNodeFree) { node = rbtNodeFree->nextFree; KLISP_MEMFREE(rbtNodeFree); rbtNodeFree = node; } - /*for (f = 0; f < rbtNodeCount; f++) { - if (rbtNodePool[f].value1 != -666) continue; - if (rbtNodePool[f].freeIt && rbtNodePool[f].str) KLISP_MEMFREE(rbtNodePool[f].str); - } - KLISP_MEMFREE(rbtNodePool); - rbtNodePool = NULL; - rbtNodeCount = 0; rbtNodeFree = NULL;*/ } @@ -199,28 +189,15 @@ static void RBTI_FreeNode (TKLispRBTNode *node) { } /*KLISP_MEMFREE(node);*/ node->str = NULL; - rbtNodeFree = node->nextFree; + node->nextFree = rbtNodeFree; + rbtNodeFree = node; } static void RBTI_GrowPool (void) { -/* note that nextFree pointers are invalid after the growth! */ TKLispRBTNode *rn; int f; - /*int newSz;*/ - - /*assert(!rbtNodeFree);*/ - /* mark all free nodes */ - /*newSz = rbtNodeCount+8192; - rn = KLISP_MEMREALLOC(rbtNodePool, (newSz+1)*sizeof(TKLispRBTNode)); - if (!rn) { fprintf(stderr, "***memory!\n"); abort(); } - rbtNodePool = rn; - for (f = rbtNodeCount; f < newSz; f++) { - rbtNodePool[f].nextFree = &(rbtNodePool[f+1]); - } - rbtNodePool[newSz-1].nextFree = NULL; - rbtNodeFree = &(rbtNodePool[rbtNodeCount]); - rbtNodeCount = newSz;*/ + for (f = 512; f; f--) { rn = KLISP_MEMALLOC(sizeof(TKLispRBTNode)); if (!rn) return; @@ -230,7 +207,7 @@ static void RBTI_GrowPool (void) { } -static TKLispRBTNode *RBTI_NewNode (const char *str, int value0, int value1, int freeIt) { +static TKLispRBTNode *RBTI_NewNode (const char *str, int value0, int freeIt) { TKLispRBTNode *rn; assert(str); @@ -253,7 +230,7 @@ static TKLispRBTNode *RBTI_NewNode (const char *str, int value0, int value1, int return NULL; } } - rn->value0 = value0; rn->value1 = value1; + rn->value0 = value0; rn->freeIt = freeIt; rn->hash = HashString(rn->str); } @@ -324,7 +301,7 @@ static TKLispRBTNode *KLispRBTDoubleRotation (TKLispRBTNode *root, int dir) { /* dataptr: pointer to data; data will be copied */ /* newnode will be non-zero, if new node was generated; newnode can be NULL */ -TKLispRBTNode *KLispRBTInsert (TKLispRBTree *tree, const char *str, int value0, int value1, int freeIt, int *newnode) { +TKLispRBTNode *KLispRBTInsert (TKLispRBTree *tree, const char *str, int value0, int freeIt, int *newnode) { TKLispRBTNode *res = NULL; TKLispRBTNode head = {0}; /* false tree root */ TKLispRBTNode *g, *t; /* grandparent & parent */ @@ -335,7 +312,7 @@ TKLispRBTNode *KLispRBTInsert (TKLispRBTree *tree, const char *str, int value0, if (tree->root == NULL) { /* empty tree case */ if (newnode) *newnode = 1; - tree->root = RBTI_NewNode(str, value0, value1, freeIt); + tree->root = RBTI_NewNode(str, value0, freeIt); if (tree->root) { /* make root black */ tree->root->red = 0; @@ -353,7 +330,7 @@ TKLispRBTNode *KLispRBTInsert (TKLispRBTree *tree, const char *str, int value0, for (;;) { if (q == NULL) { /* insert new node at the bottom */ - p->link[dir] = q = RBTI_NewNode(str, value0, value1, freeIt); + p->link[dir] = q = RBTI_NewNode(str, value0, freeIt); if (q == NULL) return NULL; if (newnode) *newnode = 1; res = q; @@ -458,9 +435,8 @@ int KLispRBTDelete (TKLispRBTree *tree, const char *str) { p->link[p->link[1] == q] = q->link[q->link[0] == NULL]; /* swap data for found node and q */ KLISP_RBT_SWAP(freeIt, last); - KLISP_RBT_SWAP(str, tmpstr);; + KLISP_RBT_SWAP(str, tmpstr); found->value0 = q->value0; - found->value1 = q->value1; found->hash = q->hash; found = q; /*found->str = q->str;*/ diff --git a/src/syren.lsp b/src/syren.lsp deleted file mode 100644 index 1872955..0000000 --- a/src/syren.lsp +++ /dev/null @@ -1,112 +0,0 @@ -(set 'defun '(mlambda (name args body) - (set-up-n 1 name (list 'lambda args body)) -)) - - - -(set 'redirs - '( - ("switch.dl.sourceforge.net" - "kent.dl.sourceforge.net" "puzzle.dl.sourceforge.net" "belnet.dl.sourceforge.net" - "superb-west.dl.sourceforge.net" "superb-east.dl.sourceforge.net" - "garr.dl.sourceforge.net") - ("ketmar.pb.id" "localhost") - ;(prdownload.berlios.de download.berlios.de) - ) -) - - -(defun _StrInList (str item rest) - (cond item - (cond - ($= str item) t - rest (_StrInList str (car rest) (cdr rest)) - ) - ) -) -(defun StrInList (str list) - (cond list (_StrInList str (car list) (cdr list))) -) - - -(defun _FindRedir (host item rest) - (cond item - (cond - (StrInList host (cdr item)) (car item) - rest (_FindRedir host (car rest) (cdr rest)) - ) - ) -) -(defun FindRedir (host ... rl) - (_FindRedir host (car redirs) (cdr redirs)) -) - - - -(defun _StrSplit (char acc rest) - (cond - rest - (cond ($= char ($sub rest 1 1)) (list 'noop acc rest) - t (_StrSplit char ($+ acc ($sub rest 1 1)) ($sub rest 2)) - ) - t nil - ) -) -(defun StrSplit (char str) (_StrSplit char "" str) ) - - -(defun LocSplit (loc ... tmp) (prog - (cond ($= ($sub loc 1 7) "http://") (set 'loc ($sub loc 8)) ) - (set 'tmp (StrSplit "/" loc)) - ;(print "tmp=" tmp "\n") - ;(list 'quote tmp) - tmp -)) - - -(defun Event.AddHeaders (...) (prog - ;(print "AddHeaders!\n") - ;(print "host=" (HdrGetField "host") "|\n") - ;(set 'url (URL)) - ;(cond ($= (url GetHost) "localhost") - ; (prog (invoke url 'SetHost "ketmar.pb.id") (HdrSetField "Host" "ketmar.pb.id")) - ;) - (set 'url (URL)) - (cond ($= (url GetHost) "prdownload.berlios.de") (prog - (invoke url 'SetHost "download.berlios.de") - (HdrSetField "Host" "download.berlios.de") - (print "BERLIOS download detected!\n") - ) - ) -)) - - -(defun Event.GotHeaders (... ls) (prog - ;(print "GotHeaders!\n") - ;(set 'url (URL)) - ;(cond ($= (url GetHost) "localhost") - ; (prog (HdrSetField "Location" "http://ketmar.pb.id/") (HdrSetCode 301)) - ;) - (cond (= (trunc (/ (HdrGetCode) 100)) 3) (prog - (set 'ls (LocSplit (HdrGetField "location")) ) - (cond ls - ;(print "ls=" ls "\n") - (set 'rd (FindRedir (car (cdr ls))) ) - ;(print "rd=" rd "\n") - (cond rd (prog - (print "*****************************************\n") - (print (car (cdr ls)) "-->" rd "\n") - (print "*****************************************\n") - (HdrSetField "Location" ($+ "http://" rd (car (cdr (cdr ls)))) ) - ;(HdrSetCode 301) - ;(print "code: " (HdrGetCode) "\n") - ;(print "loc: " (HdrGetField "location") "\n") - ) - ) - ) - ) - ) -)) - - -(print "syren.lsp loaded.\n") diff --git a/src/syren_script.c b/src/syren_script.c index 59c9ae8..442fdd7 100644 --- a/src/syren_script.c +++ b/src/syren_script.c @@ -225,7 +225,7 @@ static int KURL_Get##name (KLISP_POOL_DEF int args) {\ if (!KLispCheckArgs(KLISP_POOL_ARG args, 1, "u", "URL:Get" #name, 1)) return 0; \ if (!(uurl = KLCheckUType(KLISP_POOL_ARG args, UDATA_URL))) return 0; \ \ - return KLispNewStr(KLISP_POOL_ARG uurl->url->fldname); \ + return KLispNewSym(KLISP_POOL_ARG uurl->url->fldname); \ } \ static int KURL_Set##name (KLISP_POOL_DEF int args) { \ TUDataURL *uurl; \ @@ -324,7 +324,7 @@ static int KLPrim_HdrGetField (KLISP_POOL_DEF int args) { if (!scHdrs) return 0; /* no headers here */ val = SyHdrGetFieldValue(scHdrs, KLISP_CELL(KLISP_CELL(args).car).str); if (!val) return 0; /* no such field */ - args = KLispNewStr(KLISP_POOL_ARG val); + args = KLispNewSym(KLISP_POOL_ARG val); SyStrFree(val); return args; -- 2.11.4.GIT