/* * SketchyLISP -- An interpreter for purely applicative Scheme * Copyright (C) 2005,2006,2007 Nils M Holm * Derived from ArrowLISP, Copyright (C) 1998-2005 Nils M Holm. * See the file LICENSE for conditions of use. */ #include #ifdef __TURBOC__ #include #include #else #include #ifndef __MINGW32__ #ifndef __CYGWIN__ #define setmode(fd, mode) #endif #endif #endif #include #include #include #include #include #define __SKETCHYLIB__ #include "sketchy.h" #define TEXTLEN SK_TEXTLEN #define MAXPATHL SK_MAXPATHL #define NROOT 13 /* Number of GC roots */ /* Tag Masks */ #define AFLAG 0x01 /* Atom flag, Car = char, CDR = next */ #define MFLAG 0x02 /* Mark flag of garbage collector */ #define SFLAG 0x04 /* State flag of garbage collector */ #define XFLAG 0x08 /* Extended type flag */ #define EOT SK_EOT /* EOT indicator */ #define DOT -2 /* Internal: dot character */ #define RPAREN -3 /* Internal: right parenthesis */ /* Evaluator states */ #define MATOM '0' /* Processing Atom */ #define MLIST '1' /* Processing List */ #define MBETA '2' /* Beta-reducing */ #define MBIND '3' /* Processing bindings of LET */ #define MBINR '4' /* Processing bindings of LETREC */ #define MLETR '5' /* Finish LET or LETREC */ #define MCOND '6' /* Processing predicates of COND */ #define MCONJ '7' /* Processing arguments of AND */ #define MDISJ '8' /* Processing arguments of OR */ #define MIFPR '9' /* Processing predicate of IF */ #define MBEGN 'A' /* Processing BEGIN */ /* Short cut */ #define NOEXPR SK_NOEXPR static int PoolSize, VPoolSize; /* Sizes of node and vector pool */ static int NIL; /* Not In List (or Pool) */ static int *Car, /* Vector holding CAR fields */ *Cdr; /* Vector holding CDR fields */ static char *Tag; /* Vector holding TAG fields */ static int *Vpool; /* Vector pool */ static int Vptr; /* Free space pointer of Vpool */ static char Infile[MAXPATHL]; /* Input file name */ static char DirName[MAXPATHL]; /* Source directory */ static char LocPath[MAXPATHL]; /* Buffer for findSource() */ static char ExpPath[MAXPATHL]; /* Expanded path of input file */ static char Path[MAXPATHL]; /* Path to input file */ static FILE *Input; /* Current input stream */ static int Rejected; /* Unread character */ static char *InputString; /* READ-FROM-STRING pointer */ static int Line; /* Input line number */ static FILE *Output; /* Current output stream */ static char *OutputString; /* WRITE-TO-STRING buffer */ static int OutStrSize; /* Chars left in OutputString */ static int Mstack, Lstack; /* Mode stack, List stack */ static int Bstack; /* Binding stack, used by LET/LETREC */ static int Estack; /* Env. stack, for fixing closures */ static int Free; /* Freelist */ static int Symbols; /* Symbol table */ static int Packages; /* Package list */ static int Transformers; /* Syntax transformers */ static int Digits[10]; /* Digit symbols */ static int SafeSymbols; /* Safe copy of symbols */ static int Stack, Stack0; /* Global stack, bottom of Stack */ static int Frame; /* Current call frame */ static int Tmp, Tmp2; /* Safe locations */ static int SafeCar, SafeCdr; /* Safe harbours during allocation */ static int *Root[NROOT]; /* GC Roots */ static int Level; /* Nesting level during input */ static int LoadLev; /* Nesting level of LOAD */ static int EvLev; /* Number of nested EVALs */ static int FatalFlag; /* Fatal error flag */ static int Function; /* Name of current lambda function */ static int Quoted; /* Quote flag of PRINT */ static int DisplayMode; /* Display Mode flag of PRINT */ static int SyntaxMode; /* Syntax Definition Mode flag */ static unsigned GensymCounter; /* Unique symbol id */ static int MaxAtoms, MaxCells; /* Memory use gauge */ static int Ntrace; /* Max fns to print in call trace */ static int LexEnv; /* Environment for creating closures */ static int Bound; /* Variables bound in a closure */ /* Builtin symbol pointers (for fast lookup) */ static int S_bottom, S_char, S_closure, S_core, S_defineSyntax, S_else, S_eof, S_false, S_gensym, S_integer, S_lambda, S_primitive, S_quote, S_special, S_special_cbv, S_string, S_syntax, S_true, S_undefined, S_user_primitive, S_vector, S_void, S_voidSym, S_last, S_0, S_1, S_2, S_3, S_4, S_5, S_6, S_7, S_8, S_9; /* Primitive function opcodes */ enum { P_BOTTOM, P_CAR, P_CDR, P_CHAR_TO_INTEGER, P_CHAR_CI_EQP, P_CHAR_CI_GEP, P_CHAR_CI_GTP, P_CHAR_CI_LEP, P_CHAR_CI_LTP, P_CHAR_EQP, P_CHAR_GEP, P_CHAR_GTP, P_CHAR_LTP, P_CHAR_LEP, P_CHARP, P_CONS, P_DELETE_FILE, P_DISPLAY, P_EOF_OBJECTP, P_EQP, P_GENSYM, P_INTEGER_TO_CHAR, P_INTEGER_TO_LIST, P_LIST_TO_INTEGER, P_LIST_TO_STRING, P_LIST_TO_VECTOR, P_LOAD, P_NLESS, P_NMINUS, P_NPLUS, P_NULLP, P_NUMBERP, P_PACKAGE, P_PAIRP, P_PEEK_CHAR, P_PROCEDUREP, P_READ, P_READ_CHAR, P_READ_FROM_STRING, P_RECURSIVE_BIND, P_REQUIRE, P_STRING_TO_LIST, P_STRING_TO_SYMBOL, P_STRING_APPEND, P_STRING_LENGTH, P_STRING_REF, P_STRINGP, P_SUBSTRING, P_SYMBOL_TO_STRING, P_SYMBOLP, P_SYNTAX_OF, P_VECTOR_TO_LIST, P_VECTOR_LENGTH, P_VECTOR_REF, P_VECTORP, P_VOID, P_WRITE, P_WRITE_CHAR, P_WRITE_TO_STRING, N_PRIMITIVES }; /* Primitive function pointers. */ static int (*Primitives[N_PRIMITIVES])(int); /* Special form opcodes */ enum { SF_AND, SF_APPLY, SF_BEGIN, SF_COND, SF_DEFINE, SF_DEFINE_SYNTAX, SF_EVAL, SF_IF, SF_LAMBDA, SF_LET, SF_LETREC, SF_OR, SF_QUOTE, SF_SYNTAX_RULES, SF_WITH_INPUT_FROM_FILE, SF_WITH_OUTPUT_TO_FILE, N_SPECIALS }; /* Special form handler pointers */ static int (*Specials[N_SPECIALS])(int, int *, int *, int *); /* Pointers to functions handling user-supplied primitives. */ static int (*UsrPrimitives[SK_MAX_USER_PRIMITIVES])(int); static int LastUsrPrimitive; /* # of user primitives */ /* LINT: unused args in special form handlers */ #define USE(arg) arg = 0 /* * Prototypes */ static int addPackage(int sym); static int addPrim(char *name, int opcode); static int addSpecial(char *name, int opcode, int cbv); static int addSym(char *s, int v); static int alloc3(int pcar, int pcdr, int ptag); static int allocv(int type, int size); static int badArgLst(int n); static int bindArgs(int n, int name); static void bindLet(int env); static int bunsave(int k); static void cacheDigits(void); static int character(void); static int charPred(int n, int pred, char *msg); static void clearStats(void); static int closure(int n); static void collect(int n); static int copyBindings(void); static int digitToValue(int n); static int doAnd(int n, int *pcf, int *pmode, int *pcbn); static int doApply(int n, int *pcf, int *pmode, int *pcbn); static int doBegin(int n, int *pcf, int *pmode, int *pcbn); static int doBottom(int n); static int doCar(int n); static int doCdr(int n); static int doCharCiEqP(int n); static int doCharCiGEP(int n); static int doCharCiGtP(int n); static int doCharCiLEP(int n); static int doCharCiLtP(int n); static int doCharEqP(int n); static int doCharGtP(int n); static int doCharGEP(int n); static int doCharLtP(int n); static int doCharLEP(int n); static int doCharP(int n); static int doCharToInteger(int n); static int doCond(int n, int *pcf, int *pmode, int *pcbn); static int doCons(int n); static int doDefine(int n, int *pcf, int *pmode, int *pcbn); static int doDefineSyntax(int n, int *pcf, int *pmode, int *pcbn); static int doDeleteFile(int n); static int doDisplay(int n); static int doEofObjectP(int n); static int doEqP(int n); static int doEval(int n, int *pcf, int *pmode, int *pcbn); static int doGensym(int n); static int doIf(int n, int *pcf, int *pmode, int *pcbn); static int doIntegerToChar(int n); static int doIntegerToList(int n); static int doLambda(int n, int *pcf, int *pmode, int *pcbn); static int doLet(int n, int *pcf, int *pmode, int *pcbn); static int doLetrec(int n, int *pcf, int *pmode, int *pcbn); static int doListToInteger(int n); static int doListToString(int n); static int doNLess(int n); static int doNMinus(int n); static int doNPlus(int n); static int doNullP(int n); static int doNumberP(int n); static int doOr(int n, int *pcf, int *pmode, int *pcbn); static int doPackage(int n); static int doPairP(int n); static int doPeekChar(int n); static int doProcedureP(int n); static int doQuote(int n, int *pcf, int *pmode, int *pcbn); static int doRead(int n); static int doReadChar(int n); static int doReadFromString(int n); static int doRecursiveBind(int n); static int doStringAppend(int n); static int doStringLength(int n); static int doStringP(int n); static int doStringRef(int n); static int doStringToList(int n); static int doStringToSymbol(int n); static int doSubstring(int n); static int doSymbolP(int n); static int doSymbolToString(int n); static int doSyntaxToList(int n); static int doVoid(int n); static int doWithInputFromFile(int n, int *pcf, int *pmode, int *pcbn); static int doWithOutputToFile(int n, int *pcf, int *pmode, int *pcbn); static int doWrite(int n); static int doWriteChar(int n); static int doWriteToString(int n); #ifdef DEBUG static void dumpState(char *s, int m); #endif static int equals(int n, int m); static int error(char *m, int n); static int eval(int n); static int evalClause(int n); static int evalLet(void); static char *expandPath(char *s); static int explodeNum(char *s); static int explodeStr(char *s); static void fatal(char *m); static int findPackage(int sym); static int findPsym(char *s, int y); static int findSym(char *s); static int findTransformer(int y); static int finishLet(int rec); static void fixAllClosures(int b); static void fixCachedClosures(void); static void fixClosuresOf(int n, int bindings); static void fixNIL(int *p, int nilval); static int flatCopy(int n, int *lastp); static int gc(void); static void gcv(void); static void getDirName(char *path, char *pfx); static int getFactors(char *msg, int n, int *p1, int *p2); static int getPred(void); static char *implodeStr(int m, int k, char *s); static void init1(void); static void init2(void); static void mark(int n); static int isAlist(int n); static int isBound(int n); static int isSymList(int m); static int length(int n); static int list_to_vector(int m, char *msg); static int localize(int n, int *exprp); static char *locase(char *s); static int lunsave(int k); static void markVec(int n, int type); static int mkLexEnv(int term, int locals); static int munsave(void); static int nestedComment(void); static int newDefine(int n); static int nextLet(int n); static void nl(void); static int nreverse(int n); static int numericStr(char *s); static void pr(char *s); #ifdef DEBUG static void prDepth(int n); #endif static int primitive(int *np); static void _print(int n); static int printChar(int n); static int printClosure(int n); static int printNum(int n); static int printPrim(int n); static int printQuote(int n); static int printSpecial(int n); static int printString(int n); static void printTrace(int n); static void prnum(int n, int w); static void _prnum(int n, int w, char *spaces); static void prznum(int n, int w); static int quote(int n); static int rdch(void); int c; static int readList(void); static int readVector(void); static void registerTransformer(int y, int tr); static void REL(void); static void resetState(void); static void restoreBindings(int values); static int reverse(int n); static int safe_eval(int n); static void setErrArg(char *s); static int setupCond(int n); static int setupLet(int n); static int setupLogOp(int n); static int special(int *np, int *pcf, int *pmode, int *pcbn); static int stringLiteral(void); static void subst(int old, int new, int *p); static int symOrNum(int c); static int syntaxTransform(int n); static int _syntaxTransform(int n); static int tagged(int n); static void tailCall(void); static void unbindArgs(void); static void unmarkVecs(void); static int unreadable(void); static int unsave(int k); static void updatePackages(int old, int new); static int valueOf(char *src, int n); static int valueToDigit(int n); static void verify(void); static int wrongArgs(int n); static int xread(void); /* string node --> string text */ #define string(n) ((char *) &Vpool[Car[Cdr[n]]]) /* string node --> string length */ #define string_len(n) (Vpool[Car[Cdr[n]] - 1]) /* Size of vector in chars --> size in ints */ #define vector_size(k) (((k) + sizeof(int)-1) / sizeof(int) + 2) /* vector node --> vector elements */ #define vector(n) (&Vpool[Car[Cdr[n]]]) /* Number of vector elements */ #define vector_len(n) (vector_size(string_len(n)) - 2) /* Nested lists... */ #define caar(x) (Car[Car[x]]) #define cadr(x) (Car[Cdr[x]]) #define cdar(x) (Cdr[Car[x]]) #define cddr(x) (Cdr[Cdr[x]]) #define caaar(x) (Car[Car[Car[x]]]) #define caadr(x) (Car[Car[Cdr[x]]]) #define cadar(x) (Car[Cdr[Car[x]]]) #define caddr(x) (Car[Cdr[Cdr[x]]]) #define cddar(x) (Cdr[Cdr[Car[x]]]) #define cdddr(x) (Cdr[Cdr[Cdr[x]]]) #define caddar(x) (Car[Cdr[Cdr[Car[x]]]]) #define cadddr(x) (Car[Cdr[Cdr[Cdr[x]]]]) /* * Print the string S through a buffered interface. * If OutputString is not NULL, write to that string. */ static void pr(char *s) { int k; if (OutputString) { k = strlen(s); if (OutStrSize - k < 1) fatal("doWriteToString(): out of vector space"); strcpy(OutputString, s); OutputString += k; OutStrSize -= k; return; } fputs(s, Output); } /* pr() wrapper */ void sk_pr(char *s) { pr(s); } /* * Print a number with leading characters. * w = total width; * spaces must hold >=w padding characters. */ static void _prnum(int n, int w, char *spaces) { char b[20]; int k; sprintf(b, "%d", n); k = strlen(b); if (k < w) pr(&spaces[k]); pr(b); } /* Print number with leading spaces. */ static void prnum(int n, int w) { _prnum(n, w, " "); } /* prnum() wrapper */ void sk_prnum(int n, int w) { prnum(n, w); } /* Print number with leading zeroes. */ static void prznum(int n, int w) { _prnum(n, w, "000"); } /* Emit a newline sequence and flush the output buffer. */ static void nl(void) { putc('\n', Output); if (Output == stdout) fflush(Output); } /* nl() wrapper */ void sk_nl(void) { nl(); } /* Convert string to lower case. */ static char *locase(char *s) { int k, i; k = strlen(s); for (i=0; in = 0; c->n1k = 0; c->n1m = 0; c->n1g = 0; } /* Increment counter by K. K must be <= 1000. */ void sk_count(struct sk_counter *c, int k) { char *msg = "statistics counter overflow"; c->n = c->n+k; if (c->n >= 1000) { c->n = c->n - 1000; c->n1k = c->n1k + 1; if (c->n1k >= 1000) { c->n1k = 0; c->n1m = c->n1m+1; if (c->n1m >= 1000) { c->n1m = 0; c->n1g = c->n1g+1; if (c->n1g >= 1000) { error(msg, NOEXPR); } } } } } /* Print counter value. */ void sk_printCounter(struct sk_counter *c) { if (c->n1g) { prznum(c->n1g, 0); pr(","); } if (c->n1m || c->n1g) { prznum(c->n1m, c->n1g?3:0); pr(","); } if (c->n1k || c->n1m || c->n1g) { prznum(c->n1k, (c->n1m||c->n1g)?3:0); pr(","); } prznum(c->n, (c->n1k||c->n1m||c->n1g)?3:0); } /* Mark object at offset N in the Vpool */ static void markVec(int n, int type) { int *p, k; p = &Vpool[cadr(n) - 2]; *p = n; if (type == S_vector) { k = vector_len(n); p = vector(n); while (k) { mark(*p); p++; k--; } } } /* * Mark nodes which can be accessed through N. * This routine uses the Deutsch/Schorr/Waite algorithm * (aka pointer reversal algorithm) which marks the * nodes of a pool in constant space. * It uses MFLAG and SFLAG of the tag field to keep track * of the state of the current node. * Each visited node goes through these states: * S0: M==0 S==0 unvisited, process CAR * S1: M==1 S==1 CAR visited, process CDR * S2: M==1 S==0 completely visited, return to parent */ static void mark(int n) { int p, x, t; int parent; parent = NIL; /* Initially, there is no parent node */ while (1) { /* Reached a dead end? */ if (n == NIL || Tag[n] & MFLAG) { if (parent == NIL) break; if (Tag[parent] & SFLAG) { /* S1 */ /* Swap CAR and CDR pointers and */ /* proceed with CDR. Goto S2. */ p = Cdr[parent]; Cdr[parent] = Car[parent]; Car[parent] = n; Tag[parent] &= ~SFLAG; /* S=0 */ Tag[parent] |= MFLAG; /* M=1 */ n = p; } else { /* S2 */ /* Return to the parent and */ /* restore parent of parent */ p = parent; parent = Cdr[p]; Cdr[p] = n; n = p; } } else { /* S0 */ if (Tag[n] & AFLAG) { /* If the node is an atom, go directly */ /* to state 3: Save the parent in CDR, */ /* make the current node the new parent */ /* and move to its CDR. */ p = Cdr[n]; Cdr[n] = parent; /*Tag[n] &= ~SFLAG;*/ /* S=0 */ parent = n; n = p; Tag[parent] |= MFLAG; /* M=1 */ } else { t = (Tag[n] & XFLAG)? Car[n]: NIL; x = n; /* Go to state 2: like above, but save */ /* the parent in CAR and proceed to CAR. */ p = Car[n]; Car[n] = parent; Tag[n] |= MFLAG; /* M=1 */ parent = n; n = p; Tag[parent] |= SFLAG; /* S=1 */ if (t != NIL) markVec(x, t); } } } } /* Mark all vectors of the Vpool unused */ static void unmarkVecs(void) { int p, k, link; p = 0; while (p < Vptr) { link = p; k = Vpool[p+1]; p += vector_size(k); Vpool[link] = NIL; } } /* * Mark and Sweep Garbage Collection. * First mark all nodes that can be accessed through * Root registers (Root[]) and then reclaim unmarked * nodes. */ static int gc(void) { int i, k; k = 0; #ifdef DEBUG pr("GC called"); nl(); #endif for (i=0; i MaxCells) MaxCells = Vptr; } /* Allocate vector from vpool */ static int allocv(int type, int size) { int v, n, wsize; wsize = vector_size(size); if (Vptr + wsize >= VPoolSize) { gcv(); if (Vptr + wsize >= VPoolSize) fatal("allocv(): out of vector space"); } v = Vptr; Vptr += wsize; Tmp2 = alloc3(v+2, NIL, AFLAG); n = alloc3(type, Tmp2, XFLAG); Tmp2 = NIL; Vpool[v] = n; Vpool[v+1] = size; return n; } /* Save node N on the Stack. */ #define save(n) (Stack = alloc((n), Stack)) /* * Pop K nodes off the Stack and return * the one most recently popped. */ static int unsave(int k) { int n = NIL; /*LINT*/ while (k) { if (Stack == NIL) fatal("unsave(): stack underflow"); n = Car[Stack]; Stack = Cdr[Stack]; k = k-1; } return n; } /* * Save value V on the M-Stack. * Since the Mstack holds integer values rather than * nodes, the values are packaged in the character * fields of atoms. */ #define msave(v) (Car[Mstack] = alloc3((v), Car[Mstack], AFLAG)) /* Pop a value off the M-Stack and return it. */ static int munsave(void) { int v; if (Car[Mstack] == NIL) fatal("munsave(): m-stack underflow"); v = caar(Mstack); /* See msave() */ Car[Mstack] = cdar(Mstack); return v; } /* Save node N on the L-Stack. */ #define lsave(n) (Lstack = alloc((n), Lstack)) /* * Pop K nodes off the L-Stack and return * the one most recently popped. */ static int lunsave(int k) { int n = NIL; /*LINT*/ while (k) { if (Lstack == NIL) fatal("lunsave(): l-stack underflow"); n = Car[Lstack]; Lstack = Cdr[Lstack]; k = k-1; } return n; } /* Save node N on the B-Stack. */ #define bsave(n) (Bstack = alloc((n), Bstack)) /* * Pop K nodes off the B-Stack and return * the one most recently popped. */ static int bunsave(int k) { int n = NIL; /*LINT*/ while (k) { if (Bstack == NIL) fatal("bunsave(): b-stack underflow"); n = Car[Bstack]; Bstack = Cdr[Bstack]; k = k-1; } return n; } /* * Read a single character from the input stream * and return it. Sk_rdch()==EOT indicates that * the input is exhausted. */ int sk_rdch(void) { int c; if (Rejected != EOT) { c = Rejected; Rejected = EOT; return c; } if (InputString) { if (*InputString == 0) return EOT; return *InputString++; } c = getc(Input); if (feof(Input)) return EOT; if (c == '\n') Line = Line+1; return c; } /* Put char back to input stream */ void sk_reject(int c) { Rejected = c; } /* Read a character and convert it to lower case. */ static int rdch(void) { return tolower(sk_rdch()); } /* * Find a symbol named S in the symbol table Y. * Each symbol is represented by a (NAME . VALUE) pair * where NAME is a list of character nodes and value * may be any datum. * The symbol table is a list containing symbol * pairs ((N1 . V1) ...). * When a symbol named S is found, return its * pair (S . V) and otherwise return NIL. */ static int findPsym(char *s, int y) { int n, i; while (y != NIL) { n = caar(y); i = 0; while (n != NIL && s[i]) { if (s[i] != (Car[n] & 255)) break; n = Cdr[n]; i = i+1; } if (n == NIL && !s[i]) return Car[y]; y = Cdr[y]; } return NIL; } /* * Find the symbol S in the symbol table of any * package in the package list. * Search the current package first. */ static int findSym(char *s) { int p, y; y = findPsym(s, Symbols); if (y != NIL) return y; p = Packages; while (p != NIL) { y = findPsym(s, cdar(p)); if (y != NIL) return y; p = Cdr[p]; } return NIL; } /* findSym() wrapper */ int sk_findSym(char *s) { return findSym(s); } /* Explode a string to a list of atoms. */ static int explodeStr(char *s) { int i, n, m, a; i = 0; if (s[i] == 0) return NIL; a = n = NIL; while (s[i]) { m = alloc3(s[i], NIL, AFLAG); if (n == NIL) { /* Protect the first character */ n = m; save(n); } else { /* Append the rest */ Cdr[a] = m; } a = m; i = i+1; } unsave(1); return n; } /* * Implode a list of atoms to a string. * K = size of S. */ static char *implodeStr(int n, int k, char *s) { int i; i = 0; while (n != NIL) { if (i >= k-1) fatal("implodeStr(): string too long"); s[i++] = Car[n] & 255; n = Cdr[n]; } s[i] = 0; return s; } /* Update symbol table pointer in package list. */ static void updatePackages(int old, int new) { int p; p = Packages; while (p != NIL) { if (cdar(p) == old) { cdar(p) = new; return; } p = Cdr[p]; } if (Packages != NIL) fatal("updatePackages(): symbol table not in package list?"); } /* * Add the symbol S to the symbol table if it * does not already exist. If it does exist, * return the existing symbol. * When adding a new symbol, initialize the * VALUE field with V. If V==0, bind S to S. * Return the pair representing the symbol S. */ static int addSym(char *s, int v) { int n, m, osym; n = findSym(s); if (n != NIL) return n; n = explodeStr(s); m = alloc(n, v); if (!v) Cdr[m] = m; osym = Symbols; Symbols = alloc(m, Symbols); updatePackages(osym, Symbols); return m; } /* Add primitive procedure. */ static int addPrim(char *name, int opcode) { int y; y = addSym(name, 0); Cdr[y] = alloc(S_primitive, NIL); cddr(y) = alloc3(opcode, NIL, AFLAG); cdddr(y) = y; return y; } /* Add special form handler. */ static int addSpecial(char *name, int opcode, int cbv) { int y; y = addSym(name, 0); Cdr[y] = alloc(cbv? S_special_cbv: S_special, NIL); cddr(y) = alloc3(opcode, NIL, AFLAG); cdddr(y) = y; return y; } /* Add user primitive handler. */ int sk_addUserPrim(char *name, int (*handler)(int n)) { int y; if (LastUsrPrimitive >= SK_MAX_USER_PRIMITIVES) return -1; y = addSym(name, 0); Cdr[y] = alloc(S_user_primitive, NIL); cddr(y) = alloc3(LastUsrPrimitive, NIL, AFLAG); cdddr(y) = y; UsrPrimitives[LastUsrPrimitive] = handler; LastUsrPrimitive += 1; return LastUsrPrimitive; } /* Find a package. */ static int findPackage(int sym) { int p; p = Packages; while (p != NIL) { if (caar(p) == sym) return Car[p]; p = Cdr[p]; } return NIL; } /* Add a package. */ static int addPackage(int sym) { int y, p; y = findPackage(sym); if (y != NIL) return Cdr[y]; p = alloc(sym, NIL); Packages = alloc(p, Packages); return Cdr[p]; } /* * Read a list (S0 ... SN) or pair (S0 . S1) and return it. * For empty lists return NIL. */ static int readList(void) { int n, /* Node read */ m, /* List */ a, /* Used to append nodes to m */ c; /* Member counter */ char *badpair; badpair = "bad pair"; Level = Level+1; m = alloc(NIL, NIL); /* Root node */ save(m); a = NIL; c = 0; while (1) { if (SK_errFlag) { unsave(1); return NIL; } n = xread(); if (n == S_eof) { if (LoadLev) { unsave(1); return S_eof; } error("missing ')'", NOEXPR); } if (n == DOT) { if (c < 1) { error(badpair, NOEXPR); continue; } n = xread(); Cdr[a] = n; if (n == RPAREN || xread() != RPAREN) { error(badpair, NOEXPR); continue; } unsave(1); Level = Level-1; return m; } if (n == RPAREN) break; if (a == NIL) a = m; /* First member: insert at root */ else a = Cdr[a]; /* Following members: append */ Car[a] = n; Cdr[a] = alloc(NIL, NIL); /* Alloc space for next member */ c = c+1; } Level = Level-1; if (a != NIL) Cdr[a] = NIL; /* Remove trailing empty node */ unsave(1); return c? m: NIL; } /* Read a vector literal */ static int readVector(void) { int n; n = readList(); save(n); n = list_to_vector(n, "bad vector syntax"); unsave(1); return n; } /* Is N a 'real' (non-NIL) atom? */ #define atomic(n) \ ((n) != NIL && Car[n] != NIL && (Tag[Car[n]] & AFLAG)) /* Is N a tagged list (an internal type)? */ static int tagged(int n) { if ( n == NIL || !atomic(Car[n]) || Car[n] == S_true || Car[n] == S_false ) return 0; n = caar(n); return (Tag[n] & AFLAG) && Car[n] == '#'; } /* Is N a lazy atom (atomic or tagged list)? */ #define lazyAtom(n) (atomic(n) || tagged(n)) /* Quote an expression. */ static int quote(int n) { int q; q = alloc(n, NIL); return alloc(S_quote, q); } /* * Check whether a string represents a number. * Numbers are defined as [+-]?[0-9]+. */ static int numericStr(char *s) { int i; i = 0; if (s[0] == '+' || s[0] == '-') i = 1; if (!s[i]) return 0; while (s[i]) { if (!isdigit(s[i])) return 0; i = i+1; } return 1; } /* Explode a numeric string into a bignum. */ static int explodeNum(char *s) { int i, l, x, y; char name[3]; i = 0; l = alloc(S_integer, NIL); x = l; save(l); strcpy(name, "0d"); while (s[i]) { name[0] = s[i]; name[1] = isdigit(s[i])? 'd': 0; y = addSym(name, NIL); Cdr[x] = alloc(y, NIL); x = Cdr[x]; i = i+1; } unsave(1); return l; } /* Report unreadable object */ static int unreadable(void) { int c, i; char buf[TEXTLEN]; error("unreadable object", NOEXPR); strcpy(buf, "#<"); i = 2; while (1) { c = rdch(); if (c == '>' || c == '\n') break; if (i < TEXTLEN-2) buf[i++] = c; } buf[i++] = '>'; buf[i] = 0; setErrArg(buf); return NIL; } /* Create a character literal. */ int sk_mkChar(int x) { int n; n = alloc3(x, NIL, AFLAG); return alloc(S_char, n); } /* Read a character literal. */ static int character(void) { char buf[10]; int i, c; for (i=0; i<9; i++) { c = sk_rdch(); if (i > 0 && !isalpha(c)) break; buf[i] = c; } Rejected = c; buf[i] = 0; if (i == 0) c = ' '; else if (i == 1) c = buf[0]; else if (!strcmp(buf, "space")) c = ' '; else if (!strcmp(buf, "newline")) c = '\n'; else if (!strcmp(buf, "linefeed")) c = '\n'; else { error("bad # syntax", NOEXPR); c = 0; } return sk_mkChar(c); } /* Create a string; K = length */ int sk_mkString(char *s, int k) { int n; n = allocv(S_string, k+1); strcpy(string(n), s); return n; } /* Read a string literal. */ static int stringLiteral(void) { char s[TEXTLEN+1]; int c, i, n, q; int inv; i = 0; q = 0; c = sk_rdch(); inv = 0; while (q || c != '"') { if (SK_errFlag) break; if (i >= TEXTLEN-2) { error("symbol too long", NOEXPR); i = i-1; } if (q && c != '"' && c != '\\') { s[i++] = '\\'; inv = 1; } s[i] = c; q = !q && c == '\\'; if (!q) i = i+1; c = sk_rdch(); } s[i] = 0; n = sk_mkString(s, i); if (inv) error("invalid escape sequence in string", n); return n; } #define separator(c) \ ((c) == ' ' || (c) == '\t' || (c) == '\n' || \ (c) == '\r' || (c) == '(' || (c) == ')' || \ (c) == ';' || (c) == '#' || (c) == '\'' || \ (c) == '"' || (c) == EOT) /* * Read a symbol or a numeric literal. When reading a * symbol, add it to the global symbol table. */ static int symOrNum(int c) { char s[TEXTLEN]; int i; i = 0; while (!separator(c)) { if (i >= TEXTLEN-2) { error("symbol too long", NOEXPR); i = i-1; } s[i] = c; i = i+1; c = rdch(); } s[i] = 0; Rejected = c; if (numericStr(s)) return explodeNum(s); return addSym(s, S_undefined); } /* (EQUAL N M)? */ static int equals(int n, int m) { if (n == m) return 1; if (n == NIL || m == NIL) return 0; if (tagged(n) && tagged(m)) { if ( Car[n] == S_integer && Car[m] == S_integer && equals(Cdr[n], Cdr[m]) ) return 1; if ( Car[n] == S_char && Car[m] == S_char && cadr(n) == cadr(m) ) return 1; if ( Car[n] == S_string && Car[m] == S_string && !strcmp(string(n), string(m)) ) return 1; } if (Tag[n] & AFLAG || Tag[m] & AFLAG) return 0; return equals(Car[n], Car[m]) && equals(Cdr[n], Cdr[m]); } /* Verify most recently evaluated expression */ static void verify(void) { int expected; expected = sk_read(); if (!equals(expected, Cdr[S_last])) error("Verification failed; expected", expected); } /* Skip over nested #| ... |# */ static int nestedComment(void) { int p, c, k; k = 1; p = 0; c = rdch(); while (k) { if (c == EOT) fatal("end of input in nested comment"); if (p == '#' && c == '|') { k++; c = 0; } if (p == '|' && c == '#') { k--; c = 0; } p = c; c = rdch(); } return c; } /* * Read an expression from the current input stream * and return it. */ int xread(void) { int c, c2; c = rdch(); while (1) { /* Skip spaces and comments */ while (c == ' ' || c == '\t' || c == '\n' || c == '\r') { if (SK_errFlag) return NIL; c = rdch(); } if (c == '#') { c = rdch(); if (c == '|') { c = nestedComment(); continue; } if (c == ';') { xread(); c = rdch(); continue; } if (c != '!') { Rejected = c; c = '#'; break; } } else if (SK_arrowMode && c == '=') { c = rdch(); if (c != '>') { Rejected = c; c = '='; break; } if (SK_arrowMode > 1) verify(); } else if (c != ';') break; while (c != '\n' && c != EOT) c = rdch(); } if (c == EOT) return S_eof; if (c == '(') { return readList(); } else if (c == '\'') { return quote(xread()); } else if (c == '#') { c = rdch(); if (c == 'f') return S_false; if (c == 't') return S_true; if (c == '\\') return character(); if (c == '(') return readVector(); if (c == '<') return unreadable(); return error("bad # syntax", NOEXPR); } else if (c == '"') { return stringLiteral(); } else if (c == ')') { if (!Level) return error("unexpected ')'", NOEXPR); return RPAREN; } else if (c == '.') { c2 = rdch(); sk_reject(c2); if (separator(c2)) { if (!Level) return error("unexpected '.'", NOEXPR); return DOT; } return symOrNum(c); } else { return symOrNum(c); } } /* Syntax transformer */ int _syntaxTransform(int n) { int m; int tr, app; if (SK_errFlag) return NIL; if (n == NIL || lazyAtom(n)) return n; if (Car[n] == S_quote) return n; m = n; while (m != NIL && !lazyAtom(m)) { Car[m] = _syntaxTransform(Car[m]); if (SK_errFlag) return NIL; m = Cdr[m]; } if (atomic(Car[n]) && cadar(n) == S_syntax) { /* * Doing this in C is simply too ugly. * Pass all the stuff to TRANSFORM-SYNTAX * and let it do the real work. * TRANSFORM-SYNTAX is in sketchy.scm. */ tr = findPsym("transform-syntax", Cdr[S_core]); if (tr == NIL) fatal("image lacks 'transform-syntax' procedure"); app = quote(n); app = alloc(app, NIL); app = alloc(tr, app); n = safe_eval(app); Function = NIL; } return n; } /* Syntax transformer, friendly version */ int syntaxTransform(int n) { if (!lazyAtom(n) && Car[n] != S_defineSyntax) { save(n); n = _syntaxTransform(n); unsave(1); } return n; } /* Friendly version of XREAD. */ int sk_read(void) { Level = 0; return xread(); } /* Error reporting... */ static int wrongArgs(int n) { return error("wrong argument count", n); } static int badArgLst(int n) { return error("bad argument list", n); } /* Evaluate N=(CONS M M2) */ static int doCons(int n) { int m, m2; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); m2 = cadr(m); return alloc(Car[m], m2); } /* Evaluate N=(CAR M) */ static int doCar(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); if (atomic(Car[m]) || Car[m] == NIL || tagged(Car[m])) return error("non-pair in 'car'", Car[m]); return caar(m); } /* Evaluate N=(CDR M) */ static int doCdr(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); if (atomic(Car[m]) || Car[m] == NIL || tagged(Car[m])) { return error("non-pair in 'cdr'", Car[m]); } return cdar(m); } /* Evaluate N=(CHAR->INTEGER M) */ static int doCharToInteger(int n) { int m, i, c; char b[4]; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_char) return error("non-character in 'char->integer'", m); c = cadr(m); i = 3; b[i] = 0; while (c || i == 4) { i = i-1; b[i] = c % 10 + '0'; c = c / 10; } return explodeNum(&b[i]); } #define CHAR_CI_LT 0 #define CHAR_CI_LE 1 #define CHAR_CI_EQ 2 #define CHAR_CI_GT 3 #define CHAR_CI_GE 4 #define CHAR_LT 5 #define CHAR_LE 6 #define CHAR_EQ 7 #define CHAR_GT 8 #define CHAR_GE 9 /* Process CHAR... predicates. */ static int charPred(int n, int pred, char *msg) { int m, c1, c2; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL) { wrongArgs(n); return NIL; } while (Cdr[m] != NIL) { c1 = Car[m]; c2 = cadr(m); if (atomic(c1) || Car[c1] != S_char) return error(msg, c1); if (atomic(c2) || Car[c2] != S_char) return error(msg, c2); c1 = cadr(c1); c2 = cadr(c2); switch (pred) { case CHAR_CI_LT: if (tolower(c1) >= tolower(c2)) return S_false; break; case CHAR_CI_LE: if (tolower(c1) > tolower(c2)) return S_false; break; case CHAR_CI_EQ: if (tolower(c1) != tolower(c2)) return S_false; break; case CHAR_CI_GT: if (tolower(c1) <= tolower(c2)) return S_false; break; case CHAR_CI_GE: if (tolower(c1) < tolower(c2)) return S_false; break; case CHAR_LT: if (c1 >= c2) return S_false; break; case CHAR_LE: if (c1 > c2) return S_false; break; case CHAR_EQ: if (c1 != c2) return S_false; break; case CHAR_GT: if (c1 <= c2) return S_false; break; case CHAR_GE: if (c1 < c2) return S_false; break; } m = Cdr[m]; } return S_true; } /* Evaluate N=(CHAR-CI? M1 M2 ...) */ static int doCharCiGtP(int n) { return charPred(n, CHAR_CI_GT, "non-char in char-ci=? M1 M2 ...) */ static int doCharCiGEP(int n) { return charPred(n, CHAR_CI_GE, "non-char in char-ci<=?"); } /* Evaluate N=(CHAR? M1 M2 ...) */ static int doCharGtP(int n) { return charPred(n, CHAR_GT, "non-char in char=? M1 M2 ...) */ static int doCharGEP(int n) { return charPred(n, CHAR_GE, "non-char in char 9) { r -= 10; carry = 1; } else { carry = 0; } res = alloc(valueToDigit(r), res); if (f1 != NIL) f1 = Cdr[f1]; if (f2 != NIL) f2 = Cdr[f2]; } res = alloc(S_integer, res); unsave(2); return res; } /* Evaluate N=(GENSYM M) */ static int doGensym(int n) { int m, k, i, d; char sym[TEXTLEN]; m = Cdr[n]; if (m != NIL && Cdr[m] != NIL) return wrongArgs(n); if (m == NIL) m = S_gensym; else if (!atomic(Car[m])) return error("non-symbol in 'gensym'", Car[m]); else m = Car[m]; implodeStr(Car[m], TEXTLEN, sym); k = strlen(sym); while (1) { d = 1; for (i=GensymCounter; i; i /= 10) d++; if (k + d >= TEXTLEN) fatal("doGensym(): symbol too long"); GensymCounter += 1; if (GensymCounter == 0) fatal("doGensym(): out of unique symbols"); sprintf(&sym[k], "%d", GensymCounter); if (findSym(sym) == NIL) { m = explodeStr(sym); m = alloc(m, S_undefined); return m; } } return m; } /* Evaluate N=(INTEGER->CHAR M) */ static int doIntegerToChar(int n) { int m, p; unsigned char c; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_integer) return error("non-integer in 'integer->char'", m); p = Cdr[m]; c = 0; while (p != NIL) { c = c * 10 + caaar(p) - '0'; p = Cdr[p]; } if (c > 127) return error("value out of range in 'integer->char'", m); return sk_mkChar(c); } /* Evaluate N=(INTEGER->LIST M) */ static int doIntegerToList(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_integer) return error("non-integer in 'integer->list'", m); return Cdr[m]; } /* Evaluate N=(LIST->INTEGER M) */ static int doListToInteger(int n) { int m, check, p, d, found_digit; m = Cdr[n]; if (m == NIL || (Cdr[m] != NIL && cddr(m) != NIL)) return wrongArgs(n); check = cddr(m) != NIL; m = Car[m]; if (m == NIL || atomic(m) || tagged(m)) return error("non-list or empty list in 'list->integer'", m); if (check) { p = m; d = Car[p]; if ( atomic(d) && (caar(d) == '+' || caar(d) == '-') && cdar(d) == NIL ) p = Cdr[p]; found_digit = 0; while (p != NIL) { d = Car[p]; if ( d == S_0 || d == S_1 || d == S_2 || d == S_3 || d == S_4 || d == S_5 || d == S_6 || d == S_7 || d == S_8 || d == S_9 ) found_digit = 1; else error( "non-digit in argument to 'list->integer'", d); p = Cdr[p]; } if (!found_digit) return error("no digits in 'list->integer'", m); } return alloc(S_integer, m); } /* Evaluate N=(NULL? M) */ static int doNullP(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); return Car[m] == NIL? S_true: S_false; } /* Evaluate N=(EOF-OBJECT? M) */ static int doEofObjectP(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); return Car[m] == S_eof? S_true: S_false; } /* Evaluate N=(EQ? M M2) */ static int doEqP(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); return Car[m] == cadr(m)? S_true: S_false; } /* Evaluate N=(LIST->STRING M) */ static int doListToString(int n) { int m, p, i, k, ch; char *s; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (m == NIL) { p = allocv(S_string, 1); s = string(p); s[0] = 0; return p; } if (lazyAtom(m)) return error("non-list in 'list->string'", m); k = 0; for (p = m; p != NIL; p = Cdr[p]) { if (lazyAtom(p)) return error("improper list in 'list->string'", cadr(n)); k++; } p = allocv(S_string, k+1); i = 0; s = string(p); while (m != NIL) { ch = Car[m]; if (atomic(ch) || Car[ch] != S_char) return error("non-char in argument to 'list->string'", ch); s[i++] = cadr(ch); m = Cdr[m]; } s[i] = 0; return p; } static int list_to_vector(int m, char *msg) { int n; int vec, k; int *p; k = 0; for (n = m; n != NIL; n = Cdr[n]) { if (lazyAtom(n)) return error(msg, m); k++; } vec = allocv(S_vector, k*sizeof(int)); p = vector(vec); for (n = m; n != NIL; n = Cdr[n]) { *p = Car[n]; p++; } return vec; } /* Evaluate N=(LIST->VECTOR M) */ static int doListToVector(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (lazyAtom(m)) return error("non-list in 'list->vector'", m); return list_to_vector(m, "improper list in 'list->vector'"); } /* Evaluate N=(LOAD M) */ static int doLoad (int n) { int m, f; char *s; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); f = Car[m]; if (atomic(f) || f == NIL || Car[f] != S_string) return error("non-string in 'load'", f); s = string(f); /* file name */ sk_load(s); return S_void; } /* Evaluate N=(NUMBER? M) */ static int doNumberP(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; return atomic(m) || m == NIL? S_false: Car[m] == S_integer? S_true: S_false; } /* Evaluate N=(PACKAGE [N1]) */ static int doPackage(int n) { int m; m = Cdr[n]; if (m != NIL && Cdr[m] != NIL) return wrongArgs(n); m = m == NIL? NIL: Car[m]; Symbols = addPackage(m); return m; } /* Evaluate N=(PAIR? M) */ static int doPairP(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; return atomic(m) || tagged(m) || m == NIL? S_false: S_true; } /* Evaluate N=(PEEK-CHAR M) */ static int doPeekChar(int n) { int m, c; m = Cdr[n]; if (m != NIL) return wrongArgs(n); c = sk_rdch(); Rejected = c; return sk_mkChar(c); } /* Evaluate N=(PROCEDURE? M) */ static int doProcedureP(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL) return S_false; if ( Car[m] == S_closure || Car[m] == S_primitive || Car[m] == S_special_cbv || Car[m] == S_user_primitive ) return S_true; return S_false; } /* Evaluate N=(REQUIRE M) */ static int doRequire(int n) { int m, f; char *file; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); f = Car[m]; if (atomic(f) || f == NIL || Car[f] != S_string) return error("non-string in 'require'", f); file = string(f); return sk_require(file)? S_true: S_false; } /* Evaluate N=(STRING->LIST M) */ static int doStringToList(int n) { int m, a, lst, k, i; char *s; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_string) return error("non-string in 'string->list'", m); s = string(m); k = string_len(m) - 1; if (*s == 0) return NIL; lst = alloc(NIL, NIL); save(lst); a = lst; i = 0; while (i < k) { Car[a] = sk_mkChar(s[i++]); if (i < k) { Cdr[a] = alloc(NIL, NIL); a = Cdr[a]; } } unsave(1); return lst; } /* Evaluate N=(STRING->SYMBOL M) */ static int doStringToSymbol(int n) { int m; char *s; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_string) return error("non-string in 'string->symbol'", m); s = string(m); if (s[0] == 0) return error("empty string in 'string->symbol'", m); return addSym(s, S_undefined); } /* Evaluate N=(STRING-APPEND M ...) */ static int doStringAppend(int n) { int m, p; int k, len, o; int new; char *s, *q; m = Cdr[n]; k = 0; while (m != NIL) { p = Car[m]; if (atomic(p) || p == NIL || Car[p] != S_string) return error("non-string in 'string-append'", p); s = string(p); o = k; len = strlen(s); k = k + len; if (k < 0 || k - len != o) return error("string too long in 'string-append'", NOEXPR); m = Cdr[m]; } new = allocv(S_string, k+1); q = string(new); q[0] = 0; m = Cdr[n]; while (m != NIL) { p = Car[m]; s = string(p); strcpy(q, s); q = &q[strlen(q)]; m = Cdr[m]; } return new; } /* Evaluate N=(STRING-LENGTH M) */ static int doStringLength(int n) { int m; char *s; char buf[20]; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_string) return error("non-string in 'string-length'", m); s = string(m); sprintf(buf, "%d", strlen(s)); return explodeNum(buf); } /* * Convert bignum integer to long int and return it. * If the value of the bignum does not fit in a long int, * set EP[0] to a non-zero value. Otherwise, leave EP[0] * alone. */ long sk_int(int n, int *ep) { long v, o, d; int neg; if (atomic(n) || n == NIL || Car[n] != S_integer) { ep[0] = -1; return 0; } v = 0; n = Cdr[n]; neg = 0; if (caaar(n) == '+') { n = Cdr[n]; } else if (caaar(n) == '-') { n = Cdr[n]; neg = 1; } while (n != NIL) { o = v; d = digitToValue(Car[n]); v = v * 10 + d; if (v < 0 || (v - d) / 10 != o) { ep[0] = -1; return 0; } n = Cdr[n]; } return neg? -v: v; } /* Convert bignum integer to C integer */ static int valueOf(char *src, int n) { int e, iv; long v; char buf[100]; e = 0; v = sk_int(n, &e); iv = (int) v; if (e || v != iv) { sprintf(buf, "value too big in '%s'", src); error(buf, n); } return iv; } /* Evaluate N=(STRING-REF M1 M2) */ static int doStringRef(int n) { int m, m2, pos; char *s; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); m2 = Cdr[m]; m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_string) return error("non-string in argument 1 of 'string-ref'", m); m2 = Car[m2]; if (atomic(m2) || m2 == NIL || Car[m2] != S_integer) return error("non-number in argument 2 of 'string-ref'", m2); s = string(m); pos = valueOf("string-ref", m2); if (pos < 0 || pos >= strlen(s)) return error("offset out of range in 'string-ref'", m2); return sk_mkChar(s[pos]); } /* Evaluate N=(STRING? M) */ static int doStringP(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; return !atomic(m) && m != NIL && Car[m] == S_string ? S_true: S_false; } /* Evaluate N=(SUBSTRING M1 M2 M3) */ static int doSubstring(int n) { int m, m2, m3, start, end, k; char *s, *q; int new; m = Cdr[n]; if ( m == NIL || Cdr[m] == NIL || cddr(m) == NIL || cdddr(m) != NIL ) return wrongArgs(n); m2 = Cdr[m]; m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_string) return error("non-string in argument 1 of 'substring'", m); m3 = Cdr[m2]; m2 = Car[m2]; if (atomic(m2) || m2 == NIL || Car[m2] != S_integer) return error("non-number in argument 2 of 'substring'", m2); m3 = Car[m3]; if (atomic(m3) || m3 == NIL || Car[m3] != S_integer) return error("non-number in argument 3 of 'substring'", m2); s = string(m); start = valueOf("substring", m2); end = valueOf("substring", m3); if (start < 0 || start > strlen(s)) return error("offset out of range in 'substring'", m2); if (end < start || end > strlen(s)) return error("bad range in 'substring'", NOEXPR); k = end - start; new = allocv(S_string, k+1); q = string(new); memcpy(q, &s[start], k); q[k] = 0; return new; } /* Evaluate N=(SYMBOL->STRING M) */ static int doSymbolToString(int n) { int m, p, k, q, i; char *s; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (!atomic(m)) return error("non-symbol in 'symbol->string'", m); k = 1; for (p = Car[m]; p != NIL; p = Cdr[p]) k++; q = allocv(S_string, k); s = string(q); p = Car[m]; for (i = 0; iLIST M) */ static int doSyntaxToList(int n) { int m, t; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (!atomic(m) && m != NIL && Car[m] == S_syntax) return Cdr[m]; if (!atomic(m)) return S_false; t = findTransformer(m); if (t != S_false) return cddr(t); return S_false; } /* Evaluate N=(VECTOR->LIST M) */ static int doVectorToList(int n) { int m, a, lst, k, i; int *p; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_vector) return error("non-vector in 'vector->list'", m); p = vector(m); k = vector_len(m); if (k == 0) return NIL; lst = alloc(NIL, NIL); save(lst); a = lst; i = 0; while (i < k) { Car[a] = p[i++]; if (i < k) { Cdr[a] = alloc(NIL, NIL); a = Cdr[a]; } } unsave(1); return lst; } /* Evaluate N=(VECTOR-LENGTH M) */ static int doVectorLength(int n) { int m; char buf[20]; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m) || m == NIL || Car[m] != S_vector) return error("non-vector in 'vector-length'", m); sprintf(buf, "%d", vector_len(m)); return explodeNum(buf); } /* Evaluate N=(VECTOR-REF M1 M2) */ static int doVectorRef(int n) { int m, v, i; int *p; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); v = Car[m]; if (atomic(v) || m == NIL || Car[v] != S_vector) return error("non-vector in 'vector-ref'", v); m = cadr(m); if (atomic(m) || m == NIL || Car[m] != S_integer) return error("non-integer in 'vector-ref'", m); i = valueOf("vector-ref", m); if (i >= vector_len(v)) return error("reference out of range in 'vector-ref'", m); p = vector(v); return p[i]; } /* Evaluate N=(VECTOR? M) */ static int doVectorP(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); m = Car[m]; return !atomic(m) && m != NIL && Car[m] == S_vector? S_true: S_false; } /* Evaluate N=(BOTTOM ...) */ static int doBottom(int n) { n = alloc(S_bottom, Cdr[n]); return error("", n); } /* Evaluate N=(VOID) */ static int doVoid(int n) { if (Cdr[n] != NIL) return wrongArgs(n); return S_void; } /* Evaluate N=(READ) */ static int doRead(int n) { if (Cdr[n] != NIL) return wrongArgs(n); return sk_read(); } /* Evaluate N=(READ-CHAR) */ static int doReadChar(int n) { int c; if (Cdr[n] != NIL) return wrongArgs(n); c = sk_rdch(); return c == EOT? S_eof: sk_mkChar(c); } /* Evaluate N=(READ-FROM-STRING) */ static int doReadFromString(int n) { int m; int oline; char ofile[MAXPATHL]; int orejct; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); if (atomic(Car[m]) || caar(m) != S_string) error("non-string in 'read-from-string'", Car[m]); oline = Line; Line = 1; strcpy(ofile, Infile); strcpy(Infile, "READ-FROM-STRING"); orejct = Rejected; Rejected = EOT; gcv(); /* Make sure InputString stays in place */ InputString = string(Car[m]); n = xread(); if (*InputString != 0 || Rejected != EOT) SK_errFlag = 1; if (n == S_eof) SK_errFlag = 1; InputString = NULL; Line = oline; strcpy(Infile, ofile); Rejected = orejct; if (SK_errFlag) { sk_gotError(); return S_false; } return alloc(n, NIL); } /* Evaluate N=(WRITE M) */ static int doWrite(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); Quoted = 1; _print(Car[m]); return S_void; } /* Evaluate N=(WRITE-CHAR M) */ static int doWriteChar(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); if (atomic(Car[m]) || caar(m) != S_char) error("non-char in 'write-char'", Car[m]); fputc(cadar(m), Output); return S_void; } /* Evaluate N=(WRITE-TO-STRING M) */ static int doWriteToString(int n) { int m, str, k; int vp; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); /* Allocate all remaining vector space */ gcv(); vp = Vptr; str = allocv(S_string, (VPoolSize-Vptr-3) * sizeof(int)); OutputString = string(str); OutStrSize = string_len(str); k = OutStrSize; sk_print(Car[m]); OutputString = NULL; /* Shrink string to actual size */ Vptr = vp; return allocv(S_string, k - OutStrSize+1); } /* Evaluate N=(DISPLAY M) */ static int doDisplay(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); sk_display(Car[m]); return S_void; } /* Evaluate N=(DELETE-FILE M) */ static int doDeleteFile(int n) { int m, f; char *s; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); f = Car[m]; if (atomic(f) || f == NIL || Car[f] != S_string) return error("non-string in 'delete-file'", f); s = string(f); /* file name */ return unlink(s)? S_false: S_true; } /* * Check whether (CAR NP[0]) is a builtin procedure. * If it is one, run the appropriate routine, save * its result in NP[0], and return -1. * If (CAR NP[0]) is not a builtin procedure, return 0. */ static int primitive(int *np) { int n, y; int (*op)(int); n = np[0]; y = Car[n]; if (SK_errFlag) return 0; if (Car[y] == S_primitive) { op = Primitives[cadr(y)]; } else if (Car[y] == S_user_primitive) { y = cadr(y); if (y > LastUsrPrimitive) fatal("primitive(): bad user primitive"); op = UsrPrimitives[y]; } else { return 0; } n = (*op)(n); np[0] = n; return -1; } /* * Create a flat copy of a list. * Store a reference to the last member * of the copy in lastp. */ static int flatCopy(int n, int *lastp) { int a, m, last; if (n == NIL) { lastp[0] = NIL; return NIL; } m = alloc(NIL, NIL); save(m); a = m; last = m; while (n != NIL) { Car[a] = Car[n]; last = a; n = Cdr[n]; if (n != NIL) { Cdr[a] = alloc(NIL, NIL); a = Cdr[a]; } } unsave(1); lastp[0] = last; return m; } /* Copy names and values of the symbol table into an alist. */ static int copyBindings(void) { int y, p, ny, pk, q; pk = Packages; p = alloc(NIL, NIL); ny = p; q = NIL; save(p); while (pk != NIL) { y = cdar(pk); while (y != NIL) { Car[p] = alloc(Car[y], cdar(y)); y = Cdr[y]; Cdr[p] = alloc(NIL, NIL); q = p; p = Cdr[p]; } pk = Cdr[pk]; } if (q != NIL) Cdr[q] = NIL; unsave(1); return Car[ny] == NIL? NIL: ny; } /* Restore values of the symbol table. */ static void restoreBindings(int values) { int b; while (values != NIL) { b = Car[values]; cdar(b) = Cdr[b]; values = Cdr[values]; } } /* * Extract clause of COND. * Check the syntax of the clause * and return its predicate. */ static int getPred(void) { int e; e = caar(Bstack); if ( atomic(e) || e == NIL || Cdr[e] == NIL || cddr(e) != NIL ) return error("bad clause in 'cond'", e); if (cdar(Bstack) == NIL && Car[e] == S_else) return S_true; return Car[e]; } /* * Setup context for evaluation of (COND (P1 E1) ... (Pn En)). * The context consits of a list of clauses. * Return the predicate of the first clause. */ static int setupCond(int n) { int m; m = Cdr[n]; if (m == NIL) return wrongArgs(n); bsave(m); return getPred(); } /* * Evaluate next clause of COND. * N is the value of the current predicate. * If N=#T, return the expression of the predicate. * If N=#F, return the predicate of the next clause. * When returning the expression of a predicate (N=#T), * set the context on the Bstack to NIL to signal that * a true predicate was found. */ static int evalClause(int n) { int e; e = Car[Bstack]; if (n == S_false) { Car[Bstack] = Cdr[e]; if (Car[Bstack] == NIL) return error("no default in 'cond'", NOEXPR); return getPred(); } else { e = cadar(e); Car[Bstack] = NIL; return e; } } /* * Setup context for evaluation of (AND ...) and (OR ...) * Return the first expression of the form. */ static int setupLogOp(int n) { int m; m = Cdr[n]; if (m == NIL) return wrongArgs(n); bsave(m); return Car[m]; } /* * Unbind the arguments of LAMBDA, LET and LETREC. * See also bindArgs(). */ static void unbindArgs(void) { int v; Frame = unsave(1); Function = unsave(1); v = bunsave(1); /* Caller's namelist */ while (v != NIL) { cdar(v) = unsave(1); v = Cdr[v]; } } /* * Check whether the symbol N is bound in the current * lexical environment. */ static int isBound(int n) { int b; b = Bound; while (b != NIL) { if (atomic(b)) { if (n == b) return 1; break; } if (n == Car[b]) return 1; b = Cdr[b]; } b = Car[LexEnv]; while (b != NIL) { if (caar(b) == n) return 1; b = Cdr[b]; } return 0; } /* * Recursively collect free variables and add their symbols * and values to the current lexical environment. */ static void collect(int n) { int m; if (n == NIL || (Tag[n] & AFLAG) || tagged(n)) return; if (atomic(n)) { if (isBound(n)) return; Car[LexEnv] = alloc(NIL, Car[LexEnv]); caar(LexEnv) = alloc(n, Cdr[n]); return; } if (Car[n] == S_quote) { collect(Car[n]); return; } m = n; while (m != NIL && !atomic(m)) { collect(Car[m]); m = Cdr[m]; } } /* Create lexical environment. */ static int mkLexEnv(int term, int locals) { LexEnv = alloc(NIL, NIL); save(LexEnv); Bound = locals; collect(term); unsave(1); return Car[LexEnv]; } /* Create a closure from a lambda expression. */ static int closure(int n) { int cl, env, args, term; if (SK_errFlag) return NIL; args = cadr(n); term = caddr(n); if (cdddr(n) == NIL) { env = mkLexEnv(term, args); if (Estack != NIL) Estack = alloc(env, Estack); } else if (cadddr(n) == S_void) { /* Use dynamic scoping */ env = NIL; } else { env = cadddr(n); } cl = alloc(env, NIL); cl = alloc(term, cl); cl = alloc(args, cl); return alloc(S_closure, cl); } /* Fix cached recursive bindings in closures. */ static void fixCachedClosures(void) { int a, ee, e; if (SK_errFlag || Estack == NIL || Estack == S_true) return; a = Car[Bstack]; while (a != NIL) { ee = Estack; while (ee != NIL && ee != S_true) { e = Car[ee]; while (e != NIL) { if (Car[a] == caar(e)) { cdar(e) = cdar(a); break; } e = Cdr[e]; } ee = Cdr[ee]; } a = Cdr[a]; } } /* * Fix references to symbols of BINDINGS * in all closures of N. */ static void fixClosuresOf(int n, int bindings) { int ee, e; int bb, b; if (n == NIL || atomic(n)) return; if (Car[n] == S_lambda) { fixClosuresOf(caddr(n), bindings); ee = cdddr(n); if (ee == NIL) return; ee = Car[ee]; while (ee != NIL) { e = Car[ee]; bb = bindings; while (bb != NIL) { b = Car[bb]; if (Car[b] == Car[e]) Cdr[e] = Cdr[b]; bb = Cdr[bb]; } ee = Cdr[ee]; } return; } if (tagged(n)) return; fixClosuresOf(Car[n], bindings); fixClosuresOf(Cdr[n], bindings); } /* Fix recursive bindings of closures. */ static void fixAllClosures(int b) { int p; p = b; while (p != NIL) { fixClosuresOf(cdar(p), b); p = Cdr[p]; } } /* Check whether N is an alist. */ static int isAlist(int n) { if (atomic(n)) return 0; while (n != NIL) { if (lazyAtom(Car[n]) || !atomic(caar(n))) return 0; n = Cdr[n]; } return -1; } /* Check whether M is a list of symbols. */ static int isSymList(int m) { while (m != NIL) { if (!atomic(Car[m])) return 0; if (atomic(Cdr[m])) break; m = Cdr[m]; } return 1; } /* Evaluate N=(RECURSIVE-BIND M) */ static int doRecursiveBind(int n) { int m, env; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); env = Car[m]; if (!isAlist(env)) return error("non-alist in recursive-bind", env); fixAllClosures(env); return env; } /* * Set up a context for processing LET and LETREC. * Save * - the complete LET/LETREC expression on the Bstack * - the environment on the Bstack * - a list of new bindings on the Bstack (initially empty) * - a list of saved names on the Bstack (initially empty) * - a copy of the Estack on the Stack * Clear the Estack. */ static int setupLet(int n) { int m; /* Argument pointer */ m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); m = Car[m]; if (atomic(m)) return error("bad environment in 'let' or 'letrec'", m); bsave(n); /* save entire LET/LETREC */ bsave(m); /* save environment */ bsave(NIL); /* list of bindings */ bsave(NIL); /* save empty name list */ save(Estack); Estack = NIL; return m; } /* * Process one binding of LET/LETREC: * Bind value to name, advance to next binding. * Return: * non-NIL - more bindings in environment * NIL - last binding done */ static int nextLet(int n) { int m, p; m = caddr(Bstack); /* rest of environment */ if (m == NIL) return NIL; p = Car[m]; Tmp2 = n; cadr(Bstack) = alloc(NIL, cadr(Bstack)); caadr(Bstack) = alloc(Car[p], n); Tmp2 = NIL; caddr(Bstack) = Cdr[m]; return Cdr[m]; } /* * Evaluate value to bind inside of LET/LETREC: * - check syntax * - save name to bind to * - save original binding of name * - return (unevaluated) value */ static int evalLet(void) { int m, p, v; m = caddr(Bstack); p = Car[m]; /* Each binding must have the form (atom expr) */ if ( atomic(p) || Cdr[p] == NIL || atomic(Cdr[p]) || cddr(p) != NIL || !atomic(Car[p]) ) { /* In case of an error, get rid of the */ /* partial environment. */ v = bunsave(1); bunsave(3); bsave(v); Estack = unsave(1); save(Function); save(Frame); unbindArgs(); return error("bad binding in 'let' or 'letrec'", p); } Car[Bstack] = alloc(Car[p], Car[Bstack]); /* Save name */ /* Evaluate the new value of the current symbol */ return cadr(p); } /* Reverse a list in situ. */ static int nreverse(int n) { int this, next, x; if (n == NIL) return NIL; this = n; next = Cdr[n]; Cdr[this] = NIL; while (next != NIL) { x = Cdr[next]; Cdr[next] = this; this = next; next = x; } return this; } /* Establish the bindings of LET/LETREC. */ static void bindLet(int env) { int b; while (env != NIL) { b = Car[env]; save(cdar(b)); /* Save old value */ cdar(b) = Cdr[b]; /* Bind new value */ env = Cdr[env]; } } /* * Finish processing bindings of LET/LETREC: * finish context and return body. */ static int finishLet(int rec) { int m, v, b, e; Tmp2 = alloc(NIL, NIL); /* Create safe storage */ Tmp2 = alloc(NIL, Tmp2); Tmp2 = alloc(NIL, Tmp2); Tmp2 = alloc(NIL, Tmp2); v = bunsave(1); b = bunsave(1); /* get bindings */ m = bunsave(2); /* drop environment, get full LET/LETREC */ b = nreverse(b); /* needed for unbindArgs() */ e = unsave(1); /* outer Estack */ Car[Tmp2] = b; /* protect b, m, v */ cadr(Tmp2) = m; caddr(Tmp2) = v; cdddr(Tmp2) = e; bindLet(b); bsave(v); if (rec) fixCachedClosures(); Estack = e; save(Function); /* required by unbindArgs() */ save(Frame); Tmp2 = NIL; return caddr(m); /* return body */ } /* Substitute each OLD in *P with NEW. */ static void subst(int old, int new, int *p) { if (*p == NIL) return; if (lazyAtom(*p)) { if (*p == old) *p = new; return; } subst(old, new, &Car[*p]); subst(old, new, &Cdr[*p]); } /* * Make symbol N local to the current package. * Also fix recursive references to N in EXPR. */ int localize(int n, int *exprp) { int y, osym; y = Symbols; while (y != NIL) { if (n == Car[y]) return n; y = Cdr[y]; } osym = Symbols; Symbols = alloc(NIL, Symbols); Car[Symbols] = alloc(Car[n], S_undefined); updatePackages(osym, Symbols); subst(n, Car[Symbols], exprp); return Car[Symbols]; } /* Evaluate N=(AND ...) */ static int doAnd(int n, int *pcf, int *pmode, int *pcbn) { USE(pcbn); if (Cdr[n] == NIL) { return S_true; } else if (cddr(n) == NIL) { *pcf = 1; return cadr(n); } else { *pcf = 2; *pmode = MCONJ; return setupLogOp(n); } } /* Evaluate N=(APPLY M) */ static int doApply(int n, int *pcf, int *pmode, int *pcbn) { int m, p, q, last; *pcf = 1; USE(pmode); *pcbn = 1; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL) return wrongArgs(n); if (Car[m] == NIL || atomic(Car[m])) return error("non-procedure in 'apply'", Car[m]); p = caar(m); if (!SK_strictApply && p == S_special) ; /* OK */ else if (p != S_primitive && p != S_special_cbv && p != S_closure && p != S_user_primitive ) return error("non-procedure in 'apply'", Car[m]); p = m; last = p; while (p != NIL) { if (lazyAtom(p)) return error("improper list in application", n); last = p; p = Cdr[p]; } p = Car[last]; while (p != NIL) { if (atomic(p) || tagged(p)) return error("improper list in 'apply'", Car[last]); p = Cdr[p]; } if (cddr(m) == NIL) return alloc(Car[m], cadr(m)); p = flatCopy(Cdr[m], &q); q = p; while (cddr(q) != NIL) q = Cdr[q]; Cdr[q] = Car[last]; return alloc(Car[m], p); } /* Evaluate N=(BEGIN ...) */ static int doBegin(int n, int *pcf, int *pmode, int *pcbn) { USE(pcbn); if (Cdr[n] == NIL) { return S_void; } else if (cddr(n) == NIL) { *pcf = 1; return cadr(n); } else { *pcf = 2; *pmode = MBEGN; return setupLogOp(n); } } /* Evaluate N=(COND M1 ...) */ static int doCond(int n, int *pcf, int *pmode, int *pcbn) { *pcf = 2; *pmode = MCOND; USE(pcbn); return setupCond(n); } /* Evaluate N=(DEFINE (M ...) MN) */ static int newDefine(int n) { int m, y; m = Cdr[n]; if (Car[m] == NIL) return error("missing function name in 'define'", Car[m]); if (!isSymList(Car[m])) return badArgLst(Car[m]); y = caar(m); save(cadr(m)); Tmp2 = alloc(S_void, NIL); Tmp2 = alloc(cadr(m), Tmp2); Tmp2 = alloc(cdar(m), Tmp2); Tmp2 = alloc(S_lambda, Tmp2); y = localize(y, &cadr(m)); Cdr[y] = eval(Tmp2); Tmp2 = NIL; unsave(1); return S_void; } /* Evaluate N=(DEFINE M eval[M2]) */ static int doDefine(int n, int *pcf, int *pmode, int *pcbn) { int m, v, y; if (EvLev > 1) { error("'define' is limited to the top level", NOEXPR); return NIL; } m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); y = Car[m]; if (!atomic(y)) return newDefine(n); /* Protect the unevaluated expression */ v = cadr(m); save(v); /* really? */ /* If we are binding to a lambda expression, */ /* add a null environment */ if (!lazyAtom(v) && Car[v] == S_lambda) { if ( Cdr[v] != NIL && cddr(v) != NIL && cdddr(v) == NIL ) { cdddr(v) = alloc(S_void, NIL); } } y = localize(y, &cadr(m)); /* Evaluate and bind second argument */ Cdr[y] = eval(cadr(m)); unsave(1); return S_void; } /* Register a syntax transformer */ void registerTransformer(int y, int tr) { int t; t = findTransformer(y); if (t != S_false) { Cdr[t] = tr; } else { Transformers = alloc(NIL, Transformers); Car[Transformers] = alloc(y, tr); } } /* Evaluate N=(DEFINE-SYNTAX M1 M2) */ static int doDefineSyntax(int n, int *pcf, int *pmode, int *pcbn) { int m, tr, y; USE(pcf); USE(pmode); USE(pcbn); if (EvLev > 1) { error("'define-syntax' is limited to the top level", NOEXPR); return NIL; } m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); if (!atomic(Car[m])) return error("name expected in 'define-syntax'", Car[m]); y = Car[m]; save(cadr(m)); /* really? */ SyntaxMode = 1; tr = eval(cadr(m)); SyntaxMode = 0; unsave(1); if (atomic(tr) || tr == NIL || Car[tr] != S_syntax) return error("transformer expected in 'define-syntax'", cadr(m)); Cdr[y] = tr; cadr(tr) = y; registerTransformer(y, tr); return S_void; } /* Evaluate N=(SYNTAX-RULES (M1 ...) (P1 E1) ...) */ static int doSyntaxRules(int n, int *pcf, int *pmode, int *pcbn) { int m, cl, tr; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] == NIL) return wrongArgs(n); if (!SyntaxMode) return error("'syntax-rules' not in 'define-syntax'", NOEXPR); if (lazyAtom(Car[m]) || !isSymList(Car[m])) return error("list of symbols expected in 'syntax-rules'", Car[m]); cl = Cdr[m]; while (cl != NIL) { if (lazyAtom(cl)) return error("improper list in 'syntax-rules'", Cdr[m]); if ( Car[cl] == NIL || lazyAtom(Car[cl]) || cdar(cl) == NIL || lazyAtom(cdar(cl)) ) return error("bad clause in 'syntax-rules'", Car[cl]); cl = Cdr[cl]; } tr = alloc(Cdr[m], NIL); tr = alloc(Car[m], tr); tr = alloc(NIL, tr); tr = alloc(S_syntax, tr); return tr; } /* Evaluate N=(EVAL M) */ static int doEval(int n, int *pcf, int *pmode, int *pcbn) { int m; *pcf = 1; USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); n = eval(Car[m]); return syntaxTransform(n); } /* Evaluate N=(IF P C A) */ static int doIf(int n, int *pcf, int *pmode, int *pcbn) { int m; *pcf = 2; *pmode = MIFPR; USE(pcbn); m = Cdr[n]; if ( m == NIL || Cdr[m] == NIL || cddr(m) == NIL || cdddr(m) != NIL ) return wrongArgs(n); bsave(m); return Car[m]; } /* Evaluate N=(LAMBDA ARGS BODY) */ static int doLambda(int n, int *pcf, int *pmode, int *pcbn) { int m; m = Cdr[n]; if ( m == NIL || Cdr[m] == NIL || (cddr(m) != NIL && cdddr(m) != NIL) ) return wrongArgs(n); if (cddr(m) != NIL && caddr(m) != S_void) return wrongArgs(n); if (!atomic(Car[m])) { if (tagged(Car[m])) return badArgLst(Car[m]); if (!isSymList(Car[m])) return badArgLst(Car[m]); } return closure(n); } /* Evaluate N=(LET ENV EXPR) */ static int doLet(int n, int *pcf, int *pmode, int *pcbn) { *pcf = 2; *pmode = MBIND; USE(pcbn); if (setupLet(n) != NIL) return evalLet(); else return NIL; } /* Evaluate N=(LETREC ENV EXPR) */ static int doLetrec(int n, int *pcf, int *pmode, int *pcbn) { int m; *pcf = 2; *pmode = MBINR; USE(pcbn); if (setupLet(n) != NIL) m = evalLet(); else m = NIL; Estack = S_true; return m; } /* Evaluate N=(OR ...) */ static int doOr(int n, int *pcf, int *pmode, int *pcbn) { USE(pcbn); if (Cdr[n] == NIL) { return S_false; } else if (cddr(n) == NIL) { *pcf = 1; return cadr(n); } else { *pcf = 2; *pmode = MDISJ; return setupLogOp(n); } } /* Evaluate N=(QUOTE M) */ static int doQuote(int n, int *pcf, int *pmode, int *pcbn) { int m; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrongArgs(n); return (Car[m]); } /* Evaluate N=(WITH-INPUT-FROM-FILE M1 M2) */ static int doWithInputFromFile(int n, int *pcf, int *pmode, int *pcbn) { int m, f; int r, p; FILE *ofile, *nfile; char *s; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); f = Car[m]; if (atomic(f) || f == NIL || Car[f] != S_string) return error("non-string in 'string->symbol'", f); s = string(f); /* file name */ if ((nfile = fopen(s, "r")) == NULL) return error("cannot open input file", f); /* Save old input state, create new */ ofile = Input; Input = nfile; r = Rejected; Rejected = EOT; p = alloc(cadr(m), NIL); /* thunk => (thunk) */ n = eval(p); /* Restore input state */ Input = ofile; Rejected = r; fclose(nfile); return n; } /* Evaluate N=(WITH-OUTPUT-TO-FILE M1 M2) */ static int doWithOutputToFile(int n, int *pcf, int *pmode, int *pcbn) { int m, f; int p; FILE *ofile, *nfile; char *s; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrongArgs(n); f = Car[m]; if (atomic(f) || f == NIL || Car[f] != S_string) return error("non-string in 'string->symbol'", f); s = string(f); /* file name */ if ((nfile = fopen(s, "w")) == NULL) return error("cannot create output file", f); /* Save old output state, create new */ fflush(Output); ofile = Output; Output = nfile; p = alloc(cadr(m), NIL); /* thunk => (thunk) */ n = eval(p); /* Restore output state */ Output = ofile; fclose(nfile); return n; } /* * Check whether (CAR NP[0]) is a special form handler. * If it is one, run the appropriate routine, save * its result in NP[0], and return -1. * If (CAR NP[0]) is not a SF handler, return 0. */ static int special(int *np, int *pcf, int *pmode, int *pcbn) { int n, y; int (*op)(int, int *, int *, int *); n = np[0]; y = Car[n]; if (SK_errFlag) return 0; if (Car[y] == S_special || Car[y] == S_special_cbv) op = Specials[cadr(y)]; else if (atomic(y) && (cadr(y) == S_special || cadr(y) == S_special_cbv) ) op = Specials[caddr(y)]; else return 0; np[0] = (*op)(n, pcf, pmode, pcbn); return -1; } /* * Bind the arguments of a LAMBDA function. * For a lambda application N=((LAMBDA (X1 ... Xn) EXPR) Y1 ... Yn) * this includes the following steps for j in {1,...,n}: * 1) save Xj * 2) save the value of Xj * 3) bind Xj to Yj */ static int bindArgs(int n, int name) { int fa, /* Formal arg list */ aa, /* Actual arg list */ e; /* Expression */ int env; /* Optional lexical environment */ int p; int at; /* Atomic argument list flag */ if (SK_errFlag) return NIL; fa = cadar(n); at = atomic(fa); aa = Cdr[n]; p = cddar(n); e = Car[p]; env = Cdr[p] != NIL ? cadr(p): NIL; bsave(NIL); while ((fa != NIL && aa != NIL) || at) { if (!at) { /* Save name */ Car[Bstack] = alloc(Car[fa], Car[Bstack]); save(cdar(fa)); /* Save value */ cdar(fa) = Car[aa]; /* Bind arg */ fa = Cdr[fa]; aa = Cdr[aa]; } if (atomic(fa)) { /* improper argument list */ Car[Bstack] = alloc(fa, Car[Bstack]); /* Save name */ save(Cdr[fa]); /* Save value */ Cdr[fa] = aa; /* Bind remaining arg list */ fa = NIL; aa = NIL; break; } } while (env != NIL) { p = Car[env]; Car[Bstack] = alloc(Car[p], Car[Bstack]);/* Save name */ save(cdar(p)); /* Save value */ cdar(p) = Cdr[p]; /* Bind lex val */ env = Cdr[env]; } if (fa != NIL || aa != NIL) { wrongArgs(n); n = NIL; } else { n = e; } save(Function); Function = name; save(Frame); Frame = Stack; return n; } /* * Print application of traced function N: * * (NAME A1 ... An) * PRINT() cannot be used because it would print NAME in * its expanded (LAMBDA...) form which is not desirable. */ static void printTrace(int n) { if (SK_traceHandler) { (*SK_traceHandler)(n); return; } pr("+ "); pr("("); Quoted = 1; _print(SK_trace); while (1) { n = Cdr[n]; if (n == NIL) break; pr(" "); _print(Car[n]); } pr(")"); nl(); } #ifdef DEBUG /* Print depth of stack N. */ static void prDepth(int n) { int k; k = 0; while (n != NIL) { n = Cdr[n]; k = k+1; } prnum(k, 7); pr(" "); } /* Debugging: dump interpreter state */ static void dumpState(char *s, int m) { pr(s); nl(); pr(" "); pr("Mode = "); prnum(m-'0',0); nl(); prDepth(Lstack); pr("Lstack = "); sk_print(Lstack); nl(); pr(" "); pr("Mstack = "); sk_print(Mstack); nl(); prDepth(Stack); pr("Car[Stack] == "); sk_print(Car[Stack]); nl(); pr(" "); pr("Stack0 = "); prnum(Stack0,0); nl(); prDepth(Bstack); pr("Bstack = "); sk_print(Bstack); nl(); } #endif /*DEBUG*/ /* Do tail call optimization. */ static void tailCall(void) { int m, y; m = Car[Mstack]; /* Skip over callee's LET/LETREC frames, if any */ while (m != NIL && Car[m] == MLETR) { m = Cdr[m]; } /* Parent not beta-reducing? Give up. */ if (m == NIL || Car[m] != MBETA) return; /* Yes, this is a tail call: */ /* - remove callee's LET/LETREC frames. */ /* - remove caller's call frame. */ while (1) { Tmp2 = unsave(1); /* M */ unbindArgs(); unsave(1); y = munsave(); save(Tmp2); Tmp2 = NIL; if (y == MBETA) break; } } /* * Evaluate the term N and return its normal form. * This is the heart of the interpreter: * A constant space EVAL function with tail-call optimization. */ static int eval(int n) { int m, /* Result node */ m2, /* Root of result list */ a, /* Used to append to result */ cbn; /* Use call-by-name in next iteration */ int mode, /* Current state */ cf; /* Continue flag */ int nm; /* name of function to apply */ EvLev = EvLev + 1; save(n); save(Lstack); save(Bstack); save(Car[Mstack]); save(Stack0); Stack0 = Stack; mode = MATOM; cf = 0; cbn = 0; while (!SK_errFlag) { if (SK_statFlag) sk_count(&SK_reductions, 1); if (n == NIL) { /* () -> () */ m = NIL; } else if (atomic(n)) { /* Symbol -> Value */ if (cbn) { m = n; cbn = 0; } else { m = Cdr[n]; if (m == S_undefined) { error("symbol not bound", n); break; } } } else if (lazyAtom(n) || /* Auto-quoting atoms */ cbn == 2 ) { m = n; cbn = 0; } else { /* List (...) and Pair (X.Y) */ /* * This block is used to DESCEND into lists. * The following nodes/variables will be saved: * 1) the original list (on Stack) * 2) the current state (on Mstack) * 3) the root of the result list (on Lstack) * 4) a ptr to the next free node * in the result list (on Lstack) * 5) a ptr to the next member of * the original list (on Lstack) */ m = Car[n]; if (lazyAtom(Cdr[n])) { error("improper list in application", n); n = NIL; } save(n); /* Save original list */ msave(mode); /* Check call-by-name built-ins and flag */ if ((atomic(m) && cadr(m) == S_special) || cbn) { cbn = 0; lsave(NIL); lsave(NIL); lsave(n); /* Root of result list */ n = NIL; } else { a = alloc(NIL, NIL); lsave(a); lsave(Cdr[n]); lsave(a); /* Root of result list */ n = Car[n]; } mode = MLIST; continue; } /* * The following loop is used to ASCEND back to the * root of a list, thereby performing BETA reduction * and creating result lists. */ while (1) if (mode == MBETA || mode == MLETR) { /* Finish BETA reduction */ unbindArgs(); unsave(1); /* Original list */ mode = munsave(); } else if (mode == MLIST) { /* Append to list, reduce */ n = cadr(Lstack); /* Next member */ a = caddr(Lstack); /* Place to append to */ m2 = lunsave(1); /* Root of result list */ if (a != NIL) /* Append new member */ Car[a] = m; if (n == NIL) { /* End of list */ m = m2; lunsave(2); /* Drop N,A */ /* Drop original list, remember first element */ nm = Car[unsave(1)]; save(m); /* Save result */ if (SK_trace == nm) printTrace(m); if (primitive(&m)) ; else if (special(&m, &cf, &mode, &cbn)) n = m; else if (!atomic(Car[m]) && Car[m] != NIL && caar(m) == S_closure ) { /* ((LAMBDA...)...) */ nm = atomic(nm)? nm: NIL; tailCall(); bindArgs(m, nm); /* N=S of ((LAMBDA (...) S) ...) */ n = caddar(m); cf = 2; mode = MBETA; } else { error("application of non-procedure", nm); n = NIL; } if (cf != 2) { unsave(1); /* Drop result */ mode = munsave(); } /* Continue this evaluation. */ /* Leave the ASCENDING loop and descend */ /* once more into N. */ if (cf) break; } else { /* N =/= NIL: Append to list */ lsave(m2); /* Create space for next argument */ Cdr[a] = alloc(NIL, NIL); caddr(Lstack) = Cdr[a]; cadr(Lstack) = Cdr[n]; n = Car[n]; /* Evaluate next member */ break; } } else if (mode == MCOND) { n = evalClause(m); if (Car[Bstack] == NIL) { unsave(1); /* Original list */ bunsave(1); mode = munsave(); } cf = 1; break; } else if (mode == MCONJ || mode == MDISJ) { Car[Bstack] = cdar(Bstack); if ( (m == S_false && mode == MCONJ) || (m != S_false && mode == MDISJ) || Car[Bstack] == NIL ) { unsave(1); /* Original list */ bunsave(1); mode = munsave(); n = m; cbn = 1; } else if (cdar(Bstack) == NIL) { n = caar(Bstack); unsave(1); /* Original list */ bunsave(1); mode = munsave(); } else { n = caar(Bstack); } cf = 1; break; } else if (mode == MIFPR) { unsave(1); /* Original list */ n = bunsave(1); mode = munsave(); if (m != S_false) n = cadr(n); else n = caddr(n); cf = 1; break; } else if (mode == MBEGN) { Car[Bstack] = cdar(Bstack); if (cdar(Bstack) == NIL) { n = caar(Bstack); unsave(1); /* Original list */ bunsave(1); mode = munsave(); } else { n = caar(Bstack); } cf = 1; break; } else if (mode == MBIND || mode == MBINR) { if (nextLet(m) == NIL) { n = finishLet(mode == MBINR); mode = MLETR; } else { n = evalLet(); } cf = 1; break; } else { /* Atom */ break; } if (cf) { /* Continue evaluation if requested */ cf = 0; continue; } if (Stack == Stack0) break; } while (Stack != Stack0) unsave(1); Stack0 = unsave(1); Car[Mstack] = unsave(1); Bstack = unsave(1); Lstack = unsave(1); unsave(1); EvLev = EvLev - 1; return m; /* Return the evaluated expr */ } /* Print lists of digits in condensed format. */ static int printNum(int n) { char s[2]; if (Car[n] != S_integer) return 0; s[1] = 0; n = Cdr[n]; while (1) { if (n == NIL) break; s[0] = caaar(n) & 255; pr(s); n = Cdr[n]; } return -1; } /* Print expressions of the form (QUOTE X) as 'X. */ static int printQuote(int n) { if ( Car[n] == S_quote && Cdr[n] != NIL && cddr(n) == NIL ) { n = cadr(n); if (n != S_true && n != S_false) pr("'"); _print(n); return 1; } return 0; } /* Print a closure. */ static int printClosure(int n) { if ( Car[n] == S_closure && Cdr[n] != NIL && !atomic(Cdr[n]) && cddr(n) != NIL && !atomic(cddr(n)) ) { Quoted = 1; pr("# 0) { pr(" "); _print(caddr(n)); if (SK_closureForm > 1 && cdddr(n) != NIL) { pr(" "); _print(cadddr(n)); } } pr(">"); return -1; } return 0; } /* Print a character. */ static int printChar(int n) { char b[2]; int c; if (Car[n] != S_char) return 0; if (!DisplayMode) pr("#\\"); c = cadr(n); if (!DisplayMode && c == ' ') { pr("space"); } else if (!DisplayMode && c == '\n') { pr("newline"); } else { b[1] = 0; b[0] = c; pr(b); } return -1; } /* Print a string. */ static int printString(int n) { char b[2]; int k; char *s; if (Car[n] != S_string) return 0; if (!DisplayMode) pr("\""); s = string(n); k = string_len(n); b[1] = 0; while (k) { b[0] = *s++; if (!DisplayMode) if (b[0] == '"' || b[0] == '\\') pr("\\"); pr(b); k = k-1; } if (!DisplayMode) pr("\""); return -1; } /* Print a primitive function. */ static int printPrim(int n) { if (Car[n] != S_primitive && Car[n] != S_user_primitive) return 0; pr(Car[n] == S_primitive? "#"); return -1; } /* Print a special form handler. */ static int printSpecial(int n) { if (Car[n] != S_special && Car[n] != S_special_cbv) return 0; pr(Car[n] == S_special? "#"); return -1; } /* Print a syntax transformer. */ static int printSyntax(int n) { if (Car[n] != S_syntax) return 0; pr("#"); return -1; } /* Print a vector. */ static int printVector(int n) { int *p; int k; if (Car[n] != S_vector) return 0; pr("#("); Quoted = 1; p = vector(n); k = vector_len(n); while (k--) { _print(*p++); if (k) pr(" "); } pr(")"); return -1; } /* Print #. */ static int printVoid(int n) { if (Car[n] != S_voidSym) return 0; pr("#"); return -1; } /* Recursively print the term N. */ static void _print(int n) { char s[TEXTLEN+1]; int i; if (n == NIL) { if (!Quoted) { pr("'"); Quoted = 1; } pr("()"); } else if (Tag[n] & AFLAG) { /* Characters are limited to the symbol table */ pr("#"); } else if (atomic(n)) { if (!Quoted) { if ( n != S_true && n != S_false && n != S_integer && n != S_eof && n != S_void && n != S_undefined ) pr("'"); Quoted = 1; } i = 0; /* Symbol */ n = Car[n]; while (n != NIL) { s[i] = Car[n]; if (i < TEXTLEN-2) i = i+1; n = Cdr[n]; } s[i] = 0; pr(s); } else { /* List */ if (printNum(n)) return; if (printChar(n)) return; if (printString(n)) return; if (printClosure(n)) return; if (printPrim(n)) return; if (printSpecial(n)) return; if (printSyntax(n)) return; if (printVector(n)) return; if (printVoid(n)) return; if (!Quoted) { pr("'"); Quoted = 1; } if (printQuote(n)) return; pr("("); while (n != NIL) { _print(Car[n]); n = Cdr[n]; if ( n != NIL && (atomic(n) || tagged(n)) ) { pr(" . "); _print(n); n = NIL; } if (n != NIL) pr(" "); } pr(")"); } } /* Print external representation of an expression. */ void sk_print(int n) { Quoted = 1; DisplayMode = 0; _print(n); } /* Pretty-Print expression. */ void sk_display(int n) { Quoted = 1; DisplayMode = 1; _print(n); DisplayMode = 0; } /* Reset interpreter state. */ static void resetState(void) { Stack = NIL; Lstack = NIL; Bstack = NIL; Estack = NIL; Frame = NIL; Function = NIL; EvLev = 0; Level = 0; SyntaxMode = 0; } /* Stop the interpreter */ void sk_stop(void) { error("interrupted", NOEXPR); } /* Initialize interpreter variables. */ static void init1() { /* Misc. variables */ NIL = PoolSize; Level = 0; resetState(); Mstack = NIL; SK_errFlag = 0; setErrArg(""); FatalFlag = 0; Symbols = NIL; Packages = NIL; Transformers = NIL; SafeSymbols = NIL; Tmp = NIL; Tmp2 = NIL; SafeCar = NIL; SafeCdr = NIL; LoadLev = 0; GensymCounter = 0; SK_trace = NIL; SK_traceHandler = NULL; MaxAtoms = 0; MaxCells = 0; Ntrace = 10; SK_statFlag = 0; SK_closureForm = 0; SK_arrowMode = 0; SK_strictApply = 1; SK_metaChar = ':'; Line = 1; /* Initialize Freelist */ Free = NIL; Vptr = 0; /* Clear input buffer */ Infile[0] = 0; DirName[0] = 0; Input = stdin; Output = stdout; Rejected = EOT; InputString = NULL; OutputString = NULL; } /* For fast lookup */ void cacheDigits(void) { Digits[0] = S_0; Digits[1] = S_1; Digits[2] = S_2; Digits[3] = S_3; Digits[4] = S_4; Digits[5] = S_5; Digits[6] = S_6; Digits[7] = S_7; Digits[8] = S_8; Digits[9] = S_9; } /* * Second stage of initialization: * protect registers from GC, * build the free list, * create builtin symbols. */ static void init2(void) { int core; /* Protect base registers */ Root[0] = &Symbols; Root[1] = &SafeCar; Root[2] = &SafeCdr; Root[3] = &Stack; Root[4] = &Mstack; Root[5] = &Lstack; Root[6] = &Bstack; Root[7] = &Estack; Root[8] = &Tmp; Root[9] = &Tmp2; Root[10] = &SafeSymbols; Root[11] = &Packages; Root[12] = &Transformers; /* Create builtin symbols */ S_0 = addSym("0d", 0); /* First GC will be triggered HERE */ S_1 = addSym("1d", 0); S_2 = addSym("2d", 0); S_3 = addSym("3d", 0); S_4 = addSym("4d", 0); S_5 = addSym("5d", 0); S_6 = addSym("6d", 0); S_7 = addSym("7d", 0); S_8 = addSym("8d", 0); S_9 = addSym("9d", 0); cacheDigits(); /* * Tags (especially # and #) * must be defined before the first primitive. */ S_special = addSym("#", 0); S_special_cbv = addSym("#", 0); S_primitive = addSym("#", 0); S_user_primitive = addSym("#", 0); S_char = addSym("#", 0); S_closure = addSym("#", 0); S_eof = addSym("#", 0); S_integer = addSym("#", 0); S_string = addSym("#", 0); S_syntax = addSym("#", 0); S_undefined = addSym("#", 0); S_vector = addSym("#", 0); S_voidSym = addSym("#", 0); S_void = alloc(S_voidSym, NIL); S_void = addSym("#", S_void); addSym("_", S_undefined); addSym("...", S_undefined); addSpecial("and", SF_AND, 0); addSpecial("apply", SF_APPLY, 1); addSpecial("begin", SF_BEGIN, 0); S_bottom = addPrim("bottom", P_BOTTOM); addPrim("car", P_CAR); addPrim("cdr", P_CDR); addPrim("char->integer", P_CHAR_TO_INTEGER); addPrim("char-ci?", P_CHAR_CI_GTP); addPrim("char-ci>=?", P_CHAR_CI_GEP); addPrim("char?", P_CHAR_GTP); addPrim("char>=?", P_CHAR_GEP); addPrim("char?", P_CHARP); addSpecial("cond", SF_COND, 0); addPrim("cons", P_CONS); addSpecial("define", SF_DEFINE, 0); S_defineSyntax = addSpecial("define-syntax", SF_DEFINE_SYNTAX, 0); addPrim("delete-file", P_DELETE_FILE); addPrim("display", P_DISPLAY); S_else = addSym("else", S_undefined); addPrim("eof-object?", P_EOF_OBJECTP); addSpecial("eval", SF_EVAL, 0); addPrim("eq?", P_EQP); S_false = addSym("#f", 0); S_gensym = addPrim("gensym", P_GENSYM); addSpecial("if", SF_IF, 0); addPrim("integer->char", P_INTEGER_TO_CHAR); addPrim("integer->list", P_INTEGER_TO_LIST); S_lambda = addSpecial("lambda", SF_LAMBDA, 0); addSpecial("let", SF_LET, 0); addSpecial("letrec", SF_LETREC, 0); addPrim("list->integer", P_LIST_TO_INTEGER); addPrim("list->string", P_LIST_TO_STRING); addPrim("list->vector", P_LIST_TO_VECTOR); addPrim("load", P_LOAD); addPrim("n+", P_NPLUS); addPrim("n-", P_NMINUS); addPrim("n<", P_NLESS); addPrim("null?", P_NULLP); addPrim("number?", P_NUMBERP); addSpecial("or", SF_OR, 0); addPrim("package", P_PACKAGE); addPrim("pair?", P_PAIRP); addPrim("peek-char", P_PEEK_CHAR); addPrim("procedure?", P_PROCEDUREP); S_quote = addSpecial("quote", SF_QUOTE, 0); addPrim("require", P_REQUIRE); addPrim("read", P_READ); addPrim("read-char", P_READ_CHAR); addPrim("read-from-string", P_READ_FROM_STRING); addPrim("recursive-bind", P_RECURSIVE_BIND); addPrim("string->symbol", P_STRING_TO_SYMBOL); addPrim("string->list", P_STRING_TO_LIST); addPrim("string-append", P_STRING_APPEND); addPrim("string-length", P_STRING_LENGTH); addPrim("string-ref", P_STRING_REF); addPrim("string?", P_STRINGP); addPrim("substring", P_SUBSTRING); addPrim("symbol->string", P_SYMBOL_TO_STRING); addPrim("symbol?", P_SYMBOLP); addPrim("syntax->list", P_SYNTAX_OF); addSpecial("syntax-rules", SF_SYNTAX_RULES, 0); addPrim("vector->list", P_VECTOR_TO_LIST); addPrim("vector-length", P_VECTOR_LENGTH); addPrim("vector-ref", P_VECTOR_REF); addPrim("vector?", P_VECTORP); addPrim("void", P_VOID); addSpecial("with-input-from-file", SF_WITH_INPUT_FROM_FILE, 1); addSpecial("with-output-to-file", SF_WITH_OUTPUT_TO_FILE, 1); addPrim("write", P_WRITE); addPrim("write-char", P_WRITE_CHAR); addPrim("write-to-string", P_WRITE_TO_STRING); S_true = addSym("#t", 0); S_last = addSym("**", S_void); Mstack = alloc(NIL, NIL); Primitives[P_BOTTOM] = &doBottom; Primitives[P_CAR] = &doCar; Primitives[P_CDR] = &doCdr; Primitives[P_CHAR_TO_INTEGER] = &doCharToInteger; Primitives[P_CHAR_CI_LTP] = &doCharCiLtP; Primitives[P_CHAR_CI_LEP] = &doCharCiLEP; Primitives[P_CHAR_CI_EQP] = &doCharCiEqP; Primitives[P_CHAR_CI_GTP] = &doCharCiGtP; Primitives[P_CHAR_CI_GEP] = &doCharCiGEP; Primitives[P_CHAR_LTP] = &doCharLtP; Primitives[P_CHAR_LEP] = &doCharLEP; Primitives[P_CHAR_EQP] = &doCharEqP; Primitives[P_CHAR_GTP] = &doCharGtP; Primitives[P_CHAR_GEP] = &doCharGEP; Primitives[P_CHARP] = &doCharP; Primitives[P_CONS] = &doCons; Primitives[P_DELETE_FILE] = &doDeleteFile; Primitives[P_DISPLAY] = &doDisplay; Primitives[P_EOF_OBJECTP] = &doEofObjectP; Primitives[P_EQP] = &doEqP; Primitives[P_GENSYM] = &doGensym; Primitives[P_INTEGER_TO_CHAR] = &doIntegerToChar; Primitives[P_INTEGER_TO_LIST] = &doIntegerToList; Primitives[P_LIST_TO_INTEGER] = &doListToInteger; Primitives[P_LIST_TO_STRING] = &doListToString; Primitives[P_LIST_TO_VECTOR] = &doListToVector; Primitives[P_LOAD] = &doLoad; Primitives[P_NPLUS] = &doNPlus; Primitives[P_NMINUS] = &doNMinus; Primitives[P_NLESS] = &doNLess; Primitives[P_NULLP] = &doNullP; Primitives[P_NUMBERP] = &doNumberP; Primitives[P_PACKAGE] = &doPackage; Primitives[P_PAIRP] = &doPairP; Primitives[P_PEEK_CHAR] = &doPeekChar; Primitives[P_PROCEDUREP] = &doProcedureP; Primitives[P_READ] = &doRead; Primitives[P_READ_CHAR] = &doReadChar; Primitives[P_READ_FROM_STRING] = &doReadFromString; Primitives[P_RECURSIVE_BIND] = &doRecursiveBind; Primitives[P_REQUIRE] = &doRequire; Primitives[P_STRING_TO_LIST] = &doStringToList; Primitives[P_STRING_TO_SYMBOL] = &doStringToSymbol; Primitives[P_STRING_APPEND] = &doStringAppend; Primitives[P_STRING_LENGTH] = &doStringLength; Primitives[P_STRING_REF] = &doStringRef; Primitives[P_STRINGP] = &doStringP; Primitives[P_SUBSTRING] = &doSubstring; Primitives[P_SYMBOL_TO_STRING] = &doSymbolToString; Primitives[P_SYMBOLP] = &doSymbolP; Primitives[P_SYNTAX_OF] = &doSyntaxToList; Primitives[P_VECTOR_TO_LIST] = &doVectorToList; Primitives[P_VECTOR_LENGTH] = &doVectorLength; Primitives[P_VECTOR_REF] = &doVectorRef; Primitives[P_VECTORP] = &doVectorP; Primitives[P_VOID] = &doVoid; Primitives[P_WRITE] = &doWrite; Primitives[P_WRITE_CHAR] = &doWriteChar; Primitives[P_WRITE_TO_STRING] = &doWriteToString; Specials[SF_AND] = &doAnd; Specials[SF_APPLY] = &doApply; Specials[SF_BEGIN] = &doBegin; Specials[SF_COND] = &doCond; Specials[SF_DEFINE] = &doDefine; Specials[SF_DEFINE_SYNTAX] = &doDefineSyntax; Specials[SF_EVAL] = &doEval; Specials[SF_IF] = &doIf; Specials[SF_LAMBDA] = &doLambda; Specials[SF_LET] = &doLet; Specials[SF_LETREC] = &doLetrec; Specials[SF_OR] = &doOr; Specials[SF_QUOTE] = &doQuote; Specials[SF_SYNTAX_RULES] = &doSyntaxRules; Specials[SF_WITH_INPUT_FROM_FILE] = &doWithInputFromFile; Specials[SF_WITH_OUTPUT_TO_FILE] = &doWithOutputToFile; core = addSym("core", S_undefined); Packages = alloc(core, Symbols); S_core = Packages; Packages = alloc(Packages, NIL); Symbols = addPackage(NIL); LastUsrPrimitive = 0; } /* * Initialize the interpreter and allocate pools of * the given sizes. */ int sk_init(int nodes, int vcells) { PoolSize = nodes? nodes: SK_DFL_NODES; VPoolSize = vcells? vcells: SK_DFL_VCELLS; if (PoolSize < SK_MIN_SIZE || VPoolSize < SK_MIN_SIZE) return -1; if ( (Car = (int *) malloc(PoolSize * sizeof(int))) == NULL || (Cdr = (int *) malloc(PoolSize * sizeof(int))) == NULL || (Tag = (char *) malloc(PoolSize)) == NULL || (Vpool = (int *) malloc(VPoolSize * sizeof(int))) == NULL ) { if (Car) free(Car); if (Cdr) free(Cdr); if (Tag) free(Tag); Car = Cdr = NULL; Tag = NULL; return -1; } memset(Tag, 0, PoolSize); init1(); init2(); return 0; } /* Shut down the interpreter */ void sk_fini() { if (Car) free(Car); if (Cdr) free(Cdr); if (Tag) free(Tag); if (Vpool) free(Vpool); Car = Cdr = Vpool = NULL; Tag = NULL; } /* Reset the reduction counter */ static void clearStats(void) { sk_resetCounter(&SK_reductions); sk_resetCounter(&SK_allocations); sk_resetCounter(&SK_collections); } /* Print the number of reductions done in last EVAL */ void sk_printStats(void) { sk_printCounter(&SK_reductions); pr(" reduction steps"); nl(); sk_printCounter(&SK_allocations); pr(" nodes allocated"); nl(); sk_printCounter(&SK_collections); pr(" garbage collections"); nl(); } /* Evaluate an expression and returns its normal form. */ int safe_eval(int n) { save(n); SafeSymbols = copyBindings(); n = eval(Car[Stack]); unsave(1); if (SK_errFlag) restoreBindings(SafeSymbols); return n; } /* Evaluate an expression and returns its normal form. */ int sk_eval(int n) { int m; if (SK_errFlag) return NIL; n = syntaxTransform(n); if (SK_statFlag) clearStats(); m = safe_eval(n); if (Stack != NIL) fatal("sk_eval(): unbalanced stack"); if (!SK_errFlag) Cdr[S_last] = m; resetState(); while (Car[Mstack] != NIL) munsave(); return m; } /* Variables to dump to image file */ int *ImageVars[] = { &SK_statFlag, &SK_closureForm, &SK_arrowMode, &SK_strictApply, &SK_metaChar, &Symbols, &Packages, &Transformers, &Free, &Vptr, &S_bottom, &S_char, &S_closure, &S_core, &S_defineSyntax, &S_else, &S_eof, &S_false, &S_gensym, &S_integer, &S_lambda, &S_primitive, &S_quote, &S_special, &S_special_cbv, &S_string, &S_syntax, &S_true, &S_undefined, &S_user_primitive, &S_vector, &S_void, &S_voidSym, &S_last, &S_0, &S_1, &S_2, &S_3, &S_4, &S_5, &S_6, &S_7, &S_8, &S_9, NULL }; /* Dump node pool image to path P. */ void sk_dumpImage(char *p) { int fd, n, i; int **v; char magic[17]; if (LastUsrPrimitive != 0) { error("cannot dump image with user extensions", NOEXPR); return; } fd = open(p, O_CREAT | O_WRONLY, 0644); setmode(fd, O_BINARY); if (fd < 0) { error("cannot create file", NOEXPR); setErrArg(p); return; } strcpy(magic, "SKETCHY_________"); magic[7] = sizeof(int); magic[8] = SK_MAJOR; n = 0x12345678; memcpy(&magic[10], &n, sizeof(int)); write(fd, magic, 16); n = PoolSize; write(fd, &n, sizeof(int)); n = VPoolSize; write(fd, &n, sizeof(int)); v = ImageVars; i = 0; while (v[i]) { write(fd, v[i], sizeof(int)); i = i+1; } if ( write(fd, Car, PoolSize*sizeof(int)) != PoolSize*sizeof(int) || write(fd, Cdr, PoolSize*sizeof(int)) != PoolSize*sizeof(int) || write(fd, Tag, PoolSize) != PoolSize || write(fd, Vpool, VPoolSize*sizeof(int)) != VPoolSize*sizeof(int) ) { close(fd); error("image dump failed", NOEXPR); return; } close(fd); } /* * Fix NIL nodes of a pool. This is necessary when * loading an image that is smaller than the current * pool. (NIL is represented by an integer that cannot * be a valid offset into a pool. It might be a valid * offset in a larger pool, though.) */ void fixNIL(int *p, int oldnil) { int i; for (i=0; i PoolSize) { error("bad image (too many nodes)", NOEXPR); bad = 1; } read(fd, &ivcells, sizeof(int)); if (ivcells > VPoolSize) { error("bad image (too many vcells)", NOEXPR); bad = 1; } v = ImageVars; i = 0; while (v[i]) { read(fd, v[i], sizeof(int)); i = i+1; } if ( !bad && (read(fd, Car, inodes*sizeof(int)) != inodes*sizeof(int) || read(fd, Cdr, inodes*sizeof(int)) != inodes*sizeof(int) || read(fd, Tag, inodes) != inodes || read(fd, Vpool, ivcells*sizeof(int)) != ivcells*sizeof(int)) ) { error("bad image (bad file size)", NOEXPR); bad = 1; } if (inodes != PoolSize) { fixNIL(Car, inodes); fixNIL(Cdr, inodes); } close(fd); cacheDigits(); if (bad) setErrArg(p); return SK_errFlag; } /* Return a node representing NIL */ const int sk_nil(void) { return NIL; } /* Return a node representing the undefined value */ const int sk_undefined(void) { return S_undefined; } /* Return a node representing (VOID) */ const int sk_void(void) { return S_void; } /* Return a node representing #T */ const int sk_true(void) { return S_true; } /* Return a node representing #F */ const int sk_false(void) { return S_false; } /* Return a node representing # */ int sk_eof() { return S_eof; } /* Return the CAR part of N */ int sk_car(int n) { return Car[n]; } /* Return the CDR part of N */ int sk_cdr(int n) { return Cdr[n]; } /* Return the Nth argument of a function application N */ int sk_nthArg(int n, int i) { i++; while (i--) { if (lazyAtom(n)) return NIL; n = Cdr[n]; } return Car[n]; } /* Return the number of arguments in a function application N */ int sk_args(int n) { return length(n)-1; } /* Return the value of a CHAR */ int sk_char(int n) { return cadr(n); } /* Return the value of a STRING */ const char *sk_string(int n) { if (atomic(n) || n == NIL || Car[n] != S_string) { return NULL; } return string(n); } /* Return the elements of a VECTOR */ const int *sk_vector(int n) { if (atomic(n) || n == NIL || Car[n] != S_vector) { return NULL; } return vector(n); } /* Return length of a VECTOR */ int sk_vector_len(int n) { if (atomic(n) || n == NIL || Car[n] != S_vector) { return NULL; } return vector_len(n); } /* Write N to a string and return the string. */ int sk_writeToString(int n) { n = alloc(n, NIL); n = alloc(NIL, n); save(n); n = doWriteToString(n); unsave(1); return n; } /* Read an expression from the string S and return it. */ int sk_readFromString(char *s) { int n; n = sk_mkString(s, strlen(s)); n = alloc(n, NIL); n = alloc(NIL, n); save(n); n = doReadFromString(n); unsave(1); return n; } /* Return the type of an object */ int sk_typeof(int n) { if (atomic(n)) return SK_TYPE_SYMBOL; if (n == S_true || n == S_false) return SK_TYPE_BOOLEAN; if (n == S_eof) return SK_TYPE_EOF; if (n == S_undefined) return SK_TYPE_UNDEFINED; if (n == S_void) return SK_TYPE_VOID; if (Car[n] == S_integer) return SK_TYPE_INTEGER; if (Car[n] == S_char) return SK_TYPE_CHAR; if (Car[n] == S_string) return SK_TYPE_STRING; if ( Car[n] == S_closure || Car[n] == S_primitive || Car[n] == S_user_primitive || Car[n] == S_special_cbv ) return SK_TYPE_PROCEDURE; if (Car[n] == S_special || Car[n] == S_syntax) return SK_TYPE_SYNTAX; return SK_TYPE_PAIR; } /* Say goodbye to the world */ void sk_bye(void) { sk_fini(); exit(0); } /* Create a pair */ int sk_cons(int car, int cdr) { return alloc(car, cdr); } /* Create a bignum integer */ int sk_mkInteger(long v) { char buf[100]; sprintf(buf, "%ld", v); return explodeNum(buf); } /* Convert list to vector */ int sk_listToVector(int n) { return list_to_vector(n, "sk_listToVector()"); } /* Protect a node */ void sk_protect(int n) { save(n); } /* Unprotect a number of nodes */ void sk_unprotect(int k) { unsave(k); } /* Modify CAR part of pair */ void sk_setCar(int n, int new) { Car[n] = new; } /* Modify CDR part of pair */ void sk_setCdr(int n, int new) { Cdr[n] = new; } /* Extract directory name of PATH into PFX. */ static void getDirName(char *path, char *pfx) { char *p; if (strlen(path) > 256) { error("path too long in :load or 'require'", NOEXPR); return; } strcpy(pfx, path); p = strrchr(pfx, '/'); if (p == NULL) strcpy(pfx, "."); else *p = 0; } /* Expand leading '~/' path name */ static char *expandPath(char *s) { char *var, *r, *v; if (!strncmp(s, "~/", 2)) { var = "HOME"; r = &s[2]; } else { return s; } if ((v = getenv(var)) == NULL) return s; if (strlen(v) + strlen(r) + 2 >= MAXPATHL) { error("path too long in 'load' or 'require'", NOEXPR); return s; } sprintf(ExpPath, "%s/%s", v, r); return ExpPath; } /* Internal Read-Eval-Loop for loading source files. */ static void REL(void) { int n, evl; SK_errFlag = 0; evl = EvLev; EvLev = 0; while(!SK_errFlag) { n = sk_read(); n = syntaxTransform(n); if (n == S_eof) return; n = safe_eval(n); } EvLev = evl; } /* * Locate source file. * Try: ./file * ./file.scm (if no .scm suffix is present) * P/file * P/file.scm (where P is a path from $SKETCHYSRC). * SKETCHYSRC is a colon-separated list of paths. */ char *sk_findSource(char *p, char *buf) { char *sksrc, *q; char *toolong; FILE *f; int k; toolong = "path too long in 'require'"; if (strlen(p) >= SK_MAXPATHL-1) { error(toolong, NOEXPR); return NULL; } strcpy(buf, p); if (*p == '.' || *p == '/' || *p == '~') { return p; } sksrc = getenv("SKETCHYSRC"); if ((f = fopen(p, "r")) != NULL) { fclose(f); return p; } k = strlen(p); if (k < 4 || strcmp(&p[k-4], ".scm")) { if (strlen(p) + 4 >= SK_MAXPATHL-1) { error(toolong, NOEXPR); return NULL; } strcpy(buf, p); strcat(buf, ".scm"); f = fopen(buf, "r"); if (f) return buf; } q = strrchr(p, '/'); if (q) p = q; k = strlen(p); while (sksrc && *sksrc) { q = strchr(sksrc, ':'); if (q) *q = 0; if (strlen(sksrc) + strlen(p) >= SK_MAXPATHL-2) { error(toolong, NOEXPR); return NULL; } sprintf(buf, "%s/%s", sksrc, p); if (q) *q = ':'; f = fopen(buf, "r"); if (f) return buf; k = strlen(buf); if (k < 4 || strcmp(&buf[k-4], ".scm")) { if (strlen(buf) + 4 >= SK_MAXPATHL-1) { error(toolong, NOEXPR); return NULL; } strcat(buf, ".scm"); f = fopen(buf, "r"); if (f) return buf; } sksrc = q? &q[1]: ""; } return NULL; } /* Load expressions from the file P. Return error flag. */ int sk_load(char *p) { FILE *ofile, *nfile; int r; char oname[MAXPATHL]; int oline; char *q; if (LoadLev > 0) { if (strlen(p) + strlen(DirName) >= MAXPATHL) { error("path too long in :load or 'require'", NOEXPR); return -1; } if (*p != '.' && *p != '/') sprintf(Path, "%s/%s", DirName, p); else strcpy(Path, p); q = p = Path; } else if (p[0] == '/' || p[0] == '.' || p[0] == '~') { q = p; p = expandPath(p); getDirName(p, DirName); } else { q = p; p = sk_findSource(p, ExpPath); getDirName(p, DirName); } nfile = fopen(p, "r"); if (nfile == NULL) { p = sk_findSource(p, LocPath); if (p == NULL) { error("could not locate input file", NOEXPR); setErrArg(q); return -1; } nfile = fopen(p, "r"); if (nfile == NULL) { error("cannot open source file", NOEXPR); setErrArg(p); return -1; } } LoadLev = LoadLev + 1; /* Save old I/O state */ r = Rejected; /* Run the toplevel loop with redirected I/O */ ofile = Input; Input = nfile; oline = Line; Line = 1; strcpy(oname, Infile); strcpy(Infile, p); REL(); strcpy(Infile, oname); Line = oline; /* Restore previous I/O state */ Rejected = r; Input = ofile; LoadLev = LoadLev - 1; fclose(nfile); if (Level) error("unbalanced parentheses in loaded file", NOEXPR); return 0; } /* Load conditionally */ int sk_require(char *p) { char *q1, *q2; char s[TEXTLEN]; int y; memset(s, 0, TEXTLEN); strncpy(s, p, TEXTLEN-1); if (p[0] == '=') p = &p[1]; q1 = strchr(p, '/'); q2 = strchr(q1? q1: p, '.'); if (q2 != NULL) *q2 = 0; y = findSym(locase(q1? &q1[1]: p)); if (q2 != NULL) *q2 = '.'; if (y == NIL || Cdr[y] == S_undefined) { sk_load(s); return 1; } return 0; } /* Return conditions of use */ char **sk_license() { static char *license_text[] = { "SketchyLISP -- An Interpreter for Purely Applicative Scheme", "Copyright (C) 2005,2006,2007 Nils M Holm. All rights reserved.", "", "Redistribution and use in source and binary forms, with or without", "modification, are permitted provided that the following conditions", "are met:", "1. Redistributions of source code must retain the above copyright", " notice, this list of conditions and the following disclaimer.", "2. Redistributions in binary form must reproduce the above copyright", " notice, this list of conditions and the following disclaimer in the", " documentation and/or other materials provided with the distribution.", "", "THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND", "ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE", "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE", "ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE", "FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL", "DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS", "OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)", "HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT", "LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY", "OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF", "SUCH DAMAGE.", NULL}; return license_text; } /* Run GC and return statistics. */ void sk_gc(struct sk_gcStats *stats) { stats->nodes_used = PoolSize - gc(); gcv(); stats->vcells_used = Vptr; stats->nodes_max = MaxAtoms; stats->vcells_max = MaxCells; MaxAtoms = 0; MaxCells = 0; } /* Dump symbol table */ void sk_dumpSymbols(char *p) { int pk, y; y = findSym(p); Quoted = 1; pk = Packages; pr("Packages:"); while (pk != sk_nil()) { pr(" "); _print(caar(pk)); if (cdar(pk) == Symbols) pr("[open]"); pk = Cdr[pk]; } nl(); y = findPackage(y); _print(Car[y]); pr(": "); _print(Cdr[y]); nl(); }