pico.h (12909B)
1 /* 01apr08abu 2 * (c) Software Lab. Alexander Burger 3 */ 4 5 #include <stdio.h> 6 #include <stdlib.h> 7 #include <stdarg.h> 8 #include <ctype.h> 9 #include <string.h> 10 #include <errno.h> 11 #include <setjmp.h> 12 13 #define WORD ((int)sizeof(long)) 14 #define BITS (8*WORD) 15 #define CELLS (1024*1024/sizeof(cell)) 16 17 typedef unsigned long word; 18 typedef unsigned char byte; 19 typedef unsigned char *ptr; 20 21 #undef bool 22 typedef enum {NO,YES} bool; 23 24 typedef struct cell { // Pico primary data type 25 struct cell *car; 26 struct cell *cdr; 27 } cell, *any; 28 29 typedef any (*fun)(any); 30 31 typedef struct heap { 32 cell cells[CELLS]; 33 struct heap *next; 34 } heap; 35 36 typedef struct bindFrame { 37 struct bindFrame *link; 38 int i, cnt; 39 struct {any sym; any val;} bnd[1]; 40 } bindFrame; 41 42 typedef struct methFrame { 43 struct methFrame *link; 44 any key, cls; 45 } methFrame; 46 47 typedef struct inFrame { 48 struct inFrame *link; 49 void (*get)(void); 50 FILE *fp; 51 int next; 52 } inFrame; 53 54 typedef struct outFrame { 55 struct outFrame *link; 56 void (*put)(int); 57 FILE *fp; 58 } outFrame; 59 60 typedef struct parseFrame { 61 int i; 62 word w; 63 any sym, nm; 64 } parseFrame; 65 66 typedef struct stkEnv { 67 cell *stack, *arg; 68 bindFrame *bind; 69 methFrame *meth; 70 int next; 71 any make; 72 inFrame *inFiles; 73 outFrame *outFiles; 74 parseFrame *parser; 75 void (*get)(void); 76 void (*put)(int); 77 bool brk; 78 } stkEnv; 79 80 typedef struct catchFrame { 81 struct catchFrame *link; 82 any tag; 83 stkEnv env; 84 jmp_buf rst; 85 } catchFrame; 86 87 /*** Macros ***/ 88 #define Free(p) ((p)->car=Avail, Avail=(p)) 89 90 /* Number access */ 91 #define num(x) ((long)(x)) 92 #define txt(n) ((any)(num(n)<<1|1)) 93 #define box(n) ((any)(num(n)<<2|2)) 94 #define unBox(n) (num(n)>>2) 95 #define Zero ((any)2) 96 #define One ((any)6) 97 98 /* Symbol access */ 99 #define symPtr(x) ((any)&(x)->cdr) 100 #define val(x) ((x)->car) 101 #define tail(x) (((x)-1)->cdr) 102 103 /* Cell access */ 104 #define car(x) ((x)->car) 105 #define cdr(x) ((x)->cdr) 106 #define caar(x) (car(car(x))) 107 #define cadr(x) (car(cdr(x))) 108 #define cdar(x) (cdr(car(x))) 109 #define cddr(x) (cdr(cdr(x))) 110 #define caaar(x) (car(car(car(x)))) 111 #define caadr(x) (car(car(cdr(x)))) 112 #define cadar(x) (car(cdr(car(x)))) 113 #define caddr(x) (car(cdr(cdr(x)))) 114 #define cdaar(x) (cdr(car(car(x)))) 115 #define cdadr(x) (cdr(car(cdr(x)))) 116 #define cddar(x) (cdr(cdr(car(x)))) 117 #define cdddr(x) (cdr(cdr(cdr(x)))) 118 #define cadddr(x) (car(cdr(cdr(cdr(x))))) 119 #define cddddr(x) (cdr(cdr(cdr(cdr(x))))) 120 121 #define data(c) ((c).car) 122 #define Save(c) ((c).cdr=Env.stack, Env.stack=&(c)) 123 #define drop(c) (Env.stack=(c).cdr) 124 #define Push(c,x) (data(c)=(x), Save(c)) 125 #define Pop(c) (drop(c), data(c)) 126 127 #define Bind(s,f) ((f).i=0, (f).cnt=1, (f).bnd[0].sym=(s), (f).bnd[0].val=val(s), (f).link=Env.bind, Env.bind=&(f)) 128 #define Unbind(f) (val((f).bnd[0].sym)=(f).bnd[0].val, Env.bind=(f).link) 129 130 /* Predicates */ 131 #define isNil(x) ((x)==Nil) 132 #define isTxt(x) (num(x)&1) 133 #define isNum(x) (num(x)&2) 134 #define isSym(x) (num(x)&WORD) 135 #define isSymb(x) ((num(x)&(WORD+2))==WORD) 136 #define isCell(x) (!(num(x)&(2*WORD-1))) 137 138 /* Evaluation */ 139 #define EVAL(x) (isNum(x)? x : isSym(x)? val(x) : evList(x)) 140 #define evSubr(f,x) (*(fun)(num(f) & ~2))(x) 141 142 /* Error checking */ 143 #define NeedNum(ex,x) if (!isNum(x)) numError(ex,x) 144 #define NeedSym(ex,x) if (!isSym(x)) symError(ex,x) 145 #define NeedSymb(ex,x) if (!isSymb(x)) symError(ex,x) 146 #define NeedCell(ex,x) if (!isCell(x)) cellError(ex,x) 147 #define NeedAtom(ex,x) if (isCell(x)) atomError(ex,x) 148 #define NeedLst(ex,x) if (!isCell(x) && !isNil(x)) lstError(ex,x) 149 #define NeedVar(ex,x) if (isNum(x)) varError(ex,x) 150 #define CheckVar(ex,x) if ((x)>=Nil && (x)<=T) protError(ex,x) 151 152 /* Globals */ 153 extern int Chr, Trace; 154 extern char **AV, *Home; 155 extern heap *Heaps; 156 extern cell *Avail; 157 extern stkEnv Env; 158 extern catchFrame *CatchPtr; 159 extern FILE *InFile, *OutFile; 160 extern any TheKey, TheCls; 161 extern any Intern[2], Transient[2], Reloc; 162 extern any ApplyArgs, ApplyBody; 163 extern any Nil, Meth, Quote, T, At, At2, At3, This; 164 extern any Dbg, Scl, Class, Up, Err, Rst, Msg, Bye; 165 166 /* Prototypes */ 167 void *alloc(void*,size_t); 168 any apply(any,any,bool,int,cell*); 169 void argError(any,any) __attribute__ ((noreturn)); 170 void atomError(any,any) __attribute__ ((noreturn)); 171 void begString(void); 172 any boxSubr(fun); 173 void brkLoad(any); 174 int bufNum(char[BITS/2],long); 175 int bufSize(any); 176 void bufString(any,char*); 177 void bye(int) __attribute__ ((noreturn)); 178 void cellError(any,any) __attribute__ ((noreturn)); 179 int compare(any,any); 180 any cons(any,any); 181 any consName(word,any); 182 any consSym(any,word); 183 void crlf(void); 184 any endString(void); 185 bool equal(any,any); 186 void err(any,any,char*,...) __attribute__ ((noreturn)); 187 any evExpr(any,any); 188 any evList(any); 189 long evNum(any,any); 190 any evSym(any); 191 void execError(char*) __attribute__ ((noreturn)); 192 int firstByte(any); 193 any get(any,any); 194 int getByte(int*,word*,any*); 195 int getByte1(int*,word*,any*); 196 void getStdin(void); 197 void giveup(char*) __attribute__ ((noreturn)); 198 void heapAlloc(void); 199 void initSymbols(void); 200 any intern(any,any[2]); 201 bool isBlank(any); 202 any isIntern(any,any[2]); 203 void lstError(any,any) __attribute__ ((noreturn)); 204 any load(any,int,any); 205 any method(any); 206 any mkChar(int); 207 any mkChar2(int,int); 208 any mkSym(byte*); 209 any mkStr(char*); 210 any mkTxt(int); 211 any name(any); 212 int numBytes(any); 213 void numError(any,any) __attribute__ ((noreturn)); 214 any numToSym(any,int,int,int); 215 void outName(any); 216 void outNum(long); 217 void outString(char*); 218 void pack(any,int*,word*,any*,cell*); 219 int pathSize(any); 220 void pathString(any,char*); 221 void popInFiles(void); 222 void popOutFiles(void); 223 any popSym(int,word,any,cell*); 224 void prin(any); 225 void print(any); 226 void protError(any,any) __attribute__ ((noreturn)); 227 void pushInFiles(inFrame*); 228 void pushOutFiles(outFrame*); 229 any put(any,any,any); 230 void putByte(int,int*,word*,any*,cell*); 231 void putByte0(int*,word*,any*); 232 void putByte1(int,int*,word*,any*); 233 void putStdout(int); 234 void rdOpen(any,any,inFrame*); 235 any read1(int); 236 int secondByte(any); 237 void space(void); 238 int symBytes(any); 239 void symError(any,any) __attribute__ ((noreturn)); 240 any symToNum(any,int,int,int); 241 void undefined(any,any); 242 void unintern(any,any[2]); 243 void unwind (catchFrame*); 244 void varError(any,any) __attribute__ ((noreturn)); 245 void wrOpen(any,any,outFrame*); 246 long xNum(any,any); 247 any xSym(any); 248 249 any doAbs(any); 250 any doAdd(any); 251 any doAll(any); 252 any doAnd(any); 253 any doAny(any); 254 any doAppend(any); 255 any doApply(any); 256 any doArg(any); 257 any doArgs(any); 258 any doArgv(any); 259 any doAsoq(any); 260 any doAs(any); 261 any doAssoc(any); 262 any doAt(any); 263 any doAtom(any); 264 any doBind(any); 265 any doBitAnd(any); 266 any doBitOr(any); 267 any doBitQ(any); 268 any doBitXor(any); 269 any doBool(any); 270 any doBox(any); 271 any doBoxQ(any); 272 any doBreak(any); 273 any doBy(any); 274 any doBye(any) __attribute__ ((noreturn)); 275 any doCaaar(any); 276 any doCaadr(any); 277 any doCaar(any); 278 any doCadar(any); 279 any doCadddr(any); 280 any doCaddr(any); 281 any doCadr(any); 282 any doCar(any); 283 any doCase(any); 284 any doCatch(any); 285 any doCdaar(any); 286 any doCdadr(any); 287 any doCdar(any); 288 any doCddar(any); 289 any doCddddr(any); 290 any doCdddr(any); 291 any doCddr(any); 292 any doCdr(any); 293 any doChain(any); 294 any doChar(any); 295 any doChop(any); 296 any doCirc(any); 297 any doClip(any); 298 any doCnt(any); 299 any doCol(any); 300 any doCon(any); 301 any doConc(any); 302 any doCond(any); 303 any doCons(any); 304 any doCopy(any); 305 any doCut(any); 306 any doDate(any); 307 any doDe(any); 308 any doDec(any); 309 any doDef(any); 310 any doDefault(any); 311 any doDel(any); 312 any doDelete(any); 313 any doDelq(any); 314 any doDiff(any); 315 any doDiv(any); 316 any doDm(any); 317 any doDo(any); 318 any doE(any); 319 any doEnv(any); 320 any doEof(any); 321 any doEol(any); 322 any doEq(any); 323 any doEqual(any); 324 any doEqual0(any); 325 any doEqualT(any); 326 any doEval(any); 327 any doExtra(any); 328 any doFifo(any); 329 any doFill(any); 330 any doFilter(any); 331 any doFin(any); 332 any doFinally(any); 333 any doFind(any); 334 any doFish(any); 335 any doFlgQ(any); 336 any doFlip(any); 337 any doFlush(any); 338 any doFold(any); 339 any doFor(any); 340 any doFormat(any); 341 any doFrom(any); 342 any doFull(any); 343 any doFunQ(any); 344 any doGc(any); 345 any doGe(any); 346 any doGe0(any); 347 any doGet(any); 348 any doGetl(any); 349 any doGlue(any); 350 any doGt(any); 351 any doGt0(any); 352 any doHead(any); 353 any doHeap(any); 354 any doHide(any); 355 any doIdx(any); 356 any doIf(any); 357 any doIf2(any); 358 any doIfn(any); 359 any doIn(any); 360 any doInc(any); 361 any doIndex(any); 362 any doIntern(any); 363 any doIsa(any); 364 any doJob(any); 365 any doLast(any); 366 any doLe(any); 367 any doLength(any); 368 any doLet(any); 369 any doLetQ(any); 370 any doLine(any); 371 any doLink(any); 372 any doList(any); 373 any doLit(any); 374 any doLstQ(any); 375 any doLoad(any); 376 any doLookup(any); 377 any doLoop(any); 378 any doLowQ(any); 379 any doLowc(any); 380 any doLt(any); 381 any doLt0(any); 382 any doLup(any); 383 any doMade(any); 384 any doMake(any); 385 any doMap(any); 386 any doMapc(any); 387 any doMapcan(any); 388 any doMapcar(any); 389 any doMapcon(any); 390 any doMaplist(any); 391 any doMaps(any); 392 any doMatch(any); 393 any doMax(any); 394 any doMaxi(any); 395 any doMember(any); 396 any doMemq(any); 397 any doMeta(any); 398 any doMeth(any); 399 any doMethod(any); 400 any doMin(any); 401 any doMini(any); 402 any doMix(any); 403 any doMmeq(any); 404 any doMul(any); 405 any doMulDiv(any); 406 any doName(any); 407 any doNand(any); 408 any doNEq(any); 409 any doNEq0(any); 410 any doNEqT(any); 411 any doNEqual(any); 412 any doNeed(any); 413 any doNew(any); 414 any doNext(any); 415 any doNil(any); 416 any doNond(any); 417 any doNor(any); 418 any doNot(any); 419 any doNth(any); 420 any doNumQ(any); 421 any doOff(any); 422 any doOffset(any); 423 any doOn(any); 424 any doOne(any); 425 any doOnOff(any); 426 any doOpt(any); 427 any doOr(any); 428 any doOut(any); 429 any doPack(any); 430 any doPair(any); 431 any doPass(any); 432 any doPath(any); 433 any doPatQ(any); 434 any doPeek(any); 435 any doPick(any); 436 any doPop(any); 437 any doPreQ(any); 438 any doPrin(any); 439 any doPrinl(any); 440 any doPrint(any); 441 any doPrintln(any); 442 any doPrintsp(any); 443 any doProg(any); 444 any doProg1(any); 445 any doProg2(any); 446 any doProp(any); 447 any doPropCol(any); 448 any doProve(any); 449 any doPush(any); 450 any doPush1(any); 451 any doPut(any); 452 any doPutl(any); 453 any doQueue(any); 454 any doQuit(any); 455 any doQuote(any); 456 any doRand(any); 457 any doRank(any); 458 any doRead(any); 459 any doRem(any); 460 any doReplace(any); 461 any doRest(any); 462 any doReverse(any); 463 any doRot(any); 464 any doRun(any); 465 any doSave(any); 466 any doSect(any); 467 any doSeed(any); 468 any doSeek(any); 469 any doSemicol(any); 470 any doSend(any); 471 any doSet(any); 472 any doSetCol(any); 473 any doSetq(any); 474 any doShift(any); 475 any doSize(any); 476 any doSkip(any); 477 any doSort(any); 478 any doSpace(any); 479 any doSplit(any); 480 any doSpQ(any); 481 any doSqrt(any); 482 any doState(any); 483 any doStem(any); 484 any doStk(any); 485 any doStr(any); 486 any doStrip(any); 487 any doStrQ(any); 488 any doSub(any); 489 any doSum(any); 490 any doSuper(any); 491 any doSym(any); 492 any doSymQ(any); 493 any doT(any); 494 any doTail(any); 495 any doText(any); 496 any doThrow(any); 497 any doTill(any); 498 any doTrace(any); 499 any doTrim(any); 500 any doTry(any); 501 any doType(any); 502 any doUnify(any); 503 any doUnless(any); 504 any doUntil(any); 505 any doUp(any); 506 any doUppQ(any); 507 any doUppc(any); 508 any doUse(any); 509 any doVal(any); 510 any doWhen(any); 511 any doWhile(any); 512 any doWith(any); 513 any doXchg(any); 514 any doXor(any); 515 any doYoke(any); 516 any doZap(any); 517 any doZero(any); 518 519 /* List element access */ 520 static inline any nCdr(int n, any x) { 521 while (--n >= 0) 522 x = cdr(x); 523 return x; 524 } 525 526 static inline any nth(int n, any x) { 527 if (--n < 0) 528 return Nil; 529 return nCdr(n,x); 530 } 531 532 static inline any getn(any x, any y) { 533 if (isNum(x)) { 534 long n = unBox(x); 535 536 if (n < 0) { 537 while (++n) 538 y = cdr(y); 539 return cdr(y); 540 } 541 if (n == 0) 542 return Nil; 543 while (--n) 544 y = cdr(y); 545 return car(y); 546 } 547 do 548 if (isCell(car(y)) && x == caar(y)) 549 return cdar(y); 550 while (isCell(y = cdr(y))); 551 return Nil; 552 } 553 554 /* List length calculation */ 555 static inline int length(any x) { 556 int n; 557 558 for (n = 0; isCell(x); x = cdr(x)) 559 ++n; 560 return n; 561 } 562 563 /* Membership */ 564 static inline any member(any x, any y) { 565 any z = y; 566 567 while (isCell(y)) { 568 if (equal(x, car(y))) 569 return y; 570 if (z == (y = cdr(y))) 571 return NULL; 572 } 573 return isNil(y) || !equal(x,y)? NULL : y; 574 } 575 576 static inline any memq(any x, any y) { 577 any z = y; 578 579 while (isCell(y)) { 580 if (x == car(y)) 581 return y; 582 if (z == (y = cdr(y))) 583 return NULL; 584 } 585 return isNil(y) || x != y? NULL : y; 586 } 587 588 static inline int indx(any x, any y) { 589 int n = 1; 590 any z = y; 591 592 while (isCell(y)) { 593 if (equal(x, car(y))) 594 return n; 595 ++n; 596 if (z == (y = cdr(y))) 597 return 0; 598 } 599 return 0; 600 } 601 602 /* List interpreter */ 603 static inline any prog(any x) { 604 any y; 605 606 do 607 y = EVAL(car(x)); 608 while (isCell(x = cdr(x))); 609 return y; 610 } 611 612 static inline any run(any x) { 613 any y; 614 cell at; 615 616 Push(at,val(At)); 617 do 618 y = EVAL(car(x)); 619 while (isCell(x = cdr(x))); 620 val(At) = Pop(at); 621 return y; 622 }