src/klisp/klisp_core.c

   1 #ifndef _KLISP_CORE_MODULE_BODY_
   2 #define _KLISP_CORE_MODULE_BODY_
   3
   4 #include "klisp.h"
   5
   6
   7 #ifdef KLISP_DEBUG_EVAL
   8 int klispOptPrintStack = 1;
   9 #endif
  10
  11
  12 /*****************************************************************
  13  error messages
  14  *****************************************************************/
  15 void KLispFreeError (KLISP_POOL_DEF0) {
  16   if (!KLISP_POOL || KLISP_POOL->errorStatic || !KLISP_POOL->error) return;
  17   KLISP_MEMFREE(KLISP_POOL->error);
  18   KLISP_POOL->error = NULL;
  19 }
  20
  21
  22 int KLispError (KLISP_POOL_DEF const char *fmt, ...) {
  23   static char *sErrorMem = "fatal out of memory!";
  24   int n, size = 256;
  25   va_list ap;
  26   char *p, *np;
  27
  28   if (!KLISP_POOL) return -1;
  29   KLispFreeError(KLISP_POOL_ARG0);
  30   if (!fmt || !*fmt) return -1;
  31
  32   KLISP_POOL->errorStatic = 1; KLISP_POOL->error = sErrorMem;
  33   if ((p = KLISP_MEMALLOC(size*sizeof(char))) == NULL) return -1;
  34   while (1) {
  35     memset(p, 0, size);
  36     va_start(ap, fmt);
  37     n = vsnprintf(p, size, fmt?fmt:"", ap);
  38     va_end(ap);
  39     if (n > -1 && n < size) break;
  40     if (n > -1) size = n+1; else size *= 2;
  41     if ((np = KLISP_MEMREALLOC(p, size*sizeof(char))) == NULL) { KLISP_MEMFREE(p); return -1; }
  42     p = np;
  43   }
  44   KLISP_POOL->errorStatic = 0; KLISP_POOL->error = p;
  45   KLISP_POOL->errorLine = KLISP_POOL->lineNo;
  46
  47   return -1;
  48 }
  49
  50
  51 int KLispErrorMem (KLISP_POOL_DEF0) {
  52   return KLispError(KLISP_POOL_ARG "out of memory");
  53 }
  54
  55
  56 /*****************************************************************
  57  initializers/allocators
  58  *****************************************************************/
  59 void KLispFreePool (KLISP_POOL_DEF0) {
  60   TKLispCell *cell;
  61   int f;
  62
  63   if (!KLISP_POOL) return;
  64   KLISP_POOL->gcPhase++;
  65   for (f = 0; f < KLISP_POOL->cellCount; f++) {
  66     cell = &(KLISP_POOL->cells[f]);
  67     if (cell->ctype & KLISP_FFLAG) continue;
  68     if (cell->ctype == KLISP_TYPE_UDATA && cell->finalizer) KLispInvokeFinalizer(KLISP_POOL_ARG f);
  69   }
  70   KLISP_POOL->gcPhase--;
  71   KLispDeinitStack(&KLISP_POOL->roots);
  72   KLispDeinitStack(&KLISP_POOL->stack);
  73   KLispDeinitStack(&KLISP_POOL->frames);
  74   KLispRBTFreeTree(KLISP_POOL->primitives);
  75   KLispRBTFreeTree(KLISP_POOL->globals);
  76   KLispRBTFreeTree(KLISP_POOL->strpool);
  77   KLISP_MEMFREE(KLISP_POOL->cells);
  78   KLispFreeError(KLISP_POOL_ARG0);
  79   KLISP_MEMFREE(KLISP_POOL);
  80 }
  81
  82
  83 static void InitPool (KLISP_POOL_DEF int from) {
  84   TKLispCell *cell;
  85   int f;
  86
  87   if (KLISP_POOL->free) KLISP_CELL(KLISP_POOL->free).cdr = from;
  88   KLISP_POOL->free = from;
  89   cell = &(KLISP_CELL(from));
  90   for (f = from; f < KLISP_POOL->cellCount; f++, cell++) {
  91     cell->ctype = KLISP_TYPE_NUM | KLISP_FFLAG;
  92     cell->num = 0;
  93     cell->str = NULL;
  94     cell->car = cell->lineno = 0;
  95     cell->cdr = f+1;
  96   }
  97   KLISP_CELL(KLISP_POOL->cellCount-1).cdr = 0; /* end of free list */
  98 }
  99
 100
 101 TKLispPool *KLispNewPool (void) {
 102   TKLispRBTNode *ci;
 103   TKLispPool *pool;
 104   TKLispCell *cell;
 105   int f, initPS;
 106   char buf[4];
 107
 108   /* alloc pool */
 109   KLISP_POOL = KLISP_MEMALLOC(sizeof(TKLispPool));
 110   if (!KLISP_POOL) goto errexit;
 111   memset(KLISP_POOL, 0, sizeof(TKLispPool));
 112   /* alloc cells */
 113   initPS = KLISP_INIT_POOL_SIZE;
 114   if (initPS < KLISP_SPEC_MAX+16) initPS = KLISP_INIT_POOL_SIZE+16;
 115   KLISP_POOL->cellCount = initPS;
 116   KLISP_POOL->cells = KLISP_MEMALLOC(KLISP_POOL->cellCount*sizeof(TKLispCell));
 117   if (!KLISP_POOL->cells) goto errexit;
 118   memset(KLISP_POOL->cells, 0, KLISP_POOL->cellCount*sizeof(TKLispCell));
 119   /* alloc primlist */
 120   KLISP_POOL->primitives = KLispRBTNewTree();
 121   if (!KLISP_POOL->primitives) goto errexit;
 122   /* alloc globals */
 123   KLISP_POOL->globals = KLispRBTNewTree();
 124   if (!KLISP_POOL->globals) goto errexit;
 125   /* alloc stringling */
 126   KLISP_POOL->strpool = KLispRBTNewTree();
 127   if (!KLISP_POOL->strpool) goto errexit;
 128   /* stacks */
 129   if (!KLispInitStack(&KLISP_POOL->frames, 128, 64, 4096) ||
 130       !KLispInitStack(&KLISP_POOL->stack, 128, 64, 4096) ||
 131       !KLispInitStack(&KLISP_POOL->roots, 16, 8, 4096)) goto errexit;
 132
 133   buf[0] = buf[1] = buf[2] = '.'; buf[3] = '\0';
 134   if (!KLispRBTInsert(KLISP_POOL->strpool, buf, 0, 1, NULL)) goto errexit;
 135   buf[1] = '\0';
 136   /* fill strpool with chars */
 137   for (f = 1; f < 256; f++) {
 138     buf[0] = f;
 139     if (!KLispRBTInsert(KLISP_POOL->strpool, buf, 0, 1, NULL)) goto errexit;
 140   }
 141
 142   KLISP_POOL->usedCount = 0;
 143   /* init nil and t */
 144   cell = KLISP_POOL->cells;
 145   for (f = 0; f < 2; f++, cell++) {
 146     KLISP_POOL->usedCount++;
 147     cell->num = f;
 148     cell->ctype = KLISP_TYPE_NUM;
 149     cell->car = 0;
 150     cell->str = NULL;
 151     cell->cdr = 0;
 152   }
 153   /* 1-char symbols */
 154   for (f = 0; f < 256; f++, cell++) {
 155     if (f) { buf[0] = f; buf[1] = '\0'; } else { buf[0] = buf[1] = buf[2] = '.'; buf[3] = '\0'; }
 156     KLISP_POOL->syms[f] = KLISP_POOL->usedCount;
 157     KLISP_POOL->usedCount++;
 158     cell->num = 0;
 159     cell->ctype = KLISP_TYPE_SYM;
 160     cell->car = 0;
 161     ci = KLispRBTFind(KLISP_POOL->strpool, buf);
 162     assert(ci);
 163     ci->value0 = KLISP_POOL->syms[f];
 164     cell->str = ci->str;
 165     cell->cdr = cell->lineno = 0;
 166   }
 167
 168   InitPool(KLISP_POOL_ARG KLISP_POOL->usedCount);
 169
 170   KLISP_POOL->prog = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "prog");
 171   KLISP_POOL->cond = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "cond");
 172   KLISP_POOL->lambda = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "lambda");
 173   KLISP_POOL->mlambda = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "mlambda");
 174   KLISP_POOL->quote = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "quote");
 175   KLISP_POOL->defun = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "defun");
 176   KLISP_POOL->defmac = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, NULL, "defmac");
 177   KLISP_POOL->invoke = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_PRIM, NULL, "invoke");
 178
 179   KLispSetGlobal(KLISP_POOL_ARG "prog", KLISP_POOL->prog);
 180   KLispSetGlobal(KLISP_POOL_ARG "cond", KLISP_POOL->cond);
 181   KLispSetGlobal(KLISP_POOL_ARG "lambda", KLISP_POOL->lambda);
 182   KLispSetGlobal(KLISP_POOL_ARG "mlambda", KLISP_POOL->mlambda);
 183   KLispSetGlobal(KLISP_POOL_ARG "quote", KLISP_POOL->quote);
 184   KLispSetGlobal(KLISP_POOL_ARG "defun", KLISP_POOL->defun);
 185   KLispSetGlobal(KLISP_POOL_ARG "defmac", KLISP_POOL->defmac);
 186   KLispSetGlobal(KLISP_POOL_ARG "invoke", KLISP_POOL->invoke);
 187
 188   return pool;
 189
 190 errexit:
 191   if (KLISP_POOL->cells) KLISP_MEMFREE(KLISP_POOL->cells);
 192   KLispDeinitStack(&KLISP_POOL->roots);
 193   KLispDeinitStack(&KLISP_POOL->stack);
 194   KLispDeinitStack(&KLISP_POOL->frames);
 195   KLispRBTFreeTree(KLISP_POOL->primitives);
 196   KLispRBTFreeTree(KLISP_POOL->globals);
 197   KLispRBTFreeTree(KLISP_POOL->strpool);
 198   KLISP_MEMFREE(KLISP_POOL);
 199   return NULL;
 200 }
 201
 202
 203 static int AllocCell (KLISP_POOL_DEF0) {
 204   TKLispCell *newcp;
 205   int f, newSz;
 206
 207 #ifdef KLISP_DEBUG_VERY_AGRESSIVE_GC
 208   KLispGC(KLISP_POOL_ARG0);
 209 #endif
 210   if (!KLISP_POOL->free || KLISP_POOL->cellCount-KLISP_POOL->usedCount < KLISP_GROW_POOL_SIZE/4) {
 211     /* gc */
 212     KLispGC(KLISP_POOL_ARG0);
 213     if (!KLISP_POOL->free) {
 214       /* grow */
 215       newSz = KLISP_POOL->cellCount+KLISP_GROW_POOL_SIZE;
 216       newcp = KLISP_MEMREALLOC(KLISP_POOL->cells, sizeof(TKLispCell)*newSz);
 217       if (!newcp) return KLispErrorMem(KLISP_POOL_ARG0);
 218       KLISP_POOL->cells = newcp;
 219       f = KLISP_POOL->cellCount;
 220       KLISP_POOL->cellCount = newSz;
 221       InitPool(KLISP_POOL_ARG f);
 222     }
 223   }
 224
 225   if (!KLISP_POOL->free) return KLispErrorMem(KLISP_POOL_ARG0);
 226   f = KLISP_POOL->free;
 227   newcp = &(KLISP_POOL->cells[f]);
 228   KLISP_POOL->free = newcp->cdr;
 229   newcp->ctype = KLISP_TYPE_NUM;
 230   newcp->car = newcp->cdr = 0;
 231   newcp->lineno = KLISP_POOL->lineNo;
 232   KLISP_POOL->usedCount++;
 233
 234   return f;
 235 }
 236
 237
 238 int KLispNewCons (KLISP_POOL_DEF int car, int cdr) {
 239   int cell;
 240
 241   if (car < 0 || cdr < 0) return -1;
 242   assert(!KLISP_POOL->tempRootGC0 && !KLISP_POOL->tempRootGC1);
 243   KLISP_POOL->tempRootGC0 = car;
 244   KLISP_POOL->tempRootGC1 = cdr;
 245   cell = AllocCell(KLISP_POOL_ARG0);
 246   KLISP_POOL->tempRootGC0 = KLISP_POOL->tempRootGC1 = 0;
 247   if (cell >= 0) {
 248     KLISP_CTYPE(cell) = KLISP_TYPE_CONS;
 249     KLISP_CAR(cell) = car;
 250     KLISP_CDR(cell) = cdr;
 251   }
 252
 253   return cell;
 254 }
 255
 256
 257 int KLispNewNum (KLISP_POOL_DEF TKLispNumber value) {
 258   int cell;
 259
 260   if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1;
 261   KLISP_CTYPE(cell) = KLISP_TYPE_NUM;
 262   KLISP_CELL(cell).num = value;
 263
 264   return cell;
 265 }
 266
 267
 268 int KLispNewSym (KLISP_POOL_DEF const char *value) {
 269   int cell;
 270   TKLispRBTNode *sp;
 271
 272   assert(value);
 273
 274   if (*value && !value[1]) return KLISP_POOL->syms[*((unsigned char *)value)];
 275
 276   sp = KLispRBTFind(KLISP_POOL->strpool, value);
 277   if (sp && sp->value0) return sp->value0;
 278
 279   if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1;
 280   if (!sp) {
 281     if (!(sp = KLispRBTInsert(KLISP_POOL->strpool, value, cell, 1, NULL))) return -1;
 282   } else sp->value0 = cell;
 283
 284   KLISP_CTYPE(cell) = KLISP_TYPE_SYM;
 285   KLISP_CELL(cell).str = sp->str;
 286
 287   return cell;
 288 }
 289
 290
 291 int KLispNewXPrim (KLISP_POOL_DEF int prtype, TKLispPrimFn fn, const char *name) {
 292   TKLispRBTNode *sp;
 293   int cell;
 294
 295   assert(name && *name);
 296   switch (prtype) {
 297     case KLISP_TYPE_PRIM: case KLISP_TYPE_MPRIM:
 298     case KLISP_TYPE_IPRIM: case KLISP_TYPE_IMPRIM:
 299       break;
 300     default: return KLispError(KLISP_POOL_ARG "KLispNewXPrim: invalid prim type");
 301   }
 302
 303   sp = KLispRBTFind(KLISP_POOL->primitives, name);
 304   if (!sp) {
 305     if ((cell = AllocCell(KLISP_POOL_ARG0)) < 0) return -1;
 306     if (!(sp = KLispRBTInsert(KLISP_POOL->primitives, name, cell, 1, NULL))) return -1;
 307     KLISP_CELL(cell).str = sp->str;
 308   } else cell = sp->value0;
 309
 310   KLISP_CTYPE(cell) = prtype;
 311   KLISP_CELL(cell).fn = fn;
 312
 313   return cell;
 314 }
 315
 316
 317 int KLispNewSymbolPair (KLISP_POOL_DEF const char *name, int valueCell) {
 318   int sym;
 319
 320   KLISP_GC_FREEZE;
 321   sym = KLispNewSym(KLISP_POOL_ARG name);
 322   if (sym > 0) sym = KLispNewCons(KLISP_POOL_ARG sym, valueCell);
 323   KLISP_GC_UNFREEZE;
 324
 325   return sym;
 326 }
 327
 328
 329 /* UDATA:
 330    car: ptr to cell with some data or nil; cdr: list of methods;
 331    list of methods: car: symbol (name . xPRIM); cdr: next
 332    method args: (udata_obj ...)
 333    call: (udata method ...)
 334 */
 335 int KLispNewUData (KLISP_POOL_DEF void *ptr, TKLispFinalizeFn finalizer) {
 336   int cell;
 337
 338   if ((cell = KLispNewCons(KLISP_POOL_ARG 0, 0)) < 0) return -1;
 339   KLISP_CTYPE(cell) = KLISP_TYPE_UDATA;
 340   KLISP_CELL(cell).finalizer = finalizer;
 341   KLISP_CELL(cell).udata = ptr;
 342
 343   return cell;
 344 }
 345
 346
 347 /* return 0 or method cell */
 348 static int KLispUDataFindMethod (KLISP_POOL_DEF int udata, const char *name) {
 349   int mcell;
 350
 351   if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return -1;
 352   mcell = KLispFindSymbol(KLISP_POOL_ARG KLISP_CDR(udata), name);
 353
 354   return mcell<=0?0:mcell;
 355 }
 356
 357
 358 int KLispUDataGetMethod (KLISP_POOL_DEF int udata, const char *name) {
 359   int sym;
 360
 361   if ((sym = KLispUDataFindMethod(KLISP_POOL_ARG udata, name)) <= 0) return -1;
 362
 363   return KLISP_CDR(sym);
 364 }
 365
 366
 367 int KLispUDataSetMethod (KLISP_POOL_DEF int udata, int methodcell, const char *name) {
 368   int sym, t;
 369
 370   if (methodcell < 0) return -1;
 371   sym = KLispUDataFindMethod(KLISP_POOL_ARG udata, name);
 372   if (sym < 0) return -1;
 373   if (!sym) {
 374     /* create new symbol */
 375     if ((sym = KLispNewSymbolPair(KLISP_POOL_ARG name, methodcell)) < 0) return -1;
 376     /* add it to method list */
 377     KLISP_GC_FREEZE;
 378     t = KLispNewCons(KLISP_POOL_ARG sym, KLISP_CDR(udata));
 379     KLISP_GC_UNFREEZE;
 380     if (t < 0) return -1;
 381     KLISP_CDR(udata) = t;
 382   } else KLISP_CDR(sym) = methodcell;
 383
 384   return sym;
 385 }
 386
 387
 388 void *KLispUDataGetPtr (KLISP_POOL_DEF int udata) {
 389   if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return NULL;
 390
 391   return KLISP_CELL(udata).udata;
 392 }
 393
 394
 395 int KLispUDataSetPtr (KLISP_POOL_DEF int udata, void *ptr) {
 396   if (udata < 2 || KLISP_CTYPE(udata) != KLISP_TYPE_UDATA) return 0;
 397
 398   KLISP_CELL(udata).udata = ptr;
 399
 400   return 1;
 401 }
 402
 403
 404 int KLispRegisterMethods (KLISP_POOL_DEF int udatacell, struct _TKLispPrimItem *list) {
 405   int methodcell, res = 0;
 406
 407   KLISP_GC_FREEZE;
 408   /*if (!KLispPushRoot(KLISP_POOL_ARG udatacell)) return -1;*/
 409   while (list && list->name) {
 410     methodcell = KLispNewXPrim(KLISP_POOL_ARG KLISP_TYPE_MPRIM, list->fn, list->name);
 411     if (methodcell < 0) goto done;
 412     if (KLispUDataSetMethod(KLISP_POOL_ARG udatacell, methodcell, list->name) < 0) goto done;
 413     list++;
 414   }
 415   res = 1;
 416 done:
 417   KLISP_GC_UNFREEZE;
 418   /*KLispPopRoots(KLISP_POOL_ARG 1);*/
 419
 420   return res;
 421 }
 422
 423
 424 #endif /* _KLISP_CORE_MODULE_BODY_ */