1 /*
2 * SketchyLISP -- An interpreter for purely applicative Scheme
3 * Copyright (C) 2005,2006,2007 Nils M Holm <nmh@t3x.org>
4 * Derived from ArrowLISP, Copyright (C) 1998-2005 Nils M Holm.
5 * See the file LICENSE for conditions of use.
6 */
7
8 #include <stdlib.h>
9 #ifdef __TURBOC__
10 #include <io.h>
11 #include <alloc.h>
12 #else
13 #include <unistd.h>
14 #ifndef __MINGW32__
15 #ifndef __CYGWIN__
16 #define setmode(fd, mode)
17 #endif
18 #endif
19 #endif
20 #include <stdio.h>
21 #include <string.h>
22 #include <ctype.h>
23 #include <fcntl.h>
24 #include <time.h>
25
26 #define __SKETCHYLIB__
27 #include "sketchy.h"
28
29 #define TEXTLEN SK_TEXTLEN
30 #define MAXPATHL SK_MAXPATHL
31
32 #define NROOT 13 /* Number of GC roots */
33
34 /* Tag Masks */
35 #define AFLAG 0x01 /* Atom flag, Car = char, CDR = next */
36 #define MFLAG 0x02 /* Mark flag of garbage collector */
37 #define SFLAG 0x04 /* State flag of garbage collector */
38 #define XFLAG 0x08 /* Extended type flag */
39
40 #define EOT SK_EOT /* EOT indicator */
41 #define DOT -2 /* Internal: dot character */
42 #define RPAREN -3 /* Internal: right parenthesis */
43
44 /* Evaluator states */
45 #define MATOM '0' /* Processing Atom */
46 #define MLIST '1' /* Processing List */
47 #define MBETA '2' /* Beta-reducing */
48 #define MBIND '3' /* Processing bindings of LET */
49 #define MBINR '4' /* Processing bindings of LETREC */
50 #define MLETR '5' /* Finish LET or LETREC */
51 #define MCOND '6' /* Processing predicates of COND */
52 #define MCONJ '7' /* Processing arguments of AND */
53 #define MDISJ '8' /* Processing arguments of OR */
54 #define MIFPR '9' /* Processing predicate of IF */
55 #define MBEGN 'A' /* Processing BEGIN */
56
57 /* Short cut */
58 #define NOEXPR SK_NOEXPR
59
60 static int PoolSize, VPoolSize; /* Sizes of node and vector pool */
61 static int NIL; /* Not In List (or Pool) */
62 static int *Car, /* Vector holding CAR fields */
63 *Cdr; /* Vector holding CDR fields */
64 static char *Tag; /* Vector holding TAG fields */
65 static int *Vpool; /* Vector pool */
66 static int Vptr; /* Free space pointer of Vpool */
67 static char Infile[MAXPATHL]; /* Input file name */
68 static char DirName[MAXPATHL]; /* Source directory */
69 static char LocPath[MAXPATHL]; /* Buffer for findSource() */
70 static char ExpPath[MAXPATHL]; /* Expanded path of input file */
71 static char Path[MAXPATHL]; /* Path to input file */
72 static FILE *Input; /* Current input stream */
73 static int Rejected; /* Unread character */
74 static char *InputString; /* READ-FROM-STRING pointer */
75 static int Line; /* Input line number */
76 static FILE *Output; /* Current output stream */
77 static char *OutputString; /* WRITE-TO-STRING buffer */
78 static int OutStrSize; /* Chars left in OutputString */
79 static int Mstack, Lstack; /* Mode stack, List stack */
80 static int Bstack; /* Binding stack, used by LET/LETREC */
81 static int Estack; /* Env. stack, for fixing closures */
82 static int Free; /* Freelist */
83 static int Symbols; /* Symbol table */
84 static int Packages; /* Package list */
85 static int Transformers; /* Syntax transformers */
86 static int Digits[10]; /* Digit symbols */
87 static int SafeSymbols; /* Safe copy of symbols */
88 static int Stack, Stack0; /* Global stack, bottom of Stack */
89 static int Frame; /* Current call frame */
90 static int Tmp, Tmp2; /* Safe locations */
91 static int SafeCar, SafeCdr; /* Safe harbours during allocation */
92 static int *Root[NROOT]; /* GC Roots */
93 static int Level; /* Nesting level during input */
94 static int LoadLev; /* Nesting level of LOAD */
95 static int EvLev; /* Number of nested EVALs */
96 static int FatalFlag; /* Fatal error flag */
97 static int Function; /* Name of current lambda function */
98 static int Quoted; /* Quote flag of PRINT */
99 static int DisplayMode; /* Display Mode flag of PRINT */
100 static int SyntaxMode; /* Syntax Definition Mode flag */
101 static unsigned GensymCounter; /* Unique symbol id */
102 static int MaxAtoms, MaxCells; /* Memory use gauge */
103 static int Ntrace; /* Max fns to print in call trace */
104 static int LexEnv; /* Environment for creating closures */
105 static int Bound; /* Variables bound in a closure */
106
107 /* Builtin symbol pointers (for fast lookup) */
108 static int S_bottom, S_char, S_closure, S_core, S_defineSyntax,
109 S_else, S_eof, S_false, S_gensym, S_integer, S_lambda,
110 S_primitive, S_quote, S_special, S_special_cbv,
111 S_string, S_syntax, S_true, S_undefined, S_user_primitive,
112 S_vector, S_void, S_voidSym, S_last, S_0, S_1, S_2, S_3,
113 S_4, S_5, S_6, S_7, S_8, S_9;
114
115 /* Primitive function opcodes */
116 enum { P_BOTTOM, P_CAR, P_CDR, P_CHAR_TO_INTEGER, P_CHAR_CI_EQP,
117 P_CHAR_CI_GEP, P_CHAR_CI_GTP, P_CHAR_CI_LEP, P_CHAR_CI_LTP,
118 P_CHAR_EQP, P_CHAR_GEP, P_CHAR_GTP, P_CHAR_LTP, P_CHAR_LEP,
119 P_CHARP, P_CONS, P_DELETE_FILE, P_DISPLAY, P_EOF_OBJECTP, P_EQP,
120 P_GENSYM, P_INTEGER_TO_CHAR, P_INTEGER_TO_LIST, P_LIST_TO_INTEGER,
121 P_LIST_TO_STRING, P_LIST_TO_VECTOR, P_LOAD, P_NLESS, P_NMINUS,
122 P_NPLUS, P_NULLP, P_NUMBERP, P_PACKAGE, P_PAIRP, P_PEEK_CHAR,
123 P_PROCEDUREP, P_READ, P_READ_CHAR, P_READ_FROM_STRING,
124 P_RECURSIVE_BIND, P_REQUIRE, P_STRING_TO_LIST, P_STRING_TO_SYMBOL,
125 P_STRING_APPEND, P_STRING_LENGTH, P_STRING_REF, P_STRINGP,
126 P_SUBSTRING, P_SYMBOL_TO_STRING, P_SYMBOLP, P_SYNTAX_OF,
127 P_VECTOR_TO_LIST, P_VECTOR_LENGTH, P_VECTOR_REF, P_VECTORP,
128 P_VOID, P_WRITE, P_WRITE_CHAR, P_WRITE_TO_STRING, N_PRIMITIVES };
129
130 /* Primitive function pointers. */
131 static int (*Primitives[N_PRIMITIVES])(int);
132
133 /* Special form opcodes */
134 enum { SF_AND, SF_APPLY, SF_BEGIN, SF_COND, SF_DEFINE, SF_DEFINE_SYNTAX,
135 SF_EVAL, SF_IF, SF_LAMBDA, SF_LET, SF_LETREC, SF_OR, SF_QUOTE,
136 SF_SYNTAX_RULES, SF_WITH_INPUT_FROM_FILE, SF_WITH_OUTPUT_TO_FILE,
137 N_SPECIALS };
138
139 /* Special form handler pointers */
140 static int (*Specials[N_SPECIALS])(int, int *, int *, int *);
141
142 /* Pointers to functions handling user-supplied primitives. */
143 static int (*UsrPrimitives[SK_MAX_USER_PRIMITIVES])(int);
144 static int LastUsrPrimitive; /* # of user primitives */
145
146 /* LINT: unused args in special form handlers */
147 #define USE(arg) arg = 0
148
149 /*
150 * Prototypes
151 */
152 static int addPackage(int sym);
153 static int addPrim(char *name, int opcode);
154 static int addSpecial(char *name, int opcode, int cbv);
155 static int addSym(char *s, int v);
156 static int alloc3(int pcar, int pcdr, int ptag);
157 static int allocv(int type, int size);
158 static int badArgLst(int n);
159 static int bindArgs(int n, int name);
160 static void bindLet(int env);
161 static int bunsave(int k);
162 static void cacheDigits(void);
163 static int character(void);
164 static int charPred(int n, int pred, char *msg);
165 static void clearStats(void);
166 static int closure(int n);
167 static void collect(int n);
168 static int copyBindings(void);
169 static int digitToValue(int n);
170 static int doAnd(int n, int *pcf, int *pmode, int *pcbn);
171 static int doApply(int n, int *pcf, int *pmode, int *pcbn);
172 static int doBegin(int n, int *pcf, int *pmode, int *pcbn);
173 static int doBottom(int n);
174 static int doCar(int n);
175 static int doCdr(int n);
176 static int doCharCiEqP(int n);
177 static int doCharCiGEP(int n);
178 static int doCharCiGtP(int n);
179 static int doCharCiLEP(int n);
180 static int doCharCiLtP(int n);
181 static int doCharEqP(int n);
182 static int doCharGtP(int n);
183 static int doCharGEP(int n);
184 static int doCharLtP(int n);
185 static int doCharLEP(int n);
186 static int doCharP(int n);
187 static int doCharToInteger(int n);
188 static int doCond(int n, int *pcf, int *pmode, int *pcbn);
189 static int doCons(int n);
190 static int doDefine(int n, int *pcf, int *pmode, int *pcbn);
191 static int doDefineSyntax(int n, int *pcf, int *pmode, int *pcbn);
192 static int doDeleteFile(int n);
193 static int doDisplay(int n);
194 static int doEofObjectP(int n);
195 static int doEqP(int n);
196 static int doEval(int n, int *pcf, int *pmode, int *pcbn);
197 static int doGensym(int n);
198 static int doIf(int n, int *pcf, int *pmode, int *pcbn);
199 static int doIntegerToChar(int n);
200 static int doIntegerToList(int n);
201 static int doLambda(int n, int *pcf, int *pmode, int *pcbn);
202 static int doLet(int n, int *pcf, int *pmode, int *pcbn);
203 static int doLetrec(int n, int *pcf, int *pmode, int *pcbn);
204 static int doListToInteger(int n);
205 static int doListToString(int n);
206 static int doNLess(int n);
207 static int doNMinus(int n);
208 static int doNPlus(int n);
209 static int doNullP(int n);
210 static int doNumberP(int n);
211 static int doOr(int n, int *pcf, int *pmode, int *pcbn);
212 static int doPackage(int n);
213 static int doPairP(int n);
214 static int doPeekChar(int n);
215 static int doProcedureP(int n);
216 static int doQuote(int n, int *pcf, int *pmode, int *pcbn);
217 static int doRead(int n);
218 static int doReadChar(int n);
219 static int doReadFromString(int n);
220 static int doRecursiveBind(int n);
221 static int doStringAppend(int n);
222 static int doStringLength(int n);
223 static int doStringP(int n);
224 static int doStringRef(int n);
225 static int doStringToList(int n);
226 static int doStringToSymbol(int n);
227 static int doSubstring(int n);
228 static int doSymbolP(int n);
229 static int doSymbolToString(int n);
230 static int doSyntaxToList(int n);
231 static int doVoid(int n);
232 static int doWithInputFromFile(int n, int *pcf, int *pmode, int *pcbn);
233 static int doWithOutputToFile(int n, int *pcf, int *pmode, int *pcbn);
234 static int doWrite(int n);
235 static int doWriteChar(int n);
236 static int doWriteToString(int n);
237 #ifdef DEBUG
238 static void dumpState(char *s, int m);
239 #endif
240 static int equals(int n, int m);
241 static int error(char *m, int n);
242 static int eval(int n);
243 static int evalClause(int n);
244 static int evalLet(void);
245 static char *expandPath(char *s);
246 static int explodeNum(char *s);
247 static int explodeStr(char *s);
248 static void fatal(char *m);
249 static int findPackage(int sym);
250 static int findPsym(char *s, int y);
251 static int findSym(char *s);
252 static int findTransformer(int y);
253 static int finishLet(int rec);
254 static void fixAllClosures(int b);
255 static void fixCachedClosures(void);
256 static void fixClosuresOf(int n, int bindings);
257 static void fixNIL(int *p, int nilval);
258 static int flatCopy(int n, int *lastp);
259 static int gc(void);
260 static void gcv(void);
261 static void getDirName(char *path, char *pfx);
262 static int getFactors(char *msg, int n, int *p1, int *p2);
263 static int getPred(void);
264 static char *implodeStr(int m, int k, char *s);
265 static void init1(void);
266 static void init2(void);
267 static void mark(int n);
268 static int isAlist(int n);
269 static int isBound(int n);
270 static int isSymList(int m);
271 static int length(int n);
272 static int list_to_vector(int m, char *msg);
273 static int localize(int n, int *exprp);
274 static char *locase(char *s);
275 static int lunsave(int k);
276 static void markVec(int n, int type);
277 static int mkLexEnv(int term, int locals);
278 static int munsave(void);
279 static int nestedComment(void);
280 static int newDefine(int n);
281 static int nextLet(int n);
282 static void nl(void);
283 static int nreverse(int n);
284 static int numericStr(char *s);
285 static void pr(char *s);
286 #ifdef DEBUG
287 static void prDepth(int n);
288 #endif
289 static int primitive(int *np);
290 static void _print(int n);
291 static int printChar(int n);
292 static int printClosure(int n);
293 static int printNum(int n);
294 static int printPrim(int n);
295 static int printQuote(int n);
296 static int printSpecial(int n);
297 static int printString(int n);
298 static void printTrace(int n);
299 static void prnum(int n, int w);
300 static void _prnum(int n, int w, char *spaces);
301 static void prznum(int n, int w);
302 static int quote(int n);
303 static int rdch(void); int c;
304 static int readList(void);
305 static int readVector(void);
306 static void registerTransformer(int y, int tr);
307 static void REL(void);
308 static void resetState(void);
309 static void restoreBindings(int values);
310 static int reverse(int n);
311 static int safe_eval(int n);
312 static void setErrArg(char *s);
313 static int setupCond(int n);
314 static int setupLet(int n);
315 static int setupLogOp(int n);
316 static int special(int *np, int *pcf, int *pmode, int *pcbn);
317 static int stringLiteral(void);
318 static void subst(int old, int new, int *p);
319 static int symOrNum(int c);
320 static int syntaxTransform(int n);
321 static int _syntaxTransform(int n);
322 static int tagged(int n);
323 static void tailCall(void);
324 static void unbindArgs(void);
325 static void unmarkVecs(void);
326 static int unreadable(void);
327 static int unsave(int k);
328 static void updatePackages(int old, int new);
329 static int valueOf(char *src, int n);
330 static int valueToDigit(int n);
331 static void verify(void);
332 static int wrongArgs(int n);
333 static int xread(void);
334
335 /* string node --> string text */
336 #define string(n) ((char *) &Vpool[Car[Cdr[n]]])
337
338 /* string node --> string length */
339 #define string_len(n) (Vpool[Car[Cdr[n]] - 1])
340
341 /* Size of vector in chars --> size in ints */
342 #define vector_size(k) (((k) + sizeof(int)-1) / sizeof(int) + 2)
343
344 /* vector node --> vector elements */
345 #define vector(n) (&Vpool[Car[Cdr[n]]])
346
347 /* Number of vector elements */
348 #define vector_len(n) (vector_size(string_len(n)) - 2)
349
350 /* Nested lists... */
351 #define caar(x) (Car[Car[x]])
352 #define cadr(x) (Car[Cdr[x]])
353 #define cdar(x) (Cdr[Car[x]])
354 #define cddr(x) (Cdr[Cdr[x]])
355 #define caaar(x) (Car[Car[Car[x]]])
356 #define caadr(x) (Car[Car[Cdr[x]]])
357 #define cadar(x) (Car[Cdr[Car[x]]])
358 #define caddr(x) (Car[Cdr[Cdr[x]]])
359 #define cddar(x) (Cdr[Cdr[Car[x]]])
360 #define cdddr(x) (Cdr[Cdr[Cdr[x]]])
361 #define caddar(x) (Car[Cdr[Cdr[Car[x]]]])
362 #define cadddr(x) (Car[Cdr[Cdr[Cdr[x]]]])
363
364 /*
365 * Print the string S through a buffered interface.
366 * If OutputString is not NULL, write to that string.
367 */
pr(char * s)368 static void pr(char *s) {
369 int k;
370
371 if (OutputString) {
372 k = strlen(s);
373 if (OutStrSize - k < 1)
374 fatal("doWriteToString(): out of vector space");
375 strcpy(OutputString, s);
376 OutputString += k;
377 OutStrSize -= k;
378 return;
379 }
380 fputs(s, Output);
381 }
382
383 /* pr() wrapper */
sk_pr(char * s)384 void sk_pr(char *s) {
385 pr(s);
386 }
387
388 /*
389 * Print a number with leading characters.
390 * w = total width;
391 * spaces must hold >=w padding characters.
392 */
_prnum(int n,int w,char * spaces)393 static void _prnum(int n, int w, char *spaces) {
394 char b[20];
395 int k;
396
397 sprintf(b, "%d", n);
398 k = strlen(b);
399 if (k < w) pr(&spaces[k]);
400 pr(b);
401 }
402
403 /* Print number with leading spaces. */
prnum(int n,int w)404 static void prnum(int n, int w) {
405 _prnum(n, w, " ");
406 }
407
408 /* prnum() wrapper */
sk_prnum(int n,int w)409 void sk_prnum(int n, int w) {
410 prnum(n, w);
411 }
412
413 /* Print number with leading zeroes. */
prznum(int n,int w)414 static void prznum(int n, int w) {
415 _prnum(n, w, "000");
416 }
417
418 /* Emit a newline sequence and flush the output buffer. */
nl(void)419 static void nl(void) {
420 putc('\n', Output);
421 if (Output == stdout) fflush(Output);
422 }
423
424 /* nl() wrapper */
sk_nl(void)425 void sk_nl(void) {
426 nl();
427 }
428
429 /* Convert string to lower case. */
locase(char * s)430 static char *locase(char *s) {
431 int k, i;
432
433 k = strlen(s);
434 for (i=0; i<k; i++)
435 if ('A' <= s[i] && s[i] <= 'Z')
436 s[i] = s[i] + ('a' - 'A');
437 return s;
438 }
439
440 /* Print function names on call stack */
sk_printCallTrace(int frame)441 void sk_printCallTrace(int frame) {
442 int s, n;
443
444 s = frame;
445 n = Ntrace;
446 while (s != NIL) {
447 if (!n || Cdr[s] == NIL || cadr(s) == NIL) break;
448 if (n == Ntrace) pr("* Trace:");
449 n = n-1;
450 pr(" ");
451 Quoted = 1;
452 _print(cadr(s));
453 s = Car[s];
454 }
455 if (n != Ntrace) nl();
456 }
457
458 /* Register error message M and set SK_errFlag. */
error(char * m,int n)459 static int error(char *m, int n) {
460 if (SK_errFlag) return NIL;
461 SK_errMsg = m;
462 SK_errExpr = n;
463 strcpy(SK_errFile, Infile);
464 SK_errLine = Line;
465 SK_errFun = Function;
466 SK_errFrame = Frame;
467 SK_errFlag = -1;
468 return NIL;
469 }
470
471 /* error() wrapper */
sk_error(char * m,int n)472 int sk_error(char *m, int n) {
473 return error(m, n);
474 }
475
476 /* Clear error condition */
sk_gotError(void)477 void sk_gotError(void) {
478 SK_errFlag = 0;
479 SK_errFun = NIL;
480 SK_errFrame = NIL;
481 SK_errExpr = NIL;
482 SK_errArg[0] = 0;
483 }
484
setErrArg(char * s)485 void setErrArg(char *s) {
486 memset(SK_errArg, 0, TEXTLEN);
487 strncpy(SK_errArg, s, TEXTLEN-1);
488 }
489
490 /* Print error message registered by error() */
sk_printError(void)491 void sk_printError(void) {
492 pr("* ");
493 if (SK_errFile[0]) {
494 pr(SK_errFile);
495 pr(": ");
496 }
497 prnum(SK_errLine, 0);
498 pr(": ");
499 if (SK_errFun != NIL) {
500 Quoted = 1;
501 _print(SK_errFun);
502 }
503 else {
504 pr("REPL");
505 }
506 pr(": ");
507 pr(SK_errMsg);
508 if (SK_errExpr != -1) {
509 if (SK_errMsg[0]) pr(": ");
510 Quoted = 1;
511 _print(SK_errExpr);
512 }
513 nl();
514 if (SK_errArg[0]) {
515 pr("* ");
516 pr(SK_errArg); nl();
517 }
518 if (!FatalFlag && SK_errFrame != NIL && SK_errFun != NIL)
519 sk_printCallTrace(SK_errFrame);
520 sk_gotError();
521 }
522
523 /* Print message M and halt the interpreter. */
fatal(char * m)524 static void fatal(char *m) {
525 OutputString = NULL;
526 InputString = NULL;
527 SK_errFlag = 0;
528 FatalFlag = -1;
529 error(m, NOEXPR);
530 sk_printError();
531 pr("* Fatal error, aborting");
532 nl();
533 exit(1);
534 }
535
536 /* Reset counter. */
sk_resetCounter(struct sk_counter * c)537 void sk_resetCounter(struct sk_counter *c) {
538 c->n = 0;
539 c->n1k = 0;
540 c->n1m = 0;
541 c->n1g = 0;
542 }
543
544 /* Increment counter by K. K must be <= 1000. */
sk_count(struct sk_counter * c,int k)545 void sk_count(struct sk_counter *c, int k) {
546 char *msg = "statistics counter overflow";
547
548 c->n = c->n+k;
549 if (c->n >= 1000) {
550 c->n = c->n - 1000;
551 c->n1k = c->n1k + 1;
552 if (c->n1k >= 1000) {
553 c->n1k = 0;
554 c->n1m = c->n1m+1;
555 if (c->n1m >= 1000) {
556 c->n1m = 0;
557 c->n1g = c->n1g+1;
558 if (c->n1g >= 1000) {
559 error(msg, NOEXPR);
560 }
561 }
562 }
563 }
564 }
565
566 /* Print counter value. */
sk_printCounter(struct sk_counter * c)567 void sk_printCounter(struct sk_counter *c) {
568 if (c->n1g) {
569 prznum(c->n1g, 0); pr(",");
570 }
571 if (c->n1m || c->n1g) {
572 prznum(c->n1m, c->n1g?3:0); pr(",");
573 }
574 if (c->n1k || c->n1m || c->n1g) {
575 prznum(c->n1k, (c->n1m||c->n1g)?3:0); pr(",");
576 }
577 prznum(c->n, (c->n1k||c->n1m||c->n1g)?3:0);
578 }
579
580 /* Mark object at offset N in the Vpool */
markVec(int n,int type)581 static void markVec(int n, int type) {
582 int *p, k;
583
584 p = &Vpool[cadr(n) - 2];
585 *p = n;
586 if (type == S_vector) {
587 k = vector_len(n);
588 p = vector(n);
589 while (k) {
590 mark(*p);
591 p++;
592 k--;
593 }
594 }
595 }
596
597 /*
598 * Mark nodes which can be accessed through N.
599 * This routine uses the Deutsch/Schorr/Waite algorithm
600 * (aka pointer reversal algorithm) which marks the
601 * nodes of a pool in constant space.
602 * It uses MFLAG and SFLAG of the tag field to keep track
603 * of the state of the current node.
604 * Each visited node goes through these states:
605 * S0: M==0 S==0 unvisited, process CAR
606 * S1: M==1 S==1 CAR visited, process CDR
607 * S2: M==1 S==0 completely visited, return to parent
608 */
mark(int n)609 static void mark(int n) {
610 int p, x, t;
611 int parent;
612
613 parent = NIL; /* Initially, there is no parent node */
614 while (1) {
615 /* Reached a dead end? */
616 if (n == NIL || Tag[n] & MFLAG) {
617 if (parent == NIL) break;
618 if (Tag[parent] & SFLAG) { /* S1 */
619 /* Swap CAR and CDR pointers and */
620 /* proceed with CDR. Goto S2. */
621 p = Cdr[parent];
622 Cdr[parent] = Car[parent];
623 Car[parent] = n;
624 Tag[parent] &= ~SFLAG; /* S=0 */
625 Tag[parent] |= MFLAG; /* M=1 */
626 n = p;
627 }
628 else { /* S2 */
629 /* Return to the parent and */
630 /* restore parent of parent */
631 p = parent;
632 parent = Cdr[p];
633 Cdr[p] = n;
634 n = p;
635 }
636 }
637 else { /* S0 */
638 if (Tag[n] & AFLAG) {
639 /* If the node is an atom, go directly */
640 /* to state 3: Save the parent in CDR, */
641 /* make the current node the new parent */
642 /* and move to its CDR. */
643 p = Cdr[n];
644 Cdr[n] = parent;
645 /*Tag[n] &= ~SFLAG;*/ /* S=0 */
646 parent = n;
647 n = p;
648 Tag[parent] |= MFLAG; /* M=1 */
649 }
650 else {
651 t = (Tag[n] & XFLAG)? Car[n]: NIL;
652 x = n;
653 /* Go to state 2: like above, but save */
654 /* the parent in CAR and proceed to CAR. */
655 p = Car[n];
656 Car[n] = parent;
657 Tag[n] |= MFLAG; /* M=1 */
658 parent = n;
659 n = p;
660 Tag[parent] |= SFLAG; /* S=1 */
661 if (t != NIL) markVec(x, t);
662 }
663 }
664 }
665 }
666
667 /* Mark all vectors of the Vpool unused */
unmarkVecs(void)668 static void unmarkVecs(void) {
669 int p, k, link;
670
671 p = 0;
672 while (p < Vptr) {
673 link = p;
674 k = Vpool[p+1];
675 p += vector_size(k);
676 Vpool[link] = NIL;
677 }
678 }
679
680 /*
681 * Mark and Sweep Garbage Collection.
682 * First mark all nodes that can be accessed through
683 * Root registers (Root[]) and then reclaim unmarked
684 * nodes.
685 */
gc(void)686 static int gc(void) {
687 int i, k;
688
689 k = 0;
690 #ifdef DEBUG
691 pr("GC called");
692 nl();
693 #endif
694 for (i=0; i<NROOT; i++) mark(Root[i][0]);
695 if (SK_errFlag) {
696 mark(SK_errExpr);
697 mark(SK_errFun);
698 mark(SK_errFrame);
699 }
700 Free = NIL;
701 for (i=0; i<PoolSize; i++) {
702 if (!(Tag[i] & MFLAG)) {
703 Cdr[i] = Free;
704 Free = i;
705 k = k+1;
706 }
707 else {
708 Tag[i] &= ~MFLAG;
709 }
710 }
711 if (MaxAtoms < PoolSize-k) MaxAtoms = PoolSize-k;
712 #ifdef DEBUG
713 prnum(k, 0);
714 pr(" nodes reclaimed");
715 nl();
716 #endif
717 sk_count(&SK_collections, 1);
718 return k;
719 }
720
721 /* Allocate a fresh node and initialize with PCAR,PCDR,PTAG. */
alloc3(int pcar,int pcdr,int ptag)722 static int alloc3(int pcar, int pcdr, int ptag) {
723 int n;
724
725 if (SK_statFlag) sk_count(&SK_allocations, 1);
726 if (Free == NIL) {
727 if (ptag == 0) SafeCar = pcar;
728 SafeCdr = pcdr;
729 gc();
730 if (Free == NIL) fatal("alloc3(): out of nodes");
731 SafeCar = SafeCdr = NIL;
732 }
733 n = Free;
734 Free = Cdr[Free];
735 Car[n] = pcar;
736 Cdr[n] = pcdr;
737 Tag[n] = ptag;
738 return n;
739 }
740
741 /* Allocate a fresh node and initialize with PCAR,PCDR. */
742 #define alloc(pcar, pcdr) alloc3((pcar), (pcdr), 0)
743
744 /* In situ vector pool garbage collection and compaction */
gcv(void)745 static void gcv(void) {
746 int k, to, from;
747
748 unmarkVecs();
749 gc(); /* re-mark live vecs */
750 to = from = 0;
751 while (from < Vptr) {
752 k = Vpool[from+1];
753 k = vector_size(k);
754 if (Vpool[from] != NIL) {
755 if (to != from) {
756 memmove(&Vpool[to], &Vpool[from],
757 k * sizeof(int));
758 cadr(Vpool[to]) = to + 2;
759 }
760 to += k;
761 }
762 from += k;
763 }
764 Vptr = to;
765 if (Vptr > MaxCells) MaxCells = Vptr;
766 }
767
768 /* Allocate vector from vpool */
allocv(int type,int size)769 static int allocv(int type, int size) {
770 int v, n, wsize;
771
772 wsize = vector_size(size);
773 if (Vptr + wsize >= VPoolSize) {
774 gcv();
775 if (Vptr + wsize >= VPoolSize)
776 fatal("allocv(): out of vector space");
777 }
778 v = Vptr;
779 Vptr += wsize;
780 Tmp2 = alloc3(v+2, NIL, AFLAG);
781 n = alloc3(type, Tmp2, XFLAG);
782 Tmp2 = NIL;
783 Vpool[v] = n;
784 Vpool[v+1] = size;
785 return n;
786 }
787
788 /* Save node N on the Stack. */
789 #define save(n) (Stack = alloc((n), Stack))
790
791 /*
792 * Pop K nodes off the Stack and return
793 * the one most recently popped.
794 */
unsave(int k)795 static int unsave(int k) {
796 int n = NIL; /*LINT*/
797
798 while (k) {
799 if (Stack == NIL) fatal("unsave(): stack underflow");
800 n = Car[Stack];
801 Stack = Cdr[Stack];
802 k = k-1;
803 }
804 return n;
805 }
806
807 /*
808 * Save value V on the M-Stack.
809 * Since the Mstack holds integer values rather than
810 * nodes, the values are packaged in the character
811 * fields of atoms.
812 */
813 #define msave(v) (Car[Mstack] = alloc3((v), Car[Mstack], AFLAG))
814
815 /* Pop a value off the M-Stack and return it. */
munsave(void)816 static int munsave(void) {
817 int v;
818
819 if (Car[Mstack] == NIL) fatal("munsave(): m-stack underflow");
820 v = caar(Mstack); /* See msave() */
821 Car[Mstack] = cdar(Mstack);
822 return v;
823 }
824
825 /* Save node N on the L-Stack. */
826 #define lsave(n) (Lstack = alloc((n), Lstack))
827
828 /*
829 * Pop K nodes off the L-Stack and return
830 * the one most recently popped.
831 */
lunsave(int k)832 static int lunsave(int k) {
833 int n = NIL; /*LINT*/
834
835 while (k) {
836 if (Lstack == NIL) fatal("lunsave(): l-stack underflow");
837 n = Car[Lstack];
838 Lstack = Cdr[Lstack];
839 k = k-1;
840 }
841 return n;
842 }
843
844 /* Save node N on the B-Stack. */
845 #define bsave(n) (Bstack = alloc((n), Bstack))
846
847 /*
848 * Pop K nodes off the B-Stack and return
849 * the one most recently popped.
850 */
bunsave(int k)851 static int bunsave(int k) {
852 int n = NIL; /*LINT*/
853
854 while (k) {
855 if (Bstack == NIL) fatal("bunsave(): b-stack underflow");
856 n = Car[Bstack];
857 Bstack = Cdr[Bstack];
858 k = k-1;
859 }
860 return n;
861 }
862
863 /*
864 * Read a single character from the input stream
865 * and return it. Sk_rdch()==EOT indicates that
866 * the input is exhausted.
867 */
sk_rdch(void)868 int sk_rdch(void) {
869 int c;
870
871 if (Rejected != EOT) {
872 c = Rejected;
873 Rejected = EOT;
874 return c;
875 }
876 if (InputString) {
877 if (*InputString == 0) return EOT;
878 return *InputString++;
879 }
880 c = getc(Input);
881 if (feof(Input)) return EOT;
882 if (c == '\n') Line = Line+1;
883 return c;
884 }
885
886 /* Put char back to input stream */
sk_reject(int c)887 void sk_reject(int c) {
888 Rejected = c;
889 }
890
891 /* Read a character and convert it to lower case. */
rdch(void)892 static int rdch(void) {
893 return tolower(sk_rdch());
894 }
895
896 /*
897 * Find a symbol named S in the symbol table Y.
898 * Each symbol is represented by a (NAME . VALUE) pair
899 * where NAME is a list of character nodes and value
900 * may be any datum.
901 * The symbol table is a list containing symbol
902 * pairs ((N1 . V1) ...).
903 * When a symbol named S is found, return its
904 * pair (S . V) and otherwise return NIL.
905 */
findPsym(char * s,int y)906 static int findPsym(char *s, int y) {
907 int n, i;
908
909 while (y != NIL) {
910 n = caar(y);
911 i = 0;
912 while (n != NIL && s[i]) {
913 if (s[i] != (Car[n] & 255)) break;
914 n = Cdr[n];
915 i = i+1;
916 }
917 if (n == NIL && !s[i]) return Car[y];
918 y = Cdr[y];
919 }
920 return NIL;
921 }
922
923 /*
924 * Find the symbol S in the symbol table of any
925 * package in the package list.
926 * Search the current package first.
927 */
findSym(char * s)928 static int findSym(char *s) {
929 int p, y;
930
931 y = findPsym(s, Symbols);
932 if (y != NIL) return y;
933 p = Packages;
934 while (p != NIL) {
935 y = findPsym(s, cdar(p));
936 if (y != NIL) return y;
937 p = Cdr[p];
938 }
939 return NIL;
940 }
941
942
943 /* findSym() wrapper */
sk_findSym(char * s)944 int sk_findSym(char *s) {
945 return findSym(s);
946 }
947
948 /* Explode a string to a list of atoms. */
explodeStr(char * s)949 static int explodeStr(char *s) {
950 int i, n, m, a;
951
952 i = 0;
953 if (s[i] == 0) return NIL;
954 a = n = NIL;
955 while (s[i]) {
956 m = alloc3(s[i], NIL, AFLAG);
957 if (n == NIL) { /* Protect the first character */
958 n = m;
959 save(n);
960 }
961 else { /* Append the rest */
962 Cdr[a] = m;
963 }
964 a = m;
965 i = i+1;
966 }
967 unsave(1);
968 return n;
969 }
970
971 /*
972 * Implode a list of atoms to a string.
973 * K = size of S.
974 */
implodeStr(int n,int k,char * s)975 static char *implodeStr(int n, int k, char *s) {
976 int i;
977
978 i = 0;
979 while (n != NIL) {
980 if (i >= k-1) fatal("implodeStr(): string too long");
981 s[i++] = Car[n] & 255;
982 n = Cdr[n];
983 }
984 s[i] = 0;
985 return s;
986 }
987
988 /* Update symbol table pointer in package list. */
updatePackages(int old,int new)989 static void updatePackages(int old, int new) {
990 int p;
991
992 p = Packages;
993 while (p != NIL) {
994 if (cdar(p) == old) {
995 cdar(p) = new;
996 return;
997 }
998 p = Cdr[p];
999 }
1000 if (Packages != NIL)
1001 fatal("updatePackages(): symbol table not in package list?");
1002 }
1003
1004 /*
1005 * Add the symbol S to the symbol table if it
1006 * does not already exist. If it does exist,
1007 * return the existing symbol.
1008 * When adding a new symbol, initialize the
1009 * VALUE field with V. If V==0, bind S to S.
1010 * Return the pair representing the symbol S.
1011 */
addSym(char * s,int v)1012 static int addSym(char *s, int v) {
1013 int n, m, osym;
1014
1015 n = findSym(s);
1016 if (n != NIL) return n;
1017 n = explodeStr(s);
1018 m = alloc(n, v);
1019 if (!v) Cdr[m] = m;
1020 osym = Symbols;
1021 Symbols = alloc(m, Symbols);
1022 updatePackages(osym, Symbols);
1023 return m;
1024 }
1025
1026 /* Add primitive procedure. */
addPrim(char * name,int opcode)1027 static int addPrim(char *name, int opcode) {
1028 int y;
1029
1030 y = addSym(name, 0);
1031 Cdr[y] = alloc(S_primitive, NIL);
1032 cddr(y) = alloc3(opcode, NIL, AFLAG);
1033 cdddr(y) = y;
1034 return y;
1035 }
1036
1037 /* Add special form handler. */
addSpecial(char * name,int opcode,int cbv)1038 static int addSpecial(char *name, int opcode, int cbv) {
1039 int y;
1040
1041 y = addSym(name, 0);
1042 Cdr[y] = alloc(cbv? S_special_cbv: S_special, NIL);
1043 cddr(y) = alloc3(opcode, NIL, AFLAG);
1044 cdddr(y) = y;
1045 return y;
1046 }
1047
1048 /* Add user primitive handler. */
sk_addUserPrim(char * name,int (* handler)(int n))1049 int sk_addUserPrim(char *name, int (*handler)(int n)) {
1050 int y;
1051
1052 if (LastUsrPrimitive >= SK_MAX_USER_PRIMITIVES)
1053 return -1;
1054 y = addSym(name, 0);
1055 Cdr[y] = alloc(S_user_primitive, NIL);
1056 cddr(y) = alloc3(LastUsrPrimitive, NIL, AFLAG);
1057 cdddr(y) = y;
1058 UsrPrimitives[LastUsrPrimitive] = handler;
1059 LastUsrPrimitive += 1;
1060 return LastUsrPrimitive;
1061 }
1062
1063 /* Find a package. */
findPackage(int sym)1064 static int findPackage(int sym) {
1065 int p;
1066
1067 p = Packages;
1068 while (p != NIL) {
1069 if (caar(p) == sym) return Car[p];
1070 p = Cdr[p];
1071 }
1072 return NIL;
1073 }
1074
1075 /* Add a package. */
addPackage(int sym)1076 static int addPackage(int sym) {
1077 int y, p;
1078
1079 y = findPackage(sym);
1080 if (y != NIL) return Cdr[y];
1081 p = alloc(sym, NIL);
1082 Packages = alloc(p, Packages);
1083 return Cdr[p];
1084 }
1085
1086 /*
1087 * Read a list (S0 ... SN) or pair (S0 . S1) and return it.
1088 * For empty lists return NIL.
1089 */
readList(void)1090 static int readList(void) {
1091 int n, /* Node read */
1092 m, /* List */
1093 a, /* Used to append nodes to m */
1094 c; /* Member counter */
1095 char *badpair;
1096
1097 badpair = "bad pair";
1098 Level = Level+1;
1099 m = alloc(NIL, NIL); /* Root node */
1100 save(m);
1101 a = NIL;
1102 c = 0;
1103 while (1) {
1104 if (SK_errFlag) {
1105 unsave(1);
1106 return NIL;
1107 }
1108 n = xread();
1109 if (n == S_eof) {
1110 if (LoadLev) {
1111 unsave(1);
1112 return S_eof;
1113 }
1114 error("missing ')'", NOEXPR);
1115 }
1116 if (n == DOT) {
1117 if (c < 1) {
1118 error(badpair, NOEXPR);
1119 continue;
1120 }
1121 n = xread();
1122 Cdr[a] = n;
1123 if (n == RPAREN || xread() != RPAREN) {
1124 error(badpair, NOEXPR);
1125 continue;
1126 }
1127 unsave(1);
1128 Level = Level-1;
1129 return m;
1130 }
1131 if (n == RPAREN) break;
1132 if (a == NIL)
1133 a = m; /* First member: insert at root */
1134 else
1135 a = Cdr[a]; /* Following members: append */
1136 Car[a] = n;
1137 Cdr[a] = alloc(NIL, NIL); /* Alloc space for next member */
1138 c = c+1;
1139 }
1140 Level = Level-1;
1141 if (a != NIL) Cdr[a] = NIL; /* Remove trailing empty node */
1142 unsave(1);
1143 return c? m: NIL;
1144 }
1145
1146 /* Read a vector literal */
readVector(void)1147 static int readVector(void) {
1148 int n;
1149
1150 n = readList();
1151 save(n);
1152 n = list_to_vector(n, "bad vector syntax");
1153 unsave(1);
1154 return n;
1155 }
1156
1157 /* Is N a 'real' (non-NIL) atom? */
1158 #define atomic(n) \
1159 ((n) != NIL && Car[n] != NIL && (Tag[Car[n]] & AFLAG))
1160
1161 /* Is N a tagged list (an internal type)? */
tagged(int n)1162 static int tagged(int n) {
1163 if ( n == NIL || !atomic(Car[n]) ||
1164 Car[n] == S_true || Car[n] == S_false
1165 )
1166 return 0;
1167 n = caar(n);
1168 return (Tag[n] & AFLAG) && Car[n] == '#';
1169 }
1170
1171 /* Is N a lazy atom (atomic or tagged list)? */
1172 #define lazyAtom(n) (atomic(n) || tagged(n))
1173
1174 /* Quote an expression. */
quote(int n)1175 static int quote(int n) {
1176 int q;
1177
1178 q = alloc(n, NIL);
1179 return alloc(S_quote, q);
1180 }
1181
1182 /*
1183 * Check whether a string represents a number.
1184 * Numbers are defined as [+-]?[0-9]+.
1185 */
numericStr(char * s)1186 static int numericStr(char *s) {
1187 int i;
1188
1189 i = 0;
1190 if (s[0] == '+' || s[0] == '-') i = 1;
1191 if (!s[i]) return 0;
1192 while (s[i]) {
1193 if (!isdigit(s[i])) return 0;
1194 i = i+1;
1195 }
1196 return 1;
1197 }
1198
1199 /* Explode a numeric string into a bignum. */
explodeNum(char * s)1200 static int explodeNum(char *s) {
1201 int i, l, x, y;
1202 char name[3];
1203
1204 i = 0;
1205 l = alloc(S_integer, NIL);
1206 x = l;
1207 save(l);
1208 strcpy(name, "0d");
1209 while (s[i]) {
1210 name[0] = s[i];
1211 name[1] = isdigit(s[i])? 'd': 0;
1212 y = addSym(name, NIL);
1213 Cdr[x] = alloc(y, NIL);
1214 x = Cdr[x];
1215 i = i+1;
1216 }
1217 unsave(1);
1218 return l;
1219 }
1220
1221 /* Report unreadable object */
unreadable(void)1222 static int unreadable(void) {
1223 int c, i;
1224 char buf[TEXTLEN];
1225
1226 error("unreadable object", NOEXPR);
1227 strcpy(buf, "#<");
1228 i = 2;
1229 while (1) {
1230 c = rdch();
1231 if (c == '>' || c == '\n') break;
1232 if (i < TEXTLEN-2) buf[i++] = c;
1233 }
1234 buf[i++] = '>';
1235 buf[i] = 0;
1236 setErrArg(buf);
1237 return NIL;
1238 }
1239
1240 /* Create a character literal. */
sk_mkChar(int x)1241 int sk_mkChar(int x) {
1242 int n;
1243
1244 n = alloc3(x, NIL, AFLAG);
1245 return alloc(S_char, n);
1246 }
1247
1248 /* Read a character literal. */
character(void)1249 static int character(void) {
1250 char buf[10];
1251 int i, c;
1252
1253 for (i=0; i<9; i++) {
1254 c = sk_rdch();
1255 if (i > 0 && !isalpha(c)) break;
1256 buf[i] = c;
1257 }
1258 Rejected = c;
1259 buf[i] = 0;
1260 if (i == 0) c = ' ';
1261 else if (i == 1) c = buf[0];
1262 else if (!strcmp(buf, "space")) c = ' ';
1263 else if (!strcmp(buf, "newline")) c = '\n';
1264 else if (!strcmp(buf, "linefeed")) c = '\n';
1265 else {
1266 error("bad # syntax", NOEXPR);
1267 c = 0;
1268 }
1269 return sk_mkChar(c);
1270 }
1271
1272 /* Create a string; K = length */
sk_mkString(char * s,int k)1273 int sk_mkString(char *s, int k) {
1274 int n;
1275
1276 n = allocv(S_string, k+1);
1277 strcpy(string(n), s);
1278 return n;
1279 }
1280
1281 /* Read a string literal. */
stringLiteral(void)1282 static int stringLiteral(void) {
1283 char s[TEXTLEN+1];
1284 int c, i, n, q;
1285 int inv;
1286
1287 i = 0;
1288 q = 0;
1289 c = sk_rdch();
1290 inv = 0;
1291 while (q || c != '"') {
1292 if (SK_errFlag) break;
1293 if (i >= TEXTLEN-2) {
1294 error("symbol too long", NOEXPR);
1295 i = i-1;
1296 }
1297 if (q && c != '"' && c != '\\') {
1298 s[i++] = '\\';
1299 inv = 1;
1300 }
1301 s[i] = c;
1302 q = !q && c == '\\';
1303 if (!q) i = i+1;
1304 c = sk_rdch();
1305 }
1306 s[i] = 0;
1307 n = sk_mkString(s, i);
1308 if (inv) error("invalid escape sequence in string", n);
1309 return n;
1310 }
1311
1312 #define separator(c) \
1313 ((c) == ' ' || (c) == '\t' || (c) == '\n' || \
1314 (c) == '\r' || (c) == '(' || (c) == ')' || \
1315 (c) == ';' || (c) == '#' || (c) == '\'' || \
1316 (c) == '"' || (c) == EOT)
1317
1318 /*
1319 * Read a symbol or a numeric literal. When reading a
1320 * symbol, add it to the global symbol table.
1321 */
symOrNum(int c)1322 static int symOrNum(int c) {
1323 char s[TEXTLEN];
1324 int i;
1325
1326 i = 0;
1327 while (!separator(c)) {
1328 if (i >= TEXTLEN-2) {
1329 error("symbol too long", NOEXPR);
1330 i = i-1;
1331 }
1332 s[i] = c;
1333 i = i+1;
1334 c = rdch();
1335 }
1336 s[i] = 0;
1337 Rejected = c;
1338 if (numericStr(s)) return explodeNum(s);
1339 return addSym(s, S_undefined);
1340 }
1341
1342 /* (EQUAL N M)? */
equals(int n,int m)1343 static int equals(int n, int m) {
1344 if (n == m) return 1;
1345 if (n == NIL || m == NIL) return 0;
1346 if (tagged(n) && tagged(m)) {
1347 if ( Car[n] == S_integer &&
1348 Car[m] == S_integer &&
1349 equals(Cdr[n], Cdr[m])
1350 )
1351 return 1;
1352 if ( Car[n] == S_char &&
1353 Car[m] == S_char &&
1354 cadr(n) == cadr(m)
1355 )
1356 return 1;
1357 if ( Car[n] == S_string &&
1358 Car[m] == S_string &&
1359 !strcmp(string(n), string(m))
1360 )
1361 return 1;
1362 }
1363 if (Tag[n] & AFLAG || Tag[m] & AFLAG) return 0;
1364 return equals(Car[n], Car[m])
1365 && equals(Cdr[n], Cdr[m]);
1366 }
1367
1368 /* Verify most recently evaluated expression */
verify(void)1369 static void verify(void) {
1370 int expected;
1371
1372 expected = sk_read();
1373 if (!equals(expected, Cdr[S_last]))
1374 error("Verification failed; expected", expected);
1375 }
1376
1377 /* Skip over nested #| ... |# */
nestedComment(void)1378 static int nestedComment(void) {
1379 int p, c, k;
1380
1381 k = 1;
1382 p = 0;
1383 c = rdch();
1384 while (k) {
1385 if (c == EOT) fatal("end of input in nested comment");
1386 if (p == '#' && c == '|') { k++; c = 0; }
1387 if (p == '|' && c == '#') { k--; c = 0; }
1388 p = c;
1389 c = rdch();
1390 }
1391 return c;
1392 }
1393
1394 /*
1395 * Read an expression from the current input stream
1396 * and return it.
1397 */
xread(void)1398 int xread(void) {
1399 int c, c2;
1400
1401 c = rdch();
1402 while (1) { /* Skip spaces and comments */
1403 while (c == ' ' || c == '\t' || c == '\n' || c == '\r') {
1404 if (SK_errFlag) return NIL;
1405 c = rdch();
1406 }
1407 if (c == '#') {
1408 c = rdch();
1409 if (c == '|') {
1410 c = nestedComment();
1411 continue;
1412 }
1413 if (c == ';') {
1414 xread();
1415 c = rdch();
1416 continue;
1417 }
1418 if (c != '!') {
1419 Rejected = c;
1420 c = '#';
1421 break;
1422 }
1423 }
1424 else if (SK_arrowMode && c == '=') {
1425 c = rdch();
1426 if (c != '>') {
1427 Rejected = c;
1428 c = '=';
1429 break;
1430 }
1431 if (SK_arrowMode > 1) verify();
1432 }
1433 else if (c != ';')
1434 break;
1435 while (c != '\n' && c != EOT) c = rdch();
1436 }
1437 if (c == EOT) return S_eof;
1438 if (c == '(') {
1439 return readList();
1440 }
1441 else if (c == '\'') {
1442 return quote(xread());
1443 }
1444 else if (c == '#') {
1445 c = rdch();
1446 if (c == 'f') return S_false;
1447 if (c == 't') return S_true;
1448 if (c == '\\') return character();
1449 if (c == '(') return readVector();
1450 if (c == '<') return unreadable();
1451 return error("bad # syntax", NOEXPR);
1452 }
1453 else if (c == '"') {
1454 return stringLiteral();
1455 }
1456 else if (c == ')') {
1457 if (!Level) return error("unexpected ')'", NOEXPR);
1458 return RPAREN;
1459 }
1460 else if (c == '.') {
1461 c2 = rdch();
1462 sk_reject(c2);
1463 if (separator(c2)) {
1464 if (!Level) return error("unexpected '.'",
1465 NOEXPR);
1466 return DOT;
1467 }
1468 return symOrNum(c);
1469 }
1470 else {
1471 return symOrNum(c);
1472 }
1473 }
1474
1475 /* Syntax transformer */
_syntaxTransform(int n)1476 int _syntaxTransform(int n) {
1477 int m;
1478 int tr, app;
1479
1480 if (SK_errFlag) return NIL;
1481 if (n == NIL || lazyAtom(n)) return n;
1482 if (Car[n] == S_quote) return n;
1483 m = n;
1484 while (m != NIL && !lazyAtom(m)) {
1485 Car[m] = _syntaxTransform(Car[m]);
1486 if (SK_errFlag) return NIL;
1487 m = Cdr[m];
1488 }
1489 if (atomic(Car[n]) && cadar(n) == S_syntax) {
1490 /*
1491 * Doing this in C is simply too ugly.
1492 * Pass all the stuff to TRANSFORM-SYNTAX
1493 * and let it do the real work.
1494 * TRANSFORM-SYNTAX is in sketchy.scm.
1495 */
1496 tr = findPsym("transform-syntax", Cdr[S_core]);
1497 if (tr == NIL)
1498 fatal("image lacks 'transform-syntax' procedure");
1499 app = quote(n);
1500 app = alloc(app, NIL);
1501 app = alloc(tr, app);
1502 n = safe_eval(app);
1503 Function = NIL;
1504 }
1505 return n;
1506 }
1507
1508 /* Syntax transformer, friendly version */
syntaxTransform(int n)1509 int syntaxTransform(int n) {
1510 if (!lazyAtom(n) && Car[n] != S_defineSyntax) {
1511 save(n);
1512 n = _syntaxTransform(n);
1513 unsave(1);
1514 }
1515 return n;
1516 }
1517
1518 /* Friendly version of XREAD. */
sk_read(void)1519 int sk_read(void) {
1520 Level = 0;
1521 return xread();
1522 }
1523
1524 /* Error reporting... */
1525
wrongArgs(int n)1526 static int wrongArgs(int n) {
1527 return error("wrong argument count", n);
1528 }
1529
badArgLst(int n)1530 static int badArgLst(int n) {
1531 return error("bad argument list", n);
1532 }
1533
1534 /* Evaluate N=(CONS M M2) */
doCons(int n)1535 static int doCons(int n) {
1536 int m, m2;
1537
1538 m = Cdr[n];
1539 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
1540 return wrongArgs(n);
1541 m2 = cadr(m);
1542 return alloc(Car[m], m2);
1543 }
1544
1545 /* Evaluate N=(CAR M) */
doCar(int n)1546 static int doCar(int n) {
1547 int m;
1548
1549 m = Cdr[n];
1550 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
1551 if (atomic(Car[m]) || Car[m] == NIL || tagged(Car[m]))
1552 return error("non-pair in 'car'", Car[m]);
1553 return caar(m);
1554 }
1555
1556 /* Evaluate N=(CDR M) */
doCdr(int n)1557 static int doCdr(int n) {
1558 int m;
1559
1560 m = Cdr[n];
1561 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
1562 if (atomic(Car[m]) || Car[m] == NIL || tagged(Car[m])) {
1563 return error("non-pair in 'cdr'", Car[m]);
1564 }
1565 return cdar(m);
1566 }
1567
1568 /* Evaluate N=(CHAR->INTEGER M) */
doCharToInteger(int n)1569 static int doCharToInteger(int n) {
1570 int m, i, c;
1571 char b[4];
1572
1573 m = Cdr[n];
1574 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
1575 m = Car[m];
1576 if (atomic(m) || m == NIL || Car[m] != S_char)
1577 return error("non-character in 'char->integer'", m);
1578 c = cadr(m);
1579 i = 3;
1580 b[i] = 0;
1581 while (c || i == 4) {
1582 i = i-1;
1583 b[i] = c % 10 + '0';
1584 c = c / 10;
1585 }
1586 return explodeNum(&b[i]);
1587 }
1588
1589 #define CHAR_CI_LT 0
1590 #define CHAR_CI_LE 1
1591 #define CHAR_CI_EQ 2
1592 #define CHAR_CI_GT 3
1593 #define CHAR_CI_GE 4
1594 #define CHAR_LT 5
1595 #define CHAR_LE 6
1596 #define CHAR_EQ 7
1597 #define CHAR_GT 8
1598 #define CHAR_GE 9
1599
1600 /* Process CHAR... predicates. */
charPred(int n,int pred,char * msg)1601 static int charPred(int n, int pred, char *msg) {
1602 int m, c1, c2;
1603
1604 m = Cdr[n];
1605 if (m == NIL || Cdr[m] == NIL) {
1606 wrongArgs(n);
1607 return NIL;
1608 }
1609 while (Cdr[m] != NIL) {
1610 c1 = Car[m];
1611 c2 = cadr(m);
1612 if (atomic(c1) || Car[c1] != S_char)
1613 return error(msg, c1);
1614 if (atomic(c2) || Car[c2] != S_char)
1615 return error(msg, c2);
1616 c1 = cadr(c1);
1617 c2 = cadr(c2);
1618 switch (pred) {
1619 case CHAR_CI_LT:
1620 if (tolower(c1) >= tolower(c2)) return S_false;
1621 break;
1622 case CHAR_CI_LE:
1623 if (tolower(c1) > tolower(c2)) return S_false;
1624 break;
1625 case CHAR_CI_EQ:
1626 if (tolower(c1) != tolower(c2)) return S_false;
1627 break;
1628 case CHAR_CI_GT:
1629 if (tolower(c1) <= tolower(c2)) return S_false;
1630 break;
1631 case CHAR_CI_GE:
1632 if (tolower(c1) < tolower(c2)) return S_false;
1633 break;
1634 case CHAR_LT:
1635 if (c1 >= c2) return S_false;
1636 break;
1637 case CHAR_LE:
1638 if (c1 > c2) return S_false;
1639 break;
1640 case CHAR_EQ:
1641 if (c1 != c2) return S_false;
1642 break;
1643 case CHAR_GT:
1644 if (c1 <= c2) return S_false;
1645 break;
1646 case CHAR_GE:
1647 if (c1 < c2) return S_false;
1648 break;
1649 }
1650 m = Cdr[m];
1651 }
1652 return S_true;
1653 }
1654
1655 /* Evaluate N=(CHAR-CI<? M1 M2 ...) */
doCharCiLtP(int n)1656 static int doCharCiLtP(int n) {
1657 return charPred(n, CHAR_CI_LT, "non-char in char-ci<?");
1658 }
1659
1660 /* Evaluate N=(CHAR-CI<=? M1 M2 ...) */
doCharCiLEP(int n)1661 static int doCharCiLEP(int n) {
1662 return charPred(n, CHAR_CI_LE, "non-char in char-ci<=?");
1663 }
1664
1665 /* Evaluate N=(CHAR-CI=? M1 M2 ...) */
doCharCiEqP(int n)1666 static int doCharCiEqP(int n) {
1667 return charPred(n, CHAR_CI_EQ, "non-char in char-ci=?");
1668 }
1669
1670 /* Evaluate N=(CHAR-CI>? M1 M2 ...) */
doCharCiGtP(int n)1671 static int doCharCiGtP(int n) {
1672 return charPred(n, CHAR_CI_GT, "non-char in char-ci<?");
1673 }
1674
1675 /* Evaluate N=(CHAR-CI>=? M1 M2 ...) */
doCharCiGEP(int n)1676 static int doCharCiGEP(int n) {
1677 return charPred(n, CHAR_CI_GE, "non-char in char-ci<=?");
1678 }
1679
1680 /* Evaluate N=(CHAR<? M1 M2 ...) */
doCharLtP(int n)1681 static int doCharLtP(int n) {
1682 return charPred(n, CHAR_LT, "non-char in char<?");
1683 }
1684
1685 /* Evaluate N=(CHAR<=? M1 M2 ...) */
doCharLEP(int n)1686 static int doCharLEP(int n) {
1687 return charPred(n, CHAR_LE, "non-char in char<?");
1688 }
1689
1690 /* Evaluate N=(CHAR=? M1 M2 ...) */
doCharEqP(int n)1691 static int doCharEqP(int n) {
1692 return charPred(n, CHAR_EQ, "non-char in char=?");
1693 }
1694
1695 /* Evaluate N=(CHAR>? M1 M2 ...) */
doCharGtP(int n)1696 static int doCharGtP(int n) {
1697 return charPred(n, CHAR_GT, "non-char in char<?");
1698 }
1699
1700 /* Evaluate N=(CHAR>=? M1 M2 ...) */
doCharGEP(int n)1701 static int doCharGEP(int n) {
1702 return charPred(n, CHAR_GE, "non-char in char<?");
1703 }
1704
1705 /* Evaluate N=(CHAR? M) */
doCharP(int n)1706 static int doCharP(int n) {
1707 int m;
1708
1709 m = Cdr[n];
1710 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
1711 m = Car[m];
1712 return !atomic(m) && m != NIL && Car[m] == S_char ? S_true: S_false;
1713 }
1714
1715 /* Return the value of a digit. */
digitToValue(int n)1716 static int digitToValue(int n) {
1717 int y;
1718
1719 y = Car[n];
1720 if ( !isdigit(Car[y]) ||
1721 cadr(y) != 'd' ||
1722 cddr(y) != NIL
1723 ) {
1724 error("non-digit in natural arithmetic operation", n);
1725 return -1;
1726 }
1727 return Car[y] - '0';
1728 }
1729
1730 /* Convert a value to a digit. */
valueToDigit(int n)1731 static int valueToDigit(int n) {
1732 return Digits[n];
1733 }
1734
1735 /* Reverse a list */
reverse(int n)1736 static int reverse(int n) {
1737 int m;
1738
1739 /* protect N? */
1740 m = NIL;
1741 while (n != NIL) {
1742 m = alloc(Car[n], m);
1743 n = Cdr[n];
1744 }
1745 return m;
1746 }
1747
1748 /* Compute the length of a list */
length(int n)1749 static int length(int n) {
1750 int k;
1751
1752 k = 0;
1753 while (n != NIL) {
1754 n = Cdr[n];
1755 k = k+1;
1756 }
1757 return k;
1758 }
1759
1760 /* Retrieve factors of a numeric function */
getFactors(char * msg,int n,int * p1,int * p2)1761 static int getFactors(char *msg, int n, int *p1, int *p2) {
1762 int m, m2;
1763
1764 m = Cdr[n];
1765 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
1766 return wrongArgs(n);
1767 m = Car[m];
1768 if (atomic(m) || m == NIL || Car[m] != S_integer)
1769 return error(msg, m);
1770 m2 = caddr(n);
1771 if (atomic(m2) || m2 == NIL || Car[m2] != S_integer)
1772 return error(msg, m2);
1773 *p1 = Cdr[m];
1774 *p2 = Cdr[m2];
1775 return SK_errFlag;
1776 }
1777
1778 /* Evaluate N=(N< M1 M2) */
doNLess(int n)1779 static int doNLess(int n) {
1780 int f1, f2;
1781 int k1, k2;
1782 int v1, v2;
1783
1784 getFactors("non-natural in 'n<'", n, &f1, &f2);
1785 if (SK_errFlag) return NIL;
1786 save(f1);
1787 save(f2);
1788 k1 = length(f1);
1789 k2 = length(f2);
1790 if (caaar(f1) == '-' || caaar(f1) == '+')
1791 error("non-natural in 'n<'", cadr(n));
1792 if (caaar(f2) == '-' || caaar(f2) == '+')
1793 error("non-natural in 'n<'", caddr(n));
1794 if (k1 != k2) {
1795 unsave(2);
1796 if (k1 < k2) return S_true;
1797 return S_false;
1798 }
1799 while (f1 != NIL) {
1800 v1 = digitToValue(Car[f1]);
1801 v2 = digitToValue(Car[f2]);
1802 if (v1 != v2) {
1803 unsave(2);
1804 if (v1 < v2) return S_true;
1805 return S_false;
1806 }
1807 f1 = Cdr[f1];
1808 f2 = Cdr[f2];
1809 }
1810 unsave(2);
1811 return S_false;
1812 }
1813
1814 /* Evaluate N=(N- M1 M2) */
doNMinus(int n)1815 static int doNMinus(int n) {
1816 int f1, f2, res;
1817 int r, borrow;
1818
1819 getFactors("non-natural in 'n-'", n, &f1, &f2);
1820 if (SK_errFlag) return NIL;
1821 f1 = reverse(f1);
1822 save(f1);
1823 f2 = reverse(f2);
1824 save(f2);
1825 res = NIL;
1826 borrow = 0;
1827 while (f1 != NIL) {
1828 r = digitToValue(Car[f1])
1829 - (f2 == NIL? 0: digitToValue(Car[f2]))
1830 - borrow;
1831 if (r < 0) {
1832 r += 10;
1833 borrow = 1;
1834 }
1835 else {
1836 borrow = 0;
1837 }
1838 res = alloc(valueToDigit(r), res);
1839 if (f1 != NIL) f1 = Cdr[f1];
1840 if (f2 != NIL) f2 = Cdr[f2];
1841 }
1842 if (f2 != NIL || borrow)
1843 error("negative difference in 'n-'", n);
1844 while (Car[res] == S_0 && Cdr[res] != NIL)
1845 res = Cdr[res];
1846 res = alloc(S_integer, res);
1847 unsave(2);
1848 return res;
1849 }
1850
1851 /* Evaluate N=(N+ M1 M2) */
doNPlus(int n)1852 static int doNPlus(int n) {
1853 int f1, f2, res;
1854 int r, carry;
1855
1856 getFactors("non-natural in 'n+'", n, &f1, &f2);
1857 if (SK_errFlag) return NIL;
1858 f1 = reverse(f1);
1859 save(f1);
1860 f2 = reverse(f2);
1861 save(f2);
1862 res = NIL;
1863 carry = 0;
1864 while (f1 != NIL || f2 != NIL || carry) {
1865 r = (f1 == NIL? 0: digitToValue(Car[f1]))
1866 + (f2 == NIL? 0: digitToValue(Car[f2]))
1867 + carry;
1868 if (r > 9) {
1869 r -= 10;
1870 carry = 1;
1871 }
1872 else {
1873 carry = 0;
1874 }
1875 res = alloc(valueToDigit(r), res);
1876 if (f1 != NIL) f1 = Cdr[f1];
1877 if (f2 != NIL) f2 = Cdr[f2];
1878 }
1879 res = alloc(S_integer, res);
1880 unsave(2);
1881 return res;
1882 }
1883
1884 /* Evaluate N=(GENSYM M) */
doGensym(int n)1885 static int doGensym(int n) {
1886 int m, k, i, d;
1887 char sym[TEXTLEN];
1888
1889 m = Cdr[n];
1890 if (m != NIL && Cdr[m] != NIL) return wrongArgs(n);
1891 if (m == NIL)
1892 m = S_gensym;
1893 else if (!atomic(Car[m]))
1894 return error("non-symbol in 'gensym'", Car[m]);
1895 else
1896 m = Car[m];
1897 implodeStr(Car[m], TEXTLEN, sym);
1898 k = strlen(sym);
1899 while (1) {
1900 d = 1;
1901 for (i=GensymCounter; i; i /= 10)
1902 d++;
1903 if (k + d >= TEXTLEN)
1904 fatal("doGensym(): symbol too long");
1905 GensymCounter += 1;
1906 if (GensymCounter == 0)
1907 fatal("doGensym(): out of unique symbols");
1908 sprintf(&sym[k], "%d", GensymCounter);
1909 if (findSym(sym) == NIL) {
1910 m = explodeStr(sym);
1911 m = alloc(m, S_undefined);
1912 return m;
1913 }
1914 }
1915 return m;
1916 }
1917
1918 /* Evaluate N=(INTEGER->CHAR M) */
doIntegerToChar(int n)1919 static int doIntegerToChar(int n) {
1920 int m, p;
1921 unsigned char c;
1922
1923 m = Cdr[n];
1924 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
1925 m = Car[m];
1926 if (atomic(m) || m == NIL || Car[m] != S_integer)
1927 return error("non-integer in 'integer->char'", m);
1928 p = Cdr[m];
1929 c = 0;
1930 while (p != NIL) {
1931 c = c * 10 + caaar(p) - '0';
1932 p = Cdr[p];
1933 }
1934 if (c > 127)
1935 return error("value out of range in 'integer->char'", m);
1936 return sk_mkChar(c);
1937 }
1938
1939 /* Evaluate N=(INTEGER->LIST M) */
doIntegerToList(int n)1940 static int doIntegerToList(int n) {
1941 int m;
1942
1943 m = Cdr[n];
1944 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
1945 m = Car[m];
1946 if (atomic(m) || m == NIL || Car[m] != S_integer)
1947 return error("non-integer in 'integer->list'", m);
1948 return Cdr[m];
1949 }
1950
1951 /* Evaluate N=(LIST->INTEGER M) */
doListToInteger(int n)1952 static int doListToInteger(int n) {
1953 int m, check, p, d, found_digit;
1954
1955 m = Cdr[n];
1956 if (m == NIL || (Cdr[m] != NIL && cddr(m) != NIL))
1957 return wrongArgs(n);
1958 check = cddr(m) != NIL;
1959 m = Car[m];
1960 if (m == NIL || atomic(m) || tagged(m))
1961 return error("non-list or empty list in 'list->integer'", m);
1962 if (check) {
1963 p = m;
1964 d = Car[p];
1965 if ( atomic(d) &&
1966 (caar(d) == '+' ||
1967 caar(d) == '-') &&
1968 cdar(d) == NIL
1969 )
1970 p = Cdr[p];
1971 found_digit = 0;
1972 while (p != NIL) {
1973 d = Car[p];
1974 if ( d == S_0 || d == S_1 || d == S_2 ||
1975 d == S_3 || d == S_4 || d == S_5 ||
1976 d == S_6 || d == S_7 || d == S_8 ||
1977 d == S_9
1978 )
1979 found_digit = 1;
1980 else
1981 error(
1982 "non-digit in argument to 'list->integer'",
1983 d);
1984 p = Cdr[p];
1985 }
1986 if (!found_digit)
1987 return error("no digits in 'list->integer'", m);
1988 }
1989 return alloc(S_integer, m);
1990 }
1991
1992 /* Evaluate N=(NULL? M) */
doNullP(int n)1993 static int doNullP(int n) {
1994 int m;
1995
1996 m = Cdr[n];
1997 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
1998 return Car[m] == NIL? S_true: S_false;
1999 }
2000
2001 /* Evaluate N=(EOF-OBJECT? M) */
doEofObjectP(int n)2002 static int doEofObjectP(int n) {
2003 int m;
2004
2005 m = Cdr[n];
2006 if (m == NIL || Cdr[m] != NIL)
2007 return wrongArgs(n);
2008 return Car[m] == S_eof? S_true: S_false;
2009 }
2010
2011 /* Evaluate N=(EQ? M M2) */
doEqP(int n)2012 static int doEqP(int n) {
2013 int m;
2014
2015 m = Cdr[n];
2016 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
2017 return wrongArgs(n);
2018 return Car[m] == cadr(m)? S_true: S_false;
2019 }
2020
2021 /* Evaluate N=(LIST->STRING M) */
doListToString(int n)2022 static int doListToString(int n) {
2023 int m, p, i, k, ch;
2024 char *s;
2025
2026 m = Cdr[n];
2027 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2028 m = Car[m];
2029 if (m == NIL) {
2030 p = allocv(S_string, 1);
2031 s = string(p);
2032 s[0] = 0;
2033 return p;
2034 }
2035 if (lazyAtom(m)) return error("non-list in 'list->string'", m);
2036 k = 0;
2037 for (p = m; p != NIL; p = Cdr[p]) {
2038 if (lazyAtom(p))
2039 return error("improper list in 'list->string'",
2040 cadr(n));
2041 k++;
2042 }
2043 p = allocv(S_string, k+1);
2044 i = 0;
2045 s = string(p);
2046 while (m != NIL) {
2047 ch = Car[m];
2048 if (atomic(ch) || Car[ch] != S_char)
2049 return error("non-char in argument to 'list->string'",
2050 ch);
2051 s[i++] = cadr(ch);
2052 m = Cdr[m];
2053 }
2054 s[i] = 0;
2055 return p;
2056 }
2057
list_to_vector(int m,char * msg)2058 static int list_to_vector(int m, char *msg) {
2059 int n;
2060 int vec, k;
2061 int *p;
2062
2063 k = 0;
2064 for (n = m; n != NIL; n = Cdr[n]) {
2065 if (lazyAtom(n))
2066 return error(msg, m);
2067 k++;
2068 }
2069 vec = allocv(S_vector, k*sizeof(int));
2070 p = vector(vec);
2071 for (n = m; n != NIL; n = Cdr[n]) {
2072 *p = Car[n];
2073 p++;
2074 }
2075 return vec;
2076 }
2077
2078 /* Evaluate N=(LIST->VECTOR M) */
doListToVector(int n)2079 static int doListToVector(int n) {
2080 int m;
2081
2082 m = Cdr[n];
2083 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2084 m = Car[m];
2085 if (lazyAtom(m))
2086 return error("non-list in 'list->vector'", m);
2087 return list_to_vector(m, "improper list in 'list->vector'");
2088 }
2089
2090 /* Evaluate N=(LOAD M) */
doLoad(int n)2091 static int doLoad (int n) {
2092 int m, f;
2093 char *s;
2094
2095 m = Cdr[n];
2096 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2097 f = Car[m];
2098 if (atomic(f) || f == NIL || Car[f] != S_string)
2099 return error("non-string in 'load'", f);
2100 s = string(f); /* file name */
2101 sk_load(s);
2102 return S_void;
2103 }
2104
2105 /* Evaluate N=(NUMBER? M) */
doNumberP(int n)2106 static int doNumberP(int n) {
2107 int m;
2108
2109 m = Cdr[n];
2110 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2111 m = Car[m];
2112 return atomic(m) || m == NIL? S_false:
2113 Car[m] == S_integer? S_true: S_false;
2114 }
2115
2116 /* Evaluate N=(PACKAGE [N1]) */
doPackage(int n)2117 static int doPackage(int n) {
2118 int m;
2119
2120 m = Cdr[n];
2121 if (m != NIL && Cdr[m] != NIL)
2122 return wrongArgs(n);
2123 m = m == NIL? NIL: Car[m];
2124 Symbols = addPackage(m);
2125 return m;
2126 }
2127
2128 /* Evaluate N=(PAIR? M) */
doPairP(int n)2129 static int doPairP(int n) {
2130 int m;
2131
2132 m = Cdr[n];
2133 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2134 m = Car[m];
2135 return atomic(m) || tagged(m) || m == NIL? S_false:
2136 S_true;
2137 }
2138
2139 /* Evaluate N=(PEEK-CHAR M) */
doPeekChar(int n)2140 static int doPeekChar(int n) {
2141 int m, c;
2142
2143 m = Cdr[n];
2144 if (m != NIL) return wrongArgs(n);
2145 c = sk_rdch();
2146 Rejected = c;
2147 return sk_mkChar(c);
2148 }
2149
2150 /* Evaluate N=(PROCEDURE? M) */
doProcedureP(int n)2151 static int doProcedureP(int n) {
2152 int m;
2153
2154 m = Cdr[n];
2155 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2156 m = Car[m];
2157 if (atomic(m) || m == NIL)
2158 return S_false;
2159 if ( Car[m] == S_closure ||
2160 Car[m] == S_primitive ||
2161 Car[m] == S_special_cbv ||
2162 Car[m] == S_user_primitive
2163 )
2164 return S_true;
2165 return S_false;
2166 }
2167
2168 /* Evaluate N=(REQUIRE M) */
doRequire(int n)2169 static int doRequire(int n) {
2170 int m, f;
2171 char *file;
2172
2173 m = Cdr[n];
2174 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2175 f = Car[m];
2176 if (atomic(f) || f == NIL || Car[f] != S_string)
2177 return error("non-string in 'require'", f);
2178 file = string(f);
2179 return sk_require(file)? S_true: S_false;
2180 }
2181
2182 /* Evaluate N=(STRING->LIST M) */
doStringToList(int n)2183 static int doStringToList(int n) {
2184 int m, a, lst, k, i;
2185 char *s;
2186
2187 m = Cdr[n];
2188 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2189 m = Car[m];
2190 if (atomic(m) || m == NIL || Car[m] != S_string)
2191 return error("non-string in 'string->list'", m);
2192 s = string(m);
2193 k = string_len(m) - 1;
2194 if (*s == 0) return NIL;
2195 lst = alloc(NIL, NIL);
2196 save(lst);
2197 a = lst;
2198 i = 0;
2199 while (i < k) {
2200 Car[a] = sk_mkChar(s[i++]);
2201 if (i < k) {
2202 Cdr[a] = alloc(NIL, NIL);
2203 a = Cdr[a];
2204 }
2205 }
2206 unsave(1);
2207 return lst;
2208 }
2209
2210 /* Evaluate N=(STRING->SYMBOL M) */
doStringToSymbol(int n)2211 static int doStringToSymbol(int n) {
2212 int m;
2213 char *s;
2214
2215 m = Cdr[n];
2216 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2217 m = Car[m];
2218 if (atomic(m) || m == NIL || Car[m] != S_string)
2219 return error("non-string in 'string->symbol'", m);
2220 s = string(m);
2221 if (s[0] == 0)
2222 return error("empty string in 'string->symbol'", m);
2223 return addSym(s, S_undefined);
2224 }
2225
2226 /* Evaluate N=(STRING-APPEND M ...) */
doStringAppend(int n)2227 static int doStringAppend(int n) {
2228 int m, p;
2229 int k, len, o;
2230 int new;
2231 char *s, *q;
2232
2233 m = Cdr[n];
2234 k = 0;
2235 while (m != NIL) {
2236 p = Car[m];
2237 if (atomic(p) || p == NIL || Car[p] != S_string)
2238 return error("non-string in 'string-append'", p);
2239 s = string(p);
2240 o = k;
2241 len = strlen(s);
2242 k = k + len;
2243 if (k < 0 || k - len != o)
2244 return error("string too long in 'string-append'",
2245 NOEXPR);
2246 m = Cdr[m];
2247 }
2248 new = allocv(S_string, k+1);
2249 q = string(new);
2250 q[0] = 0;
2251 m = Cdr[n];
2252 while (m != NIL) {
2253 p = Car[m];
2254 s = string(p);
2255 strcpy(q, s);
2256 q = &q[strlen(q)];
2257 m = Cdr[m];
2258 }
2259 return new;
2260 }
2261
2262 /* Evaluate N=(STRING-LENGTH M) */
doStringLength(int n)2263 static int doStringLength(int n) {
2264 int m;
2265 char *s;
2266 char buf[20];
2267
2268 m = Cdr[n];
2269 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2270 m = Car[m];
2271 if (atomic(m) || m == NIL || Car[m] != S_string)
2272 return error("non-string in 'string-length'", m);
2273 s = string(m);
2274 sprintf(buf, "%d", strlen(s));
2275 return explodeNum(buf);
2276 }
2277
2278 /*
2279 * Convert bignum integer to long int and return it.
2280 * If the value of the bignum does not fit in a long int,
2281 * set EP[0] to a non-zero value. Otherwise, leave EP[0]
2282 * alone.
2283 */
sk_int(int n,int * ep)2284 long sk_int(int n, int *ep) {
2285 long v, o, d;
2286 int neg;
2287
2288 if (atomic(n) || n == NIL || Car[n] != S_integer) {
2289 ep[0] = -1;
2290 return 0;
2291 }
2292 v = 0;
2293 n = Cdr[n];
2294 neg = 0;
2295 if (caaar(n) == '+') {
2296 n = Cdr[n];
2297 }
2298 else if (caaar(n) == '-') {
2299 n = Cdr[n];
2300 neg = 1;
2301 }
2302 while (n != NIL) {
2303 o = v;
2304 d = digitToValue(Car[n]);
2305 v = v * 10 + d;
2306 if (v < 0 || (v - d) / 10 != o) {
2307 ep[0] = -1;
2308 return 0;
2309 }
2310 n = Cdr[n];
2311 }
2312 return neg? -v: v;
2313 }
2314
2315 /* Convert bignum integer to C integer */
valueOf(char * src,int n)2316 static int valueOf(char *src, int n) {
2317 int e, iv;
2318 long v;
2319 char buf[100];
2320
2321 e = 0;
2322 v = sk_int(n, &e);
2323 iv = (int) v;
2324 if (e || v != iv) {
2325 sprintf(buf, "value too big in '%s'", src);
2326 error(buf, n);
2327 }
2328 return iv;
2329 }
2330
2331 /* Evaluate N=(STRING-REF M1 M2) */
doStringRef(int n)2332 static int doStringRef(int n) {
2333 int m, m2, pos;
2334 char *s;
2335
2336 m = Cdr[n];
2337 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
2338 return wrongArgs(n);
2339 m2 = Cdr[m];
2340 m = Car[m];
2341 if (atomic(m) || m == NIL || Car[m] != S_string)
2342 return error("non-string in argument 1 of 'string-ref'", m);
2343 m2 = Car[m2];
2344 if (atomic(m2) || m2 == NIL || Car[m2] != S_integer)
2345 return error("non-number in argument 2 of 'string-ref'", m2);
2346 s = string(m);
2347 pos = valueOf("string-ref", m2);
2348 if (pos < 0 || pos >= strlen(s))
2349 return error("offset out of range in 'string-ref'", m2);
2350 return sk_mkChar(s[pos]);
2351 }
2352
2353 /* Evaluate N=(STRING? M) */
doStringP(int n)2354 static int doStringP(int n) {
2355 int m;
2356
2357 m = Cdr[n];
2358 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2359 m = Car[m];
2360 return !atomic(m) && m != NIL && Car[m] == S_string ? S_true: S_false;
2361 }
2362
2363 /* Evaluate N=(SUBSTRING M1 M2 M3) */
doSubstring(int n)2364 static int doSubstring(int n) {
2365 int m, m2, m3, start, end, k;
2366 char *s, *q;
2367 int new;
2368
2369 m = Cdr[n];
2370 if ( m == NIL || Cdr[m] == NIL || cddr(m) == NIL ||
2371 cdddr(m) != NIL
2372 )
2373 return wrongArgs(n);
2374 m2 = Cdr[m];
2375 m = Car[m];
2376 if (atomic(m) || m == NIL || Car[m] != S_string)
2377 return error("non-string in argument 1 of 'substring'", m);
2378 m3 = Cdr[m2];
2379 m2 = Car[m2];
2380 if (atomic(m2) || m2 == NIL || Car[m2] != S_integer)
2381 return error("non-number in argument 2 of 'substring'", m2);
2382 m3 = Car[m3];
2383 if (atomic(m3) || m3 == NIL || Car[m3] != S_integer)
2384 return error("non-number in argument 3 of 'substring'", m2);
2385 s = string(m);
2386 start = valueOf("substring", m2);
2387 end = valueOf("substring", m3);
2388 if (start < 0 || start > strlen(s))
2389 return error("offset out of range in 'substring'", m2);
2390 if (end < start || end > strlen(s))
2391 return error("bad range in 'substring'", NOEXPR);
2392 k = end - start;
2393 new = allocv(S_string, k+1);
2394 q = string(new);
2395 memcpy(q, &s[start], k);
2396 q[k] = 0;
2397 return new;
2398 }
2399
2400 /* Evaluate N=(SYMBOL->STRING M) */
doSymbolToString(int n)2401 static int doSymbolToString(int n) {
2402 int m, p, k, q, i;
2403 char *s;
2404
2405 m = Cdr[n];
2406 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2407 m = Car[m];
2408 if (!atomic(m))
2409 return error("non-symbol in 'symbol->string'", m);
2410 k = 1;
2411 for (p = Car[m]; p != NIL; p = Cdr[p])
2412 k++;
2413 q = allocv(S_string, k);
2414 s = string(q);
2415 p = Car[m];
2416 for (i = 0; i<k; i++) {
2417 s[i] = Car[p];
2418 p = Cdr[p];
2419 }
2420 s[i-1] = 0;
2421 return q;
2422 }
2423
2424
2425 /* Evaluate N=(SYMBOL? M) */
doSymbolP(int n)2426 static int doSymbolP(int n) {
2427 int m;
2428
2429 m = Cdr[n];
2430 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2431 m = Car[m];
2432 return atomic(m) && m != S_true && m != S_false ?
2433 S_true: S_false;
2434 }
2435
2436 /* Find syntax transformer bound to symbol Y. */
findTransformer(int y)2437 int findTransformer(int y) {
2438 int t;
2439
2440 for (t = Transformers; t != NIL; t = Cdr[t]) {
2441 if (caar(t) == y) return Car[t];
2442 }
2443 return S_false;
2444 }
2445
2446 /* Evaluate N=(SYNTAX->LIST M) */
doSyntaxToList(int n)2447 static int doSyntaxToList(int n) {
2448 int m, t;
2449
2450 m = Cdr[n];
2451 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2452 m = Car[m];
2453 if (!atomic(m) && m != NIL && Car[m] == S_syntax)
2454 return Cdr[m];
2455 if (!atomic(m)) return S_false;
2456 t = findTransformer(m);
2457 if (t != S_false) return cddr(t);
2458 return S_false;
2459 }
2460
2461 /* Evaluate N=(VECTOR->LIST M) */
doVectorToList(int n)2462 static int doVectorToList(int n) {
2463 int m, a, lst, k, i;
2464 int *p;
2465
2466 m = Cdr[n];
2467 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2468 m = Car[m];
2469 if (atomic(m) || m == NIL || Car[m] != S_vector)
2470 return error("non-vector in 'vector->list'", m);
2471 p = vector(m);
2472 k = vector_len(m);
2473 if (k == 0) return NIL;
2474 lst = alloc(NIL, NIL);
2475 save(lst);
2476 a = lst;
2477 i = 0;
2478 while (i < k) {
2479 Car[a] = p[i++];
2480 if (i < k) {
2481 Cdr[a] = alloc(NIL, NIL);
2482 a = Cdr[a];
2483 }
2484 }
2485 unsave(1);
2486 return lst;
2487 }
2488
2489 /* Evaluate N=(VECTOR-LENGTH M) */
doVectorLength(int n)2490 static int doVectorLength(int n) {
2491 int m;
2492 char buf[20];
2493
2494 m = Cdr[n];
2495 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2496 m = Car[m];
2497 if (atomic(m) || m == NIL || Car[m] != S_vector)
2498 return error("non-vector in 'vector-length'", m);
2499 sprintf(buf, "%d", vector_len(m));
2500 return explodeNum(buf);
2501 }
2502
2503 /* Evaluate N=(VECTOR-REF M1 M2) */
doVectorRef(int n)2504 static int doVectorRef(int n) {
2505 int m, v, i;
2506 int *p;
2507
2508 m = Cdr[n];
2509 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
2510 return wrongArgs(n);
2511 v = Car[m];
2512 if (atomic(v) || m == NIL || Car[v] != S_vector)
2513 return error("non-vector in 'vector-ref'", v);
2514 m = cadr(m);
2515 if (atomic(m) || m == NIL || Car[m] != S_integer)
2516 return error("non-integer in 'vector-ref'", m);
2517 i = valueOf("vector-ref", m);
2518 if (i >= vector_len(v))
2519 return error("reference out of range in 'vector-ref'", m);
2520 p = vector(v);
2521 return p[i];
2522 }
2523
2524 /* Evaluate N=(VECTOR? M) */
doVectorP(int n)2525 static int doVectorP(int n) {
2526 int m;
2527
2528 m = Cdr[n];
2529 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2530 m = Car[m];
2531 return !atomic(m) && m != NIL && Car[m] == S_vector? S_true: S_false;
2532 }
2533
2534 /* Evaluate N=(BOTTOM ...) */
doBottom(int n)2535 static int doBottom(int n) {
2536 n = alloc(S_bottom, Cdr[n]);
2537 return error("", n);
2538 }
2539
2540 /* Evaluate N=(VOID) */
doVoid(int n)2541 static int doVoid(int n) {
2542 if (Cdr[n] != NIL) return wrongArgs(n);
2543 return S_void;
2544 }
2545
2546 /* Evaluate N=(READ) */
doRead(int n)2547 static int doRead(int n) {
2548 if (Cdr[n] != NIL) return wrongArgs(n);
2549 return sk_read();
2550 }
2551
2552 /* Evaluate N=(READ-CHAR) */
doReadChar(int n)2553 static int doReadChar(int n) {
2554 int c;
2555
2556 if (Cdr[n] != NIL) return wrongArgs(n);
2557 c = sk_rdch();
2558 return c == EOT? S_eof: sk_mkChar(c);
2559 }
2560
2561 /* Evaluate N=(READ-FROM-STRING) */
doReadFromString(int n)2562 static int doReadFromString(int n) {
2563 int m;
2564 int oline;
2565 char ofile[MAXPATHL];
2566 int orejct;
2567
2568 m = Cdr[n];
2569 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2570 if (atomic(Car[m]) || caar(m) != S_string)
2571 error("non-string in 'read-from-string'", Car[m]);
2572 oline = Line;
2573 Line = 1;
2574 strcpy(ofile, Infile);
2575 strcpy(Infile, "READ-FROM-STRING");
2576 orejct = Rejected;
2577 Rejected = EOT;
2578 gcv(); /* Make sure InputString stays in place */
2579 InputString = string(Car[m]);
2580 n = xread();
2581 if (*InputString != 0 || Rejected != EOT) SK_errFlag = 1;
2582 if (n == S_eof) SK_errFlag = 1;
2583 InputString = NULL;
2584 Line = oline;
2585 strcpy(Infile, ofile);
2586 Rejected = orejct;
2587 if (SK_errFlag) {
2588 sk_gotError();
2589 return S_false;
2590 }
2591 return alloc(n, NIL);
2592 }
2593
2594 /* Evaluate N=(WRITE M) */
doWrite(int n)2595 static int doWrite(int n) {
2596 int m;
2597
2598 m = Cdr[n];
2599 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2600 Quoted = 1;
2601 _print(Car[m]);
2602 return S_void;
2603 }
2604
2605 /* Evaluate N=(WRITE-CHAR M) */
doWriteChar(int n)2606 static int doWriteChar(int n) {
2607 int m;
2608
2609 m = Cdr[n];
2610 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2611 if (atomic(Car[m]) || caar(m) != S_char)
2612 error("non-char in 'write-char'", Car[m]);
2613 fputc(cadar(m), Output);
2614 return S_void;
2615 }
2616
2617 /* Evaluate N=(WRITE-TO-STRING M) */
doWriteToString(int n)2618 static int doWriteToString(int n) {
2619 int m, str, k;
2620 int vp;
2621
2622 m = Cdr[n];
2623 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2624 /* Allocate all remaining vector space */
2625 gcv();
2626 vp = Vptr;
2627 str = allocv(S_string, (VPoolSize-Vptr-3) * sizeof(int));
2628 OutputString = string(str);
2629 OutStrSize = string_len(str);
2630 k = OutStrSize;
2631 sk_print(Car[m]);
2632 OutputString = NULL;
2633 /* Shrink string to actual size */
2634 Vptr = vp;
2635 return allocv(S_string, k - OutStrSize+1);
2636 }
2637
2638 /* Evaluate N=(DISPLAY M) */
doDisplay(int n)2639 static int doDisplay(int n) {
2640 int m;
2641
2642 m = Cdr[n];
2643 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2644 sk_display(Car[m]);
2645 return S_void;
2646 }
2647
2648 /* Evaluate N=(DELETE-FILE M) */
doDeleteFile(int n)2649 static int doDeleteFile(int n) {
2650 int m, f;
2651 char *s;
2652
2653 m = Cdr[n];
2654 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
2655 f = Car[m];
2656 if (atomic(f) || f == NIL || Car[f] != S_string)
2657 return error("non-string in 'delete-file'", f);
2658 s = string(f); /* file name */
2659 return unlink(s)? S_false: S_true;
2660 }
2661
2662 /*
2663 * Check whether (CAR NP[0]) is a builtin procedure.
2664 * If it is one, run the appropriate routine, save
2665 * its result in NP[0], and return -1.
2666 * If (CAR NP[0]) is not a builtin procedure, return 0.
2667 */
primitive(int * np)2668 static int primitive(int *np) {
2669 int n, y;
2670 int (*op)(int);
2671
2672 n = np[0];
2673 y = Car[n];
2674 if (SK_errFlag) return 0;
2675 if (Car[y] == S_primitive) {
2676 op = Primitives[cadr(y)];
2677 }
2678 else if (Car[y] == S_user_primitive) {
2679 y = cadr(y);
2680 if (y > LastUsrPrimitive)
2681 fatal("primitive(): bad user primitive");
2682 op = UsrPrimitives[y];
2683 }
2684 else {
2685 return 0;
2686 }
2687 n = (*op)(n);
2688 np[0] = n;
2689 return -1;
2690 }
2691
2692 /*
2693 * Create a flat copy of a list.
2694 * Store a reference to the last member
2695 * of the copy in lastp.
2696 */
flatCopy(int n,int * lastp)2697 static int flatCopy(int n, int *lastp) {
2698 int a, m, last;
2699
2700 if (n == NIL) {
2701 lastp[0] = NIL;
2702 return NIL;
2703 }
2704 m = alloc(NIL, NIL);
2705 save(m);
2706 a = m;
2707 last = m;
2708 while (n != NIL) {
2709 Car[a] = Car[n];
2710 last = a;
2711 n = Cdr[n];
2712 if (n != NIL) {
2713 Cdr[a] = alloc(NIL, NIL);
2714 a = Cdr[a];
2715 }
2716 }
2717 unsave(1);
2718 lastp[0] = last;
2719 return m;
2720 }
2721
2722 /* Copy names and values of the symbol table into an alist. */
copyBindings(void)2723 static int copyBindings(void) {
2724 int y, p, ny, pk, q;
2725
2726 pk = Packages;
2727 p = alloc(NIL, NIL);
2728 ny = p;
2729 q = NIL;
2730 save(p);
2731 while (pk != NIL) {
2732 y = cdar(pk);
2733 while (y != NIL) {
2734 Car[p] = alloc(Car[y], cdar(y));
2735 y = Cdr[y];
2736 Cdr[p] = alloc(NIL, NIL);
2737 q = p;
2738 p = Cdr[p];
2739 }
2740 pk = Cdr[pk];
2741 }
2742 if (q != NIL) Cdr[q] = NIL;
2743 unsave(1);
2744 return Car[ny] == NIL? NIL: ny;
2745 }
2746
2747 /* Restore values of the symbol table. */
restoreBindings(int values)2748 static void restoreBindings(int values) {
2749 int b;
2750
2751 while (values != NIL) {
2752 b = Car[values];
2753 cdar(b) = Cdr[b];
2754 values = Cdr[values];
2755 }
2756 }
2757
2758 /*
2759 * Extract clause of COND.
2760 * Check the syntax of the clause
2761 * and return its predicate.
2762 */
getPred(void)2763 static int getPred(void) {
2764 int e;
2765
2766 e = caar(Bstack);
2767 if ( atomic(e) || e == NIL ||
2768 Cdr[e] == NIL || cddr(e) != NIL
2769 )
2770 return error("bad clause in 'cond'", e);
2771 if (cdar(Bstack) == NIL && Car[e] == S_else)
2772 return S_true;
2773 return Car[e];
2774 }
2775
2776 /*
2777 * Setup context for evaluation of (COND (P1 E1) ... (Pn En)).
2778 * The context consits of a list of clauses.
2779 * Return the predicate of the first clause.
2780 */
setupCond(int n)2781 static int setupCond(int n) {
2782 int m;
2783
2784 m = Cdr[n];
2785 if (m == NIL) return wrongArgs(n);
2786 bsave(m);
2787 return getPred();
2788 }
2789
2790 /*
2791 * Evaluate next clause of COND.
2792 * N is the value of the current predicate.
2793 * If N=#T, return the expression of the predicate.
2794 * If N=#F, return the predicate of the next clause.
2795 * When returning the expression of a predicate (N=#T),
2796 * set the context on the Bstack to NIL to signal that
2797 * a true predicate was found.
2798 */
evalClause(int n)2799 static int evalClause(int n) {
2800 int e;
2801
2802 e = Car[Bstack];
2803 if (n == S_false) {
2804 Car[Bstack] = Cdr[e];
2805 if (Car[Bstack] == NIL)
2806 return error("no default in 'cond'", NOEXPR);
2807 return getPred();
2808 }
2809 else {
2810 e = cadar(e);
2811 Car[Bstack] = NIL;
2812 return e;
2813 }
2814 }
2815
2816 /*
2817 * Setup context for evaluation of (AND ...) and (OR ...)
2818 * Return the first expression of the form.
2819 */
setupLogOp(int n)2820 static int setupLogOp(int n) {
2821 int m;
2822
2823 m = Cdr[n];
2824 if (m == NIL) return wrongArgs(n);
2825 bsave(m);
2826 return Car[m];
2827 }
2828
2829 /*
2830 * Unbind the arguments of LAMBDA, LET and LETREC.
2831 * See also bindArgs().
2832 */
unbindArgs(void)2833 static void unbindArgs(void) {
2834 int v;
2835
2836 Frame = unsave(1);
2837 Function = unsave(1);
2838 v = bunsave(1); /* Caller's namelist */
2839 while (v != NIL) {
2840 cdar(v) = unsave(1);
2841 v = Cdr[v];
2842 }
2843 }
2844
2845 /*
2846 * Check whether the symbol N is bound in the current
2847 * lexical environment.
2848 */
isBound(int n)2849 static int isBound(int n) {
2850 int b;
2851
2852 b = Bound;
2853 while (b != NIL) {
2854 if (atomic(b)) {
2855 if (n == b) return 1;
2856 break;
2857 }
2858 if (n == Car[b]) return 1;
2859 b = Cdr[b];
2860 }
2861 b = Car[LexEnv];
2862 while (b != NIL) {
2863 if (caar(b) == n) return 1;
2864 b = Cdr[b];
2865 }
2866 return 0;
2867 }
2868
2869 /*
2870 * Recursively collect free variables and add their symbols
2871 * and values to the current lexical environment.
2872 */
collect(int n)2873 static void collect(int n) {
2874 int m;
2875
2876 if (n == NIL || (Tag[n] & AFLAG) || tagged(n)) return;
2877 if (atomic(n)) {
2878 if (isBound(n)) return;
2879 Car[LexEnv] = alloc(NIL, Car[LexEnv]);
2880 caar(LexEnv) = alloc(n, Cdr[n]);
2881 return;
2882 }
2883 if (Car[n] == S_quote) {
2884 collect(Car[n]);
2885 return;
2886 }
2887 m = n;
2888 while (m != NIL && !atomic(m)) {
2889 collect(Car[m]);
2890 m = Cdr[m];
2891 }
2892 }
2893
2894 /* Create lexical environment. */
mkLexEnv(int term,int locals)2895 static int mkLexEnv(int term, int locals) {
2896 LexEnv = alloc(NIL, NIL);
2897 save(LexEnv);
2898 Bound = locals;
2899 collect(term);
2900 unsave(1);
2901 return Car[LexEnv];
2902 }
2903
2904 /* Create a closure from a lambda expression. */
closure(int n)2905 static int closure(int n) {
2906 int cl, env, args, term;
2907
2908 if (SK_errFlag) return NIL;
2909 args = cadr(n);
2910 term = caddr(n);
2911 if (cdddr(n) == NIL) {
2912 env = mkLexEnv(term, args);
2913 if (Estack != NIL) Estack = alloc(env, Estack);
2914 }
2915 else if (cadddr(n) == S_void) {
2916 /* Use dynamic scoping */
2917 env = NIL;
2918 }
2919 else {
2920 env = cadddr(n);
2921 }
2922 cl = alloc(env, NIL);
2923 cl = alloc(term, cl);
2924 cl = alloc(args, cl);
2925 return alloc(S_closure, cl);
2926 }
2927
2928 /* Fix cached recursive bindings in closures. */
fixCachedClosures(void)2929 static void fixCachedClosures(void) {
2930 int a, ee, e;
2931
2932 if (SK_errFlag || Estack == NIL || Estack == S_true) return;
2933 a = Car[Bstack];
2934 while (a != NIL) {
2935 ee = Estack;
2936 while (ee != NIL && ee != S_true) {
2937 e = Car[ee];
2938 while (e != NIL) {
2939 if (Car[a] == caar(e)) {
2940 cdar(e) = cdar(a);
2941 break;
2942 }
2943 e = Cdr[e];
2944 }
2945 ee = Cdr[ee];
2946 }
2947 a = Cdr[a];
2948 }
2949 }
2950
2951 /*
2952 * Fix references to symbols of BINDINGS
2953 * in all closures of N.
2954 */
fixClosuresOf(int n,int bindings)2955 static void fixClosuresOf(int n, int bindings) {
2956 int ee, e;
2957 int bb, b;
2958
2959 if (n == NIL || atomic(n)) return;
2960 if (Car[n] == S_lambda) {
2961 fixClosuresOf(caddr(n), bindings);
2962 ee = cdddr(n);
2963 if (ee == NIL) return;
2964 ee = Car[ee];
2965 while (ee != NIL) {
2966 e = Car[ee];
2967 bb = bindings;
2968 while (bb != NIL) {
2969 b = Car[bb];
2970 if (Car[b] == Car[e])
2971 Cdr[e] = Cdr[b];
2972 bb = Cdr[bb];
2973 }
2974 ee = Cdr[ee];
2975 }
2976 return;
2977 }
2978 if (tagged(n)) return;
2979 fixClosuresOf(Car[n], bindings);
2980 fixClosuresOf(Cdr[n], bindings);
2981 }
2982
2983 /* Fix recursive bindings of closures. */
fixAllClosures(int b)2984 static void fixAllClosures(int b) {
2985 int p;
2986
2987 p = b;
2988 while (p != NIL) {
2989 fixClosuresOf(cdar(p), b);
2990 p = Cdr[p];
2991 }
2992 }
2993
2994 /* Check whether N is an alist. */
isAlist(int n)2995 static int isAlist(int n) {
2996 if (atomic(n)) return 0;
2997 while (n != NIL) {
2998 if (lazyAtom(Car[n]) || !atomic(caar(n)))
2999 return 0;
3000 n = Cdr[n];
3001 }
3002 return -1;
3003 }
3004
3005 /* Check whether M is a list of symbols. */
isSymList(int m)3006 static int isSymList(int m) {
3007 while (m != NIL) {
3008 if (!atomic(Car[m])) return 0;
3009 if (atomic(Cdr[m])) break;
3010 m = Cdr[m];
3011 }
3012 return 1;
3013 }
3014
3015 /* Evaluate N=(RECURSIVE-BIND M) */
doRecursiveBind(int n)3016 static int doRecursiveBind(int n) {
3017 int m, env;
3018
3019 m = Cdr[n];
3020 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
3021 env = Car[m];
3022 if (!isAlist(env))
3023 return error("non-alist in recursive-bind", env);
3024 fixAllClosures(env);
3025 return env;
3026 }
3027
3028 /*
3029 * Set up a context for processing LET and LETREC.
3030 * Save
3031 * - the complete LET/LETREC expression on the Bstack
3032 * - the environment on the Bstack
3033 * - a list of new bindings on the Bstack (initially empty)
3034 * - a list of saved names on the Bstack (initially empty)
3035 * - a copy of the Estack on the Stack
3036 * Clear the Estack.
3037 */
setupLet(int n)3038 static int setupLet(int n) {
3039 int m; /* Argument pointer */
3040
3041 m = Cdr[n];
3042 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
3043 return wrongArgs(n);
3044 m = Car[m];
3045 if (atomic(m))
3046 return error("bad environment in 'let' or 'letrec'", m);
3047 bsave(n); /* save entire LET/LETREC */
3048 bsave(m); /* save environment */
3049 bsave(NIL); /* list of bindings */
3050 bsave(NIL); /* save empty name list */
3051 save(Estack);
3052 Estack = NIL;
3053 return m;
3054 }
3055
3056 /*
3057 * Process one binding of LET/LETREC:
3058 * Bind value to name, advance to next binding.
3059 * Return:
3060 * non-NIL - more bindings in environment
3061 * NIL - last binding done
3062 */
nextLet(int n)3063 static int nextLet(int n) {
3064 int m, p;
3065
3066 m = caddr(Bstack); /* rest of environment */
3067 if (m == NIL) return NIL;
3068 p = Car[m];
3069 Tmp2 = n;
3070 cadr(Bstack) = alloc(NIL, cadr(Bstack));
3071 caadr(Bstack) = alloc(Car[p], n);
3072 Tmp2 = NIL;
3073 caddr(Bstack) = Cdr[m];
3074 return Cdr[m];
3075 }
3076
3077 /*
3078 * Evaluate value to bind inside of LET/LETREC:
3079 * - check syntax
3080 * - save name to bind to
3081 * - save original binding of name
3082 * - return (unevaluated) value
3083 */
evalLet(void)3084 static int evalLet(void) {
3085 int m, p, v;
3086
3087 m = caddr(Bstack);
3088 p = Car[m];
3089 /* Each binding must have the form (atom expr) */
3090 if ( atomic(p) || Cdr[p] == NIL || atomic(Cdr[p]) ||
3091 cddr(p) != NIL || !atomic(Car[p])
3092 ) {
3093 /* In case of an error, get rid of the */
3094 /* partial environment. */
3095 v = bunsave(1);
3096 bunsave(3);
3097 bsave(v);
3098 Estack = unsave(1);
3099 save(Function);
3100 save(Frame);
3101 unbindArgs();
3102 return error("bad binding in 'let' or 'letrec'", p);
3103 }
3104 Car[Bstack] = alloc(Car[p], Car[Bstack]); /* Save name */
3105 /* Evaluate the new value of the current symbol */
3106 return cadr(p);
3107 }
3108
3109 /* Reverse a list in situ. */
nreverse(int n)3110 static int nreverse(int n) {
3111 int this, next, x;
3112
3113 if (n == NIL) return NIL;
3114 this = n;
3115 next = Cdr[n];
3116 Cdr[this] = NIL;
3117 while (next != NIL) {
3118 x = Cdr[next];
3119 Cdr[next] = this;
3120 this = next;
3121 next = x;
3122 }
3123 return this;
3124 }
3125
3126 /* Establish the bindings of LET/LETREC. */
bindLet(int env)3127 static void bindLet(int env) {
3128 int b;
3129
3130 while (env != NIL) {
3131 b = Car[env];
3132 save(cdar(b)); /* Save old value */
3133 cdar(b) = Cdr[b]; /* Bind new value */
3134 env = Cdr[env];
3135 }
3136 }
3137
3138 /*
3139 * Finish processing bindings of LET/LETREC:
3140 * finish context and return body.
3141 */
finishLet(int rec)3142 static int finishLet(int rec) {
3143 int m, v, b, e;
3144
3145 Tmp2 = alloc(NIL, NIL); /* Create safe storage */
3146 Tmp2 = alloc(NIL, Tmp2);
3147 Tmp2 = alloc(NIL, Tmp2);
3148 Tmp2 = alloc(NIL, Tmp2);
3149 v = bunsave(1);
3150 b = bunsave(1); /* get bindings */
3151 m = bunsave(2); /* drop environment, get full LET/LETREC */
3152 b = nreverse(b); /* needed for unbindArgs() */
3153 e = unsave(1); /* outer Estack */
3154 Car[Tmp2] = b; /* protect b, m, v */
3155 cadr(Tmp2) = m;
3156 caddr(Tmp2) = v;
3157 cdddr(Tmp2) = e;
3158 bindLet(b);
3159 bsave(v);
3160 if (rec) fixCachedClosures();
3161 Estack = e;
3162 save(Function); /* required by unbindArgs() */
3163 save(Frame);
3164 Tmp2 = NIL;
3165 return caddr(m); /* return body */
3166 }
3167
3168 /* Substitute each OLD in *P with NEW. */
subst(int old,int new,int * p)3169 static void subst(int old, int new, int *p) {
3170 if (*p == NIL) return;
3171 if (lazyAtom(*p)) {
3172 if (*p == old) *p = new;
3173 return;
3174 }
3175 subst(old, new, &Car[*p]);
3176 subst(old, new, &Cdr[*p]);
3177 }
3178
3179 /*
3180 * Make symbol N local to the current package.
3181 * Also fix recursive references to N in EXPR.
3182 */
localize(int n,int * exprp)3183 int localize(int n, int *exprp) {
3184 int y, osym;
3185
3186 y = Symbols;
3187 while (y != NIL) {
3188 if (n == Car[y]) return n;
3189 y = Cdr[y];
3190 }
3191 osym = Symbols;
3192 Symbols = alloc(NIL, Symbols);
3193 Car[Symbols] = alloc(Car[n], S_undefined);
3194 updatePackages(osym, Symbols);
3195 subst(n, Car[Symbols], exprp);
3196 return Car[Symbols];
3197 }
3198
3199 /* Evaluate N=(AND ...) */
doAnd(int n,int * pcf,int * pmode,int * pcbn)3200 static int doAnd(int n, int *pcf, int *pmode, int *pcbn) {
3201 USE(pcbn);
3202 if (Cdr[n] == NIL) {
3203 return S_true;
3204 }
3205 else if (cddr(n) == NIL) {
3206 *pcf = 1;
3207 return cadr(n);
3208 }
3209 else {
3210 *pcf = 2;
3211 *pmode = MCONJ;
3212 return setupLogOp(n);
3213 }
3214 }
3215
3216 /* Evaluate N=(APPLY M) */
doApply(int n,int * pcf,int * pmode,int * pcbn)3217 static int doApply(int n, int *pcf, int *pmode, int *pcbn) {
3218 int m, p, q, last;
3219
3220 *pcf = 1;
3221 USE(pmode);
3222 *pcbn = 1;
3223 m = Cdr[n];
3224 if (m == NIL || Cdr[m] == NIL) return wrongArgs(n);
3225 if (Car[m] == NIL || atomic(Car[m]))
3226 return error("non-procedure in 'apply'", Car[m]);
3227 p = caar(m);
3228 if (!SK_strictApply && p == S_special)
3229 ; /* OK */
3230 else if (p != S_primitive &&
3231 p != S_special_cbv &&
3232 p != S_closure &&
3233 p != S_user_primitive
3234 )
3235 return error("non-procedure in 'apply'", Car[m]);
3236 p = m;
3237 last = p;
3238 while (p != NIL) {
3239 if (lazyAtom(p))
3240 return error("improper list in application", n);
3241 last = p;
3242 p = Cdr[p];
3243 }
3244 p = Car[last];
3245 while (p != NIL) {
3246 if (atomic(p) || tagged(p)) return
3247 error("improper list in 'apply'", Car[last]);
3248 p = Cdr[p];
3249 }
3250 if (cddr(m) == NIL)
3251 return alloc(Car[m], cadr(m));
3252 p = flatCopy(Cdr[m], &q);
3253 q = p;
3254 while (cddr(q) != NIL) q = Cdr[q];
3255 Cdr[q] = Car[last];
3256 return alloc(Car[m], p);
3257 }
3258
3259 /* Evaluate N=(BEGIN ...) */
doBegin(int n,int * pcf,int * pmode,int * pcbn)3260 static int doBegin(int n, int *pcf, int *pmode, int *pcbn) {
3261 USE(pcbn);
3262 if (Cdr[n] == NIL) {
3263 return S_void;
3264 }
3265 else if (cddr(n) == NIL) {
3266 *pcf = 1;
3267 return cadr(n);
3268 }
3269 else {
3270 *pcf = 2;
3271 *pmode = MBEGN;
3272 return setupLogOp(n);
3273 }
3274 }
3275
3276 /* Evaluate N=(COND M1 ...) */
doCond(int n,int * pcf,int * pmode,int * pcbn)3277 static int doCond(int n, int *pcf, int *pmode, int *pcbn) {
3278 *pcf = 2;
3279 *pmode = MCOND;
3280 USE(pcbn);
3281 return setupCond(n);
3282 }
3283
3284 /* Evaluate N=(DEFINE (M ...) MN) */
newDefine(int n)3285 static int newDefine(int n) {
3286 int m, y;
3287
3288 m = Cdr[n];
3289 if (Car[m] == NIL)
3290 return error("missing function name in 'define'",
3291 Car[m]);
3292 if (!isSymList(Car[m])) return badArgLst(Car[m]);
3293 y = caar(m);
3294 save(cadr(m));
3295 Tmp2 = alloc(S_void, NIL);
3296 Tmp2 = alloc(cadr(m), Tmp2);
3297 Tmp2 = alloc(cdar(m), Tmp2);
3298 Tmp2 = alloc(S_lambda, Tmp2);
3299 y = localize(y, &cadr(m));
3300 Cdr[y] = eval(Tmp2);
3301 Tmp2 = NIL;
3302 unsave(1);
3303 return S_void;
3304 }
3305
3306 /* Evaluate N=(DEFINE M eval[M2]) */
doDefine(int n,int * pcf,int * pmode,int * pcbn)3307 static int doDefine(int n, int *pcf, int *pmode, int *pcbn) {
3308 int m, v, y;
3309
3310 if (EvLev > 1) {
3311 error("'define' is limited to the top level", NOEXPR);
3312 return NIL;
3313 }
3314 m = Cdr[n];
3315 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
3316 return wrongArgs(n);
3317 y = Car[m];
3318 if (!atomic(y)) return newDefine(n);
3319 /* Protect the unevaluated expression */
3320 v = cadr(m);
3321 save(v); /* really? */
3322 /* If we are binding to a lambda expression, */
3323 /* add a null environment */
3324 if (!lazyAtom(v) && Car[v] == S_lambda) {
3325 if ( Cdr[v] != NIL && cddr(v) != NIL &&
3326 cdddr(v) == NIL
3327 ) {
3328 cdddr(v) = alloc(S_void, NIL);
3329 }
3330 }
3331 y = localize(y, &cadr(m));
3332 /* Evaluate and bind second argument */
3333 Cdr[y] = eval(cadr(m));
3334 unsave(1);
3335 return S_void;
3336 }
3337
3338 /* Register a syntax transformer */
registerTransformer(int y,int tr)3339 void registerTransformer(int y, int tr) {
3340 int t;
3341
3342 t = findTransformer(y);
3343 if (t != S_false) {
3344 Cdr[t] = tr;
3345 }
3346 else {
3347 Transformers = alloc(NIL, Transformers);
3348 Car[Transformers] = alloc(y, tr);
3349 }
3350 }
3351
3352 /* Evaluate N=(DEFINE-SYNTAX M1 M2) */
doDefineSyntax(int n,int * pcf,int * pmode,int * pcbn)3353 static int doDefineSyntax(int n, int *pcf, int *pmode, int *pcbn) {
3354 int m, tr, y;
3355
3356 USE(pcf);
3357 USE(pmode);
3358 USE(pcbn);
3359 if (EvLev > 1) {
3360 error("'define-syntax' is limited to the top level", NOEXPR);
3361 return NIL;
3362 }
3363 m = Cdr[n];
3364 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
3365 return wrongArgs(n);
3366 if (!atomic(Car[m]))
3367 return error("name expected in 'define-syntax'", Car[m]);
3368 y = Car[m];
3369 save(cadr(m)); /* really? */
3370 SyntaxMode = 1;
3371 tr = eval(cadr(m));
3372 SyntaxMode = 0;
3373 unsave(1);
3374 if (atomic(tr) || tr == NIL || Car[tr] != S_syntax)
3375 return error("transformer expected in 'define-syntax'",
3376 cadr(m));
3377 Cdr[y] = tr;
3378 cadr(tr) = y;
3379 registerTransformer(y, tr);
3380 return S_void;
3381 }
3382
3383 /* Evaluate N=(SYNTAX-RULES (M1 ...) (P1 E1) ...) */
doSyntaxRules(int n,int * pcf,int * pmode,int * pcbn)3384 static int doSyntaxRules(int n, int *pcf, int *pmode, int *pcbn) {
3385 int m, cl, tr;
3386
3387 USE(pcf);
3388 USE(pmode);
3389 USE(pcbn);
3390 m = Cdr[n];
3391 if (m == NIL || Cdr[m] == NIL) return wrongArgs(n);
3392 if (!SyntaxMode)
3393 return error("'syntax-rules' not in 'define-syntax'",
3394 NOEXPR);
3395 if (lazyAtom(Car[m]) || !isSymList(Car[m]))
3396 return error("list of symbols expected in 'syntax-rules'",
3397 Car[m]);
3398 cl = Cdr[m];
3399 while (cl != NIL) {
3400 if (lazyAtom(cl))
3401 return error("improper list in 'syntax-rules'",
3402 Cdr[m]);
3403 if ( Car[cl] == NIL ||
3404 lazyAtom(Car[cl]) ||
3405 cdar(cl) == NIL ||
3406 lazyAtom(cdar(cl))
3407 )
3408 return error("bad clause in 'syntax-rules'",
3409 Car[cl]);
3410 cl = Cdr[cl];
3411 }
3412 tr = alloc(Cdr[m], NIL);
3413 tr = alloc(Car[m], tr);
3414 tr = alloc(NIL, tr);
3415 tr = alloc(S_syntax, tr);
3416 return tr;
3417 }
3418
3419 /* Evaluate N=(EVAL M) */
doEval(int n,int * pcf,int * pmode,int * pcbn)3420 static int doEval(int n, int *pcf, int *pmode, int *pcbn) {
3421 int m;
3422
3423 *pcf = 1;
3424 USE(pmode);
3425 USE(pcbn);
3426 m = Cdr[n];
3427 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
3428 n = eval(Car[m]);
3429 return syntaxTransform(n);
3430 }
3431
3432 /* Evaluate N=(IF P C A) */
doIf(int n,int * pcf,int * pmode,int * pcbn)3433 static int doIf(int n, int *pcf, int *pmode, int *pcbn) {
3434 int m;
3435
3436 *pcf = 2;
3437 *pmode = MIFPR;
3438 USE(pcbn);
3439 m = Cdr[n];
3440 if ( m == NIL || Cdr[m] == NIL || cddr(m) == NIL ||
3441 cdddr(m) != NIL
3442 )
3443 return wrongArgs(n);
3444 bsave(m);
3445 return Car[m];
3446 }
3447
3448 /* Evaluate N=(LAMBDA ARGS BODY) */
doLambda(int n,int * pcf,int * pmode,int * pcbn)3449 static int doLambda(int n, int *pcf, int *pmode, int *pcbn) {
3450 int m;
3451
3452 m = Cdr[n];
3453 if ( m == NIL || Cdr[m] == NIL ||
3454 (cddr(m) != NIL && cdddr(m) != NIL)
3455 )
3456 return wrongArgs(n);
3457 if (cddr(m) != NIL && caddr(m) != S_void)
3458 return wrongArgs(n);
3459 if (!atomic(Car[m])) {
3460 if (tagged(Car[m])) return badArgLst(Car[m]);
3461 if (!isSymList(Car[m])) return badArgLst(Car[m]);
3462 }
3463 return closure(n);
3464 }
3465
3466 /* Evaluate N=(LET ENV EXPR) */
doLet(int n,int * pcf,int * pmode,int * pcbn)3467 static int doLet(int n, int *pcf, int *pmode, int *pcbn) {
3468 *pcf = 2;
3469 *pmode = MBIND;
3470 USE(pcbn);
3471 if (setupLet(n) != NIL)
3472 return evalLet();
3473 else
3474 return NIL;
3475 }
3476
3477 /* Evaluate N=(LETREC ENV EXPR) */
doLetrec(int n,int * pcf,int * pmode,int * pcbn)3478 static int doLetrec(int n, int *pcf, int *pmode, int *pcbn) {
3479 int m;
3480
3481 *pcf = 2;
3482 *pmode = MBINR;
3483 USE(pcbn);
3484 if (setupLet(n) != NIL)
3485 m = evalLet();
3486 else
3487 m = NIL;
3488 Estack = S_true;
3489 return m;
3490 }
3491
3492 /* Evaluate N=(OR ...) */
doOr(int n,int * pcf,int * pmode,int * pcbn)3493 static int doOr(int n, int *pcf, int *pmode, int *pcbn) {
3494 USE(pcbn);
3495 if (Cdr[n] == NIL) {
3496 return S_false;
3497 }
3498 else if (cddr(n) == NIL) {
3499 *pcf = 1;
3500 return cadr(n);
3501 }
3502 else {
3503 *pcf = 2;
3504 *pmode = MDISJ;
3505 return setupLogOp(n);
3506 }
3507 }
3508
3509 /* Evaluate N=(QUOTE M) */
doQuote(int n,int * pcf,int * pmode,int * pcbn)3510 static int doQuote(int n, int *pcf, int *pmode, int *pcbn) {
3511 int m;
3512
3513 USE(pcf);
3514 USE(pmode);
3515 USE(pcbn);
3516 m = Cdr[n];
3517 if (m == NIL || Cdr[m] != NIL) return wrongArgs(n);
3518 return (Car[m]);
3519 }
3520
3521 /* Evaluate N=(WITH-INPUT-FROM-FILE M1 M2) */
doWithInputFromFile(int n,int * pcf,int * pmode,int * pcbn)3522 static int doWithInputFromFile(int n, int *pcf, int *pmode, int *pcbn) {
3523 int m, f;
3524 int r, p;
3525 FILE *ofile, *nfile;
3526 char *s;
3527
3528 USE(pcf);
3529 USE(pmode);
3530 USE(pcbn);
3531 m = Cdr[n];
3532 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
3533 return wrongArgs(n);
3534 f = Car[m];
3535 if (atomic(f) || f == NIL || Car[f] != S_string)
3536 return error("non-string in 'string->symbol'", f);
3537 s = string(f); /* file name */
3538 if ((nfile = fopen(s, "r")) == NULL)
3539 return error("cannot open input file", f);
3540 /* Save old input state, create new */
3541 ofile = Input;
3542 Input = nfile;
3543 r = Rejected;
3544 Rejected = EOT;
3545 p = alloc(cadr(m), NIL); /* thunk => (thunk) */
3546 n = eval(p);
3547 /* Restore input state */
3548 Input = ofile;
3549 Rejected = r;
3550 fclose(nfile);
3551 return n;
3552 }
3553
3554 /* Evaluate N=(WITH-OUTPUT-TO-FILE M1 M2) */
doWithOutputToFile(int n,int * pcf,int * pmode,int * pcbn)3555 static int doWithOutputToFile(int n, int *pcf, int *pmode, int *pcbn) {
3556 int m, f;
3557 int p;
3558 FILE *ofile, *nfile;
3559 char *s;
3560
3561 USE(pcf);
3562 USE(pmode);
3563 USE(pcbn);
3564 m = Cdr[n];
3565 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
3566 return wrongArgs(n);
3567 f = Car[m];
3568 if (atomic(f) || f == NIL || Car[f] != S_string)
3569 return error("non-string in 'string->symbol'", f);
3570 s = string(f); /* file name */
3571 if ((nfile = fopen(s, "w")) == NULL)
3572 return error("cannot create output file", f);
3573 /* Save old output state, create new */
3574 fflush(Output);
3575 ofile = Output;
3576 Output = nfile;
3577 p = alloc(cadr(m), NIL); /* thunk => (thunk) */
3578 n = eval(p);
3579 /* Restore output state */
3580 Output = ofile;
3581 fclose(nfile);
3582 return n;
3583 }
3584
3585 /*
3586 * Check whether (CAR NP[0]) is a special form handler.
3587 * If it is one, run the appropriate routine, save
3588 * its result in NP[0], and return -1.
3589 * If (CAR NP[0]) is not a SF handler, return 0.
3590 */
special(int * np,int * pcf,int * pmode,int * pcbn)3591 static int special(int *np, int *pcf, int *pmode, int *pcbn) {
3592 int n, y;
3593 int (*op)(int, int *, int *, int *);
3594
3595 n = np[0];
3596 y = Car[n];
3597 if (SK_errFlag) return 0;
3598 if (Car[y] == S_special || Car[y] == S_special_cbv)
3599 op = Specials[cadr(y)];
3600 else if (atomic(y) &&
3601 (cadr(y) == S_special ||
3602 cadr(y) == S_special_cbv)
3603 )
3604 op = Specials[caddr(y)];
3605 else
3606 return 0;
3607 np[0] = (*op)(n, pcf, pmode, pcbn);
3608 return -1;
3609 }
3610
3611 /*
3612 * Bind the arguments of a LAMBDA function.
3613 * For a lambda application N=((LAMBDA (X1 ... Xn) EXPR) Y1 ... Yn)
3614 * this includes the following steps for j in {1,...,n}:
3615 * 1) save Xj
3616 * 2) save the value of Xj
3617 * 3) bind Xj to Yj
3618 */
bindArgs(int n,int name)3619 static int bindArgs(int n, int name) {
3620 int fa, /* Formal arg list */
3621 aa, /* Actual arg list */
3622 e; /* Expression */
3623 int env; /* Optional lexical environment */
3624 int p;
3625 int at; /* Atomic argument list flag */
3626
3627 if (SK_errFlag) return NIL;
3628 fa = cadar(n);
3629 at = atomic(fa);
3630 aa = Cdr[n];
3631 p = cddar(n);
3632 e = Car[p];
3633 env = Cdr[p] != NIL ? cadr(p): NIL;
3634 bsave(NIL);
3635 while ((fa != NIL && aa != NIL) || at) {
3636 if (!at) {
3637 /* Save name */
3638 Car[Bstack] = alloc(Car[fa], Car[Bstack]);
3639 save(cdar(fa)); /* Save value */
3640 cdar(fa) = Car[aa]; /* Bind arg */
3641 fa = Cdr[fa];
3642 aa = Cdr[aa];
3643 }
3644 if (atomic(fa)) { /* improper argument list */
3645 Car[Bstack] = alloc(fa, Car[Bstack]); /* Save name */
3646 save(Cdr[fa]); /* Save value */
3647 Cdr[fa] = aa; /* Bind remaining arg list */
3648 fa = NIL;
3649 aa = NIL;
3650 break;
3651 }
3652 }
3653 while (env != NIL) {
3654 p = Car[env];
3655 Car[Bstack] = alloc(Car[p], Car[Bstack]);/* Save name */
3656 save(cdar(p)); /* Save value */
3657 cdar(p) = Cdr[p]; /* Bind lex val */
3658 env = Cdr[env];
3659 }
3660 if (fa != NIL || aa != NIL) {
3661 wrongArgs(n);
3662 n = NIL;
3663 }
3664 else {
3665 n = e;
3666 }
3667 save(Function);
3668 Function = name;
3669 save(Frame);
3670 Frame = Stack;
3671 return n;
3672 }
3673
3674 /*
3675 * Print application of traced function N:
3676 * * (NAME A1 ... An)
3677 * PRINT() cannot be used because it would print NAME in
3678 * its expanded (LAMBDA...) form which is not desirable.
3679 */
printTrace(int n)3680 static void printTrace(int n) {
3681 if (SK_traceHandler) {
3682 (*SK_traceHandler)(n);
3683 return;
3684 }
3685 pr("+ ");
3686 pr("(");
3687 Quoted = 1;
3688 _print(SK_trace);
3689 while (1) {
3690 n = Cdr[n];
3691 if (n == NIL) break;
3692 pr(" ");
3693 _print(Car[n]);
3694 }
3695 pr(")"); nl();
3696 }
3697
3698 #ifdef DEBUG
3699 /* Print depth of stack N. */
prDepth(int n)3700 static void prDepth(int n) {
3701 int k;
3702
3703 k = 0;
3704 while (n != NIL) {
3705 n = Cdr[n];
3706 k = k+1;
3707 }
3708 prnum(k, 7); pr(" ");
3709 }
3710
3711 /* Debugging: dump interpreter state */
dumpState(char * s,int m)3712 static void dumpState(char *s, int m) {
3713 pr(s); nl();
3714 pr(" ");
3715 pr("Mode = "); prnum(m-'0',0); nl();
3716 prDepth(Lstack);
3717 pr("Lstack = "); sk_print(Lstack); nl();
3718 pr(" ");
3719 pr("Mstack = "); sk_print(Mstack); nl();
3720 prDepth(Stack); pr("Car[Stack] == ");
3721 sk_print(Car[Stack]); nl();
3722 pr(" ");
3723 pr("Stack0 = "); prnum(Stack0,0); nl();
3724 prDepth(Bstack);
3725 pr("Bstack = "); sk_print(Bstack); nl();
3726 }
3727 #endif /*DEBUG*/
3728
3729 /* Do tail call optimization. */
tailCall(void)3730 static void tailCall(void) {
3731 int m, y;
3732
3733 m = Car[Mstack];
3734 /* Skip over callee's LET/LETREC frames, if any */
3735 while (m != NIL && Car[m] == MLETR) {
3736 m = Cdr[m];
3737 }
3738 /* Parent not beta-reducing? Give up. */
3739 if (m == NIL || Car[m] != MBETA)
3740 return;
3741 /* Yes, this is a tail call: */
3742 /* - remove callee's LET/LETREC frames. */
3743 /* - remove caller's call frame. */
3744 while (1) {
3745 Tmp2 = unsave(1); /* M */
3746 unbindArgs();
3747 unsave(1);
3748 y = munsave();
3749 save(Tmp2);
3750 Tmp2 = NIL;
3751 if (y == MBETA) break;
3752 }
3753 }
3754
3755 /*
3756 * Evaluate the term N and return its normal form.
3757 * This is the heart of the interpreter:
3758 * A constant space EVAL function with tail-call optimization.
3759 */
eval(int n)3760 static int eval(int n) {
3761 int m, /* Result node */
3762 m2, /* Root of result list */
3763 a, /* Used to append to result */
3764 cbn; /* Use call-by-name in next iteration */
3765 int mode, /* Current state */
3766 cf; /* Continue flag */
3767 int nm; /* name of function to apply */
3768
3769 EvLev = EvLev + 1;
3770 save(n);
3771 save(Lstack);
3772 save(Bstack);
3773 save(Car[Mstack]);
3774 save(Stack0);
3775 Stack0 = Stack;
3776 mode = MATOM;
3777 cf = 0;
3778 cbn = 0;
3779 while (!SK_errFlag) {
3780 if (SK_statFlag) sk_count(&SK_reductions, 1);
3781 if (n == NIL) { /* () -> () */
3782 m = NIL;
3783 }
3784 else if (atomic(n)) { /* Symbol -> Value */
3785 if (cbn) {
3786 m = n;
3787 cbn = 0;
3788 }
3789 else {
3790 m = Cdr[n];
3791 if (m == S_undefined) {
3792 error("symbol not bound", n);
3793 break;
3794 }
3795 }
3796 }
3797 else if (lazyAtom(n) || /* Auto-quoting atoms */
3798 cbn == 2
3799 ) {
3800 m = n;
3801 cbn = 0;
3802 }
3803 else { /* List (...) and Pair (X.Y) */
3804 /*
3805 * This block is used to DESCEND into lists.
3806 * The following nodes/variables will be saved:
3807 * 1) the original list (on Stack)
3808 * 2) the current state (on Mstack)
3809 * 3) the root of the result list (on Lstack)
3810 * 4) a ptr to the next free node
3811 * in the result list (on Lstack)
3812 * 5) a ptr to the next member of
3813 * the original list (on Lstack)
3814 */
3815 m = Car[n];
3816 if (lazyAtom(Cdr[n])) {
3817 error("improper list in application", n);
3818 n = NIL;
3819 }
3820 save(n); /* Save original list */
3821 msave(mode);
3822 /* Check call-by-name built-ins and flag */
3823 if ((atomic(m) && cadr(m) == S_special) || cbn) {
3824 cbn = 0;
3825 lsave(NIL);
3826 lsave(NIL);
3827 lsave(n); /* Root of result list */
3828 n = NIL;
3829 }
3830 else {
3831 a = alloc(NIL, NIL);
3832 lsave(a);
3833 lsave(Cdr[n]);
3834 lsave(a); /* Root of result list */
3835 n = Car[n];
3836 }
3837 mode = MLIST;
3838 continue;
3839 }
3840 /*
3841 * The following loop is used to ASCEND back to the
3842 * root of a list, thereby performing BETA reduction
3843 * and creating result lists.
3844 */
3845 while (1) if (mode == MBETA || mode == MLETR) {
3846 /* Finish BETA reduction */
3847 unbindArgs();
3848 unsave(1); /* Original list */
3849 mode = munsave();
3850 }
3851 else if (mode == MLIST) { /* Append to list, reduce */
3852 n = cadr(Lstack); /* Next member */
3853 a = caddr(Lstack); /* Place to append to */
3854 m2 = lunsave(1); /* Root of result list */
3855 if (a != NIL) /* Append new member */
3856 Car[a] = m;
3857 if (n == NIL) { /* End of list */
3858 m = m2;
3859 lunsave(2); /* Drop N,A */
3860 /* Drop original list, remember first element */
3861 nm = Car[unsave(1)];
3862 save(m); /* Save result */
3863 if (SK_trace == nm) printTrace(m);
3864 if (primitive(&m))
3865 ;
3866 else if (special(&m, &cf, &mode, &cbn))
3867 n = m;
3868 else if (!atomic(Car[m]) &&
3869 Car[m] != NIL &&
3870 caar(m) == S_closure
3871 ) {
3872 /* ((LAMBDA...)...) */
3873 nm = atomic(nm)? nm: NIL;
3874 tailCall();
3875 bindArgs(m, nm);
3876 /* N=S of ((LAMBDA (...) S) ...) */
3877 n = caddar(m);
3878 cf = 2;
3879 mode = MBETA;
3880 }
3881 else {
3882 error("application of non-procedure",
3883 nm);
3884 n = NIL;
3885 }
3886 if (cf != 2) {
3887 unsave(1); /* Drop result */
3888 mode = munsave();
3889 }
3890 /* Continue this evaluation. */
3891 /* Leave the ASCENDING loop and descend */
3892 /* once more into N. */
3893 if (cf) break;
3894 }
3895 else { /* N =/= NIL: Append to list */
3896 lsave(m2);
3897 /* Create space for next argument */
3898 Cdr[a] = alloc(NIL, NIL);
3899 caddr(Lstack) = Cdr[a];
3900 cadr(Lstack) = Cdr[n];
3901 n = Car[n]; /* Evaluate next member */
3902 break;
3903 }
3904 }
3905 else if (mode == MCOND) {
3906 n = evalClause(m);
3907 if (Car[Bstack] == NIL) {
3908 unsave(1); /* Original list */
3909 bunsave(1);
3910 mode = munsave();
3911 }
3912 cf = 1;
3913 break;
3914 }
3915 else if (mode == MCONJ || mode == MDISJ) {
3916 Car[Bstack] = cdar(Bstack);
3917 if ( (m == S_false && mode == MCONJ) ||
3918 (m != S_false && mode == MDISJ) ||
3919 Car[Bstack] == NIL
3920 ) {
3921 unsave(1); /* Original list */
3922 bunsave(1);
3923 mode = munsave();
3924 n = m;
3925 cbn = 1;
3926 }
3927 else if (cdar(Bstack) == NIL) {
3928 n = caar(Bstack);
3929 unsave(1); /* Original list */
3930 bunsave(1);
3931 mode = munsave();
3932 }
3933 else {
3934 n = caar(Bstack);
3935 }
3936 cf = 1;
3937 break;
3938 }
3939 else if (mode == MIFPR) {
3940 unsave(1); /* Original list */
3941 n = bunsave(1);
3942 mode = munsave();
3943 if (m != S_false)
3944 n = cadr(n);
3945 else
3946 n = caddr(n);
3947 cf = 1;
3948 break;
3949 }
3950 else if (mode == MBEGN) {
3951 Car[Bstack] = cdar(Bstack);
3952 if (cdar(Bstack) == NIL) {
3953 n = caar(Bstack);
3954 unsave(1); /* Original list */
3955 bunsave(1);
3956 mode = munsave();
3957 }
3958 else {
3959 n = caar(Bstack);
3960 }
3961 cf = 1;
3962 break;
3963 }
3964 else if (mode == MBIND || mode == MBINR) {
3965 if (nextLet(m) == NIL) {
3966 n = finishLet(mode == MBINR);
3967 mode = MLETR;
3968 }
3969 else {
3970 n = evalLet();
3971 }
3972 cf = 1;
3973 break;
3974 }
3975 else { /* Atom */
3976 break;
3977 }
3978 if (cf) { /* Continue evaluation if requested */
3979 cf = 0;
3980 continue;
3981 }
3982 if (Stack == Stack0) break;
3983 }
3984 while (Stack != Stack0) unsave(1);
3985 Stack0 = unsave(1);
3986 Car[Mstack] = unsave(1);
3987 Bstack = unsave(1);
3988 Lstack = unsave(1);
3989 unsave(1);
3990 EvLev = EvLev - 1;
3991 return m; /* Return the evaluated expr */
3992 }
3993
3994 /* Print lists of digits in condensed format. */
printNum(int n)3995 static int printNum(int n) {
3996 char s[2];
3997
3998 if (Car[n] != S_integer) return 0;
3999 s[1] = 0;
4000 n = Cdr[n];
4001 while (1) {
4002 if (n == NIL) break;
4003 s[0] = caaar(n) & 255;
4004 pr(s);
4005 n = Cdr[n];
4006 }
4007 return -1;
4008 }
4009
4010 /* Print expressions of the form (QUOTE X) as 'X. */
printQuote(int n)4011 static int printQuote(int n) {
4012 if ( Car[n] == S_quote &&
4013 Cdr[n] != NIL &&
4014 cddr(n) == NIL
4015 ) {
4016 n = cadr(n);
4017 if (n != S_true && n != S_false) pr("'");
4018 _print(n);
4019 return 1;
4020 }
4021 return 0;
4022 }
4023
4024 /* Print a closure. */
printClosure(int n)4025 static int printClosure(int n) {
4026 if ( Car[n] == S_closure &&
4027 Cdr[n] != NIL && !atomic(Cdr[n]) &&
4028 cddr(n) != NIL && !atomic(cddr(n))
4029 ) {
4030 Quoted = 1;
4031 pr("#<procedure ");
4032 _print(cadr(n));
4033 if (SK_closureForm > 0) {
4034 pr(" ");
4035 _print(caddr(n));
4036 if (SK_closureForm > 1 && cdddr(n) != NIL) {
4037 pr(" ");
4038 _print(cadddr(n));
4039 }
4040 }
4041 pr(">");
4042 return -1;
4043 }
4044 return 0;
4045 }
4046
4047 /* Print a character. */
printChar(int n)4048 static int printChar(int n) {
4049 char b[2];
4050 int c;
4051
4052 if (Car[n] != S_char) return 0;
4053 if (!DisplayMode) pr("#\\");
4054 c = cadr(n);
4055 if (!DisplayMode && c == ' ') {
4056 pr("space");
4057 }
4058 else if (!DisplayMode && c == '\n') {
4059 pr("newline");
4060 }
4061 else {
4062 b[1] = 0;
4063 b[0] = c;
4064 pr(b);
4065 }
4066 return -1;
4067 }
4068
4069 /* Print a string. */
printString(int n)4070 static int printString(int n) {
4071 char b[2];
4072 int k;
4073 char *s;
4074
4075 if (Car[n] != S_string) return 0;
4076 if (!DisplayMode) pr("\"");
4077 s = string(n);
4078 k = string_len(n);
4079 b[1] = 0;
4080 while (k) {
4081 b[0] = *s++;
4082 if (!DisplayMode)
4083 if (b[0] == '"' || b[0] == '\\')
4084 pr("\\");
4085 pr(b);
4086 k = k-1;
4087 }
4088 if (!DisplayMode) pr("\"");
4089 return -1;
4090 }
4091
4092 /* Print a primitive function. */
printPrim(int n)4093 static int printPrim(int n) {
4094 if (Car[n] != S_primitive && Car[n] != S_user_primitive)
4095 return 0;
4096 pr(Car[n] == S_primitive? "#<primitive ": "<#user-primitive ");
4097 Quoted = 1;
4098 _print(cddr(n));
4099 pr(">");
4100 return -1;
4101 }
4102
4103 /* Print a special form handler. */
printSpecial(int n)4104 static int printSpecial(int n) {
4105 if (Car[n] != S_special && Car[n] != S_special_cbv)
4106 return 0;
4107 pr(Car[n] == S_special? "#<syntax ": "#<primitive ");
4108 Quoted = 1;
4109 _print(cddr(n));
4110 pr(">");
4111 return -1;
4112 }
4113
4114 /* Print a syntax transformer. */
printSyntax(int n)4115 static int printSyntax(int n) {
4116 if (Car[n] != S_syntax) return 0;
4117 pr("#<syntax ");
4118 Quoted = 1;
4119 _print(cadr(n));
4120 pr(">");
4121 return -1;
4122 }
4123
4124 /* Print a vector. */
printVector(int n)4125 static int printVector(int n) {
4126 int *p;
4127 int k;
4128
4129 if (Car[n] != S_vector) return 0;
4130 pr("#(");
4131 Quoted = 1;
4132 p = vector(n);
4133 k = vector_len(n);
4134 while (k--) {
4135 _print(*p++);
4136 if (k) pr(" ");
4137 }
4138 pr(")");
4139 return -1;
4140 }
4141
4142 /* Print #<void>. */
printVoid(int n)4143 static int printVoid(int n) {
4144 if (Car[n] != S_voidSym) return 0;
4145 pr("#<void>");
4146 return -1;
4147 }
4148
4149 /* Recursively print the term N. */
_print(int n)4150 static void _print(int n) {
4151 char s[TEXTLEN+1];
4152 int i;
4153
4154 if (n == NIL) {
4155 if (!Quoted) {
4156 pr("'");
4157 Quoted = 1;
4158 }
4159 pr("()");
4160 }
4161 else if (Tag[n] & AFLAG) {
4162 /* Characters are limited to the symbol table */
4163 pr("#<unprintable object>");
4164 }
4165 else if (atomic(n)) {
4166 if (!Quoted) {
4167 if ( n != S_true &&
4168 n != S_false &&
4169 n != S_integer &&
4170 n != S_eof &&
4171 n != S_void &&
4172 n != S_undefined
4173 )
4174 pr("'");
4175 Quoted = 1;
4176 }
4177 i = 0; /* Symbol */
4178 n = Car[n];
4179 while (n != NIL) {
4180 s[i] = Car[n];
4181 if (i < TEXTLEN-2) i = i+1;
4182 n = Cdr[n];
4183 }
4184 s[i] = 0;
4185 pr(s);
4186 }
4187 else { /* List */
4188 if (printNum(n)) return;
4189 if (printChar(n)) return;
4190 if (printString(n)) return;
4191 if (printClosure(n)) return;
4192 if (printPrim(n)) return;
4193 if (printSpecial(n)) return;
4194 if (printSyntax(n)) return;
4195 if (printVector(n)) return;
4196 if (printVoid(n)) return;
4197 if (!Quoted) {
4198 pr("'");
4199 Quoted = 1;
4200 }
4201 if (printQuote(n)) return;
4202 pr("(");
4203 while (n != NIL) {
4204 _print(Car[n]);
4205 n = Cdr[n];
4206 if ( n != NIL &&
4207 (atomic(n) || tagged(n))
4208 ) {
4209 pr(" . ");
4210 _print(n);
4211 n = NIL;
4212 }
4213 if (n != NIL) pr(" ");
4214 }
4215 pr(")");
4216 }
4217 }
4218
4219 /* Print external representation of an expression. */
sk_print(int n)4220 void sk_print(int n) {
4221 Quoted = 1;
4222 DisplayMode = 0;
4223 _print(n);
4224 }
4225
4226 /* Pretty-Print expression. */
sk_display(int n)4227 void sk_display(int n) {
4228 Quoted = 1;
4229 DisplayMode = 1;
4230 _print(n);
4231 DisplayMode = 0;
4232 }
4233
4234 /* Reset interpreter state. */
resetState(void)4235 static void resetState(void) {
4236 Stack = NIL;
4237 Lstack = NIL;
4238 Bstack = NIL;
4239 Estack = NIL;
4240 Frame = NIL;
4241 Function = NIL;
4242 EvLev = 0;
4243 Level = 0;
4244 SyntaxMode = 0;
4245 }
4246
4247 /* Stop the interpreter */
sk_stop(void)4248 void sk_stop(void) {
4249 error("interrupted", NOEXPR);
4250 }
4251
4252 /* Initialize interpreter variables. */
init1()4253 static void init1() {
4254 /* Misc. variables */
4255 NIL = PoolSize;
4256 Level = 0;
4257 resetState();
4258 Mstack = NIL;
4259 SK_errFlag = 0;
4260 setErrArg("");
4261 FatalFlag = 0;
4262 Symbols = NIL;
4263 Packages = NIL;
4264 Transformers = NIL;
4265 SafeSymbols = NIL;
4266 Tmp = NIL;
4267 Tmp2 = NIL;
4268 SafeCar = NIL;
4269 SafeCdr = NIL;
4270 LoadLev = 0;
4271 GensymCounter = 0;
4272 SK_trace = NIL;
4273 SK_traceHandler = NULL;
4274 MaxAtoms = 0;
4275 MaxCells = 0;
4276 Ntrace = 10;
4277 SK_statFlag = 0;
4278 SK_closureForm = 0;
4279 SK_arrowMode = 0;
4280 SK_strictApply = 1;
4281 SK_metaChar = ':';
4282 Line = 1;
4283 /* Initialize Freelist */
4284 Free = NIL;
4285 Vptr = 0;
4286 /* Clear input buffer */
4287 Infile[0] = 0;
4288 DirName[0] = 0;
4289 Input = stdin;
4290 Output = stdout;
4291 Rejected = EOT;
4292 InputString = NULL;
4293 OutputString = NULL;
4294 }
4295
4296 /* For fast lookup */
cacheDigits(void)4297 void cacheDigits(void) {
4298 Digits[0] = S_0;
4299 Digits[1] = S_1;
4300 Digits[2] = S_2;
4301 Digits[3] = S_3;
4302 Digits[4] = S_4;
4303 Digits[5] = S_5;
4304 Digits[6] = S_6;
4305 Digits[7] = S_7;
4306 Digits[8] = S_8;
4307 Digits[9] = S_9;
4308 }
4309
4310 /*
4311 * Second stage of initialization:
4312 * protect registers from GC,
4313 * build the free list,
4314 * create builtin symbols.
4315 */
init2(void)4316 static void init2(void) {
4317 int core;
4318
4319 /* Protect base registers */
4320 Root[0] = &Symbols;
4321 Root[1] = &SafeCar;
4322 Root[2] = &SafeCdr;
4323 Root[3] = &Stack;
4324 Root[4] = &Mstack;
4325 Root[5] = &Lstack;
4326 Root[6] = &Bstack;
4327 Root[7] = &Estack;
4328 Root[8] = &Tmp;
4329 Root[9] = &Tmp2;
4330 Root[10] = &SafeSymbols;
4331 Root[11] = &Packages;
4332 Root[12] = &Transformers;
4333 /* Create builtin symbols */
4334 S_0 = addSym("0d", 0); /* First GC will be triggered HERE */
4335 S_1 = addSym("1d", 0);
4336 S_2 = addSym("2d", 0);
4337 S_3 = addSym("3d", 0);
4338 S_4 = addSym("4d", 0);
4339 S_5 = addSym("5d", 0);
4340 S_6 = addSym("6d", 0);
4341 S_7 = addSym("7d", 0);
4342 S_8 = addSym("8d", 0);
4343 S_9 = addSym("9d", 0);
4344 cacheDigits();
4345 /*
4346 * Tags (especially #<primitive> and #<special*>)
4347 * must be defined before the first primitive.
4348 */
4349 S_special = addSym("#<special>", 0);
4350 S_special_cbv = addSym("#<special/cbv>", 0);
4351 S_primitive = addSym("#<primitive>", 0);
4352 S_user_primitive = addSym("#<user-primitive>", 0);
4353 S_char = addSym("#<char>", 0);
4354 S_closure = addSym("#<closure>", 0);
4355 S_eof = addSym("#<eof>", 0);
4356 S_integer = addSym("#<integer>", 0);
4357 S_string = addSym("#<string>", 0);
4358 S_syntax = addSym("#<syntax>", 0);
4359 S_undefined = addSym("#<undefined>", 0);
4360 S_vector = addSym("#<vector>", 0);
4361 S_voidSym = addSym("#<void>", 0);
4362 S_void = alloc(S_voidSym, NIL);
4363 S_void = addSym("#<void>", S_void);
4364 addSym("_", S_undefined);
4365 addSym("...", S_undefined);
4366 addSpecial("and", SF_AND, 0);
4367 addSpecial("apply", SF_APPLY, 1);
4368 addSpecial("begin", SF_BEGIN, 0);
4369 S_bottom = addPrim("bottom", P_BOTTOM);
4370 addPrim("car", P_CAR);
4371 addPrim("cdr", P_CDR);
4372 addPrim("char->integer", P_CHAR_TO_INTEGER);
4373 addPrim("char-ci<?", P_CHAR_CI_LTP);
4374 addPrim("char-ci<=?", P_CHAR_CI_LEP);
4375 addPrim("char-ci=?", P_CHAR_CI_EQP);
4376 addPrim("char-ci>?", P_CHAR_CI_GTP);
4377 addPrim("char-ci>=?", P_CHAR_CI_GEP);
4378 addPrim("char<?", P_CHAR_LTP);
4379 addPrim("char<=?", P_CHAR_LEP);
4380 addPrim("char=?", P_CHAR_EQP);
4381 addPrim("char>?", P_CHAR_GTP);
4382 addPrim("char>=?", P_CHAR_GEP);
4383 addPrim("char?", P_CHARP);
4384 addSpecial("cond", SF_COND, 0);
4385 addPrim("cons", P_CONS);
4386 addSpecial("define", SF_DEFINE, 0);
4387 S_defineSyntax = addSpecial("define-syntax", SF_DEFINE_SYNTAX, 0);
4388 addPrim("delete-file", P_DELETE_FILE);
4389 addPrim("display", P_DISPLAY);
4390 S_else = addSym("else", S_undefined);
4391 addPrim("eof-object?", P_EOF_OBJECTP);
4392 addSpecial("eval", SF_EVAL, 0);
4393 addPrim("eq?", P_EQP);
4394 S_false = addSym("#f", 0);
4395 S_gensym = addPrim("gensym", P_GENSYM);
4396 addSpecial("if", SF_IF, 0);
4397 addPrim("integer->char", P_INTEGER_TO_CHAR);
4398 addPrim("integer->list", P_INTEGER_TO_LIST);
4399 S_lambda = addSpecial("lambda", SF_LAMBDA, 0);
4400 addSpecial("let", SF_LET, 0);
4401 addSpecial("letrec", SF_LETREC, 0);
4402 addPrim("list->integer", P_LIST_TO_INTEGER);
4403 addPrim("list->string", P_LIST_TO_STRING);
4404 addPrim("list->vector", P_LIST_TO_VECTOR);
4405 addPrim("load", P_LOAD);
4406 addPrim("n+", P_NPLUS);
4407 addPrim("n-", P_NMINUS);
4408 addPrim("n<", P_NLESS);
4409 addPrim("null?", P_NULLP);
4410 addPrim("number?", P_NUMBERP);
4411 addSpecial("or", SF_OR, 0);
4412 addPrim("package", P_PACKAGE);
4413 addPrim("pair?", P_PAIRP);
4414 addPrim("peek-char", P_PEEK_CHAR);
4415 addPrim("procedure?", P_PROCEDUREP);
4416 S_quote = addSpecial("quote", SF_QUOTE, 0);
4417 addPrim("require", P_REQUIRE);
4418 addPrim("read", P_READ);
4419 addPrim("read-char", P_READ_CHAR);
4420 addPrim("read-from-string", P_READ_FROM_STRING);
4421 addPrim("recursive-bind", P_RECURSIVE_BIND);
4422 addPrim("string->symbol", P_STRING_TO_SYMBOL);
4423 addPrim("string->list", P_STRING_TO_LIST);
4424 addPrim("string-append", P_STRING_APPEND);
4425 addPrim("string-length", P_STRING_LENGTH);
4426 addPrim("string-ref", P_STRING_REF);
4427 addPrim("string?", P_STRINGP);
4428 addPrim("substring", P_SUBSTRING);
4429 addPrim("symbol->string", P_SYMBOL_TO_STRING);
4430 addPrim("symbol?", P_SYMBOLP);
4431 addPrim("syntax->list", P_SYNTAX_OF);
4432 addSpecial("syntax-rules", SF_SYNTAX_RULES, 0);
4433 addPrim("vector->list", P_VECTOR_TO_LIST);
4434 addPrim("vector-length", P_VECTOR_LENGTH);
4435 addPrim("vector-ref", P_VECTOR_REF);
4436 addPrim("vector?", P_VECTORP);
4437 addPrim("void", P_VOID);
4438 addSpecial("with-input-from-file", SF_WITH_INPUT_FROM_FILE, 1);
4439 addSpecial("with-output-to-file", SF_WITH_OUTPUT_TO_FILE, 1);
4440 addPrim("write", P_WRITE);
4441 addPrim("write-char", P_WRITE_CHAR);
4442 addPrim("write-to-string", P_WRITE_TO_STRING);
4443 S_true = addSym("#t", 0);
4444 S_last = addSym("**", S_void);
4445 Mstack = alloc(NIL, NIL);
4446 Primitives[P_BOTTOM] = &doBottom;
4447 Primitives[P_CAR] = &doCar;
4448 Primitives[P_CDR] = &doCdr;
4449 Primitives[P_CHAR_TO_INTEGER] = &doCharToInteger;
4450 Primitives[P_CHAR_CI_LTP] = &doCharCiLtP;
4451 Primitives[P_CHAR_CI_LEP] = &doCharCiLEP;
4452 Primitives[P_CHAR_CI_EQP] = &doCharCiEqP;
4453 Primitives[P_CHAR_CI_GTP] = &doCharCiGtP;
4454 Primitives[P_CHAR_CI_GEP] = &doCharCiGEP;
4455 Primitives[P_CHAR_LTP] = &doCharLtP;
4456 Primitives[P_CHAR_LEP] = &doCharLEP;
4457 Primitives[P_CHAR_EQP] = &doCharEqP;
4458 Primitives[P_CHAR_GTP] = &doCharGtP;
4459 Primitives[P_CHAR_GEP] = &doCharGEP;
4460 Primitives[P_CHARP] = &doCharP;
4461 Primitives[P_CONS] = &doCons;
4462 Primitives[P_DELETE_FILE] = &doDeleteFile;
4463 Primitives[P_DISPLAY] = &doDisplay;
4464 Primitives[P_EOF_OBJECTP] = &doEofObjectP;
4465 Primitives[P_EQP] = &doEqP;
4466 Primitives[P_GENSYM] = &doGensym;
4467 Primitives[P_INTEGER_TO_CHAR] = &doIntegerToChar;
4468 Primitives[P_INTEGER_TO_LIST] = &doIntegerToList;
4469 Primitives[P_LIST_TO_INTEGER] = &doListToInteger;
4470 Primitives[P_LIST_TO_STRING] = &doListToString;
4471 Primitives[P_LIST_TO_VECTOR] = &doListToVector;
4472 Primitives[P_LOAD] = &doLoad;
4473 Primitives[P_NPLUS] = &doNPlus;
4474 Primitives[P_NMINUS] = &doNMinus;
4475 Primitives[P_NLESS] = &doNLess;
4476 Primitives[P_NULLP] = &doNullP;
4477 Primitives[P_NUMBERP] = &doNumberP;
4478 Primitives[P_PACKAGE] = &doPackage;
4479 Primitives[P_PAIRP] = &doPairP;
4480 Primitives[P_PEEK_CHAR] = &doPeekChar;
4481 Primitives[P_PROCEDUREP] = &doProcedureP;
4482 Primitives[P_READ] = &doRead;
4483 Primitives[P_READ_CHAR] = &doReadChar;
4484 Primitives[P_READ_FROM_STRING] = &doReadFromString;
4485 Primitives[P_RECURSIVE_BIND] = &doRecursiveBind;
4486 Primitives[P_REQUIRE] = &doRequire;
4487 Primitives[P_STRING_TO_LIST] = &doStringToList;
4488 Primitives[P_STRING_TO_SYMBOL] = &doStringToSymbol;
4489 Primitives[P_STRING_APPEND] = &doStringAppend;
4490 Primitives[P_STRING_LENGTH] = &doStringLength;
4491 Primitives[P_STRING_REF] = &doStringRef;
4492 Primitives[P_STRINGP] = &doStringP;
4493 Primitives[P_SUBSTRING] = &doSubstring;
4494 Primitives[P_SYMBOL_TO_STRING] = &doSymbolToString;
4495 Primitives[P_SYMBOLP] = &doSymbolP;
4496 Primitives[P_SYNTAX_OF] = &doSyntaxToList;
4497 Primitives[P_VECTOR_TO_LIST] = &doVectorToList;
4498 Primitives[P_VECTOR_LENGTH] = &doVectorLength;
4499 Primitives[P_VECTOR_REF] = &doVectorRef;
4500 Primitives[P_VECTORP] = &doVectorP;
4501 Primitives[P_VOID] = &doVoid;
4502 Primitives[P_WRITE] = &doWrite;
4503 Primitives[P_WRITE_CHAR] = &doWriteChar;
4504 Primitives[P_WRITE_TO_STRING] = &doWriteToString;
4505 Specials[SF_AND] = &doAnd;
4506 Specials[SF_APPLY] = &doApply;
4507 Specials[SF_BEGIN] = &doBegin;
4508 Specials[SF_COND] = &doCond;
4509 Specials[SF_DEFINE] = &doDefine;
4510 Specials[SF_DEFINE_SYNTAX] = &doDefineSyntax;
4511 Specials[SF_EVAL] = &doEval;
4512 Specials[SF_IF] = &doIf;
4513 Specials[SF_LAMBDA] = &doLambda;
4514 Specials[SF_LET] = &doLet;
4515 Specials[SF_LETREC] = &doLetrec;
4516 Specials[SF_OR] = &doOr;
4517 Specials[SF_QUOTE] = &doQuote;
4518 Specials[SF_SYNTAX_RULES] = &doSyntaxRules;
4519 Specials[SF_WITH_INPUT_FROM_FILE] = &doWithInputFromFile;
4520 Specials[SF_WITH_OUTPUT_TO_FILE] = &doWithOutputToFile;
4521 core = addSym("core", S_undefined);
4522 Packages = alloc(core, Symbols);
4523 S_core = Packages;
4524 Packages = alloc(Packages, NIL);
4525 Symbols = addPackage(NIL);
4526 LastUsrPrimitive = 0;
4527 }
4528
4529 /*
4530 * Initialize the interpreter and allocate pools of
4531 * the given sizes.
4532 */
sk_init(int nodes,int vcells)4533 int sk_init(int nodes, int vcells) {
4534 PoolSize = nodes? nodes: SK_DFL_NODES;
4535 VPoolSize = vcells? vcells: SK_DFL_VCELLS;
4536 if (PoolSize < SK_MIN_SIZE || VPoolSize < SK_MIN_SIZE)
4537 return -1;
4538 if ( (Car = (int *) malloc(PoolSize * sizeof(int))) == NULL ||
4539 (Cdr = (int *) malloc(PoolSize * sizeof(int))) == NULL ||
4540 (Tag = (char *) malloc(PoolSize)) == NULL ||
4541 (Vpool = (int *) malloc(VPoolSize * sizeof(int))) == NULL
4542 ) {
4543 if (Car) free(Car);
4544 if (Cdr) free(Cdr);
4545 if (Tag) free(Tag);
4546 Car = Cdr = NULL;
4547 Tag = NULL;
4548 return -1;
4549 }
4550 memset(Tag, 0, PoolSize);
4551 init1();
4552 init2();
4553 return 0;
4554 }
4555
4556 /* Shut down the interpreter */
sk_fini()4557 void sk_fini() {
4558 if (Car) free(Car);
4559 if (Cdr) free(Cdr);
4560 if (Tag) free(Tag);
4561 if (Vpool) free(Vpool);
4562 Car = Cdr = Vpool = NULL;
4563 Tag = NULL;
4564 }
4565
4566 /* Reset the reduction counter */
clearStats(void)4567 static void clearStats(void) {
4568 sk_resetCounter(&SK_reductions);
4569 sk_resetCounter(&SK_allocations);
4570 sk_resetCounter(&SK_collections);
4571 }
4572
4573 /* Print the number of reductions done in last EVAL */
sk_printStats(void)4574 void sk_printStats(void) {
4575 sk_printCounter(&SK_reductions);
4576 pr(" reduction steps"); nl();
4577 sk_printCounter(&SK_allocations);
4578 pr(" nodes allocated"); nl();
4579 sk_printCounter(&SK_collections);
4580 pr(" garbage collections"); nl();
4581 }
4582
4583 /* Evaluate an expression and returns its normal form. */
safe_eval(int n)4584 int safe_eval(int n) {
4585 save(n);
4586 SafeSymbols = copyBindings();
4587 n = eval(Car[Stack]);
4588 unsave(1);
4589 if (SK_errFlag) restoreBindings(SafeSymbols);
4590 return n;
4591 }
4592
4593 /* Evaluate an expression and returns its normal form. */
sk_eval(int n)4594 int sk_eval(int n) {
4595 int m;
4596
4597 if (SK_errFlag) return NIL;
4598 n = syntaxTransform(n);
4599 if (SK_statFlag) clearStats();
4600 m = safe_eval(n);
4601 if (Stack != NIL)
4602 fatal("sk_eval(): unbalanced stack");
4603 if (!SK_errFlag) Cdr[S_last] = m;
4604 resetState();
4605 while (Car[Mstack] != NIL) munsave();
4606 return m;
4607 }
4608
4609 /* Variables to dump to image file */
4610 int *ImageVars[] = {
4611 &SK_statFlag, &SK_closureForm, &SK_arrowMode, &SK_strictApply,
4612 &SK_metaChar, &Symbols, &Packages, &Transformers, &Free, &Vptr,
4613 &S_bottom, &S_char, &S_closure, &S_core, &S_defineSyntax,
4614 &S_else, &S_eof, &S_false, &S_gensym, &S_integer, &S_lambda,
4615 &S_primitive, &S_quote, &S_special, &S_special_cbv, &S_string,
4616 &S_syntax, &S_true, &S_undefined, &S_user_primitive, &S_vector,
4617 &S_void, &S_voidSym, &S_last, &S_0, &S_1, &S_2, &S_3, &S_4, &S_5,
4618 &S_6, &S_7, &S_8, &S_9,
4619 NULL };
4620
4621 /* Dump node pool image to path P. */
sk_dumpImage(char * p)4622 void sk_dumpImage(char *p) {
4623 int fd, n, i;
4624 int **v;
4625 char magic[17];
4626
4627 if (LastUsrPrimitive != 0) {
4628 error("cannot dump image with user extensions", NOEXPR);
4629 return;
4630 }
4631 fd = open(p, O_CREAT | O_WRONLY, 0644);
4632 setmode(fd, O_BINARY);
4633 if (fd < 0) {
4634 error("cannot create file", NOEXPR);
4635 setErrArg(p);
4636 return;
4637 }
4638 strcpy(magic, "SKETCHY_________");
4639 magic[7] = sizeof(int);
4640 magic[8] = SK_MAJOR;
4641 n = 0x12345678;
4642 memcpy(&magic[10], &n, sizeof(int));
4643 write(fd, magic, 16);
4644 n = PoolSize;
4645 write(fd, &n, sizeof(int));
4646 n = VPoolSize;
4647 write(fd, &n, sizeof(int));
4648 v = ImageVars;
4649 i = 0;
4650 while (v[i]) {
4651 write(fd, v[i], sizeof(int));
4652 i = i+1;
4653 }
4654 if ( write(fd, Car, PoolSize*sizeof(int)) != PoolSize*sizeof(int) ||
4655 write(fd, Cdr, PoolSize*sizeof(int)) != PoolSize*sizeof(int) ||
4656 write(fd, Tag, PoolSize) != PoolSize ||
4657 write(fd, Vpool, VPoolSize*sizeof(int)) !=
4658 VPoolSize*sizeof(int)
4659 ) {
4660 close(fd);
4661 error("image dump failed", NOEXPR);
4662 return;
4663 }
4664 close(fd);
4665 }
4666
4667 /*
4668 * Fix NIL nodes of a pool. This is necessary when
4669 * loading an image that is smaller than the current
4670 * pool. (NIL is represented by an integer that cannot
4671 * be a valid offset into a pool. It might be a valid
4672 * offset in a larger pool, though.)
4673 */
fixNIL(int * p,int oldnil)4674 void fixNIL(int *p, int oldnil) {
4675 int i;
4676
4677 for (i=0; i<PoolSize; i++)
4678 if (p[i] == oldnil)
4679 p[i] = NIL;
4680 }
4681
4682 /* Load initial image */
sk_loadImage(char * p)4683 int sk_loadImage(char *p) {
4684 int fd, n, i;
4685 char buf[17];
4686 int **v;
4687 int bad = 0;
4688 int inodes, ivcells;
4689
4690 fd = open(p, O_RDONLY);
4691 setmode(fd, O_BINARY);
4692 if (fd < 0) {
4693 error("cannot open image", NOEXPR);
4694 setErrArg(p);
4695 return -1;
4696 }
4697 memset(Tag, 0, PoolSize);
4698 read(fd, buf, 16);
4699 if (memcmp(buf, "SKETCHY", 7)) {
4700 error("bad image (magic match failed)", NOEXPR);
4701 bad = 1;
4702 }
4703 if (buf[7] != sizeof(int)) {
4704 error("bad image (wrong cell size)", NOEXPR);
4705 bad = 1;
4706 }
4707 if (buf[8] != SK_MAJOR) {
4708 error("bad image (wrong version)", NOEXPR);
4709 bad = 1;
4710 }
4711 memcpy(&n, &buf[10], sizeof(int));
4712 if (n != 0x12345678) {
4713 error("bad image (wrong architecture)", NOEXPR);
4714 bad = 1;
4715 }
4716 read(fd, &inodes, sizeof(int));
4717 if (inodes > PoolSize) {
4718 error("bad image (too many nodes)", NOEXPR);
4719 bad = 1;
4720 }
4721 read(fd, &ivcells, sizeof(int));
4722 if (ivcells > VPoolSize) {
4723 error("bad image (too many vcells)", NOEXPR);
4724 bad = 1;
4725 }
4726 v = ImageVars;
4727 i = 0;
4728 while (v[i]) {
4729 read(fd, v[i], sizeof(int));
4730 i = i+1;
4731 }
4732 if ( !bad &&
4733 (read(fd, Car, inodes*sizeof(int)) != inodes*sizeof(int) ||
4734 read(fd, Cdr, inodes*sizeof(int)) != inodes*sizeof(int) ||
4735 read(fd, Tag, inodes) != inodes ||
4736 read(fd, Vpool, ivcells*sizeof(int)) != ivcells*sizeof(int))
4737 ) {
4738 error("bad image (bad file size)", NOEXPR);
4739 bad = 1;
4740 }
4741 if (inodes != PoolSize) {
4742 fixNIL(Car, inodes);
4743 fixNIL(Cdr, inodes);
4744 }
4745 close(fd);
4746 cacheDigits();
4747 if (bad) setErrArg(p);
4748 return SK_errFlag;
4749 }
4750
4751 /* Return a node representing NIL */
sk_nil(void)4752 const int sk_nil(void) {
4753 return NIL;
4754 }
4755
4756 /* Return a node representing the undefined value */
sk_undefined(void)4757 const int sk_undefined(void) {
4758 return S_undefined;
4759 }
4760
4761 /* Return a node representing (VOID) */
sk_void(void)4762 const int sk_void(void) {
4763 return S_void;
4764 }
4765
4766 /* Return a node representing #T */
sk_true(void)4767 const int sk_true(void) {
4768 return S_true;
4769 }
4770
4771 /* Return a node representing #F */
sk_false(void)4772 const int sk_false(void) {
4773 return S_false;
4774 }
4775
4776 /* Return a node representing #<EOF> */
sk_eof()4777 int sk_eof() {
4778 return S_eof;
4779 }
4780
4781 /* Return the CAR part of N */
sk_car(int n)4782 int sk_car(int n) {
4783 return Car[n];
4784 }
4785
4786 /* Return the CDR part of N */
sk_cdr(int n)4787 int sk_cdr(int n) {
4788 return Cdr[n];
4789 }
4790
4791 /* Return the Nth argument of a function application N */
sk_nthArg(int n,int i)4792 int sk_nthArg(int n, int i) {
4793 i++;
4794 while (i--) {
4795 if (lazyAtom(n)) return NIL;
4796 n = Cdr[n];
4797 }
4798 return Car[n];
4799 }
4800
4801 /* Return the number of arguments in a function application N */
sk_args(int n)4802 int sk_args(int n) {
4803 return length(n)-1;
4804 }
4805
4806 /* Return the value of a CHAR */
sk_char(int n)4807 int sk_char(int n) {
4808 return cadr(n);
4809 }
4810
4811 /* Return the value of a STRING */
sk_string(int n)4812 const char *sk_string(int n) {
4813 if (atomic(n) || n == NIL || Car[n] != S_string) {
4814 return NULL;
4815 }
4816 return string(n);
4817 }
4818
4819 /* Return the elements of a VECTOR */
sk_vector(int n)4820 const int *sk_vector(int n) {
4821 if (atomic(n) || n == NIL || Car[n] != S_vector) {
4822 return NULL;
4823 }
4824 return vector(n);
4825 }
4826
4827 /* Return length of a VECTOR */
sk_vector_len(int n)4828 int sk_vector_len(int n) {
4829 if (atomic(n) || n == NIL || Car[n] != S_vector) {
4830 return NULL;
4831 }
4832 return vector_len(n);
4833 }
4834
4835 /* Write N to a string and return the string. */
sk_writeToString(int n)4836 int sk_writeToString(int n) {
4837 n = alloc(n, NIL);
4838 n = alloc(NIL, n);
4839 save(n);
4840 n = doWriteToString(n);
4841 unsave(1);
4842 return n;
4843 }
4844
4845 /* Read an expression from the string S and return it. */
sk_readFromString(char * s)4846 int sk_readFromString(char *s) {
4847 int n;
4848
4849 n = sk_mkString(s, strlen(s));
4850 n = alloc(n, NIL);
4851 n = alloc(NIL, n);
4852 save(n);
4853 n = doReadFromString(n);
4854 unsave(1);
4855 return n;
4856 }
4857
4858 /* Return the type of an object */
sk_typeof(int n)4859 int sk_typeof(int n) {
4860 if (atomic(n)) return SK_TYPE_SYMBOL;
4861 if (n == S_true || n == S_false) return SK_TYPE_BOOLEAN;
4862 if (n == S_eof) return SK_TYPE_EOF;
4863 if (n == S_undefined) return SK_TYPE_UNDEFINED;
4864 if (n == S_void) return SK_TYPE_VOID;
4865 if (Car[n] == S_integer) return SK_TYPE_INTEGER;
4866 if (Car[n] == S_char) return SK_TYPE_CHAR;
4867 if (Car[n] == S_string) return SK_TYPE_STRING;
4868 if ( Car[n] == S_closure ||
4869 Car[n] == S_primitive ||
4870 Car[n] == S_user_primitive ||
4871 Car[n] == S_special_cbv
4872 )
4873 return SK_TYPE_PROCEDURE;
4874 if (Car[n] == S_special || Car[n] == S_syntax)
4875 return SK_TYPE_SYNTAX;
4876 return SK_TYPE_PAIR;
4877 }
4878
4879 /* Say goodbye to the world */
sk_bye(void)4880 void sk_bye(void) {
4881 sk_fini();
4882 exit(0);
4883 }
4884
4885 /* Create a pair */
sk_cons(int car,int cdr)4886 int sk_cons(int car, int cdr) {
4887 return alloc(car, cdr);
4888 }
4889
4890 /* Create a bignum integer */
sk_mkInteger(long v)4891 int sk_mkInteger(long v) {
4892 char buf[100];
4893
4894 sprintf(buf, "%ld", v);
4895 return explodeNum(buf);
4896 }
4897
4898 /* Convert list to vector */
sk_listToVector(int n)4899 int sk_listToVector(int n) {
4900 return list_to_vector(n, "sk_listToVector()");
4901 }
4902
4903 /* Protect a node */
sk_protect(int n)4904 void sk_protect(int n) {
4905 save(n);
4906 }
4907
4908 /* Unprotect a number of nodes */
sk_unprotect(int k)4909 void sk_unprotect(int k) {
4910 unsave(k);
4911 }
4912
4913 /* Modify CAR part of pair */
sk_setCar(int n,int new)4914 void sk_setCar(int n, int new) {
4915 Car[n] = new;
4916 }
4917
4918 /* Modify CDR part of pair */
sk_setCdr(int n,int new)4919 void sk_setCdr(int n, int new) {
4920 Cdr[n] = new;
4921 }
4922
4923 /* Extract directory name of PATH into PFX. */
getDirName(char * path,char * pfx)4924 static void getDirName(char *path, char *pfx) {
4925 char *p;
4926
4927 if (strlen(path) > 256) {
4928 error("path too long in :load or 'require'", NOEXPR);
4929 return;
4930 }
4931 strcpy(pfx, path);
4932 p = strrchr(pfx, '/');
4933 if (p == NULL)
4934 strcpy(pfx, ".");
4935 else
4936 *p = 0;
4937 }
4938
4939 /* Expand leading '~/' path name */
expandPath(char * s)4940 static char *expandPath(char *s) {
4941 char *var, *r, *v;
4942
4943 if (!strncmp(s, "~/", 2)) {
4944 var = "HOME";
4945 r = &s[2];
4946 }
4947 else {
4948 return s;
4949 }
4950 if ((v = getenv(var)) == NULL) return s;
4951 if (strlen(v) + strlen(r) + 2 >= MAXPATHL) {
4952 error("path too long in 'load' or 'require'", NOEXPR);
4953 return s;
4954 }
4955 sprintf(ExpPath, "%s/%s", v, r);
4956 return ExpPath;
4957 }
4958
4959 /* Internal Read-Eval-Loop for loading source files. */
REL(void)4960 static void REL(void) {
4961 int n, evl;
4962
4963 SK_errFlag = 0;
4964 evl = EvLev;
4965 EvLev = 0;
4966 while(!SK_errFlag) {
4967 n = sk_read();
4968 n = syntaxTransform(n);
4969 if (n == S_eof) return;
4970 n = safe_eval(n);
4971 }
4972 EvLev = evl;
4973 }
4974
4975 /*
4976 * Locate source file.
4977 * Try: ./file
4978 * ./file.scm (if no .scm suffix is present)
4979 * P/file
4980 * P/file.scm (where P is a path from $SKETCHYSRC).
4981 * SKETCHYSRC is a colon-separated list of paths.
4982 */
sk_findSource(char * p,char * buf)4983 char *sk_findSource(char *p, char *buf) {
4984 char *sksrc, *q;
4985 char *toolong;
4986 FILE *f;
4987 int k;
4988
4989 toolong = "path too long in 'require'";
4990 if (strlen(p) >= SK_MAXPATHL-1) {
4991 error(toolong, NOEXPR);
4992 return NULL;
4993 }
4994 strcpy(buf, p);
4995 if (*p == '.' || *p == '/' || *p == '~') {
4996 return p;
4997 }
4998 sksrc = getenv("SKETCHYSRC");
4999 if ((f = fopen(p, "r")) != NULL) {
5000 fclose(f);
5001 return p;
5002 }
5003 k = strlen(p);
5004 if (k < 4 || strcmp(&p[k-4], ".scm")) {
5005 if (strlen(p) + 4 >= SK_MAXPATHL-1) {
5006 error(toolong, NOEXPR);
5007 return NULL;
5008 }
5009 strcpy(buf, p);
5010 strcat(buf, ".scm");
5011 f = fopen(buf, "r");
5012 if (f) return buf;
5013 }
5014 q = strrchr(p, '/');
5015 if (q) p = q;
5016 k = strlen(p);
5017 while (sksrc && *sksrc) {
5018 q = strchr(sksrc, ':');
5019 if (q) *q = 0;
5020 if (strlen(sksrc) + strlen(p) >= SK_MAXPATHL-2) {
5021 error(toolong, NOEXPR);
5022 return NULL;
5023 }
5024 sprintf(buf, "%s/%s", sksrc, p);
5025 if (q) *q = ':';
5026 f = fopen(buf, "r");
5027 if (f) return buf;
5028 k = strlen(buf);
5029 if (k < 4 || strcmp(&buf[k-4], ".scm")) {
5030 if (strlen(buf) + 4 >= SK_MAXPATHL-1) {
5031 error(toolong, NOEXPR);
5032 return NULL;
5033 }
5034 strcat(buf, ".scm");
5035 f = fopen(buf, "r");
5036 if (f) return buf;
5037 }
5038 sksrc = q? &q[1]: "";
5039 }
5040 return NULL;
5041 }
5042
5043 /* Load expressions from the file P. Return error flag. */
sk_load(char * p)5044 int sk_load(char *p) {
5045 FILE *ofile, *nfile;
5046 int r;
5047 char oname[MAXPATHL];
5048 int oline;
5049 char *q;
5050
5051 if (LoadLev > 0) {
5052 if (strlen(p) + strlen(DirName) >= MAXPATHL) {
5053 error("path too long in :load or 'require'", NOEXPR);
5054 return -1;
5055 }
5056 if (*p != '.' && *p != '/')
5057 sprintf(Path, "%s/%s", DirName, p);
5058 else
5059 strcpy(Path, p);
5060 q = p = Path;
5061 }
5062 else if (p[0] == '/' || p[0] == '.' || p[0] == '~') {
5063 q = p;
5064 p = expandPath(p);
5065 getDirName(p, DirName);
5066 }
5067 else {
5068 q = p;
5069 p = sk_findSource(p, ExpPath);
5070 getDirName(p, DirName);
5071 }
5072 nfile = fopen(p, "r");
5073 if (nfile == NULL) {
5074 p = sk_findSource(p, LocPath);
5075 if (p == NULL) {
5076 error("could not locate input file", NOEXPR);
5077 setErrArg(q);
5078 return -1;
5079 }
5080 nfile = fopen(p, "r");
5081 if (nfile == NULL) {
5082 error("cannot open source file", NOEXPR);
5083 setErrArg(p);
5084 return -1;
5085 }
5086 }
5087 LoadLev = LoadLev + 1;
5088 /* Save old I/O state */
5089 r = Rejected;
5090 /* Run the toplevel loop with redirected I/O */
5091 ofile = Input;
5092 Input = nfile;
5093 oline = Line;
5094 Line = 1;
5095 strcpy(oname, Infile);
5096 strcpy(Infile, p);
5097 REL();
5098 strcpy(Infile, oname);
5099 Line = oline;
5100 /* Restore previous I/O state */
5101 Rejected = r;
5102 Input = ofile;
5103 LoadLev = LoadLev - 1;
5104 fclose(nfile);
5105 if (Level) error("unbalanced parentheses in loaded file", NOEXPR);
5106 return 0;
5107 }
5108
5109 /* Load conditionally */
sk_require(char * p)5110 int sk_require(char *p) {
5111 char *q1, *q2;
5112 char s[TEXTLEN];
5113 int y;
5114
5115 memset(s, 0, TEXTLEN);
5116 strncpy(s, p, TEXTLEN-1);
5117 if (p[0] == '=') p = &p[1];
5118 q1 = strchr(p, '/');
5119 q2 = strchr(q1? q1: p, '.');
5120 if (q2 != NULL) *q2 = 0;
5121 y = findSym(locase(q1? &q1[1]: p));
5122 if (q2 != NULL) *q2 = '.';
5123 if (y == NIL || Cdr[y] == S_undefined) {
5124 sk_load(s);
5125 return 1;
5126 }
5127 return 0;
5128 }
5129
5130 /* Return conditions of use */
sk_license()5131 char **sk_license() {
5132 static char *license_text[] = {
5133 "SketchyLISP -- An Interpreter for Purely Applicative Scheme",
5134 "Copyright (C) 2005,2006,2007 Nils M Holm. All rights reserved.",
5135 "",
5136 "Redistribution and use in source and binary forms, with or without",
5137 "modification, are permitted provided that the following conditions",
5138 "are met:",
5139 "1. Redistributions of source code must retain the above copyright",
5140 " notice, this list of conditions and the following disclaimer.",
5141 "2. Redistributions in binary form must reproduce the above copyright",
5142 " notice, this list of conditions and the following disclaimer in the",
5143 " documentation and/or other materials provided with the distribution.",
5144 "",
5145 "THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND",
5146 "ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE",
5147 "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE",
5148 "ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE",
5149 "FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL",
5150 "DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS",
5151 "OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)",
5152 "HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT",
5153 "LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY",
5154 "OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF",
5155 "SUCH DAMAGE.",
5156 NULL};
5157 return license_text;
5158 }
5159
5160 /* Run GC and return statistics. */
sk_gc(struct sk_gcStats * stats)5161 void sk_gc(struct sk_gcStats *stats) {
5162 stats->nodes_used = PoolSize - gc();
5163 gcv();
5164 stats->vcells_used = Vptr;
5165 stats->nodes_max = MaxAtoms;
5166 stats->vcells_max = MaxCells;
5167 MaxAtoms = 0;
5168 MaxCells = 0;
5169 }
5170
5171 /* Dump symbol table */
sk_dumpSymbols(char * p)5172 void sk_dumpSymbols(char *p) {
5173 int pk, y;
5174
5175 y = findSym(p);
5176 Quoted = 1;
5177 pk = Packages;
5178 pr("Packages:");
5179 while (pk != sk_nil()) {
5180 pr(" ");
5181 _print(caar(pk));
5182 if (cdar(pk) == Symbols) pr("[open]");
5183 pk = Cdr[pk];
5184 }
5185 nl();
5186 y = findPackage(y);
5187 _print(Car[y]);
5188 pr(": ");
5189 _print(Cdr[y]);
5190 nl();
5191 }
5192