home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d524 / kamin.lha / Kamin / src.lzh / lisp.c < prev    next >
C/C++ Source or Header  |  1991-06-28  |  27KB  |  1,248 lines
  1. /* Output from p2c, the Pascal-to-C translator */
  2. /* From input file "lisp.p" */
  3.  
  4.  
  5. /*****************************************************************
  6.  *                     DECLARATIONS                              *
  7.  *****************************************************************/
  8.  
  9. #include <p2c/p2c.h>
  10.  
  11.  
  12. #define NAMELENG        20   /* Maximum length of a name */
  13. #define MAXNAMES        300   /* Maximum number of different names */
  14. #define MAXINPUT        4000   /* Maximum length of an input */
  15.  
  16. #define PROMPT          "-> "
  17. #define PROMPT2         "> "
  18. #define COMMENTCHAR     ";"
  19.  
  20. #define TABCODE         9   /* in ASCII */
  21.  
  22.  
  23. typedef Char NAMESTRING[NAMELENG];
  24.  
  25. /* a NAME is an index in printNames */
  26.  
  27. typedef enum {
  28.   IFOP, WHILEOP, SETOP, BEGINOP, PLUSOP, MINUSOP, TIMESOP, DIVOP, EQOP, LTOP,
  29.   GTOP, CONSOP, CAROP, CDROP, NUMBERPOP, SYMBOLPOP, LISTPOP, NULLPOP, PRINTOP
  30. } BUILTINOP;
  31.  
  32.  
  33. typedef enum {
  34.   NILSXP, NUMSXP, SYMSXP, LISTSXP
  35. } SEXPTYPE;
  36.  
  37. typedef struct SEXPREC {
  38.   SEXPTYPE sxptype;
  39.   union {
  40.     long intval;
  41.     short symval;
  42.     struct {
  43.       struct SEXPREC *carval, *cdrval;
  44.     } U3;
  45.   } UU;
  46. } SEXPREC;
  47.  
  48. typedef enum {
  49.   VALEXP, VAREXP, APEXP
  50. } EXPTYPE;
  51.  
  52. typedef struct EXPREC {
  53.   EXPTYPE etype;
  54.   union {
  55.     SEXPREC *sxp;
  56.     short varble;
  57.     struct {
  58.       short optr;
  59.       struct EXPLISTREC *args;
  60.     } U2;
  61.   } UU;
  62. } EXPREC;
  63.  
  64. typedef struct EXPLISTREC {
  65.   EXPREC *head;
  66.   struct EXPLISTREC *tail;
  67. } EXPLISTREC;
  68.  
  69. typedef struct VALUELISTREC {
  70.   SEXPREC *head;
  71.   struct VALUELISTREC *tail;
  72. } VALUELISTREC;
  73.  
  74. typedef struct NAMELISTREC {
  75.   short head;
  76.   struct NAMELISTREC *tail;
  77. } NAMELISTREC;
  78.  
  79. typedef struct ENVREC {
  80.   NAMELISTREC *vars;
  81.   VALUELISTREC *values;
  82. } ENVREC;
  83.  
  84. typedef struct FUNDEFREC {
  85.   short funname;
  86.   NAMELISTREC *formals;
  87.   EXPREC *body;
  88.   struct FUNDEFREC *nextfundef;
  89. } FUNDEFREC;
  90.  
  91.  
  92. Static FUNDEFREC *fundefs;
  93.  
  94. Static ENVREC *globalEnv;
  95.  
  96. Static EXPREC *currentExp;
  97.  
  98. Static Char userinput[MAXINPUT];
  99. Static short inputleng, pos_;
  100.  
  101. Static NAMESTRING printNames[MAXNAMES];
  102. Static short numNames, numBuiltins;
  103.  
  104. Static SEXPREC *nilValue, *trueValue;
  105.  
  106. Static boolean quittingtime;
  107.  
  108.  
  109. /*****************************************************************
  110.  *                     DATA STRUCTURE OP'S                       *
  111.  *****************************************************************/
  112.  
  113. /* mkVALEXP - return an EXP of type VALEXP with sxp s            */
  114. Static EXPREC *mkVALEXP(s)
  115. SEXPREC *s;
  116. {
  117.   EXPREC *e;
  118.  
  119.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  120.   e->etype = VALEXP;
  121.   e->UU.sxp = s;
  122.   return e;
  123. }  /* mkVALEXP */
  124.  
  125.  
  126. /* mkVAREXP - return an EXP of type VAREXP with varble nm        */
  127. Static EXPREC *mkVAREXP(nm)
  128. short nm;
  129. {
  130.   EXPREC *e;
  131.  
  132.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  133.   e->etype = VAREXP;
  134.   e->UU.varble = nm;
  135.   return e;
  136. }  /* mkVAREXP */
  137.  
  138.  
  139. /* mkAPEXP - return EXP of type APEXP w/ optr op and args el     */
  140. Static EXPREC *mkAPEXP(op, el)
  141. short op;
  142. EXPLISTREC *el;
  143. {
  144.   EXPREC *e;
  145.  
  146.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  147.   e->etype = APEXP;
  148.   e->UU.U2.optr = op;
  149.   e->UU.U2.args = el;
  150.   return e;
  151. }  /* mkAPEXP */
  152.  
  153.  
  154. /* mkSExp - return SEXP of type t (but no value)                 */
  155. Static SEXPREC *mkSExp(t)
  156. SEXPTYPE t;
  157. {
  158.   SEXPREC *s;
  159.  
  160.   s = (SEXPREC *)Malloc(sizeof(SEXPREC));
  161.   s->sxptype = t;
  162.   return s;
  163. }  /* mkSExp */
  164.  
  165.  
  166. /* mkExplist - return an EXPLIST with head e and tail el         */
  167. Static EXPLISTREC *mkExplist(e, el)
  168. EXPREC *e;
  169. EXPLISTREC *el;
  170. {
  171.   EXPLISTREC *newel;
  172.  
  173.   newel = (EXPLISTREC *)Malloc(sizeof(EXPLISTREC));
  174.   newel->head = e;
  175.   newel->tail = el;
  176.   return newel;
  177. }  /* mkExplist */
  178.  
  179.  
  180. /* mkNamelist - return a NAMELIST with head n and tail nl        */
  181. Static NAMELISTREC *mkNamelist(nm, nl)
  182. short nm;
  183. NAMELISTREC *nl;
  184. {
  185.   NAMELISTREC *newnl;
  186.  
  187.   newnl = (NAMELISTREC *)Malloc(sizeof(NAMELISTREC));
  188.   newnl->head = nm;
  189.   newnl->tail = nl;
  190.   return newnl;
  191. }  /* mkNamelist */
  192.  
  193.  
  194. /* mkValuelist - return an VALUELIST with head s and tail vl     */
  195. Static VALUELISTREC *mkValuelist(s, vl)
  196. SEXPREC *s;
  197. VALUELISTREC *vl;
  198. {
  199.   VALUELISTREC *newvl;
  200.  
  201.   newvl = (VALUELISTREC *)Malloc(sizeof(VALUELISTREC));
  202.   newvl->head = s;
  203.   newvl->tail = vl;
  204.   return newvl;
  205. }  /* mkValuelist */
  206.  
  207.  
  208. /* mkEnv - return an ENV with vars nl and values vl              */
  209. Static ENVREC *mkEnv(nl, vl)
  210. NAMELISTREC *nl;
  211. VALUELISTREC *vl;
  212. {
  213.   ENVREC *rho;
  214.  
  215.   rho = (ENVREC *)Malloc(sizeof(ENVREC));
  216.   rho->vars = nl;
  217.   rho->values = vl;
  218.   return rho;
  219. }  /* mkEnv */
  220.  
  221.  
  222. /* lengthVL - return length of VALUELIST vl                      */
  223. Static long lengthVL(vl)
  224. VALUELISTREC *vl;
  225. {
  226.   long i;
  227.  
  228.   i = 0;
  229.   while (vl != NULL) {
  230.     i++;
  231.     vl = vl->tail;
  232.   }
  233.   return i;
  234. }  /* lengthVL */
  235.  
  236.  
  237. /* lengthNL - return length of NAMELIST nl                       */
  238. Static long lengthNL(nl)
  239. NAMELISTREC *nl;
  240. {
  241.   long i;
  242.  
  243.   i = 0;
  244.   while (nl != NULL) {
  245.     i++;
  246.     nl = nl->tail;
  247.   }
  248.   return i;
  249. }  /* lengthNL */
  250.  
  251.  
  252. /*****************************************************************
  253.  *                     NAME MANAGEMENT                           *
  254.  *****************************************************************/
  255.  
  256. /* fetchFun - get function definition of fname from fundefs      */
  257. Static FUNDEFREC *fetchFun(fname)
  258. short fname;
  259. {
  260.   FUNDEFREC *f;
  261.   boolean found;
  262.  
  263.   found = false;
  264.   f = fundefs;
  265.   while (f != NULL && !found) {
  266.     if (f->funname == fname)
  267.       found = true;
  268.     else
  269.       f = f->nextfundef;
  270.   }
  271.   return f;
  272. }  /* fetchFun */
  273.  
  274.  
  275. /* newFunDef - add new function fname w/ parameters nl, body e   */
  276. Static Void newFunDef(fname, nl, e)
  277. short fname;
  278. NAMELISTREC *nl;
  279. EXPREC *e;
  280. {
  281.   FUNDEFREC *f;
  282.  
  283.   f = fetchFun(fname);
  284.   if (f == NULL) {   /* fname not yet defined as a function */
  285.     f = (FUNDEFREC *)Malloc(sizeof(FUNDEFREC));
  286.     f->nextfundef = fundefs;   /* place new FUNDEFREC */
  287.     fundefs = f;   /* on fundefs list */
  288.   }
  289.   f->funname = fname;
  290.   f->formals = nl;
  291.   f->body = e;
  292. }  /* newFunDef */
  293.  
  294.  
  295. /* initNames - place all pre-defined names into printNames       */
  296. Static Void initNames()
  297. {
  298.   long i;
  299.  
  300.   fundefs = NULL;
  301.   i = 1;
  302.   memcpy(printNames[i - 1], "if                  ", sizeof(NAMESTRING));
  303.   i++;
  304.   memcpy(printNames[i - 1], "while               ", sizeof(NAMESTRING));
  305.   i++;
  306.   memcpy(printNames[i - 1], "set                 ", sizeof(NAMESTRING));
  307.   i++;
  308.   memcpy(printNames[i - 1], "begin               ", sizeof(NAMESTRING));
  309.   i++;
  310.   memcpy(printNames[i - 1], "+                   ", sizeof(NAMESTRING));
  311.   i++;
  312.   memcpy(printNames[i - 1], "-                   ", sizeof(NAMESTRING));
  313.   i++;
  314.   memcpy(printNames[i - 1], "*                   ", sizeof(NAMESTRING));
  315.   i++;
  316.   memcpy(printNames[i - 1], "/                   ", sizeof(NAMESTRING));
  317.   i++;
  318.   memcpy(printNames[i - 1], "=                   ", sizeof(NAMESTRING));
  319.   i++;
  320.   memcpy(printNames[i - 1], "<                   ", sizeof(NAMESTRING));
  321.   i++;
  322.   memcpy(printNames[i - 1], ">                   ", sizeof(NAMESTRING));
  323.   i++;
  324.   memcpy(printNames[i - 1], "cons                ", sizeof(NAMESTRING));
  325.   i++;
  326.   memcpy(printNames[i - 1], "car                 ", sizeof(NAMESTRING));
  327.   i++;
  328.   memcpy(printNames[i - 1], "cdr                 ", sizeof(NAMESTRING));
  329.   i++;
  330.   memcpy(printNames[i - 1], "number?             ", sizeof(NAMESTRING));
  331.   i++;
  332.   memcpy(printNames[i - 1], "symbol?             ", sizeof(NAMESTRING));
  333.   i++;
  334.   memcpy(printNames[i - 1], "list?               ", sizeof(NAMESTRING));
  335.   i++;
  336.   memcpy(printNames[i - 1], "null?               ", sizeof(NAMESTRING));
  337.   i++;
  338.   memcpy(printNames[i - 1], "print               ", sizeof(NAMESTRING));
  339.   i++;
  340.   memcpy(printNames[i - 1], "T                   ", sizeof(NAMESTRING));
  341.   numNames = i;
  342.   numBuiltins = i;
  343. }  /* initNames */
  344.  
  345.  
  346. Static jmp_buf _JL99;
  347.  
  348.  
  349. /* install - insert new name into printNames                     */
  350. Static short install(nm)
  351. Char *nm;
  352. {
  353.   long i;
  354.   boolean found;
  355.  
  356.   i = 1;
  357.   found = false;
  358.   while (i <= numNames && !found) {
  359.     if (!memcmp(nm, printNames[i - 1], sizeof(NAMESTRING)))
  360.       found = true;
  361.     else
  362.       i++;
  363.   }
  364.   if (found)
  365.     return i;
  366.   if (i > MAXNAMES) {
  367.     printf("No more room for names\n");
  368.     longjmp(_JL99, 1);
  369.   }
  370.   numNames = i;
  371.   memcpy(printNames[i - 1], nm, sizeof(NAMESTRING));
  372.   return i;
  373. }  /* install */
  374.  
  375.  
  376. /* prName - print name nm                                        */
  377. Static Void prName(nm)
  378. short nm;
  379. {
  380.   long i;
  381.  
  382.   i = 1;
  383.   while (i <= NAMELENG) {
  384.     if (printNames[nm - 1][i - 1] != ' ') {
  385.       putchar(printNames[nm - 1][i - 1]);
  386.       i++;
  387.     } else
  388.       i = NAMELENG + 1;
  389.   }
  390. }  /* prName */
  391.  
  392.  
  393. /* primOp - translate NAME optr to corresponding BUILTINOP       */
  394. Static BUILTINOP primOp(optr)
  395. short optr;
  396. {
  397.   BUILTINOP op;
  398.   long i;
  399.  
  400.   op = IFOP;   /* N.B. IFOP is first value in BUILTINOPS */
  401.   for (i = 1; i < optr; i++)
  402.     op = (BUILTINOP)((long)op + 1);
  403.   return op;
  404. }  /* primOp */
  405.  
  406.  
  407. /*****************************************************************
  408.  *                        INPUT                                  *
  409.  *****************************************************************/
  410.  
  411. /* isDelim - check if c is a delimiter                           */
  412. Static boolean isDelim(c)
  413. Char c;
  414. {
  415.   return (c == ';' || c == ' ' || c == ')' || c == '(');
  416. }  /* isDelim */
  417.  
  418.  
  419. /* skipblanks - return next non-blank position in userinput      */
  420. Static long skipblanks(p)
  421. long p;
  422. {
  423.   while (userinput[p - 1] == ' ')
  424.     p++;
  425.   return p;
  426. }  /* skipblanks */
  427.  
  428.  
  429. /* matches - check if string nm matches userinput[s .. s+leng]   */
  430. Static boolean matches(s, leng, nm)
  431. long s;
  432. char leng;
  433. Char *nm;
  434. {
  435.   boolean match;
  436.   long i;
  437.  
  438.   match = true;
  439.   i = 1;
  440.   while (match && i <= leng) {
  441.     if (userinput[s - 1] != nm[i - 1])
  442.       match = false;
  443.     i++;
  444.     s++;
  445.   }
  446.   if (!isDelim(userinput[s - 1]))
  447.     match = false;
  448.   return match;
  449. }  /* matches */
  450.  
  451.  
  452. /* nextchar - read next char - filter tabs and comments          */
  453. Local Void nextchar(c)
  454. Char *c;
  455. {
  456.   Char STR1[256];
  457.  
  458.   *c = getchar();
  459.   if (*c == '\n')
  460.     *c = ' ';
  461.   if (*c == (Char)TABCODE) {
  462.     *c = ' ';
  463.     return;
  464.   }
  465.   sprintf(STR1, "%c", *c);
  466.   if (strcmp(STR1, COMMENTCHAR))
  467.     return;
  468.   while (!P_eoln(stdin)) {
  469.     *c = getchar();
  470.     if (*c == '\n')
  471.       *c = ' ';
  472.   }
  473.   *c = ' ';
  474. }  /* nextchar */
  475.  
  476. /* readParens - read char's, ignoring newlines, to matching ')'  */
  477. Local Void readParens()
  478. {
  479.   long parencnt;   /* current depth of parentheses */
  480.   Char c;
  481.  
  482.   parencnt = 1;   /* '(' just read */
  483.   do {
  484.     if (P_eoln(stdin))
  485.       fputs(PROMPT2, stdout);
  486.     nextchar(&c);
  487.     pos_++;
  488.     if (pos_ == MAXINPUT) {
  489.       printf("User input too long\n");
  490.       longjmp(_JL99, 1);
  491.     }
  492.     userinput[pos_ - 1] = c;
  493.     if (c == '(')
  494.       parencnt++;
  495.     if (c == ')')
  496.       parencnt--;
  497.   } while (parencnt != 0);   /* readParens */
  498. }
  499.  
  500. Local Void readInput()
  501. {
  502.   Char c;
  503.  
  504.   fputs(PROMPT, stdout);
  505.   pos_ = 0;
  506.   do {
  507.     pos_++;
  508.     if (pos_ == MAXINPUT) {
  509.       printf("User input too long\n");
  510.       longjmp(_JL99, 1);
  511.     }
  512.     nextchar(&c);
  513.     userinput[pos_ - 1] = c;
  514.     if (userinput[pos_ - 1] == '(')
  515.       readParens();
  516.   } while (!P_eoln(stdin));
  517.   inputleng = pos_;
  518.   userinput[pos_] = ';';   /* sentinel */
  519. }  /* readInput */
  520.  
  521.  
  522. /* reader - read char's into userinput; be sure input not blank  */
  523. Static Void reader()
  524. {
  525.  
  526.   /* readInput - read char's into userinput                        */
  527.   do {
  528.     readInput();
  529.     pos_ = skipblanks(1L);   /* ignore blank lines */
  530.   } while (pos_ > inputleng);   /* reader */
  531. }
  532.  
  533.  
  534. /* parseName - return (installed) NAME starting at userinput[pos]*/
  535. Static short parseName()
  536. {
  537.   NAMESTRING nm;   /* array to accumulate characters */
  538.   char leng;   /* length of name */
  539.  
  540.   leng = 0;
  541.   while ((pos_ <= inputleng) & (!isDelim(userinput[pos_ - 1]))) {
  542.     if (leng == NAMELENG) {
  543.       printf("Name too long, begins: %.*s\n", NAMELENG, nm);
  544.       longjmp(_JL99, 1);
  545.     }
  546.     leng++;
  547.     nm[leng - 1] = userinput[pos_ - 1];
  548.     pos_++;
  549.   }
  550.   if (leng == 0) {
  551.     printf("Error: expected name, instead read: %c\n", userinput[pos_ - 1]);
  552.     longjmp(_JL99, 1);
  553.   }
  554.   for (; leng < NAMELENG; leng++)
  555.     nm[leng] = ' ';
  556.   pos_ = skipblanks((long)pos_);   /* skip blanks after name */
  557.   return (install(nm));
  558. }  /* parseName */
  559.  
  560.  
  561. Local boolean isDigits(pos)
  562. long pos;
  563. {
  564.   boolean Result;
  565.  
  566.   if (!isdigit(userinput[pos - 1]))
  567.     return false;
  568.   Result = true;
  569.   while (isdigit(userinput[pos - 1]))
  570.     pos++;
  571.   if (!isDelim(userinput[pos - 1]))
  572.     return false;
  573.   return Result;
  574. }  /* isDigits */
  575.  
  576.  
  577. /* isNumber - check if a number begins at pos                    */
  578. Static boolean isNumber(pos)
  579. long pos;
  580. {
  581.  
  582.   /* isDigits - check if sequence of digits begins at pos          */
  583.   return (isDigits(pos) | ((userinput[pos - 1] == '-') & isDigits(pos + 1)));
  584. }  /* isNumber */
  585.  
  586.  
  587. /* isValue - check if a number or quoted const begins at pos     */
  588. Static boolean isValue(pos)
  589. long pos;
  590. {
  591.   return ((userinput[pos - 1] == '\'') | isNumber(pos));
  592. }  /* isValue */
  593.  
  594.  
  595. Local SEXPREC *parseSExp PV();
  596.  
  597. /* Local variables for parseSExp: */
  598. struct LOC_parseSExp {
  599.   SEXPREC *s;
  600. } ;
  601.  
  602. /* parseInt - return number starting at userinput[pos]           */
  603. Local SEXPREC *parseInt(LINK)
  604. struct LOC_parseSExp *LINK;
  605. {
  606.   long sum, sign;
  607.  
  608.   LINK->s = mkSExp(NUMSXP);
  609.   sum = 0;
  610.   sign = 1;
  611.   if (userinput[pos_ - 1] == '-') {
  612.     sign = -1;
  613.     pos_++;
  614.   }
  615.   while (isdigit(userinput[pos_ - 1])) {
  616.     sum = sum * 10 + userinput[pos_ - 1] - '0';
  617.     pos_++;
  618.   }
  619.   LINK->s->UU.intval = sum * sign;
  620.   pos_ = skipblanks((long)pos_);   /* skip blanks after number */
  621.   return LINK->s;
  622. }  /* parseInt */
  623.  
  624. /* parseSym - return symbol starting at userinput[pos]           */
  625. Local SEXPREC *parseSym(LINK)
  626. struct LOC_parseSExp *LINK;
  627. {
  628.   LINK->s = mkSExp(SYMSXP);
  629.   LINK->s->UU.symval = parseName();
  630.   return LINK->s;
  631. }  /* parseSym */
  632.  
  633. /* parseList - return list starting at userinput[pos]            */
  634. Local SEXPREC *parseList(LINK)
  635. struct LOC_parseSExp *LINK;
  636. {
  637.   SEXPREC *Result, *car, *cdr;
  638.  
  639.   if (userinput[pos_ - 1] == ')') {
  640.     Result = mkSExp(NILSXP);
  641.     pos_ = skipblanks(pos_ + 1L);
  642.     return Result;
  643.   } else {
  644.     car = parseSExp();
  645.     cdr = parseList(LINK);
  646.     LINK->s = mkSExp(LISTSXP);
  647.     LINK->s->UU.U3.carval = car;
  648.     LINK->s->UU.U3.cdrval = cdr;
  649.     return LINK->s;
  650.   }
  651.   return Result;
  652. }  /* parseList */
  653.  
  654. Local SEXPREC *parseSExp()
  655. {
  656.   struct LOC_parseSExp V;
  657.  
  658.   if (isNumber((long)pos_))
  659.     return (parseInt(&V));
  660.   else if (userinput[pos_ - 1] == '(') {
  661.     pos_ = skipblanks(pos_ + 1L);
  662.     return (parseList(&V));
  663.   } else
  664.     return (parseSym(&V));
  665. }  /* parseSExp */
  666.  
  667.  
  668. /* parseVal - return S-expression starting at userinput[pos]     */
  669. Static SEXPREC *parseVal()
  670. {
  671.  
  672.   /* parseSExp - return quoted S-expr starting at userinput[pos]   */
  673.   if (userinput[pos_ - 1] == '\'')
  674.     pos_++;
  675.   return (parseSExp());
  676. }  /* parseVal */
  677.  
  678.  
  679. Static EXPLISTREC *parseEL PV();
  680.  
  681.  
  682. /* parseExp - return EXP starting at userinput[pos]              */
  683. Static EXPREC *parseExp()
  684. {
  685.   short nm;
  686.   EXPLISTREC *el;
  687.  
  688.   if (userinput[pos_ - 1] == '(') {  /* APEXP */
  689.     pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  690.     nm = parseName();
  691.     el = parseEL();
  692.     return (mkAPEXP(nm, el));
  693.   } else if (isValue((long)pos_))
  694.     return (mkVALEXP(parseVal()));   /* VALEXP */
  695.   else
  696.     return (mkVAREXP(parseName()));   /* VAREXP */
  697. }  /* parseExp */
  698.  
  699.  
  700. /* parseEL - return EXPLIST starting at userinput[pos]           */
  701. Static EXPLISTREC *parseEL()
  702. {
  703.   EXPREC *e;
  704.   EXPLISTREC *el;
  705.  
  706.   if (userinput[pos_ - 1] == ')') {
  707.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  708.     return NULL;
  709.   } else {
  710.     e = parseExp();
  711.     el = parseEL();
  712.     return (mkExplist(e, el));
  713.   }
  714. }  /* parseEL */
  715.  
  716.  
  717. /* parseNL - return NAMELIST starting at userinput[pos]          */
  718. Static NAMELISTREC *parseNL()
  719. {
  720.   short nm;
  721.   NAMELISTREC *nl;
  722.  
  723.   if (userinput[pos_ - 1] == ')') {
  724.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  725.     return NULL;
  726.   } else {
  727.     nm = parseName();
  728.     nl = parseNL();
  729.     return (mkNamelist(nm, nl));
  730.   }
  731. }  /* parseNL */
  732.  
  733.  
  734. /* parseDef - parse function definition at userinput[pos]        */
  735. Static short parseDef()
  736. {
  737.   short fname;   /* function name */
  738.   NAMELISTREC *nl;   /* formal parameters */
  739.   EXPREC *e;   /* body */
  740.  
  741.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  742.   pos_ = skipblanks(pos_ + 6L);   /* skip 'define ..' */
  743.   fname = parseName();
  744.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  745.   nl = parseNL();
  746.   e = parseExp();
  747.   pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  748.   newFunDef(fname, nl, e);
  749.   return fname;
  750. }  /* parseDef */
  751.  
  752.  
  753. /*****************************************************************
  754.  *                     ENVIRONMENTS                              *
  755.  *****************************************************************/
  756.  
  757. /* emptyEnv - return an environment with no bindings             */
  758. Static ENVREC *emptyEnv()
  759. {
  760.   return (mkEnv(NULL, NULL));
  761. }  /* emptyEnv */
  762.  
  763.  
  764. /* bindVar - bind variable nm to value s in environment rho      */
  765. Static Void bindVar(nm, s, rho)
  766. short nm;
  767. SEXPREC *s;
  768. ENVREC *rho;
  769. {
  770.   rho->vars = mkNamelist(nm, rho->vars);
  771.   rho->values = mkValuelist(s, rho->values);
  772. }  /* bindVar */
  773.  
  774.  
  775. /* findVar - look up nm in rho                                   */
  776. Static VALUELISTREC *findVar(nm, rho)
  777. short nm;
  778. ENVREC *rho;
  779. {
  780.   NAMELISTREC *nl;
  781.   VALUELISTREC *vl;
  782.   boolean found;
  783.  
  784.   found = false;
  785.   nl = rho->vars;
  786.   vl = rho->values;
  787.   while (nl != NULL && !found) {
  788.     if (nl->head == nm)
  789.       found = true;
  790.     else {
  791.       nl = nl->tail;
  792.       vl = vl->tail;
  793.     }
  794.   }
  795.   return vl;
  796. }  /* findVar */
  797.  
  798.  
  799. /* assign - assign value s to variable nm in rho                 */
  800. Static Void assign(nm, s, rho)
  801. short nm;
  802. SEXPREC *s;
  803. ENVREC *rho;
  804. {
  805.   VALUELISTREC *varloc;
  806.  
  807.   varloc = findVar(nm, rho);
  808.   varloc->head = s;
  809. }  /* assign */
  810.  
  811.  
  812. /* fetch - return SEXP bound to nm in rho                        */
  813. Static SEXPREC *fetch(nm, rho)
  814. short nm;
  815. ENVREC *rho;
  816. {
  817.   VALUELISTREC *vl;
  818.  
  819.   vl = findVar(nm, rho);
  820.   return (vl->head);
  821. }  /* fetch */
  822.  
  823.  
  824. /* isBound - check if nm is bound in rho                         */
  825. Static boolean isBound(nm, rho)
  826. short nm;
  827. ENVREC *rho;
  828. {
  829.   return (findVar(nm, rho) != NULL);
  830. }  /* isBound */
  831.  
  832.  
  833. /*****************************************************************
  834.  *                     S-EXPRESSIONS                             *
  835.  *****************************************************************/
  836.  
  837. /* prValue - print S-expression s                                */
  838. Static Void prValue(s)
  839. SEXPREC *s;
  840. {
  841.   SEXPREC *s1;
  842.  
  843.   switch (s->sxptype) {
  844.  
  845.   case NILSXP:
  846.     printf("()");
  847.     break;
  848.  
  849.   case NUMSXP:
  850.     printf("%ld", s->UU.intval);
  851.     break;
  852.  
  853.   case SYMSXP:
  854.     prName(s->UU.symval);
  855.     break;
  856.  
  857.   case LISTSXP:
  858.     putchar('(');
  859.     prValue(s->UU.U3.carval);
  860.     s1 = s->UU.U3.cdrval;
  861.     while (s1->sxptype == LISTSXP) {
  862.       putchar(' ');
  863.       prValue(s1->UU.U3.carval);
  864.       s1 = s1->UU.U3.cdrval;
  865.     }
  866.     putchar(')');
  867.     break;
  868.   }/* case and with */
  869. }  /* prValue */
  870.  
  871.  
  872. /* isTrueVal - return true if s is true (non-NIL) value          */
  873. Static boolean isTrueVal(s)
  874. SEXPREC *s;
  875. {
  876.   return (s->sxptype != NILSXP);
  877. }  /* isTrueVal */
  878.  
  879.  
  880. /* Local variables for applyValueOp: */
  881. struct LOC_applyValueOp {
  882.   BUILTINOP op;
  883.   SEXPREC *result;
  884. } ;
  885.  
  886. /* applyArithOp - apply binary, arithmetic VALUEOP to arguments  */
  887. Local Void applyArithOp(n1, n2, LINK)
  888. long n1, n2;
  889. struct LOC_applyValueOp *LINK;
  890. {
  891.   SEXPREC *WITH;
  892.  
  893.   LINK->result = mkSExp(NUMSXP);
  894.   WITH = LINK->result;
  895.   switch (LINK->op) {
  896.  
  897.   case PLUSOP:
  898.     WITH->UU.intval = n1 + n2;
  899.     break;
  900.  
  901.   case MINUSOP:
  902.     WITH->UU.intval = n1 - n2;
  903.     break;
  904.  
  905.   case TIMESOP:
  906.     WITH->UU.intval = n1 * n2;
  907.     break;
  908.  
  909.   case DIVOP:
  910.     WITH->UU.intval = n1 / n2;
  911.     break;
  912.   }
  913. }  /* applyArithOp */
  914.  
  915. /* applyRelOp - apply binary, relational VALUEOP to arguments    */
  916. Local Void applyRelOp(n1, n2, LINK)
  917. long n1, n2;
  918. struct LOC_applyValueOp *LINK;
  919. {
  920.   switch (LINK->op) {
  921.  
  922.   case LTOP:
  923.     if (n1 < n2)
  924.       LINK->result = trueValue;
  925.     break;
  926.  
  927.   case GTOP:
  928.     if (n1 > n2)
  929.       LINK->result = trueValue;
  930.     break;
  931.   }
  932. }  /* applyRelOp */
  933.  
  934. /* arity - return number of arguments expected by op             */
  935. Local long arity(op, LINK)
  936. BUILTINOP op;
  937. struct LOC_applyValueOp *LINK;
  938. {
  939.   if (((1L << ((long)op)) &
  940.        ((1 << ((long)CONSOP + 1)) - (1 << ((long)PLUSOP)))) != 0)
  941.     return 2;
  942.   else
  943.     return 1;
  944. }  /* arity */
  945.  
  946.  
  947. /* applyValueOp - apply VALUEOP op to arguments in VALUELIST vl  */
  948. Static SEXPREC *applyValueOp(op_, vl)
  949. BUILTINOP op_;
  950. VALUELISTREC *vl;
  951. {
  952.   struct LOC_applyValueOp V;
  953.   SEXPREC *s1, *s2, *WITH1;
  954.  
  955.   V.op = op_;
  956.   if (arity(V.op, &V) != lengthVL(vl)) {
  957.     printf("Wrong number of arguments to ");
  958.     prName((int)V.op + 1);
  959.     putchar('\n');
  960.     longjmp(_JL99, 1);
  961.   }
  962.   V.result = nilValue;
  963.   s1 = vl->head;   /* 1st actual */
  964.   if (arity(V.op, &V) == 2)   /* 2nd actual */
  965.     s2 = vl->tail->head;
  966.   if (((1L << ((long)V.op)) &
  967.        (((1L << ((long)DIVOP + 1)) - (1 << ((long)PLUSOP))) |
  968.     ((1 << ((long)GTOP + 1)) - (1 << ((long)LTOP))))) != 0) {
  969.     if (s1->sxptype == NUMSXP && s2->sxptype == NUMSXP) {
  970.       if (((1L << ((long)V.op)) &
  971.        ((1 << ((long)DIVOP + 1)) - (1 << ((long)PLUSOP)))) != 0)
  972.     applyArithOp(s1->UU.intval, s2->UU.intval, &V);
  973.       else
  974.     applyRelOp(s1->UU.intval, s2->UU.intval, &V);
  975.       return V.result;
  976.     }
  977.     printf("Non-arithmetic arguments to ");
  978.     prName((int)V.op + 1);
  979.     putchar('\n');
  980.     longjmp(_JL99, 1);
  981.     return V.result;
  982.   }
  983.   switch (V.op) {
  984.  
  985.   case EQOP:
  986.     if (s1->sxptype == NILSXP && s2->sxptype == NILSXP)
  987.       V.result = trueValue;
  988.     else if (s1->sxptype == NUMSXP && s2->sxptype == NUMSXP &&
  989.          s1->UU.intval == s2->UU.intval)
  990.       V.result = trueValue;
  991.     else if (s1->sxptype == SYMSXP && s2->sxptype == SYMSXP &&
  992.          s1->UU.symval == s2->UU.symval)
  993.       V.result = trueValue;
  994.     break;
  995.  
  996.   case CONSOP:
  997.     V.result = mkSExp(LISTSXP);
  998.     WITH1 = V.result;
  999.     WITH1->UU.U3.carval = s1;
  1000.     WITH1->UU.U3.cdrval = s2;
  1001.     break;
  1002.  
  1003.   case CAROP:
  1004.     if (s1->sxptype != LISTSXP) {
  1005.       printf("Error: car applied to non-list: ");
  1006.       prValue(s1);
  1007.       putchar('\n');
  1008.     } else
  1009.       V.result = s1->UU.U3.carval;
  1010.     break;
  1011.  
  1012.   case CDROP:
  1013.     if (s1->sxptype != LISTSXP) {
  1014.       printf("Error: cdr applied to non-list: ");
  1015.       prValue(s1);
  1016.       putchar('\n');
  1017.     } else
  1018.       V.result = s1->UU.U3.cdrval;
  1019.     break;
  1020.  
  1021.   case NUMBERPOP:
  1022.     if (s1->sxptype == NUMSXP)
  1023.       V.result = trueValue;
  1024.     break;
  1025.  
  1026.   case SYMBOLPOP:
  1027.     if (s1->sxptype == SYMSXP)
  1028.       V.result = trueValue;
  1029.     break;
  1030.  
  1031.   case LISTPOP:
  1032.     if (s1->sxptype == LISTSXP)
  1033.       V.result = trueValue;
  1034.     break;
  1035.  
  1036.   case NULLPOP:
  1037.     if (s1->sxptype == NILSXP)
  1038.       V.result = trueValue;
  1039.     break;
  1040.  
  1041.   case PRINTOP:
  1042.     prValue(s1);
  1043.     putchar('\n');
  1044.     V.result = s1;
  1045.     break;
  1046.   }/* case and with */
  1047.   return V.result;
  1048. }  /* applyValueOp */
  1049.  
  1050.  
  1051. Static SEXPREC *eval PP((EXPREC *e, ENVREC *rho));
  1052.  
  1053. /* Local variables for eval: */
  1054. struct LOC_eval {
  1055.   ENVREC *rho;
  1056. } ;
  1057.  
  1058. /* evalList - evaluate each expression in el                     */
  1059. Local VALUELISTREC *evalList(el, LINK)
  1060. EXPLISTREC *el;
  1061. struct LOC_eval *LINK;
  1062. {
  1063.   SEXPREC *h;
  1064.   VALUELISTREC *t;
  1065.  
  1066.   if (el == NULL)
  1067.     return NULL;
  1068.   else {
  1069.     h = eval(el->head, LINK->rho);
  1070.     t = evalList(el->tail, LINK);
  1071.     return (mkValuelist(h, t));
  1072.   }
  1073. }  /* evalList */
  1074.  
  1075. /* applyUserFun - look up definition of nm and apply to actuals  */
  1076. Local SEXPREC *applyUserFun(nm, actuals, LINK)
  1077. short nm;
  1078. VALUELISTREC *actuals;
  1079. struct LOC_eval *LINK;
  1080. {
  1081.   FUNDEFREC *f;
  1082.   ENVREC *rho;
  1083.  
  1084.   f = fetchFun(nm);
  1085.   if (f == NULL) {
  1086.     printf("Undefined function: ");
  1087.     prName(nm);
  1088.     putchar('\n');
  1089.     longjmp(_JL99, 1);
  1090.   }
  1091.   if (lengthNL(f->formals) != lengthVL(actuals)) {
  1092.     printf("Wrong number of arguments to: ");
  1093.     prName(nm);
  1094.     putchar('\n');
  1095.     longjmp(_JL99, 1);
  1096.   }
  1097.   rho = mkEnv(f->formals, actuals);
  1098.   return (eval(f->body, rho));
  1099. }  /* applyUserFun */
  1100.  
  1101. /* applyCtrlOp - apply CONTROLOP op to args in rho               */
  1102. Local SEXPREC *applyCtrlOp(op, args, LINK)
  1103. BUILTINOP op;
  1104. EXPLISTREC *args;
  1105. struct LOC_eval *LINK;
  1106. {
  1107.   SEXPREC *Result, *s;
  1108.   EXPLISTREC *WITH;
  1109.  
  1110.   WITH = args;
  1111.   switch (op) {
  1112.  
  1113.   case IFOP:
  1114.     if (isTrueVal(eval(WITH->head, LINK->rho)))
  1115.       Result = eval(WITH->tail->head, LINK->rho);
  1116.     else
  1117.       Result = eval(WITH->tail->tail->head, LINK->rho);
  1118.     break;
  1119.  
  1120.   case WHILEOP:
  1121.     s = eval(WITH->head, LINK->rho);
  1122.     while (isTrueVal(s)) {
  1123.       s = eval(WITH->tail->head, LINK->rho);
  1124.       s = eval(WITH->head, LINK->rho);
  1125.     }
  1126.     Result = s;
  1127.     break;
  1128.  
  1129.   case SETOP:
  1130.     s = eval(WITH->tail->head, LINK->rho);
  1131.     if (isBound(WITH->head->UU.varble, LINK->rho))
  1132.       assign(WITH->head->UU.varble, s, LINK->rho);
  1133.     else if (isBound(WITH->head->UU.varble, globalEnv))
  1134.       assign(WITH->head->UU.varble, s, globalEnv);
  1135.     else
  1136.       bindVar(WITH->head->UU.varble, s, globalEnv);
  1137.     Result = s;
  1138.     break;
  1139.  
  1140.   case BEGINOP:
  1141.     while (args->tail != NULL) {
  1142.       s = eval(args->head, LINK->rho);
  1143.       args = args->tail;
  1144.     }
  1145.     Result = eval(args->head, LINK->rho);
  1146.     break;
  1147.   }/* case and with */
  1148.   return Result;
  1149. }  /* applyCtrlOp */
  1150.  
  1151.  
  1152. /*****************************************************************
  1153.  *                     EVALUATION                                *
  1154.  *****************************************************************/
  1155.  
  1156. /* eval - return value of expression e in local environment rho  */
  1157. Static SEXPREC *eval(e, rho_)
  1158. EXPREC *e;
  1159. ENVREC *rho_;
  1160. {
  1161.   struct LOC_eval V;
  1162.   SEXPREC *Result;
  1163.   BUILTINOP op;
  1164.  
  1165.   V.rho = rho_;
  1166.   switch (e->etype) {
  1167.  
  1168.   case VALEXP:
  1169.     Result = e->UU.sxp;
  1170.     break;
  1171.  
  1172.   case VAREXP:
  1173.     if (isBound(e->UU.varble, V.rho))
  1174.       Result = fetch(e->UU.varble, V.rho);
  1175.     else if (isBound(e->UU.varble, globalEnv))
  1176.       Result = fetch(e->UU.varble, globalEnv);
  1177.     else {
  1178.       printf("Undefined variable: ");
  1179.       prName(e->UU.varble);
  1180.       putchar('\n');
  1181.       longjmp(_JL99, 1);
  1182.     }
  1183.     break;
  1184.  
  1185.   case APEXP:
  1186.     if (e->UU.U2.optr > numBuiltins)
  1187.       Result = applyUserFun(e->UU.U2.optr, evalList(e->UU.U2.args, &V), &V);
  1188.     else {
  1189.       op = primOp(e->UU.U2.optr);
  1190.       if (((1L << ((long)op)) &
  1191.        ((1 << ((long)BEGINOP + 1)) - (1 << ((long)IFOP)))) != 0)
  1192.     Result = applyCtrlOp(op, e->UU.U2.args, &V);
  1193.       else
  1194.     Result = applyValueOp(op, evalList(e->UU.U2.args, &V));
  1195.     }
  1196.     break;
  1197.   }/* case and with */
  1198.   return Result;
  1199. }  /* eval */
  1200.  
  1201.  
  1202. /*****************************************************************
  1203.  *                     READ-EVAL-PRINT LOOP                      *
  1204.  *****************************************************************/
  1205.  
  1206. main(argc, argv)
  1207. int argc;
  1208. Char *argv[];
  1209. {  /* lisp main */
  1210.   PASCAL_MAIN(argc, argv);
  1211.   if (setjmp(_JL99))
  1212.     goto _L99;
  1213.   initNames();
  1214.  
  1215.   nilValue = mkSExp(NILSXP);
  1216.   trueValue = mkSExp(SYMSXP);
  1217.   trueValue->UU.symval = numNames;
  1218.  
  1219.   globalEnv = emptyEnv();
  1220.  
  1221.   quittingtime = false;
  1222. _L99:
  1223.   while (!quittingtime) {
  1224.     reader();
  1225.     if (matches((long)pos_, 4, "quit                ")) {
  1226.       quittingtime = true;
  1227.       break;
  1228.     }
  1229.     if ((userinput[pos_ - 1] == '(') & matches(skipblanks(pos_ + 1L), 6,
  1230.                            "define              ")) {
  1231.       prName(parseDef());
  1232.       putchar('\n');
  1233.     } else {
  1234.       currentExp = parseExp();
  1235.       prValue(eval(currentExp, emptyEnv()));
  1236.       printf("\n\n");
  1237.     }
  1238.   }  /* while */
  1239.   exit(0);
  1240. }  /* lisp */
  1241.  
  1242.  
  1243.  
  1244.  
  1245.  
  1246.  
  1247. /* End. */
  1248.