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 / chap1.c < prev    next >
C/C++ Source or Header  |  1991-06-28  |  21KB  |  1,004 lines
  1. /* Output from p2c, the Pascal-to-C translator */
  2. /* From input file "chap1.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        100   /* Maximum number of different names */
  14. #define MAXINPUT        500   /* 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, PRINTOP
  30. } BUILTINOP;
  31.  
  32.  
  33. typedef enum {
  34.   VALEXP, VAREXP, APEXP
  35. } EXPTYPE;
  36.  
  37. typedef struct EXPREC {
  38.   EXPTYPE etype;
  39.   union {
  40.     long num;
  41.     char varble;
  42.     struct {
  43.       char optr;
  44.       struct EXPLISTREC *args;
  45.     } U2;
  46.   } UU;
  47. } EXPREC;
  48.  
  49. typedef struct EXPLISTREC {
  50.   EXPREC *head;
  51.   struct EXPLISTREC *tail;
  52. } EXPLISTREC;
  53.  
  54. typedef struct VALUELISTREC {
  55.   long head;
  56.   struct VALUELISTREC *tail;
  57. } VALUELISTREC;
  58.  
  59. typedef struct NAMELISTREC {
  60.   char head;
  61.   struct NAMELISTREC *tail;
  62. } NAMELISTREC;
  63.  
  64. typedef struct ENVREC {
  65.   NAMELISTREC *vars;
  66.   VALUELISTREC *values;
  67. } ENVREC;
  68.  
  69. typedef struct FUNDEFREC {
  70.   char funname;
  71.   NAMELISTREC *formals;
  72.   EXPREC *body;
  73.   struct FUNDEFREC *nextfundef;
  74. } FUNDEFREC;
  75.  
  76.  
  77. Static FUNDEFREC *fundefs;
  78.  
  79. Static ENVREC *globalEnv;
  80.  
  81. Static EXPREC *currentExp;
  82.  
  83. Static Char userinput[MAXINPUT];
  84. Static short inputleng, pos_;
  85.  
  86. Static NAMESTRING printNames[MAXNAMES];
  87. Static char numNames, numBuiltins;
  88.  
  89. Static boolean quittingtime;
  90.  
  91.  
  92. /*****************************************************************
  93.  *                     DATA STRUCTURE OP'S                       *
  94.  *****************************************************************/
  95.  
  96. /* mkVALEXP - return an EXP of type VALEXP with num n            */
  97. Static EXPREC *mkVALEXP(n)
  98. long n;
  99. {
  100.   EXPREC *e;
  101.  
  102.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  103.   e->etype = VALEXP;
  104.   e->UU.num = n;
  105.   return e;
  106. }  /* mkVALEXP */
  107.  
  108.  
  109. /* mkVAREXP - return an EXP of type VAREXP with varble nm        */
  110. Static EXPREC *mkVAREXP(nm)
  111. char nm;
  112. {
  113.   EXPREC *e;
  114.  
  115.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  116.   e->etype = VAREXP;
  117.   e->UU.varble = nm;
  118.   return e;
  119. }  /* mkVAREXP */
  120.  
  121.  
  122. /* mkAPEXP - return EXP of type APEXP w/ optr op and args el     */
  123. Static EXPREC *mkAPEXP(op, el)
  124. char op;
  125. EXPLISTREC *el;
  126. {
  127.   EXPREC *e;
  128.  
  129.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  130.   e->etype = APEXP;
  131.   e->UU.U2.optr = op;
  132.   e->UU.U2.args = el;
  133.   return e;
  134. }  /* mkAPEXP */
  135.  
  136.  
  137. /* mkExplist - return an EXPLIST with head e and tail el         */
  138. Static EXPLISTREC *mkExplist(e, el)
  139. EXPREC *e;
  140. EXPLISTREC *el;
  141. {
  142.   EXPLISTREC *newel;
  143.  
  144.   newel = (EXPLISTREC *)Malloc(sizeof(EXPLISTREC));
  145.   newel->head = e;
  146.   newel->tail = el;
  147.   return newel;
  148. }  /* mkExplist */
  149.  
  150.  
  151. /* mkNamelist - return a NAMELIST with head n and tail nl        */
  152. Static NAMELISTREC *mkNamelist(nm, nl)
  153. char nm;
  154. NAMELISTREC *nl;
  155. {
  156.   NAMELISTREC *newnl;
  157.  
  158.   newnl = (NAMELISTREC *)Malloc(sizeof(NAMELISTREC));
  159.   newnl->head = nm;
  160.   newnl->tail = nl;
  161.   return newnl;
  162. }  /* mkNamelist */
  163.  
  164.  
  165. /* mkValuelist - return an VALUELIST with head n and tail vl     */
  166. Static VALUELISTREC *mkValuelist(n, vl)
  167. long n;
  168. VALUELISTREC *vl;
  169. {
  170.   VALUELISTREC *newvl;
  171.  
  172.   newvl = (VALUELISTREC *)Malloc(sizeof(VALUELISTREC));
  173.   newvl->head = n;
  174.   newvl->tail = vl;
  175.   return newvl;
  176. }  /* mkValuelist */
  177.  
  178.  
  179. /* mkEnv - return an ENV with vars nl and values vl              */
  180. Static ENVREC *mkEnv(nl, vl)
  181. NAMELISTREC *nl;
  182. VALUELISTREC *vl;
  183. {
  184.   ENVREC *rho;
  185.  
  186.   rho = (ENVREC *)Malloc(sizeof(ENVREC));
  187.   rho->vars = nl;
  188.   rho->values = vl;
  189.   return rho;
  190. }  /* mkEnv */
  191.  
  192.  
  193. /* lengthVL - return length of VALUELIST vl                      */
  194. Static long lengthVL(vl)
  195. VALUELISTREC *vl;
  196. {
  197.   long i;
  198.  
  199.   i = 0;
  200.   while (vl != NULL) {
  201.     i++;
  202.     vl = vl->tail;
  203.   }
  204.   return i;
  205. }  /* lengthVL */
  206.  
  207.  
  208. /* lengthNL - return length of NAMELIST nl                       */
  209. Static long lengthNL(nl)
  210. NAMELISTREC *nl;
  211. {
  212.   long i;
  213.  
  214.   i = 0;
  215.   while (nl != NULL) {
  216.     i++;
  217.     nl = nl->tail;
  218.   }
  219.   return i;
  220. }  /* lengthNL */
  221.  
  222.  
  223. /*****************************************************************
  224.  *                     NAME MANAGEMENT                           *
  225.  *****************************************************************/
  226.  
  227. /* fetchFun - get function definition of fname from fundefs      */
  228. Static FUNDEFREC *fetchFun(fname)
  229. char fname;
  230. {
  231.   FUNDEFREC *f;
  232.   boolean found;
  233.  
  234.   found = false;
  235.   f = fundefs;
  236.   while (f != NULL && !found) {
  237.     if (f->funname == fname)
  238.       found = true;
  239.     else
  240.       f = f->nextfundef;
  241.   }
  242.   return f;
  243. }  /* fetchFun */
  244.  
  245.  
  246. /* newFunDef - add new function fname w/ parameters nl, body e   */
  247. Static Void newFunDef(fname, nl, e)
  248. char fname;
  249. NAMELISTREC *nl;
  250. EXPREC *e;
  251. {
  252.   FUNDEFREC *f;
  253.  
  254.   f = fetchFun(fname);
  255.   if (f == NULL) {   /* fname not yet defined as a function */
  256.     f = (FUNDEFREC *)Malloc(sizeof(FUNDEFREC));
  257.     f->nextfundef = fundefs;   /* place new FUNDEFREC */
  258.     fundefs = f;   /* on fundefs list */
  259.   }
  260.   f->funname = fname;
  261.   f->formals = nl;
  262.   f->body = e;
  263. }  /* newFunDef */
  264.  
  265.  
  266. /* initNames - place all pre-defined names into printNames       */
  267. Static Void initNames()
  268. {
  269.   long i;
  270.  
  271.   fundefs = NULL;
  272.   i = 1;
  273.   memcpy(printNames[i - 1], "if                  ", sizeof(NAMESTRING));
  274.   i++;
  275.   memcpy(printNames[i - 1], "while               ", sizeof(NAMESTRING));
  276.   i++;
  277.   memcpy(printNames[i - 1], "set                 ", sizeof(NAMESTRING));
  278.   i++;
  279.   memcpy(printNames[i - 1], "begin               ", sizeof(NAMESTRING));
  280.   i++;
  281.   memcpy(printNames[i - 1], "+                   ", sizeof(NAMESTRING));
  282.   i++;
  283.   memcpy(printNames[i - 1], "-                   ", sizeof(NAMESTRING));
  284.   i++;
  285.   memcpy(printNames[i - 1], "*                   ", sizeof(NAMESTRING));
  286.   i++;
  287.   memcpy(printNames[i - 1], "/                   ", sizeof(NAMESTRING));
  288.   i++;
  289.   memcpy(printNames[i - 1], "=                   ", sizeof(NAMESTRING));
  290.   i++;
  291.   memcpy(printNames[i - 1], "<                   ", sizeof(NAMESTRING));
  292.   i++;
  293.   memcpy(printNames[i - 1], ">                   ", sizeof(NAMESTRING));
  294.   i++;
  295.   memcpy(printNames[i - 1], "print               ", sizeof(NAMESTRING));
  296.   numNames = i;
  297.   numBuiltins = i;
  298. }  /* initNames */
  299.  
  300.  
  301. Static jmp_buf _JL99;
  302.  
  303.  
  304. /* install - insert new name into printNames                     */
  305. Static char install(nm)
  306. Char *nm;
  307. {
  308.   long i;
  309.   boolean found;
  310.  
  311.   i = 1;
  312.   found = false;
  313.   while (i <= numNames && !found) {
  314.     if (!memcmp(nm, printNames[i - 1], sizeof(NAMESTRING)))
  315.       found = true;
  316.     else
  317.       i++;
  318.   }
  319.   if (found)
  320.     return i;
  321.   if (i > MAXNAMES) {
  322.     printf("No more room for names\n");
  323.     longjmp(_JL99, 1);
  324.   }
  325.   numNames = i;
  326.   memcpy(printNames[i - 1], nm, sizeof(NAMESTRING));
  327.   return i;
  328. }  /* install */
  329.  
  330.  
  331. /* prName - print name nm                                        */
  332. Static Void prName(nm)
  333. char nm;
  334. {
  335.   long i;
  336.  
  337.   i = 1;
  338.   while (i <= NAMELENG) {
  339.     if (printNames[nm - 1][i - 1] != ' ') {
  340.       putchar(printNames[nm - 1][i - 1]);
  341.       i++;
  342.     } else
  343.       i = NAMELENG + 1;
  344.   }
  345. }  /* prName */
  346.  
  347.  
  348. /* primOp - translate NAME optr to corresponding BUILTINOP       */
  349. Static BUILTINOP primOp(optr)
  350. char optr;
  351. {
  352.   BUILTINOP op;
  353.   long i;
  354.  
  355.   op = IFOP;   /* N.B. IFOP is first value in BUILTINOPS */
  356.   for (i = 1; i < optr; i++)
  357.     op = (BUILTINOP)((long)op + 1);
  358.   return op;
  359. }  /* primOp */
  360.  
  361.  
  362. /*****************************************************************
  363.  *                        INPUT                                  *
  364.  *****************************************************************/
  365.  
  366. /* isDelim - check if c is a delimiter                           */
  367. Static boolean isDelim(c)
  368. Char c;
  369. {
  370.   return (c == ';' || c == ' ' || c == ')' || c == '(');
  371. }  /* isDelim */
  372.  
  373.  
  374. /* skipblanks - return next non-blank position in userinput      */
  375. Static long skipblanks(p)
  376. long p;
  377. {
  378.   while (userinput[p - 1] == ' ')
  379.     p++;
  380.   return p;
  381. }  /* skipblanks */
  382.  
  383.  
  384. /* matches - check if string nm matches userinput[s .. s+leng]   */
  385. Static boolean matches(s, leng, nm)
  386. long s;
  387. char leng;
  388. Char *nm;
  389. {
  390.   boolean match;
  391.   long i;
  392.  
  393.   match = true;
  394.   i = 1;
  395.   while (match && i <= leng) {
  396.     if (userinput[s - 1] != nm[i - 1])
  397.       match = false;
  398.     i++;
  399.     s++;
  400.   }
  401.   if (!isDelim(userinput[s - 1]))
  402.     match = false;
  403.   return match;
  404. }  /* matches */
  405.  
  406.  
  407. /* nextchar - read next char - filter tabs and comments          */
  408. Local Void nextchar(c)
  409. Char *c;
  410. {
  411.   Char STR1[256];
  412.  
  413.   *c = getchar();
  414.   if (*c == '\n')
  415.     *c = ' ';
  416.   if (*c == (Char)TABCODE) {
  417.     *c = ' ';
  418.     return;
  419.   }
  420.   sprintf(STR1, "%c", *c);
  421.   if (strcmp(STR1, COMMENTCHAR))
  422.     return;
  423.   while (!P_eoln(stdin)) {
  424.     *c = getchar();
  425.     if (*c == '\n')
  426.       *c = ' ';
  427.   }
  428.   *c = ' ';
  429. }  /* nextchar */
  430.  
  431. /* readParens - read char's, ignoring newlines, to matching ')'  */
  432. Local Void readParens()
  433. {
  434.   long parencnt;   /* current depth of parentheses */
  435.   Char c;
  436.  
  437.   parencnt = 1;   /* '(' just read */
  438.   do {
  439.     if (P_eoln(stdin))
  440.       fputs(PROMPT2, stdout);
  441.     nextchar(&c);
  442.     pos_++;
  443.     if (pos_ == MAXINPUT) {
  444.       printf("User input too long\n");
  445.       longjmp(_JL99, 1);
  446.     }
  447.     userinput[pos_ - 1] = c;
  448.     if (c == '(')
  449.       parencnt++;
  450.     if (c == ')')
  451.       parencnt--;
  452.   } while (parencnt != 0);   /* readParens */
  453. }
  454.  
  455. Local Void readInput()
  456. {
  457.   Char c;
  458.  
  459.   fputs(PROMPT, stdout);
  460.   pos_ = 0;
  461.   do {
  462.     pos_++;
  463.     if (pos_ == MAXINPUT) {
  464.       printf("User input too long\n");
  465.       longjmp(_JL99, 1);
  466.     }
  467.     nextchar(&c);
  468.     userinput[pos_ - 1] = c;
  469.     if (userinput[pos_ - 1] == '(')
  470.       readParens();
  471.   } while (!P_eoln(stdin));
  472.   inputleng = pos_;
  473.   userinput[pos_] = ';';   /* sentinel */
  474. }  /* readInput */
  475.  
  476.  
  477. /* reader - read char's into userinput; be sure input not blank  */
  478. Static Void reader()
  479. {
  480.  
  481.   /* readInput - read char's into userinput                        */
  482.   do {
  483.     readInput();
  484.     pos_ = skipblanks(1L);   /* ignore blank lines */
  485.   } while (pos_ > inputleng);   /* reader */
  486. }
  487.  
  488.  
  489. /* parseName - return (installed) NAME starting at userinput[pos]*/
  490. Static char parseName()
  491. {
  492.   NAMESTRING nm;   /* array to accumulate characters */
  493.   char leng;   /* length of name */
  494.  
  495.   leng = 0;
  496.   while ((pos_ <= inputleng) & (!isDelim(userinput[pos_ - 1]))) {
  497.     if (leng == NAMELENG) {
  498.       printf("Name too long, begins: %.*s\n", NAMELENG, nm);
  499.       longjmp(_JL99, 1);
  500.     }
  501.     leng++;
  502.     nm[leng - 1] = userinput[pos_ - 1];
  503.     pos_++;
  504.   }
  505.   if (leng == 0) {
  506.     printf("Error: expected name, instead read: %c\n", userinput[pos_ - 1]);
  507.     longjmp(_JL99, 1);
  508.   }
  509.   for (; leng < NAMELENG; leng++)
  510.     nm[leng] = ' ';
  511.   pos_ = skipblanks((long)pos_);   /* skip blanks after name */
  512.   return (install(nm));
  513. }  /* parseName */
  514.  
  515.  
  516. Local boolean isDigits(pos)
  517. long pos;
  518. {
  519.   boolean Result;
  520.  
  521.   if (!isdigit(userinput[pos - 1]))
  522.     return false;
  523.   Result = true;
  524.   while (isdigit(userinput[pos - 1]))
  525.     pos++;
  526.   if (!isDelim(userinput[pos - 1]))
  527.     return false;
  528.   return Result;
  529. }  /* isDigits */
  530.  
  531.  
  532. /* isNumber - check if a number begins at pos                    */
  533. Static boolean isNumber(pos)
  534. long pos;
  535. {
  536.  
  537.   /* isDigits - check if sequence of digits begins at pos          */
  538.   return (isDigits(pos) | ((userinput[pos - 1] == '-') & isDigits(pos + 1)));
  539. }  /* isNumber */
  540.  
  541.  
  542. /* parseVal - return number starting at userinput[pos]           */
  543. Static long parseVal()
  544. {
  545.   long n, sign;
  546.  
  547.   n = 0;
  548.   sign = 1;
  549.   if (userinput[pos_ - 1] == '-') {
  550.     sign = -1;
  551.     pos_++;
  552.   }
  553.   while (isdigit(userinput[pos_ - 1])) {
  554.     n = n * 10 + userinput[pos_ - 1] - '0';
  555.     pos_++;
  556.   }
  557.   pos_ = skipblanks((long)pos_);   /* skip blanks after number */
  558.   return (n * sign);
  559. }  /* parseVal */
  560.  
  561.  
  562. Static EXPLISTREC *parseEL PV();
  563.  
  564.  
  565. /* parseExp - return EXP starting at userinput[pos]              */
  566. Static EXPREC *parseExp()
  567. {
  568.   char nm;
  569.   EXPLISTREC *el;
  570.  
  571.   if (userinput[pos_ - 1] == '(') {  /* APEXP */
  572.     pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  573.     nm = parseName();
  574.     el = parseEL();
  575.     return (mkAPEXP(nm, el));
  576.   } else if (isNumber((long)pos_))
  577.     return (mkVALEXP(parseVal()));   /* VALEXP */
  578.   else
  579.     return (mkVAREXP(parseName()));   /* VAREXP */
  580. }  /* parseExp */
  581.  
  582.  
  583. /* parseEL - return EXPLIST starting at userinput[pos]           */
  584. Static EXPLISTREC *parseEL()
  585. {
  586.   EXPREC *e;
  587.   EXPLISTREC *el;
  588.  
  589.   if (userinput[pos_ - 1] == ')') {
  590.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  591.     return NULL;
  592.   } else {
  593.     e = parseExp();
  594.     el = parseEL();
  595.     return (mkExplist(e, el));
  596.   }
  597. }  /* parseEL */
  598.  
  599.  
  600. /* parseNL - return NAMELIST starting at userinput[pos]          */
  601. Static NAMELISTREC *parseNL()
  602. {
  603.   char nm;
  604.   NAMELISTREC *nl;
  605.  
  606.   if (userinput[pos_ - 1] == ')') {
  607.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  608.     return NULL;
  609.   } else {
  610.     nm = parseName();
  611.     nl = parseNL();
  612.     return (mkNamelist(nm, nl));
  613.   }
  614. }  /* parseNL */
  615.  
  616.  
  617. /* parseDef - parse function definition at userinput[pos]        */
  618. Static char parseDef()
  619. {
  620.   char fname;   /* function name */
  621.   NAMELISTREC *nl;   /* formal parameters */
  622.   EXPREC *e;   /* body */
  623.  
  624.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  625.   pos_ = skipblanks(pos_ + 6L);   /* skip 'define ..' */
  626.   fname = parseName();
  627.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  628.   nl = parseNL();
  629.   e = parseExp();
  630.   pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  631.   newFunDef(fname, nl, e);
  632.   return fname;
  633. }  /* parseDef */
  634.  
  635.  
  636. /*****************************************************************
  637.  *                     ENVIRONMENTS                              *
  638.  *****************************************************************/
  639.  
  640. /* emptyEnv - return an environment with no bindings             */
  641. Static ENVREC *emptyEnv()
  642. {
  643.   return (mkEnv(NULL, NULL));
  644. }  /* emptyEnv */
  645.  
  646.  
  647. /* bindVar - bind variable nm to value n in environment rho      */
  648. Static Void bindVar(nm, n, rho)
  649. char nm;
  650. long n;
  651. ENVREC *rho;
  652. {
  653.   rho->vars = mkNamelist(nm, rho->vars);
  654.   rho->values = mkValuelist(n, rho->values);
  655. }  /* bindVar */
  656.  
  657.  
  658. /* findVar - look up nm in rho                                   */
  659. Static VALUELISTREC *findVar(nm, rho)
  660. char nm;
  661. ENVREC *rho;
  662. {
  663.   NAMELISTREC *nl;
  664.   VALUELISTREC *vl;
  665.   boolean found;
  666.  
  667.   found = false;
  668.   nl = rho->vars;
  669.   vl = rho->values;
  670.   while (nl != NULL && !found) {
  671.     if (nl->head == nm)
  672.       found = true;
  673.     else {
  674.       nl = nl->tail;
  675.       vl = vl->tail;
  676.     }
  677.   }
  678.   return vl;
  679. }  /* findVar */
  680.  
  681.  
  682. /* assign - assign value n to variable nm in rho                 */
  683. Static Void assign(nm, n, rho)
  684. char nm;
  685. long n;
  686. ENVREC *rho;
  687. {
  688.   VALUELISTREC *varloc;
  689.  
  690.   varloc = findVar(nm, rho);
  691.   varloc->head = n;
  692. }  /* assign */
  693.  
  694.  
  695. /* fetch - return number bound to nm in rho                      */
  696. Static long fetch(nm, rho)
  697. char nm;
  698. ENVREC *rho;
  699. {
  700.   VALUELISTREC *vl;
  701.  
  702.   vl = findVar(nm, rho);
  703.   return (vl->head);
  704. }  /* fetch */
  705.  
  706.  
  707. /* isBound - check if nm is bound in rho                         */
  708. Static boolean isBound(nm, rho)
  709. char nm;
  710. ENVREC *rho;
  711. {
  712.   return (findVar(nm, rho) != NULL);
  713. }  /* isBound */
  714.  
  715.  
  716. /*****************************************************************
  717.  *                     NUMBERS                                   *
  718.  *****************************************************************/
  719.  
  720. /* prValue - print number n                                      */
  721. Static Void prValue(n)
  722. long n;
  723. {
  724.   printf("%ld", n);
  725. }  /* prValue */
  726.  
  727.  
  728. /* isTrueVal - return true if n is a true (non-zero) value       */
  729. Static boolean isTrueVal(n)
  730. long n;
  731. {
  732.   return (n != 0);
  733. }  /* isTrueVal */
  734.  
  735.  
  736. /* arity - return number of arguments expected by op             */
  737. Local long arity(op)
  738. BUILTINOP op;
  739. {
  740.   if (((1L << ((long)op)) & ((1 << ((long)GTOP + 1)) - (1 << ((long)PLUSOP)))) != 0)
  741.     return 2;
  742.   else
  743.     return 1;
  744. }  /* arity */
  745.  
  746.  
  747. /* applyValueOp - apply VALUEOP op to arguments in VALUELIST vl  */
  748. Static long applyValueOp(op, vl)
  749. BUILTINOP op;
  750. VALUELISTREC *vl;
  751. {
  752.   long n, n1, n2;
  753.  
  754.   if (arity(op) != lengthVL(vl)) {
  755.     printf("Wrong number of arguments to ");
  756.     prName((int)op + 1);
  757.     putchar('\n');
  758.     longjmp(_JL99, 1);
  759.   }
  760.   n1 = vl->head;   /* 1st actual */
  761.   if (arity(op) == 2)   /* 2nd actual */
  762.     n2 = vl->tail->head;
  763.   switch (op) {
  764.  
  765.   case PLUSOP:
  766.     n = n1 + n2;
  767.     break;
  768.  
  769.   case MINUSOP:
  770.     n = n1 - n2;
  771.     break;
  772.  
  773.   case TIMESOP:
  774.     n = n1 * n2;
  775.     break;
  776.  
  777.   case DIVOP:
  778.     n = n1 / n2;
  779.     break;
  780.  
  781.   case EQOP:
  782.     if (n1 == n2)
  783.       n = 1;
  784.     else
  785.       n = 0;
  786.     break;
  787.  
  788.   case LTOP:
  789.     if (n1 < n2)
  790.       n = 1;
  791.     else
  792.       n = 0;
  793.     break;
  794.  
  795.   case GTOP:
  796.     if (n1 > n2)
  797.       n = 1;
  798.     else
  799.       n = 0;
  800.     break;
  801.  
  802.   case PRINTOP:
  803.     prValue(n1);
  804.     putchar('\n');
  805.     n = n1;
  806.     break;
  807.   }/* case */
  808.   return n;
  809. }  /* applyValueOp */
  810.  
  811.  
  812. Static long eval PP((EXPREC *e, ENVREC *rho));
  813.  
  814. /* Local variables for eval: */
  815. struct LOC_eval {
  816.   ENVREC *rho;
  817. } ;
  818.  
  819. /* evalList - evaluate each expression in el                     */
  820. Local VALUELISTREC *evalList(el, LINK)
  821. EXPLISTREC *el;
  822. struct LOC_eval *LINK;
  823. {
  824.   long h;
  825.   VALUELISTREC *t;
  826.  
  827.   if (el == NULL)
  828.     return NULL;
  829.   else {
  830.     h = eval(el->head, LINK->rho);
  831.     t = evalList(el->tail, LINK);
  832.     return (mkValuelist(h, t));
  833.   }
  834. }  /* evalList */
  835.  
  836. /* applyUserFun - look up definition of nm and apply to actuals  */
  837. Local long applyUserFun(nm, actuals, LINK)
  838. char nm;
  839. VALUELISTREC *actuals;
  840. struct LOC_eval *LINK;
  841. {
  842.   FUNDEFREC *f;
  843.   ENVREC *rho;
  844.  
  845.   f = fetchFun(nm);
  846.   if (f == NULL) {
  847.     printf("Undefined function: ");
  848.     prName(nm);
  849.     putchar('\n');
  850.     longjmp(_JL99, 1);
  851.   }
  852.   if (lengthNL(f->formals) != lengthVL(actuals)) {
  853.     printf("Wrong number of arguments to: ");
  854.     prName(nm);
  855.     putchar('\n');
  856.     longjmp(_JL99, 1);
  857.   }
  858.   rho = mkEnv(f->formals, actuals);
  859.   return (eval(f->body, rho));
  860. }  /* applyUserFun */
  861.  
  862. /* applyCtrlOp - apply CONTROLOP op to args in rho               */
  863. Local long applyCtrlOp(op, args, LINK)
  864. BUILTINOP op;
  865. EXPLISTREC *args;
  866. struct LOC_eval *LINK;
  867. {
  868.   long Result, n;
  869.   EXPLISTREC *WITH;
  870.  
  871.   WITH = args;
  872.   switch (op) {
  873.  
  874.   case IFOP:
  875.     if (isTrueVal(eval(WITH->head, LINK->rho)))
  876.       Result = eval(WITH->tail->head, LINK->rho);
  877.     else
  878.       Result = eval(WITH->tail->tail->head, LINK->rho);
  879.     break;
  880.  
  881.   case WHILEOP:
  882.     n = eval(WITH->head, LINK->rho);
  883.     while (isTrueVal(n)) {
  884.       n = eval(WITH->tail->head, LINK->rho);
  885.       n = eval(WITH->head, LINK->rho);
  886.     }
  887.     Result = n;
  888.     break;
  889.  
  890.   case SETOP:
  891.     n = eval(WITH->tail->head, LINK->rho);
  892.     if (isBound(WITH->head->UU.varble, LINK->rho))
  893.       assign(WITH->head->UU.varble, n, LINK->rho);
  894.     else if (isBound(WITH->head->UU.varble, globalEnv))
  895.       assign(WITH->head->UU.varble, n, globalEnv);
  896.     else
  897.       bindVar(WITH->head->UU.varble, n, globalEnv);
  898.     Result = n;
  899.     break;
  900.  
  901.   case BEGINOP:
  902.     while (args->tail != NULL) {
  903.       n = eval(args->head, LINK->rho);
  904.       args = args->tail;
  905.     }
  906.     Result = eval(args->head, LINK->rho);
  907.     break;
  908.   }/* case and with */
  909.   return Result;
  910. }  /* applyCtrlOp */
  911.  
  912.  
  913. /*****************************************************************
  914.  *                     EVALUATION                                *
  915.  *****************************************************************/
  916.  
  917. /* eval - return value of expression e in local environment rho  */
  918. Static long eval(e, rho_)
  919. EXPREC *e;
  920. ENVREC *rho_;
  921. {
  922.   struct LOC_eval V;
  923.   long Result;
  924.   BUILTINOP op;
  925.  
  926.   V.rho = rho_;
  927.   switch (e->etype) {
  928.  
  929.   case VALEXP:
  930.     Result = e->UU.num;
  931.     break;
  932.  
  933.   case VAREXP:
  934.     if (isBound(e->UU.varble, V.rho))
  935.       Result = fetch(e->UU.varble, V.rho);
  936.     else if (isBound(e->UU.varble, globalEnv))
  937.       Result = fetch(e->UU.varble, globalEnv);
  938.     else {
  939.       printf("Undefined variable: ");
  940.       prName(e->UU.varble);
  941.       putchar('\n');
  942.       longjmp(_JL99, 1);
  943.     }
  944.     break;
  945.  
  946.   case APEXP:
  947.     if (e->UU.U2.optr > numBuiltins)
  948.       Result = applyUserFun(e->UU.U2.optr, evalList(e->UU.U2.args, &V), &V);
  949.     else {
  950.       op = primOp(e->UU.U2.optr);
  951.       if (((1L << ((long)op)) &
  952.        ((1 << ((long)BEGINOP + 1)) - (1 << ((long)IFOP)))) != 0)
  953.     Result = applyCtrlOp(op, e->UU.U2.args, &V);
  954.       else
  955.     Result = applyValueOp(op, evalList(e->UU.U2.args, &V));
  956.     }
  957.     break;
  958.   }/* case and with */
  959.   return Result;
  960. }  /* eval */
  961.  
  962.  
  963. /*****************************************************************
  964.  *                     READ-EVAL-PRINT LOOP                      *
  965.  *****************************************************************/
  966.  
  967. main(argc, argv)
  968. int argc;
  969. Char *argv[];
  970. {  /* chapter1 main */
  971.   PASCAL_MAIN(argc, argv);
  972.   if (setjmp(_JL99))
  973.     goto _L99;
  974.   initNames();
  975.   globalEnv = emptyEnv();
  976.  
  977.   quittingtime = false;
  978. _L99:
  979.   while (!quittingtime) {
  980.     reader();
  981.     if (matches((long)pos_, 4, "quit                ")) {
  982.       quittingtime = true;
  983.       break;
  984.     }
  985.     if ((userinput[pos_ - 1] == '(') & matches(skipblanks(pos_ + 1L), 6,
  986.                            "define              ")) {
  987.       prName(parseDef());
  988.       putchar('\n');
  989.     } else {
  990.       currentExp = parseExp();
  991.       prValue(eval(currentExp, emptyEnv()));
  992.       printf("\n\n");
  993.     }
  994.   }  /* while */
  995.   exit(0);
  996. }  /* chapter1 */
  997.  
  998.  
  999.  
  1000.  
  1001.  
  1002.  
  1003. /* End. */
  1004.