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