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