/* Filename: ~\lisp\lisp.c Revision Date: July 23, 2007 */ /***************************************************************************** LISP INTERPRETER ----------------- This progam is a GOVOL LISP interpreter. This interpreter consists of three major functions: SREAD, SEVAL, and SWRITE. SREAD scans the input string for input S-expressions (atoms and dotted pairs) and returns a corresponding typed-pointer. The SEVAL function takes as input a typed-pointer p to an input S-expression and evaluates it and returns a typed pointer to its result. SWRITE takes as input the typed pointer returned from SEVAL and prints out the result. LISP input lines beginning with a "/" are comment lines. Indirect input text is taken from a file Z to replace the directive of the form "@Z". SEVAL tracing can be turned on by using the directive "!trace", and turned off with the directive "!notrace". *****************************************************************************/ #define int16 int #define int32 long #define forward extern #if defined(__GNUC__) # include "linuxenv.h" #else # include "c:\csihead\turbcenv.h" #endif /* The above includes declare strlen(), strcpy(), strcmp(), calloc(), fflush(), fopen(), fclose(), fprintf(), sprintf(), fgetc(), labs(), floor(), and pow(). Also the type FILE is defined, and the longjump register-save structure template: jmp_buf is defined. This include will need to be constructed to conform to any particular system. */ #if !defined(NULL) # define NULL 0L #endif #define EOF (-1) #define EOS (0) #define EQ == #define OR || #define AND && #define NOT ! #define n 1000 #define m 6000 /* n = size of Atom and Number tables, m = size of list-area. */ jmp_buf env; /* struct to hold environment for longjump */ char *sout; /* general output buffer pointer */ /* The atom table */ struct Atomtable {char name[16]; int32 L; int32 bl; int32 plist;} Atab[n]; /* The number table is used for storing floating point numbers. The field nlink is used for linking number table nodes on the number table free space list. */ union Numbertable {double num; int16 nlink;} Ntab[n]; /* the number hash index table */ int16 nx[n]; /* the number table free space list head pointer */ int16 nf= -1; /* the number table mark array nmark is used in garbage collection to mark words not to be returned to the free space list */ char nmark[n]; /* an array of 1-bit entries would suffice */ /* The list area */ struct Listarea {int32 car; int32 cdr;} *P; /* the list area free space list head pointer */ int16 fp= -1; /* the put-back variable */ int32 pb= 0; /* The input string and related pointers */ char *g,*pg,*pge; /* the input stream stack structure and head pointer */ struct Insave {struct Insave *link; char *pg, *pge; char g[202]; FILE *filep;}; struct Insave *topInsave; /* the input prompt character */ char prompt; /* seval depth count and trace switch */ int16 ct= 0, tracesw= 0; /* Global ordinary atom typed-pointers */ int32 nilptr,tptr,currentin,eaL,quoteptr,sk,traceptr; /* Number of free list-nodes */ int32 numf; /* define global macros */ #define A(j) P[j].car #define B(j) P[j].cdr #define type(f) (((f)>>28) & 0xf) #define ptrv(f) (0x0fffffff & (f)) #define sexp(t) ((t) EQ 0 OR (t) EQ 8 OR (t) EQ 9) #define fctform(t) ((t)>9) #define builtin(t) ((t) EQ 10 OR (t) EQ 11) #define userdefd(t) ((t) EQ 12 OR (t) EQ 13) #define dottedpair(t) ((t) EQ 0) #define fct(t) ((t) EQ 10 OR (t) EQ 12 OR (t) EQ 14) #define unnamedfsf(t) ((t)>13) #define namedfsf(t) ((t)>9 AND (t)<14) #define tp(t,j) ((t) | (j)) #define ud(j) (0x10000000 | (j)) #define se(j) (0x00000000 | (j)) #define oa(j) (0x80000000 | (j)) #define nu(j) (0x90000000 | (j)) #define bf(j) (0xa0000000 | (j)) #define bs(j) (0xb0000000 | (j)) #define uf(j) (0xc0000000 | (j)) #define us(j) (0xd0000000 | (j)) #define tf(j) (0xe0000000 | (j)) #define ts(j) (0xf0000000 | (j)) /* variables used in file operations */ FILE *filep; FILE *logfilep; /* forward references */ forward int32 seval(int32 i); forward void initlisp(void); forward int32 sread(void); forward void swrite(int32 i); forward int32 newloc(int32 x, int32 y); forward int32 numatom (double r); forward int32 ordatom (char *s); forward void gc(void); forward void gcmark(int32 p); forward char getgchar(void); forward char lookgchar(void); forward void fillg(void); forward int32 e(void); forward void error(char *s); forward int16 fgetline(char *s, int16 lim, FILE *stream); forward void ourprint(char *s); /*==========================================================================*/ void spacerpt(int32 r) /*--------------------------------------------------------------------------- For debugging to see if we are leaking list-nodes. We are to protect r from garbage-collection. This function can be called from within the main loop. ----------------------------------------------------------------------------*/ {char s[60]; int16 t; sprintf(s,"entering spacerpt: r=%x, numf=%d\n", r, numf); ourprint(s); t = type(r); if (namedfsf(t)) r = ptrv(Atab[ptrv(r)].L); /* dereference r */ if (builtin(t)) r = nilptr; /*do not try to mark a builtin */ gcmark(r); gc(); sprintf(s,"leaving spacerpt: numf=%d\n", numf); ourprint(s); } /*==========================================================================*/ void main(void) /*--------------------------------------------------------------------------- Here is the main read/eval/print loop. ----------------------------------------------------------------------------*/ {int32 r; initlisp(); setjmp(env); /* calling error() returns to here by longjmp() */ for (;;) {ourprint("\n"); prompt= '*'; r=sread(); r=seval(r); swrite(r); /* swrite uses/frees no list-nodes. */ } } /*==========================================================================*/ void error(char *msg) /* char *msg; message to type out */ /*--------------------------------------------------------------------------- Type-out the message msg and do longjmp() to top level ----------------------------------------------------------------------------*/ {int32 i,t; /* discard all input S-expression and argument list stacks */ Atab[currentin].L= nilptr; Atab[eaL].L= nilptr; Atab[sk].L= nilptr; /* reset all atoms to their top-level values */ for (i= 0; i='a' AND (c)<='z') if (pb!=0) {t= pb; pb= 0; return(t);} start: while ((c= getgchar()) EQ BLANK); /* remove blanks */ if (c EQ OPENP) {while (lookgchar() EQ BLANK) getgchar(); /* remove blanks */ if (lookgchar() EQ CLOSEP) {getgchar(); return(nilptr);} else return(1); } if (c EQ EOS) {if (topInsave EQ NULL) {fclose(logfilep); exit(0);} /* restore the previous input stream */ fclose(filep); strcpy(g,topInsave->g); pg= topInsave->pg; pge= topInsave->pge; filep= topInsave->filep; topInsave= topInsave->link; if (prompt EQ '@') prompt= '>'; goto start; } if (c EQ SINGLEQ) return(2); if (c EQ CLOSEP) return(4); if (c EQ DOT) {if (DIGIT(lookgchar())) {sign= 1.0; v= 0.0; goto fraction;} return(3);} if (NOT (DIGIT(c) OR ((c EQ PLUS OR c EQ MINUS) AND (DIGIT(lookgchar()) OR lookgchar() EQ DOT)))) {np= nc; *np++= c; /* put c in nc[0] */ for (c= lookgchar(); c!=BLANK AND c!=DOT AND c!=OPENP AND c!=CLOSEP; c= lookgchar()) *(np++)= getgchar(); /* add a character */ *np= EOS; /* nc is now a string */ if (*nc EQ '@') {/* switch input streams */ /* save the current input stream */ tb= (struct Insave *)calloc(1,sizeof(struct Insave)); tb->link= topInsave; topInsave= tb; strcpy(tb->g,g); tb->pg= pg; tb->pge= pge; tb->filep= filep; /* set up the new input stream */ *g= EOS; pg= pge= g; prompt= '@'; filep= fopen(nc+1,"r"); /* skip over the @ */ if (filep EQ NULL) error("Cannot open @file!"); goto start; } /* convert the string nc to upper case */ for (np= nc; *np!=EOS; np++) if (ISLOWER((int16)*np)) *np= (char)TOUPPER((int16)*np); return(ordatom(nc)); } if (c EQ MINUS) {v= 0.0; sign= -1.0;} else {v= CHVAL(c); sign= 1.0;} while (DIGIT(lookgchar())) v= 10.0*v+CHVAL(getgchar()); if (lookgchar() EQ DOT) {getgchar(); if (DIGIT(lookgchar())) {fraction: k= 1.0; f= 0.0; do {k=10.*k;f=10.*f+CHVAL(getgchar());} while (DIGIT(lookgchar())); v= v+f/k; } } return(numatom(sign*v)); } /*===========================================================================*/ char getgchar(void) /*---------------------------------------------------------------------------- Fill the buffer string pg (=pointer to g) if needed, and then remove and return the next character from the input. -----------------------------------------------------------------------------*/ {fillg(); return(*pg++);} /*===========================================================================*/ char lookgchar(void) /*---------------------------------------------------------------------------- Fill the buffer string pg (=g) if needed, and then return a copy of the next character in the input, but don't advance pg.. * -----------------------------------------------------------------------------*/ {fillg(); return(*pg);} /*===========================================================================*/ void fillg(void) /*---------------------------------------------------------------------------- Read a line into g[]. A line starting with a "/" is a comment line. -----------------------------------------------------------------------------*/ {while (pg>=pge) {sprompt: if (filep EQ stdin) {sprintf(sout,"%c",prompt); ourprint(sout);} if (fgetline(g,200,filep)<0) return; if (filep EQ stdin) {fprintf(logfilep,"%s\n",g); fflush(logfilep);} if (*g EQ '/') goto sprompt; pg= g; pge= g+strlen(g); *pge++= ' '; *pge= '\0'; prompt= '>'; } } /*===========================================================================*/ int16 fgetline(char *s, int16 lim, FILE *stream) /*---------------------------------------------------------------------------- fgetline() gets a line (CRLF or LF delimited) from stream and puts it into s (up to lim chars). The function returns the length of this string. If there are no characters but just EOF, it returns -1 (EOF) as the length. There is no deblanking except to drop CR's and LF's ('\n') and map TABs to blanks. -----------------------------------------------------------------------------*/ {int16 c,i; #define TAB 9 for (i=0; i= n) {j= 0; if (++c>1) error("atom table is full");} } strcpy(Atab[j].name,s); Atab[j].L= ud(j); ret: return(oa(j)); } /*===========================================================================*/ void swrite(int32 j) /*---------------------------------------------------------------------------- The S-expression pointed to by j is typed out. ----------------------------------------------------------------------------*/ {int32 i; int16 listsw; i= ptrv(j); switch (type(j)) {case 0: /* check for a list */ j= i; while (type(B(j)) EQ 0) j= B(j); listsw= (B(j) EQ nilptr); ourprint("("); while (listsw) {swrite(A(i)); if ((i= B(i)) EQ nilptr) goto close; ourprint(" ");} swrite(A(i)); ourprint(" . "); swrite(B(i)); close: ourprint(")"); break; case 8: ourprint(Atab[i].name); break; case 9: sprintf(sout,"%-g",Ntab[i].num); ourprint(sout); break; case 10: sprintf(sout,"{builtin function: %s}",Atab[i].name); ourprint(sout); break; case 11: sprintf(sout,"{builtin special form: %s}",Atab[i].name); ourprint(sout); break; case 12: sprintf(sout,"{user defined function: %s}",Atab[i].name); ourprint(sout); break; case 13: sprintf(sout,"{user defined special form: %s}",Atab[i].name); ourprint(sout); break; case 14: ourprint("{unnamed function}"); break; case 15: ourprint("{unnamed special form}"); break; } } /*===========================================================================*/ void traceprint(int32 v, int16 osw) /* int32 v; the object to be printed * int16 osw; 1 for seval() output, 0 for seval() input */ /*---------------------------------------------------------------------------- This function prints out the input and the result for each successive invocation of seval() when tracing is requested. ----------------------------------------------------------------------------*/ {if (tracesw>0) {if (osw EQ 1) sprintf(sout,"%d result:",ct--); else sprintf(sout,"%d seval:",++ct); ourprint(sout); swrite(v); ourprint("\n"); } } /*==========================================================================*/ int32 seval(int32 p) /*--------------------------------------------------------------------------- Evaluate the S-expression pointed to by the typed-pointer p; construct the result value as necessary; return a typed-pointer to the result. ---------------------------------------------------------------------------*/ {int32 ty,t,v,j,f,fa,na; /* I think t can be static. also fa and j? -test later. */ int32 *endeaL; static double s; #define U1 A(p) #define U2 A(B(p)) #define E1 A(p) #define E2 A(B(p)) #define Return(v) {traceprint(v,1); return(v);} traceprint(p,0); if(type(p)!=0) {/* p does not point to a non-atomic S-expression. * * If p is a type-8 typed pointer to an ordinary atom whose value is a * builtin or user-defined function or special form, then a typed-pointer * to that atom-table entry with typecode 10, 11, 12, or 13, depending upon * the value of the atom, is returned. Note that this permits us to know * the names of functions and special forms. * * if p is a type-8 typed pointer to an ordinary atom whose value is not a * builtin or user defined function or special form, and thus has the type- * code 8, 9, 14, or 15, then a typed-pointer corresponding to the value of * this atom is returned. * * if p is a non-type-8 typed-pointer to a number atom or to a function or * special form (named or unnamed), then the same pointer p is returned. */ if ((t= type(p))!=8) Return(p); j= ptrv(p); /* The association list is implemented with shallow binding in the atom- table, so the current values of all atoms are found in the atom table. */ if (Atab[j].name[0] EQ '!') {tracesw= (strcmp(Atab[j].name,"!TRACE") EQ 0)?1:0; longjmp(env,-1);} if ((t= type(Atab[j].L)) EQ 1) {sprintf(sout,"%s is undefined\n",Atab[j].name); error(sout);} if (namedfsf(t)) Return(tp(t<<28,j)); Return(Atab[j].L); } /* end of if (type(p)!=0) */ /* Save the list consisting of the current function and the supplied arguments as the top value of the currentin list to protect it from garbage collection. The currentin list is a list of lists. */ cilp= newloc(p,cilp); /* compute the function or special form to be applied */ tracesw-- ; f= seval(A(p)); tracesw++; ty= type(f); if (NOT fctform(ty)) error(" invalid function or special form"); f= ptrv(f); if (NOT unnamedfsf(ty)) f= ptrv(Atab[f].L); /* now let go of the supplied input function */ A(cilp)= p= B(p); /* If f is a function (not a special form), build a new list of its evaluated arguments and add it to the eaL list (the eaL list is a list of lists.) Then let go of the list of supplied arguments, replacing it with the new list of evaluated arguments */ if (fct(ty)) {/* compute the actual arguments */ eaLp= newloc(nilptr,eaLp); /* evaluate the actual arguments and build a list by tail-cons-ing! */ endeaL= &A(eaLp); while (p!=nilptr) {*endeaL= newloc(seval(A(p)),nilptr); endeaL= &B(*endeaL); p= B(p);} /* Set p to be the first node in the evaluated arguments list. */ p= A(eaLp); /* Throw away the current supplied arguments list by popping the currentin list */ cilp= B(cilp); } /* At this point p points to the first node of the actual argument list. if p EQ nilptr, we have a function or special form with no arguments */ if (NOT builtin(ty)) {/* f is a non-builtin function or non-builtin special form. do shallow binding of the arguments and evaluate the body of f by calling seval */ fa= A(f); /* fa points to the first node of the formal argument list */ na= 0; /* na counts the number of arguments */ /* run through the arguments and place them as the top values of the formal argument atoms in the atom-table. Push the old value of each formal argument on its binding list. */ if (type(fa) EQ 8 AND fa != nilptr) {/* This will bind the entire input actual arglist as the single actual arg. Sometimes, it is wrong - we should dereference the named fsf's in the p list, first. */ t=ptrv(fa); Atab[t].bl=newloc(Atab[t].L,Atab[t].bl); Atab[t].L=p; goto apply; } else while (p!=nilptr AND dottedpair(type(fa))) {t= ptrv(A(fa)); fa= B(fa); Atab[t].bl= newloc(Atab[t].L,Atab[t].bl); v= A(p); if (namedfsf(type(v))) v= Atab[ptrv(v)].L; Atab[t].L= v; ++na; p= B(p); } if (p!=nilptr) error("too many actuals"); /* The following code would forbid some useful trickery. if (fa!=nilptr) error("too many formals"); */ /* now apply the non-builtin special form or function */ apply: v= seval(B(f)); /* now unbind the actual arguments */ fa= A(f); if (type(fa) EQ 8 AND fa != nilptr) {t= ptrv(fa); Atab[t].L= A(Atab[t].bl); Atab[t].bl= B(Atab[t].bl);} else while (na-- > 0) {t= ptrv(A(fa)); fa= B(fa); Atab[t].L= A(Atab[t].bl); Atab[t].bl= B(Atab[t].bl); } } /* end non-builtins */ else {/* at this point we have a builtin function or special form. f is the pointer value of the atom in the atom table for the called function or special form and p is the pointer to the argument list.*/ v= nilptr; switch (f) /* begin builtins */ {case 1: /* CAR */ if (NOT dottedpair(type(E1))) error("illegal CAR argument"); v= A(E1); break; case 2: /* CDR */ if (NOT dottedpair(type(E1))) error("illegal CDR argument"); v= B(E1); break; case 3: /* CONS */ if (sexp(type(E1)) AND sexp(type(E2))) v= newloc(E1,E2); else error("Illegal CONS arguments"); break; /* for LAMBDA and SPECIAL, we could check that U1 is either an ordinary atom or a list of ordinary atoms */ case 4:/* LAMBDA */ v= tf(newloc(U1,U2)); break; case 5:/* SPECIAL */ v= ts(newloc(U1,U2)); break; case 6:/* SETQ */ f= U1; if (type(f)!=8) error("illegal assignment"); assign: v= ptrv(f); endeaL= &Atab[v].L; doit: t= seval(U2); switch (type(t)) {case 0: /* dotted pair */ case 8: /* ordinary atom */ case 9: /* number atom */ *endeaL= t; break; case 10: /* builtin function */ case 11: /* builtin special form */ case 12: /* user-defined function */ case 13: /* user-defined special form */ *endeaL= Atab[ptrv(t)].L; break; case 14: /* unnamed function */ *endeaL= uf(ptrv(t)); break; case 15: /* unamed special form */ *endeaL= us(ptrv(t)); break; } /* end of type(t) switch cases */ tracesw--; v= seval(f); tracesw++; break; case 7: /* ATOM */ if ((type(E1)) EQ 8 OR (type(E1)) EQ 9) v= tptr; break; case 8: /* NUMBERP */ if (type(E1) EQ 9) v= tptr; break; case 9: /* QUOTE */ v= U1; break; case 10: /* LIST */ v= p; break; case 11: /* DO */ while (p!=nilptr) {v= A(p); p= B(p);} break; case 12: /* COND */ while (p!=nilptr) {f = A(p); if (seval(A(f))!=nilptr) {v=seval(A(B(f))); break;} else p=B(p); } break; case 13: /* PLUS */ v= numatom(Ntab[ptrv(E1)].num+Ntab[ptrv(E2)].num); break; case 14: /* TIMES */ v= numatom(Ntab[ptrv(E1)].num*Ntab[ptrv(E2)].num); break; case 15: /* DIFFERENCE */ v= numatom(Ntab[ptrv(E1)].num-Ntab[ptrv(E2)].num); break; case 16: /* QUOTIENT */ v= numatom(Ntab[ptrv(E1)].num/Ntab[ptrv(E2)].num); break; case 17: /* POWER */ v= numatom(pow(Ntab[ptrv(E1)].num,Ntab[ptrv(E2)].num)); break; case 18: /* FLOOR */ v= numatom(floor(Ntab[ptrv(E1)].num)); break; case 19: /* MINUS */ v= numatom(-Ntab[ptrv(E1)].num); break; case 20: /* LESSP */ if(Ntab[ptrv(E1)].numNtab[ptrv(E2)].num); v= tptr; break; case 22: /* EVAL */ v= seval(E1); break; case 23: /* EQ */ v= (E1 EQ E2) ? tptr : nilptr; break; case 24: /* AND */ while (p!=nilptr AND seval(A(p))!=nilptr) p= B(p); if (p EQ nilptr) v= tptr; /* else v remains nilptr */ break; case 25: /* OR */ while (p!=nilptr AND seval(A(p)) EQ nilptr) p= B(p); if (p!=nilptr) v= tptr; /* else v remains nilptr */ break; case 26: /* SUM */ for (s= 0.0; p!=nilptr; s= s+Ntab[ptrv(A(p))].num, p= B(p)); v= numatom(s); break; case 27: /* PRODUCT */ for (s= 1.0; p!=nilptr; s= s*Ntab[ptrv(A(p))].num, p= B(p)); v= numatom(s); break; case 28: /* PUTPLIST */ v= E1; Atab[ptrv(v)].plist= E2; break; case 29: /* GETPLIST */ v= Atab[ptrv(E1)].plist; break; case 30: /* READ */ ourprint("\n!"); prompt= EOS; v= sread(); break; case 31: /* PRINT */ if (p EQ nilptr) ourprint(" "); else while (p!=nilptr) {swrite(A(p)); ourprint(" "); p= B(p);} break; case 32: /* PRINTCR */ if (p EQ nilptr) ourprint("\n"); else while (p!=nilptr) {swrite(A(p)); ourprint("\n"); p= B(p);} break; case 33: /* MKATOM */ strcpy(sout,Atab[ptrv(E1)].name); strcat(sout,Atab[ptrv(E2)].name); v= ordatom(sout); break; case 34: /* BODY */ if (unnamedfsf(type(E1))) v= ptrv(E1); else if (userdefd(type(E1))) v= ptrv(Atab[ptrv(E1)].L); else error("illegal BODY argument"); break; case 35: /* RPLACA */ v= E1; if (NOT dottedpair(type(v))) error("illegal RPLACA argument"); A(v)= E2; break; case 36: /* RPLACD */ v= E1; if (NOT dottedpair(type(v))) error("illegal RPLACD argument"); B(v)= E2; break; case 37: /* TSETQ */ /* Set the top-level value of U1 to seval(U2).*/ if (Atab[f= ptrv(U1)].bl EQ nilptr) goto assign; v= Atab[f].bl; while (B(v)!=nilptr) v= B(v); endeaL= &A(v); goto doit; case 38: /* NULL */ if (E1 EQ nilptr) v= tptr; break; case 39: /* SET */ f= seval(U1); goto assign; default: error("dryrot: bad builtin case number"); } /* end of switch cases */ } /* end builtins */ /* pop the eaL list or pop the currentin list, whichever is active */ if (fct(ty)) eaLp= B(eaLp); else cilp= B(cilp); Return(v); } /*========================================================================*/ int32 newloc(int32 x, int32 y) /*-------------------------------------------------------------------------- Allocates and loads the fields of a new location in the list area, with a()= X, b()= Y. The index of the new location is returned. -------------------------------------------------------------------------*/ {int32 j; if (fp<0) {gcmark(x); gcmark(y); gc(); if (fp<0) error("out of space");} j= fp; fp= B(j); A(j)= x; B(j)= y; numf--; return(j); } /*========================================================================*/ void gc(void) /*-------------------------------------------------------------------------- Garbage collector for number table and listarea --------------------------------------------------------------------------*/ {int32 i,t; #define marked(p) ((A(p) & 0x08000000)!=0) #define marknode(p) (A(p) |= 0x08000000) #define unmark(p) (A(p) &= 0xf7ffffff) for (i= 0; i11) start: t= type(p); if (listp(t)) {p=ptrv(p); if (marked(p)) return; t=A(p); marknode(p); if (NOT listp(type(t))) {marknum(type(t),t); p=B(p); goto start;} s=B(p); if (NOT listp(type(s))) {marknum(type(s),s); p=t; goto start;} gcmark(t); p=B(p); goto start; /* Equivalent to the recursive call: gcmark(B(p)) */ } else marknum(t,p); }