├── Interpreting Lisp source code ├── Makefile ├── lisp.c └── lispinit ├── LICENSE.txt ├── README.md └── contributing.md /Interpreting Lisp source code/Makefile: -------------------------------------------------------------------------------- 1 | # file: Makefile date: 3-01-2017 2 | # 3 | # This file is a control file for the 4 | # make program. It contains the specifications for building the lisp 5 | # executable program, lisp, from the C source file lisp.c using the 6 | # GNU C-compiler on linux. To build the lisp executable, type 'make 7 | # lisp' after the operating system prompt in the ~knott/lisp/ 8 | # directory. 9 | 10 | # CFLAGS is a macro for the flags passed to the compiler. 11 | # The flag -g tells the compiler to include debugging information 12 | # in the resulting executable; the flag -O means use the lowest 13 | # level of compiler optimizations. $(CFLAGS) is not given below. 14 | CFLAGS=-g -O 15 | 16 | # CC is a macro for the C-compiler used in compile and link commands. 17 | CC=gcc 18 | 19 | # The following line begins with the name of the target (i.e. the file 20 | # to be constructed), lisp.o, and then lists the file(s) on which it 21 | # depends--the C source file lisp.c. The next line is the command for 22 | # compiling the C source file in order to construct the file lisp.o; the 23 | # flag -c means only compile--do not link--the named C file, and the 24 | # flag -o lisp.o means name the output file lisp.o. 25 | lisp.o: lisp.c 26 | $(CC) -c -o lisp.o lisp.c 27 | 28 | # The following line begins with the name of the target, lisp, which 29 | # is an executable file, and then lists the file on which it 30 | # depends--the object file lisp.o. The next line is the command for 31 | # linking the object file, lisp.o, and producing the output file, 32 | # lisp. -lm means link in the math library module. 33 | # What are libraries are included by default, if no libraries 34 | # are explicitly named? 35 | lisp: lisp.o 36 | $(CC) -o lisp lisp.o -lm -lc 37 | 38 | # end of Makefile 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /Interpreting Lisp source code/lisp.c: -------------------------------------------------------------------------------- 1 | /* Filename: ~\lisp\lisp.c Revision Date: Feb. 16, 2017 */ 2 | /***************************************************************************** 3 | 4 | LISP INTERPRETER 5 | ----------------- 6 | 7 | This progam is a GOVOL LISP interpreter. This interpreter consists of 8 | three major functions: SREAD, SEVAL, and SWRITE. SREAD scans the 9 | input string for input S-expressions (atoms and dotted pairs) and 10 | returns a corresponding typed-pointer. The SEVAL function takes as 11 | input a typed-pointer p to an input S-expression and evaluates it and 12 | returns a typed pointer to its result. SWRITE takes as input the 13 | typed pointer returned from SEVAL and prints out the result. 14 | 15 | LISP input lines beginning with a "/" are comment lines. Indirect 16 | input text is taken from a file Z to replace the directive of the form 17 | "@Z". SEVAL tracing can be turned on by using the directive "!trace", 18 | and turned off with the directive "!notrace". 19 | 20 | *****************************************************************************/ 21 | 22 | /* Using int16_t and int32_t works on both 32-bit and 64-bit systems 23 | with newer compilers. For older 32-bit compilers, use: 24 | [#define int16 short int] and [#define int32 long int]. */ 25 | #define int16 int16_t 26 | #define int32 int32_t 27 | 28 | 29 | /* turbcenv.h is for all Windows systems with the old, but good, Borland C 30 | compiler/linker (without int32_t and int16_t). */ 31 | #if defined(__GNUC__) 32 | # include "linuxenv.h" 33 | #else 34 | # include "turbcenv.h" 35 | #endif 36 | /* The above includes declare strlen(), strcpy(), strcmp(), calloc(), 37 | fflush(), fopen(), fclose(), fprintf(), sprintf(), fgetc(), labs(), 38 | floor(), and pow(). Also the type FILE is defined, and the longjump 39 | register-save structure template: jmp_buf is defined. This include 40 | header-file will need to be constructed to conform to any particular 41 | system. */ 42 | 43 | #if !defined(NULL) 44 | # define NULL 0L 45 | #endif 46 | #define EOF (-1) 47 | #define EOS (0) 48 | 49 | #define EQ == 50 | #define OR || 51 | #define AND && 52 | #define NOT ! 53 | 54 | #define n 1000 55 | #define m 6000 56 | /* n = size of Atom and Number tables, m = size of list-area. */ 57 | 58 | jmp_buf env; /* struct to hold environment for longjump */ 59 | char *sout; /* general output buffer pointer */ 60 | 61 | /* The atom table */ 62 | struct Atomtable {char name[16]; int32 L; int32 bl; int32 plist;} Atab[n]; 63 | 64 | /* The number table is used for storing floating point numbers. The 65 | field nlink is used for linking number table nodes on the number 66 | table free space list. */ 67 | 68 | union Numbertable {double num; int16 nlink;} Ntab[n]; 69 | 70 | /* the number hash index table */ 71 | int16 nx[n]; 72 | 73 | /* the number table free space list head pointer */ 74 | int16 nf= -1; 75 | 76 | /* the number table mark array nmark is used in garbage collection to 77 | mark words not to be returned to the free space list */ 78 | char nmark[n]; /* an array of 1-bit entries would suffice */ 79 | 80 | /* The list area */ 81 | struct Listarea {int32 car; int32 cdr;} *P; 82 | 83 | /* the list area free space list head pointer */ 84 | int16 fp= -1; 85 | 86 | /* the put-back variable */ 87 | int32 pb= 0; 88 | 89 | /* The input string and related pointers */ 90 | char *g,*pg,*pge; 91 | 92 | /* the input stream stack structure and head pointer */ 93 | struct Insave 94 | {struct Insave *link; char *pg, *pge; char g[202]; FILE *filep;}; 95 | struct Insave *topInsave; 96 | 97 | /* the input prompt character */ 98 | char prompt; 99 | 100 | /* seval depth count and trace switch */ 101 | int16 ct= 0, tracesw= 0; 102 | 103 | /* Global ordinary atom typed-pointers */ 104 | int32 nilptr,tptr,currentin,eaL,quoteptr,sk,traceptr; 105 | 106 | /* Number of free list-nodes */ 107 | int32 numf; 108 | 109 | /* define global macros */ 110 | 111 | #define A(j) P[j].car 112 | #define B(j) P[j].cdr 113 | 114 | #define type(f) (((f)>>28) & 0xf) 115 | #define ptrv(f) (0x0fffffff & (f)) 116 | #define sexp(t) ((t) EQ 0 OR (t) EQ 8 OR (t) EQ 9) 117 | #define fctform(t) ((t)>9) 118 | #define builtin(t) ((t) EQ 10 OR (t) EQ 11) 119 | #define userdefd(t) ((t) EQ 12 OR (t) EQ 13) 120 | #define dottedpair(t) ((t) EQ 0) 121 | #define fct(t) ((t) EQ 10 OR (t) EQ 12 OR (t) EQ 14) 122 | #define unnamedfsf(t) ((t)>13) 123 | #define namedfsf(t) ((t)>9 AND (t)<14) 124 | #define tp(t,j) ((t) | (j)) 125 | #define ud(j) (0x10000000 | (j)) 126 | #define se(j) (0x00000000 | (j)) 127 | #define oa(j) (0x80000000 | (j)) 128 | #define nu(j) (0x90000000 | (j)) 129 | #define bf(j) (0xa0000000 | (j)) 130 | #define bs(j) (0xb0000000 | (j)) 131 | #define uf(j) (0xc0000000 | (j)) 132 | #define us(j) (0xd0000000 | (j)) 133 | #define tf(j) (0xe0000000 | (j)) 134 | #define ts(j) (0xf0000000 | (j)) 135 | 136 | /* variables used in file operations */ 137 | FILE *filep; 138 | FILE *logfilep; 139 | 140 | /* forward references */ 141 | #define forward extern 142 | forward int32 seval(int32 i); 143 | forward void initlisp(void); 144 | forward int32 sread(void); 145 | forward void swrite(int32 i); 146 | forward int32 newloc(int32 x, int32 y); 147 | forward int32 numatom (double r); 148 | forward int32 ordatom (char *s); 149 | forward void gc(void); 150 | forward void gcmark(int32 p); 151 | forward char getgchar(void); 152 | forward char lookgchar(void); 153 | forward void fillg(void); 154 | forward int32 e(void); 155 | forward void error(char *s); 156 | forward int16 fgetline(char *s, int16 lim, FILE *stream); 157 | forward void ourprint(char *s); 158 | 159 | 160 | 161 | /*==========================================================================*/ 162 | void spacerpt(int32 r) 163 | /*--------------------------------------------------------------------------- 164 | For debugging to see if we are leaking list-nodes. 165 | We are to protect r from garbage-collection. 166 | This function can be called from within the main loop. 167 | ----------------------------------------------------------------------------*/ 168 | {char s[60]; 169 | int16 t; 170 | 171 | sprintf(s,"entering spacerpt: r=%x, numf=%d\n", r, numf); ourprint(s); 172 | 173 | t = type(r); 174 | if (namedfsf(t)) r = ptrv(Atab[ptrv(r)].L); /* dereference r */ 175 | if (builtin(t)) r = nilptr; /*do not try to mark a builtin */ 176 | gcmark(r); 177 | gc(); 178 | 179 | sprintf(s,"leaving spacerpt: numf=%d\n", numf); ourprint(s); 180 | } 181 | 182 | 183 | /*==========================================================================*/ 184 | void main(void) 185 | /*--------------------------------------------------------------------------- 186 | Here is the main read/eval/print loop. 187 | ----------------------------------------------------------------------------*/ 188 | {int32 r; 189 | 190 | initlisp(); 191 | 192 | setjmp(env); 193 | /* calling error() returns to here by longjmp() */ 194 | 195 | for (;;) {ourprint("\n"); 196 | prompt= '*'; 197 | r=sread(); 198 | r=seval(r); 199 | swrite(r); /* swrite uses/frees no list-nodes. */ 200 | } 201 | } 202 | 203 | /*==========================================================================*/ 204 | void error(char *msg) 205 | /* char *msg; message to type out */ 206 | /*--------------------------------------------------------------------------- 207 | Type-out the message msg and do longjmp() to top level 208 | ----------------------------------------------------------------------------*/ 209 | {int32 i,t; 210 | 211 | /* discard all input S-expression and argument list stacks */ 212 | Atab[currentin].L= nilptr; Atab[eaL].L= nilptr; Atab[sk].L= nilptr; 213 | 214 | /* reset all atoms to their top-level values */ 215 | for (i= 0; i='a' AND (c)<='z') 381 | 382 | if (pb!=0) {t= pb; pb= 0; return(t);} 383 | 384 | start: 385 | while ((c= getgchar()) EQ BLANK); /* remove blanks */ 386 | 387 | if (c EQ OPENP) 388 | {while (lookgchar() EQ BLANK) getgchar(); /* remove blanks */ 389 | if (lookgchar() EQ CLOSEP) {getgchar(); return(nilptr);} else return(1); 390 | } 391 | if (c EQ EOS) 392 | {if (topInsave EQ NULL) {fclose(logfilep); exit(0);} 393 | /* restore the previous input stream */ 394 | fclose(filep); 395 | strcpy(g,topInsave->g); pg= topInsave->pg; pge= topInsave->pge; 396 | filep= topInsave->filep; topInsave= topInsave->link; 397 | if (prompt EQ '@') prompt= '>'; 398 | goto start; 399 | } 400 | if (c EQ SINGLEQ) return(2); 401 | if (c EQ CLOSEP) return(4); 402 | if (c EQ DOT) 403 | {if (DIGIT(lookgchar())) {sign= 1.0; v= 0.0; goto fraction;} return(3);} 404 | if (NOT (DIGIT(c) OR ((c EQ PLUS OR c EQ MINUS) AND 405 | (DIGIT(lookgchar()) OR lookgchar() EQ DOT)))) 406 | {np= nc; *np++= c; /* put c in nc[0] */ 407 | for (c= lookgchar(); 408 | c!=BLANK AND c!=DOT AND c!=OPENP AND c!=CLOSEP; 409 | c= lookgchar()) 410 | *(np++)= getgchar(); /* add a character */ 411 | *np= EOS; /* nc is now a string */ 412 | if (*nc EQ '@') 413 | {/* switch input streams */ 414 | /* save the current input stream */ 415 | tb= (struct Insave *)calloc(1,sizeof(struct Insave)); 416 | tb->link= topInsave; topInsave= tb; 417 | strcpy(tb->g,g); tb->pg= pg; tb->pge= pge; tb->filep= filep; 418 | 419 | /* set up the new input stream */ 420 | *g= EOS; pg= pge= g; prompt= '@'; 421 | filep= fopen(nc+1,"r"); /* skip over the @ */ 422 | if (filep EQ NULL) error("Cannot open @file!"); 423 | goto start; 424 | } 425 | /* convert the string nc to upper case */ 426 | for (np= nc; *np!=EOS; np++) 427 | if (ISLOWER((int16)*np)) *np= (char)TOUPPER((int16)*np); 428 | return(ordatom(nc)); 429 | } 430 | if (c EQ MINUS) {v= 0.0; sign= -1.0;} else {v= CHVAL(c); sign= 1.0;} 431 | while (DIGIT(lookgchar())) v= 10.0*v+CHVAL(getgchar()); 432 | if (lookgchar() EQ DOT) 433 | {getgchar(); 434 | if (DIGIT(lookgchar())) 435 | {fraction: 436 | k= 1.0; f= 0.0; 437 | do {k=10.*k;f=10.*f+CHVAL(getgchar());} while (DIGIT(lookgchar())); 438 | v= v+f/k; 439 | } 440 | } 441 | return(numatom(sign*v)); 442 | } 443 | 444 | /*===========================================================================*/ 445 | char getgchar(void) 446 | /*---------------------------------------------------------------------------- 447 | Fill the buffer string g and set pg=pointer to g (if needed), and then 448 | remove and return the next character from the input found at pg and 449 | advance the pointer pg.. 450 | -----------------------------------------------------------------------------*/ 451 | {fillg(); return(*pg++);} 452 | 453 | /*===========================================================================*/ 454 | char lookgchar(void) 455 | /*---------------------------------------------------------------------------- 456 | Fill the buffer string g and set pg = pointer to g (if needed), and then 457 | return a copy of the next character in the input, but don't advance pg. 458 | * -----------------------------------------------------------------------------*/ 459 | {fillg(); return(*pg);} 460 | 461 | /*===========================================================================*/ 462 | void fillg(void) 463 | /*---------------------------------------------------------------------------- 464 | Read a line into g[]. A line starting with a "/" is a comment line. 465 | -----------------------------------------------------------------------------*/ 466 | {while (pg>=pge) 467 | {sprompt: if (filep EQ stdin) {sprintf(sout,"%c",prompt); ourprint(sout);} 468 | if (fgetline(g,200,filep)<0) /* -1 result means EOF */ 469 | {*g = '\0'; pg= g; pge= g; return;} 470 | if (filep EQ stdin) {fprintf(logfilep,"%s\n",g); fflush(logfilep);} 471 | if (*g EQ '/') goto sprompt; 472 | pg= g; pge= g+strlen(g); *pge++= ' '; *pge= '\0'; prompt= '>'; 473 | } 474 | } 475 | 476 | 477 | /* ----------------------- 478 | / the problem is when / xxxxx is the last line! / 479 | 480 | /debug!!!!!/ else { ourprint(":"); ourprint(g); ourprint("&\n"); 481 | ourprint("g[0]"); 482 | sprintf(sout,"%c", *g); 483 | ourprint(sout); 484 | if (*g EQ '/') ourprint("> *g = /\n"); 485 | } 486 | ---------------- */ 487 | 488 | 489 | 490 | /*===========================================================================*/ 491 | int16 fgetline(char *s, int16 lim, FILE *stream) 492 | /*---------------------------------------------------------------------------- 493 | fgetline() gets a line (CRLF or LF delimited) from stream and puts it into s 494 | (up to lim chars). The function returns the length of this string. If there 495 | are no characters but just EOF, it returns -1 (EOF) as the length. There 496 | is no deblanking except to drop CR's and LF's ('\n') and map TABs to blanks. 497 | -----------------------------------------------------------------------------*/ 498 | {int16 c,i; 499 | #define TAB 9 500 | #define CR 13 501 | #define LF 10 502 | for (i=0; i= n) {j= 0; if (j EQ c) /* old: if (++c>1) */ 554 | error("atom table is full");} 555 | } 556 | 557 | strcpy(Atab[j].name,s); Atab[j].L= ud(j); 558 | ret: return(oa(j)); 559 | } 560 | 561 | /*===========================================================================*/ 562 | void swrite(int32 j) 563 | /*---------------------------------------------------------------------------- 564 | The S-expression pointed to by j is typed out. 565 | ----------------------------------------------------------------------------*/ 566 | {int32 i; 567 | int16 listsw; 568 | 569 | i= ptrv(j); 570 | switch (type(j)) 571 | {case 0: /* check for a list */ 572 | j= i; 573 | while (type(B(j)) EQ 0) j= B(j); 574 | listsw= (B(j) EQ nilptr); 575 | ourprint("("); 576 | while (listsw) 577 | {swrite(A(i)); if ((i= B(i)) EQ nilptr) goto close; ourprint(" ");} 578 | swrite(A(i)); ourprint(" . "); swrite(B(i)); 579 | close: ourprint(")"); 580 | break; 581 | 582 | case 8: ourprint(Atab[i].name); break; 583 | case 9: sprintf(sout,"%-g",Ntab[i].num); ourprint(sout); break; 584 | case 10: sprintf(sout,"{builtin function: %s}",Atab[i].name); 585 | ourprint(sout); break; 586 | case 11: sprintf(sout,"{builtin special form: %s}",Atab[i].name); 587 | ourprint(sout); break; 588 | case 12: sprintf(sout,"{user defined function: %s}",Atab[i].name); 589 | ourprint(sout); break; 590 | case 13: sprintf(sout,"{user defined special form: %s}",Atab[i].name); 591 | ourprint(sout); break; 592 | case 14: ourprint("{unnamed function}"); break; 593 | case 15: ourprint("{unnamed special form}"); break; 594 | } 595 | } 596 | 597 | /*===========================================================================*/ 598 | void traceprint(int32 v, int16 osw) 599 | /* int32 v; a typed-pointer to the object to be printed 600 | * int16 osw; 1 for seval() output, 0 for seval() input 601 | */ 602 | /*---------------------------------------------------------------------------- 603 | This function prints out the input and the result for each successive 604 | invocation of seval() when tracing is requested. 605 | ----------------------------------------------------------------------------*/ 606 | {if (tracesw>0) 607 | {if (osw EQ 1) sprintf(sout,"%d result:", ct--); 608 | else sprintf(sout,"%d seval:",++ct); 609 | ourprint(sout); swrite(v); ourprint("\n"); 610 | } 611 | } 612 | 613 | /*==========================================================================*/ 614 | int32 seval(int32 p) 615 | /*--------------------------------------------------------------------------- 616 | Evaluate the S-expression pointed to by the typed-pointer p; construct the 617 | result value as necessary; return a typed-pointer to the result. 618 | ---------------------------------------------------------------------------*/ 619 | {int32 ty,t,v,j,f,fa,na; 620 | /* I think t can be static. also fa and j? -test later. */ 621 | 622 | int32 *endeaL; 623 | static double s; 624 | 625 | #define U1 A(p) 626 | #define U2 A(B(p)) 627 | #define E1 A(p) 628 | #define E2 A(B(p)) 629 | 630 | #define Return(v) {traceprint(v,1); return(v);} 631 | 632 | traceprint(p,0); 633 | 634 | if(type(p)!=0) 635 | {/* p does not point to a non-atomic S-expression. 636 | * 637 | * If p is a type-8 typed pointer to an ordinary atom whose value is a 638 | * builtin or user-defined function or special form, then a typed-pointer 639 | * to that atom-table entry with typecode 10, 11, 12, or 13, depending upon 640 | * the value of the atom, is returned. Note that this permits us to know 641 | * the names of functions and special forms. 642 | * 643 | * if p is a type-8 typed pointer to an ordinary atom whose value is not a 644 | * builtin or user defined function or special form, and thus has the type- 645 | * code 8, 9, 14, or 15, then a typed-pointer corresponding to the value of 646 | * this atom is returned. 647 | * 648 | * if p is a non-type-8 typed-pointer to a number atom or to a function or 649 | * special form (named or unnamed), then the same pointer p is returned. 650 | */ 651 | 652 | if ((t= type(p))!=8) Return(p); j= ptrv(p); 653 | 654 | /* The association list is implemented with shallow binding in the atom- 655 | table, so the current values of all atoms are found in the atom table. */ 656 | 657 | if (Atab[j].name[0] EQ '!') 658 | {tracesw= (strcmp(Atab[j].name,"!TRACE") EQ 0)?1:0; longjmp(env,-1);} 659 | 660 | if ((t= type(Atab[j].L)) EQ 1) 661 | {sprintf(sout,"%s is undefined\n",Atab[j].name); error(sout);} 662 | 663 | if (namedfsf(t)) Return(tp(t<<28,j)); 664 | Return(Atab[j].L); 665 | } /* end of if (type(p)!=0) */ 666 | 667 | /* Save the list consisting of the current function and the supplied 668 | arguments as the top value of the currentin list to protect it 669 | from garbage collection. The currentin list is a list of lists. */ 670 | 671 | cilp= newloc(p,cilp); 672 | 673 | /* compute the function or special form to be applied */ 674 | tracesw-- ; f= seval(A(p)); tracesw++; ty= type(f); 675 | if (NOT fctform(ty)) error(" invalid function or special form"); 676 | f= ptrv(f); if (NOT unnamedfsf(ty)) f= ptrv(Atab[f].L); 677 | 678 | /* now let go of the supplied input function */ 679 | A(cilp)= p= B(p); 680 | 681 | /* If f is a function (not a special form), build a new list of its 682 | evaluated arguments and add it to the eaL list (the eaL list is a 683 | list of lists.) Then let go of the list of supplied arguments, 684 | replacing it with the new list of evaluated arguments */ 685 | if (fct(ty)) 686 | {/* compute the actual arguments */ 687 | eaLp= newloc(nilptr,eaLp); 688 | /* evaluate the actual arguments and build a list by tail-cons-ing! */ 689 | endeaL= &A(eaLp); 690 | while (p!=nilptr) 691 | {*endeaL= newloc(seval(A(p)),nilptr); endeaL= &B(*endeaL); p= B(p);} 692 | /* Set p to be the first node in the evaluated arguments list. */ 693 | p= A(eaLp); 694 | 695 | /* Throw away the current supplied arguments list by popping the 696 | currentin list */ 697 | cilp= B(cilp); 698 | } 699 | 700 | /* At this point p points to the first node of the actual argument 701 | list. if p EQ nilptr, we have a function or special form with no 702 | arguments */ 703 | if (NOT builtin(ty)) 704 | {/* f is a non-builtin function or non-builtin special form. do 705 | shallow binding of the arguments and evaluate the body of f by 706 | calling seval */ 707 | fa= A(f); /* fa points to the first node of the formal argument list */ 708 | na= 0; /* na counts the number of arguments */ 709 | /* run through the arguments and place them as the top values of 710 | the formal argument atoms in the atom-table. Push the old 711 | value of each formal argument on its binding list. */ 712 | if (type(fa) EQ 8 AND fa != nilptr) 713 | {/* This will bind the entire input actual arglist as the 714 | single actual arg. Sometimes, it is wrong - we should 715 | dereference the named fsf's in the p list, first. */ 716 | 717 | t=ptrv(fa); 718 | Atab[t].bl=newloc(Atab[t].L,Atab[t].bl); 719 | Atab[t].L=p; 720 | goto apply; 721 | } 722 | else 723 | while (p!=nilptr AND dottedpair(type(fa))) 724 | {t= ptrv(A(fa)); fa= B(fa); 725 | Atab[t].bl= newloc(Atab[t].L,Atab[t].bl); 726 | v= A(p); if (namedfsf(type(v))) v= Atab[ptrv(v)].L; 727 | Atab[t].L= v; ++na; p= B(p); 728 | } 729 | 730 | if (p!=nilptr) error("too many actual argumentss"); 731 | /* The following code would forbid some useful trickery. 732 | if (fa!=nilptr) error("too many formal arguments"); */ 733 | 734 | /* now apply the non-builtin special form or function */ 735 | apply: v= seval(B(f)); 736 | 737 | /* now unbind the actual arguments */ 738 | fa= A(f); 739 | if (type(fa) EQ 8 AND fa != nilptr) 740 | {t= ptrv(fa); Atab[t].L= A(Atab[t].bl); Atab[t].bl= B(Atab[t].bl);} 741 | else 742 | while (na-- > 0) 743 | {t= ptrv(A(fa)); fa= B(fa); 744 | Atab[t].L= A(Atab[t].bl); Atab[t].bl= B(Atab[t].bl); 745 | } 746 | } /* end non-builtins */ 747 | else 748 | {/* at this point we have a builtin function or special form. f 749 | is the pointer value of the atom in the atom table for the 750 | called function or special form and p is the pointer to the 751 | argument list.*/ 752 | 753 | v= nilptr; 754 | switch (f) /* begin builtins */ 755 | {case 1: /* CAR */ 756 | if (NOT dottedpair(type(E1))) error("illegal CAR argument"); 757 | v= A(E1); break; 758 | case 2: /* CDR */ 759 | if (NOT dottedpair(type(E1))) error("illegal CDR argument"); 760 | v= B(E1); break; 761 | case 3: /* CONS */ 762 | if (sexp(type(E1)) AND sexp(type(E2))) v= newloc(E1,E2); 763 | else error("Illegal CONS arguments"); 764 | break; 765 | 766 | /* for LAMBDA and SPECIAL, we could check that U1 is either an 767 | ordinary atom or a list of ordinary atoms */ 768 | case 4:/* LAMBDA */ v= tf(newloc(U1,U2)); break; 769 | case 5:/* SPECIAL */ v= ts(newloc(U1,U2)); break; 770 | case 6:/* SETQ */ 771 | f= U1; if (type(f)!=8) error("illegal assignment"); 772 | assign: v= ptrv(f); endeaL= &Atab[v].L; 773 | doit: t= seval(U2); 774 | switch (type(t)) 775 | {case 0: /* dotted pair */ 776 | case 8: /* ordinary atom */ 777 | case 9: /* number atom */ 778 | *endeaL= t; break; 779 | case 10: /* builtin function */ 780 | case 11: /* builtin special form */ 781 | case 12: /* user-defined function */ 782 | case 13: /* user-defined special form */ 783 | *endeaL= Atab[ptrv(t)].L; break; 784 | case 14: /* unnamed function */ 785 | *endeaL= uf(ptrv(t)); break; 786 | case 15: /* unamed special form */ 787 | *endeaL= us(ptrv(t)); break; 788 | } /* end of type(t) switch cases */ 789 | 790 | tracesw--; v= seval(f); tracesw++; break; 791 | 792 | case 7: /* ATOM */ 793 | if ((type(E1)) EQ 8 OR (type(E1)) EQ 9) v= tptr; break; 794 | 795 | case 8: /* NUMBERP */ 796 | if (type(E1) EQ 9) v= tptr; break; 797 | 798 | case 9: /* QUOTE */ v= U1; break; 799 | case 10: /* LIST */ v= p; break; 800 | case 11: /* DO */ while (p!=nilptr) {v= A(p); p= B(p);} break; 801 | 802 | case 12: /* COND */ 803 | while (p!=nilptr) 804 | {f = A(p); 805 | if (seval(A(f))!=nilptr) {v=seval(A(B(f))); break;} else p=B(p); 806 | } 807 | break; 808 | 809 | case 13: /* PLUS */ 810 | v= numatom(Ntab[ptrv(E1)].num+Ntab[ptrv(E2)].num); break; 811 | 812 | case 14: /* TIMES */ 813 | v= numatom(Ntab[ptrv(E1)].num*Ntab[ptrv(E2)].num); break; 814 | 815 | case 15: /* DIFFERENCE */ 816 | v= numatom(Ntab[ptrv(E1)].num-Ntab[ptrv(E2)].num); break; 817 | 818 | case 16: /* QUOTIENT */ 819 | v= numatom(Ntab[ptrv(E1)].num/Ntab[ptrv(E2)].num); break; 820 | 821 | case 17: /* POWER */ 822 | v= numatom(pow(Ntab[ptrv(E1)].num,Ntab[ptrv(E2)].num)); 823 | break; 824 | 825 | case 18: /* FLOOR */ v= numatom(floor(Ntab[ptrv(E1)].num)); break; 826 | case 19: /* MINUS */ v= numatom(-Ntab[ptrv(E1)].num); break; 827 | case 20: /* LESSP */ 828 | if(Ntab[ptrv(E1)].numNtab[ptrv(E2)].num) v= tptr; break; 832 | 833 | case 22: /* EVAL */ v= seval(E1); break; 834 | case 23: /* EQ */ v= (E1 EQ E2) ? tptr : nilptr; break; 835 | 836 | case 24: /* AND */ 837 | while (p!=nilptr AND seval(A(p))!=nilptr) p= B(p); 838 | if (p EQ nilptr) v= tptr; /* else v remains nilptr */ 839 | break; 840 | 841 | case 25: /* OR */ 842 | while (p!=nilptr AND seval(A(p)) EQ nilptr) p= B(p); 843 | if (p!=nilptr) v= tptr; /* else v remains nilptr */ 844 | break; 845 | 846 | case 26: /* SUM */ 847 | for (s= 0.0; p!=nilptr; s= s+Ntab[ptrv(A(p))].num, p= B(p)); 848 | v= numatom(s); break; 849 | 850 | case 27: /* PRODUCT */ 851 | for (s= 1.0; p!=nilptr; s= s*Ntab[ptrv(A(p))].num, p= B(p)); 852 | v= numatom(s); break; 853 | 854 | case 28: /* PUTPLIST */ v= E1; Atab[ptrv(v)].plist= E2; break; 855 | case 29: /* GETPLIST */ v= Atab[ptrv(E1)].plist; break; 856 | case 30: /* READ */ ourprint("\n!"); prompt= EOS; v= sread(); break; 857 | case 31: /* PRINT */ 858 | if (p EQ nilptr) ourprint(" "); 859 | else while (p!=nilptr) {swrite(A(p)); ourprint(" "); p= B(p);} 860 | break; 861 | 862 | case 32: /* PRINTCR */ 863 | if (p EQ nilptr) ourprint("\n"); 864 | else while (p!=nilptr) {swrite(A(p)); ourprint("\n"); p= B(p);} 865 | break; 866 | 867 | case 33: /* MKATOM */ 868 | strcpy(sout,Atab[ptrv(E1)].name); strcat(sout,Atab[ptrv(E2)].name); 869 | v= ordatom(sout); break; 870 | 871 | case 34: /* BODY */ 872 | if (unnamedfsf(type(E1))) v= ptrv(E1); 873 | else if (userdefd(type(E1))) v= ptrv(Atab[ptrv(E1)].L); 874 | else error("illegal BODY argument"); 875 | break; 876 | 877 | case 35: /* RPLACA */ 878 | v= E1; 879 | if (NOT dottedpair(type(v))) error("illegal RPLACA argument"); 880 | A(v)= E2; break; 881 | 882 | case 36: /* RPLACD */ 883 | v= E1; 884 | if (NOT dottedpair(type(v))) error("illegal RPLACD argument"); 885 | B(v)= E2; break; 886 | 887 | case 37: /* TSETQ */ 888 | /* Set the top-level value of U1 to seval(U2).*/ 889 | if (Atab[f= ptrv(U1)].bl EQ nilptr) goto assign; 890 | v= Atab[f].bl; while (B(v)!=nilptr) v= B(v); 891 | endeaL= &A(v); goto doit; 892 | 893 | case 38: /* NULL */ 894 | if (E1 EQ nilptr) v= tptr; break; 895 | 896 | case 39: /* SET */ 897 | f= seval(U1); goto assign; 898 | 899 | default: error("dryrot: bad builtin case number"); 900 | } /* end of switch cases */ 901 | 902 | } /* end builtins */ 903 | 904 | /* pop the eaL list or pop the currentin list, whichever is active */ 905 | if (fct(ty)) eaLp= B(eaLp); else cilp= B(cilp); 906 | 907 | Return(v); 908 | } 909 | 910 | /*========================================================================*/ 911 | int32 newloc(int32 x, int32 y) 912 | /*-------------------------------------------------------------------------- 913 | Allocates and loads the fields of a new location in the list area, with 914 | a()= X, b()= Y. The index of the new location is returned. 915 | -------------------------------------------------------------------------*/ 916 | {int32 j; 917 | 918 | if (fp<0) {gcmark(x); gcmark(y); gc(); if (fp<0) error("out of space");} 919 | j= fp; fp= B(j); A(j)= x; B(j)= y; numf--; return(j); 920 | } 921 | 922 | /*========================================================================*/ 923 | void gc(void) 924 | /*-------------------------------------------------------------------------- 925 | Garbage collector for number table and listarea 926 | --------------------------------------------------------------------------*/ 927 | {int32 i,t; 928 | 929 | #define marked(p) ((A(p) & 0x08000000)!=0) 930 | #define marknode(p) (A(p) |= 0x08000000) 931 | #define unmark(p) (A(p) &= 0xf7ffffff) 932 | 933 | for (i= 0; i11) 963 | 964 | start: 965 | t= type(p); 966 | if (listp(t)) 967 | {p=ptrv(p); if (marked(p)) return; t=A(p); marknode(p); 968 | if (NOT listp(type(t))) {marknum(type(t),t); p=B(p); goto start;} 969 | s=B(p); 970 | if (NOT listp(type(s))) {marknum(type(s),s); p=t; goto start;} 971 | gcmark(t); 972 | p=B(p); goto start; /* Equivalent to the recursive call: gcmark(B(p)) */ 973 | } 974 | else marknum(t,p); 975 | } 976 | 977 | -------------------------------------------------------------------------------- /Interpreting Lisp source code/lispinit: -------------------------------------------------------------------------------- 1 | /filename: lispinit revision date: March 1, 2017 2 | 3 | (SETQ APPEND (LAMBDA (X Y) (COND ((EQ X NIL) Y) 4 | ((ATOM X) (CONS X Y)) 5 | (T (CONS (CAR X) (APPEND (CDR X) Y)) )) )) 6 | 7 | (SETQ REVERSE (LAMBDA (X) (COND ((ATOM X) X) 8 | (T (APPEND (REVERSE (CDR X)) (CONS (CAR X) NIL )))) )) 9 | 10 | (SETQ EQUAL (LAMBDA (X Y) (COND ((OR (ATOM X) (ATOM Y)) (EQ X Y)) 11 | ((EQUAL (CAR X) (CAR Y)) (EQUAL (CDR X) (CDR Y))) 12 | (T NIL)) )) 13 | 14 | (SETQ EVALQUOTE (SPECIAL (X) (EVAL X))) 15 | 16 | (SETQ NOT NULL) 17 | 18 | (SETQ ZEROP (LAMBDA (X) (COND ((EQ X 0) T)))) 19 | 20 | (SETQ MEMBER (LAMBDA (A S) (COND ((EQ S NIL) NIL) ((EQUAL A (CAR S)) T) 21 | (T (MEMBER A (CDR S))) ))) 22 | 23 | (SETQ INTO (LAMBDA (G L) (COND ((NULL L) L) (T (CONS (G (CAR L)) 24 | (INTO G (CDR L))))))) 25 | 26 | (SETQ ONTO (LAMBDA (G L) (COND ((NULL L) L) (T (CONS (G L) 27 | (ONTO G (CDR L))))))) 28 | 29 | (SETQ APPLY (SPECIAL ($G $X) (EVAL (CONS $G $X)))) 30 | 31 | (SETQ SORT (LAMBDA (X) 32 | (COND ((NULL X) X) (T (MERGE (CAR X) (SORT (CDR X))))))) 33 | 34 | (SETQ MERGE (LAMBDA (V L) (COND ((OR (NULL L) (LESSP V (CAR L))) (CONS V L)) 35 | (T (CONS (CAR L) (MERGE V (CDR L))))))) 36 | 37 | (SETQ GETPROP (LAMBDA (A P) (ASSOC (GETPLIST A) P))) 38 | 39 | (SETQ ASSOC (LAMBDA (L P) (COND ((NULL L) NIL) 40 | (T (COND ((EQUAL P (CAR (CAR L))) (CDR (CAR L))) 41 | (T (ASSOC (CDR L) P))))))) 42 | 43 | (SETQ PUTPROP (LAMBDA (A P W) (PUTPLIST A 44 | (CONS (CONS P W) (GETPLIST (REMPROP A P W)))))) 45 | 46 | (SETQ REMPROP (LAMBDA (A P W) (PUTPLIST A (NAX (GETPLIST A) (CONS P W))))) 47 | 48 | (SETQ NAX (LAMBDA (L P) (COND 49 | ((NULL L) NIL) ((EQUAL (CAR L) P) (CDR L)) 50 | (T (DO (NX L P) L))))) 51 | 52 | (SETQ NX (LAMBDA (L P) (COND ((NULL (CDR L)) NIL) 53 | ((EQUAL P (CAR (CDR L))) (RPLACD L (CDR L)))))) 54 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/interpreting-lisp/a36effa31e422dec17d72f6c521b1767c414ff1d/LICENSE.txt -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Apress Source Code 2 | 3 | This repository accompanies [*Interpreting Lisp*](http://www.apress.com/9781484227060) by Gary D. Knott (Apress, 2017). 4 | 5 | [comment]: #cover 6 | 7 | 8 | Download the files as a zip using the green button, or clone the repository to your machine using Git. 9 | 10 | ## Releases 11 | 12 | Release v1.0 corresponds to the code in the published book, without corrections or updates. 13 | 14 | ## Contributions 15 | 16 | See the file Contributing.md for more information on how you can contribute to this repository. 17 | -------------------------------------------------------------------------------- /contributing.md: -------------------------------------------------------------------------------- 1 | # Contributing to Apress Source Code 2 | 3 | Copyright for Apress source code belongs to the author(s). However, under fair use you are encouraged to fork and contribute minor corrections and updates for the benefit of the author(s) and other readers. 4 | 5 | ## How to Contribute 6 | 7 | 1. Make sure you have a GitHub account. 8 | 2. Fork the repository for the relevant book. 9 | 3. Create a new branch on which to make your change, e.g. 10 | `git checkout -b my_code_contribution` 11 | 4. Commit your change. Include a commit message describing the correction. Please note that if your commit message is not clear, the correction will not be accepted. 12 | 5. Submit a pull request. 13 | 14 | Thank you for your contribution! --------------------------------------------------------------------------------