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