home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d524 / kamin.lha / Kamin / src.lzh / apl.c next >
C/C++ Source or Header  |  1991-06-28  |  41KB  |  1,877 lines
  1. /* Output from p2c, the Pascal-to-C translator */
  2. /* From input file "apl.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, MAXOP, OROP,
  29.   ANDOP, EQOP, LTOP, GTOP, REDPLUSOP, REDMINUSOP, REDTIMESOP, REDDIVOP,
  30.   REDMAXOP, REDOROP, REDANDOP, COMPRESSOP, SHAPEOP, RAVELOP, RESTRUCTOP,
  31.   CATOP, INDXOP, TRANSOP, SUBOP, PRINTOP
  32. } BUILTINOP;
  33.  
  34.  
  35. typedef enum {
  36.   SCALAR, VECTOR, MATRIX
  37. } RANK;
  38.  
  39. typedef struct APLVALUEREC {
  40.   struct INTLISTREC *intvals;
  41.   RANK rnk;
  42.   union {
  43.     long leng;
  44.     struct {
  45.       long rows, cols;
  46.     } U2;
  47.   } UU;
  48. } APLVALUEREC;
  49.  
  50. typedef struct INTLISTREC {
  51.   long int_;
  52.   struct INTLISTREC *nextint;
  53. } INTLISTREC;
  54.  
  55. typedef enum {
  56.   VALEXP, VAREXP, APEXP
  57. } EXPTYPE;
  58.  
  59. typedef struct EXPREC {
  60.   EXPTYPE etype;
  61.   union {
  62.     APLVALUEREC *aplval;
  63.     char varble;
  64.     struct {
  65.       char optr;
  66.       struct EXPLISTREC *args;
  67.     } U2;
  68.   } UU;
  69. } EXPREC;
  70.  
  71. typedef struct EXPLISTREC {
  72.   EXPREC *head;
  73.   struct EXPLISTREC *tail;
  74. } EXPLISTREC;
  75.  
  76. typedef struct VALUELISTREC {
  77.   APLVALUEREC *head;
  78.   struct VALUELISTREC *tail;
  79. } VALUELISTREC;
  80.  
  81. typedef struct NAMELISTREC {
  82.   char head;
  83.   struct NAMELISTREC *tail;
  84. } NAMELISTREC;
  85.  
  86. typedef struct ENVREC {
  87.   NAMELISTREC *vars;
  88.   VALUELISTREC *values;
  89. } ENVREC;
  90.  
  91. typedef struct FUNDEFREC {
  92.   char funname;
  93.   NAMELISTREC *formals;
  94.   EXPREC *body;
  95.   struct FUNDEFREC *nextfundef;
  96. } FUNDEFREC;
  97.  
  98.  
  99. Static FUNDEFREC *fundefs;
  100.  
  101. Static ENVREC *globalEnv;
  102.  
  103. Static EXPREC *currentExp;
  104.  
  105. Static Char userinput[MAXINPUT];
  106. Static short inputleng, pos_;
  107.  
  108. Static NAMESTRING printNames[MAXNAMES];
  109. Static char numNames, numBuiltins;
  110.  
  111. Static boolean quittingtime;
  112.  
  113.  
  114. /*****************************************************************
  115.  *                     DATA STRUCTURE OP'S                       *
  116.  *****************************************************************/
  117.  
  118. /* mkVALEXP - return an EXP of type VALEXP with aplval a         */
  119. Static EXPREC *mkVALEXP(a)
  120. APLVALUEREC *a;
  121. {
  122.   EXPREC *e;
  123.  
  124.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  125.   e->etype = VALEXP;
  126.   e->UU.aplval = a;
  127.   return e;
  128. }  /* mkVALEXP */
  129.  
  130.  
  131. /* mkVAREXP - return an EXP of type VAREXP with varble nm        */
  132. Static EXPREC *mkVAREXP(nm)
  133. char nm;
  134. {
  135.   EXPREC *e;
  136.  
  137.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  138.   e->etype = VAREXP;
  139.   e->UU.varble = nm;
  140.   return e;
  141. }  /* mkVAREXP */
  142.  
  143.  
  144. /* mkAPEXP - return EXP of type APEXP w/ optr op and args el     */
  145. Static EXPREC *mkAPEXP(op, el)
  146. char op;
  147. EXPLISTREC *el;
  148. {
  149.   EXPREC *e;
  150.  
  151.   e = (EXPREC *)Malloc(sizeof(EXPREC));
  152.   e->etype = APEXP;
  153.   e->UU.U2.optr = op;
  154.   e->UU.U2.args = el;
  155.   return e;
  156. }  /* mkAPEXP */
  157.  
  158.  
  159. /* mkExplist - return an EXPLIST with head e and tail el         */
  160. Static EXPLISTREC *mkExplist(e, el)
  161. EXPREC *e;
  162. EXPLISTREC *el;
  163. {
  164.   EXPLISTREC *newel;
  165.  
  166.   newel = (EXPLISTREC *)Malloc(sizeof(EXPLISTREC));
  167.   newel->head = e;
  168.   newel->tail = el;
  169.   return newel;
  170. }  /* mkExplist */
  171.  
  172.  
  173. /* mkNamelist - return a NAMELIST with head n and tail nl        */
  174. Static NAMELISTREC *mkNamelist(nm, nl)
  175. char nm;
  176. NAMELISTREC *nl;
  177. {
  178.   NAMELISTREC *newnl;
  179.  
  180.   newnl = (NAMELISTREC *)Malloc(sizeof(NAMELISTREC));
  181.   newnl->head = nm;
  182.   newnl->tail = nl;
  183.   return newnl;
  184. }  /* mkNamelist */
  185.  
  186.  
  187. /* mkValuelist - return an VALUELIST with head a and tail vl     */
  188. Static VALUELISTREC *mkValuelist(a, vl)
  189. APLVALUEREC *a;
  190. VALUELISTREC *vl;
  191. {
  192.   VALUELISTREC *newvl;
  193.  
  194.   newvl = (VALUELISTREC *)Malloc(sizeof(VALUELISTREC));
  195.   newvl->head = a;
  196.   newvl->tail = vl;
  197.   return newvl;
  198. }  /* mkValuelist */
  199.  
  200.  
  201. /* mkEnv - return an ENV with vars nl and values vl              */
  202. Static ENVREC *mkEnv(nl, vl)
  203. NAMELISTREC *nl;
  204. VALUELISTREC *vl;
  205. {
  206.   ENVREC *rho;
  207.  
  208.   rho = (ENVREC *)Malloc(sizeof(ENVREC));
  209.   rho->vars = nl;
  210.   rho->values = vl;
  211.   return rho;
  212. }  /* mkEnv */
  213.  
  214.  
  215. /* lengthVL - return length of VALUELIST vl                      */
  216. Static long lengthVL(vl)
  217. VALUELISTREC *vl;
  218. {
  219.   long i;
  220.  
  221.   i = 0;
  222.   while (vl != NULL) {
  223.     i++;
  224.     vl = vl->tail;
  225.   }
  226.   return i;
  227. }  /* lengthVL */
  228.  
  229.  
  230. /* lengthNL - return length of NAMELIST nl                       */
  231. Static long lengthNL(nl)
  232. NAMELISTREC *nl;
  233. {
  234.   long i;
  235.  
  236.   i = 0;
  237.   while (nl != NULL) {
  238.     i++;
  239.     nl = nl->tail;
  240.   }
  241.   return i;
  242. }  /* lengthNL */
  243.  
  244.  
  245. /* lengthIL - return length of INTLIST il                        */
  246. Static long lengthIL(il)
  247. INTLISTREC *il;
  248. {
  249.   long i;
  250.  
  251.   i = 0;
  252.   while (il != NULL) {
  253.     i++;
  254.     il = il->nextint;
  255.   }
  256.   return i;
  257. }  /* lengthIL */
  258.  
  259.  
  260. /*****************************************************************
  261.  *                     NAME MANAGEMENT                           *
  262.  *****************************************************************/
  263.  
  264. /* fetchFun - get function definition of fname from fundefs      */
  265. Static FUNDEFREC *fetchFun(fname)
  266. char fname;
  267. {
  268.   FUNDEFREC *f;
  269.   boolean found;
  270.  
  271.   found = false;
  272.   f = fundefs;
  273.   while (f != NULL && !found) {
  274.     if (f->funname == fname)
  275.       found = true;
  276.     else
  277.       f = f->nextfundef;
  278.   }
  279.   return f;
  280. }  /* fetchFun */
  281.  
  282.  
  283. /* newFunDef - add new function fname w/ parameters nl, body e   */
  284. Static Void newFunDef(fname, nl, e)
  285. char fname;
  286. NAMELISTREC *nl;
  287. EXPREC *e;
  288. {
  289.   FUNDEFREC *f;
  290.  
  291.   f = fetchFun(fname);
  292.   if (f == NULL) {   /* fname not yet defined as a function */
  293.     f = (FUNDEFREC *)Malloc(sizeof(FUNDEFREC));
  294.     f->nextfundef = fundefs;   /* place new FUNDEFREC */
  295.     fundefs = f;   /* on fundefs list */
  296.   }
  297.   f->funname = fname;
  298.   f->formals = nl;
  299.   f->body = e;
  300. }  /* newFunDef */
  301.  
  302.  
  303. /* initNames - place all pre-defined names into printNames       */
  304. Static Void initNames()
  305. {
  306.   long i;
  307.  
  308.   fundefs = NULL;
  309.   i = 1;
  310.   memcpy(printNames[i - 1], "if                  ", sizeof(NAMESTRING));
  311.   i++;
  312.   memcpy(printNames[i - 1], "while               ", sizeof(NAMESTRING));
  313.   i++;
  314.   memcpy(printNames[i - 1], "set                 ", sizeof(NAMESTRING));
  315.   i++;
  316.   memcpy(printNames[i - 1], "begin               ", sizeof(NAMESTRING));
  317.   i++;
  318.   memcpy(printNames[i - 1], "+                   ", sizeof(NAMESTRING));
  319.   i++;
  320.   memcpy(printNames[i - 1], "-                   ", sizeof(NAMESTRING));
  321.   i++;
  322.   memcpy(printNames[i - 1], "*                   ", sizeof(NAMESTRING));
  323.   i++;
  324.   memcpy(printNames[i - 1], "/                   ", sizeof(NAMESTRING));
  325.   i++;
  326.   memcpy(printNames[i - 1], "max                 ", sizeof(NAMESTRING));
  327.   i++;
  328.   memcpy(printNames[i - 1], "or                  ", sizeof(NAMESTRING));
  329.   i++;
  330.   memcpy(printNames[i - 1], "and                 ", 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], "*/                  ", sizeof(NAMESTRING));
  343.   i++;
  344.   memcpy(printNames[i - 1], "//                  ", sizeof(NAMESTRING));
  345.   i++;
  346.   memcpy(printNames[i - 1], "max/                ", sizeof(NAMESTRING));
  347.   i++;
  348.   memcpy(printNames[i - 1], "or/                 ", sizeof(NAMESTRING));
  349.   i++;
  350.   memcpy(printNames[i - 1], "and/                ", sizeof(NAMESTRING));
  351.   i++;
  352.   memcpy(printNames[i - 1], "compress            ", sizeof(NAMESTRING));
  353.   i++;
  354.   memcpy(printNames[i - 1], "shape               ", sizeof(NAMESTRING));
  355.   i++;
  356.   memcpy(printNames[i - 1], "ravel               ", sizeof(NAMESTRING));
  357.   i++;
  358.   memcpy(printNames[i - 1], "restruct            ", sizeof(NAMESTRING));
  359.   i++;
  360.   memcpy(printNames[i - 1], "cat                 ", sizeof(NAMESTRING));
  361.   i++;
  362.   memcpy(printNames[i - 1], "indx                ", sizeof(NAMESTRING));
  363.   i++;
  364.   memcpy(printNames[i - 1], "trans               ", sizeof(NAMESTRING));
  365.   i++;
  366.   memcpy(printNames[i - 1], "[]                  ", sizeof(NAMESTRING));
  367.   i++;
  368.   memcpy(printNames[i - 1], "print               ", sizeof(NAMESTRING));
  369.   numNames = i;
  370.   numBuiltins = i;
  371. }  /* initNames */
  372.  
  373.  
  374. Static jmp_buf _JL99;
  375.  
  376.  
  377. /* install - insert new name into printNames                     */
  378. Static char install(nm)
  379. Char *nm;
  380. {
  381.   long i;
  382.   boolean found;
  383.  
  384.   i = 1;
  385.   found = false;
  386.   while (i <= numNames && !found) {
  387.     if (!memcmp(nm, printNames[i - 1], sizeof(NAMESTRING)))
  388.       found = true;
  389.     else
  390.       i++;
  391.   }
  392.   if (found)
  393.     return i;
  394.   if (i > MAXNAMES) {
  395.     printf("No more room for names\n");
  396.     longjmp(_JL99, 1);
  397.   }
  398.   numNames = i;
  399.   memcpy(printNames[i - 1], nm, sizeof(NAMESTRING));
  400.   return i;
  401. }  /* install */
  402.  
  403.  
  404. /* prName - print name nm                                        */
  405. Static Void prName(nm)
  406. char nm;
  407. {
  408.   long i;
  409.  
  410.   i = 1;
  411.   while (i <= NAMELENG) {
  412.     if (printNames[nm - 1][i - 1] != ' ') {
  413.       putchar(printNames[nm - 1][i - 1]);
  414.       i++;
  415.     } else
  416.       i = NAMELENG + 1;
  417.   }
  418. }  /* prName */
  419.  
  420.  
  421. /* primOp - translate NAME optr to corresponding BUILTINOP       */
  422. Static BUILTINOP primOp(optr)
  423. char optr;
  424. {
  425.   BUILTINOP op;
  426.   long i;
  427.  
  428.   op = IFOP;   /* N.B. IFOP is first value in BUILTINOPS */
  429.   for (i = 1; i < optr; i++)
  430.     op = (BUILTINOP)((long)op + 1);
  431.   return op;
  432. }  /* primOp */
  433.  
  434.  
  435. /*****************************************************************
  436.  *                        INPUT                                  *
  437.  *****************************************************************/
  438.  
  439. /* isDelim - check if c is a delimiter                           */
  440. Static boolean isDelim(c)
  441. Char c;
  442. {
  443.   return (c == ';' || c == ' ' || c == ')' || c == '(');
  444. }  /* isDelim */
  445.  
  446.  
  447. /* skipblanks - return next non-blank position in userinput      */
  448. Static long skipblanks(p)
  449. long p;
  450. {
  451.   while (userinput[p - 1] == ' ')
  452.     p++;
  453.   return p;
  454. }  /* skipblanks */
  455.  
  456.  
  457. /* matches - check if string nm matches userinput[s .. s+leng]   */
  458. Static boolean matches(s, leng, nm)
  459. long s;
  460. char leng;
  461. Char *nm;
  462. {
  463.   boolean match;
  464.   long i;
  465.  
  466.   match = true;
  467.   i = 1;
  468.   while (match && i <= leng) {
  469.     if (userinput[s - 1] != nm[i - 1])
  470.       match = false;
  471.     i++;
  472.     s++;
  473.   }
  474.   if (!isDelim(userinput[s - 1]))
  475.     match = false;
  476.   return match;
  477. }  /* matches */
  478.  
  479.  
  480. /* nextchar - read next char - filter tabs and comments          */
  481. Local Void nextchar(c)
  482. Char *c;
  483. {
  484.   Char STR1[256];
  485.  
  486.   *c = getchar();
  487.   if (*c == '\n')
  488.     *c = ' ';
  489.   if (*c == (Char)TABCODE) {
  490.     *c = ' ';
  491.     return;
  492.   }
  493.   sprintf(STR1, "%c", *c);
  494.   if (strcmp(STR1, COMMENTCHAR))
  495.     return;
  496.   while (!P_eoln(stdin)) {
  497.     *c = getchar();
  498.     if (*c == '\n')
  499.       *c = ' ';
  500.   }
  501.   *c = ' ';
  502. }  /* nextchar */
  503.  
  504. /* readParens - read char's, ignoring newlines, to matching ')'  */
  505. Local Void readParens()
  506. {
  507.   long parencnt;   /* current depth of parentheses */
  508.   Char c;
  509.  
  510.   parencnt = 1;   /* '(' just read */
  511.   do {
  512.     if (P_eoln(stdin))
  513.       fputs(PROMPT2, stdout);
  514.     nextchar(&c);
  515.     pos_++;
  516.     if (pos_ == MAXINPUT) {
  517.       printf("User input too long\n");
  518.       longjmp(_JL99, 1);
  519.     }
  520.     userinput[pos_ - 1] = c;
  521.     if (c == '(')
  522.       parencnt++;
  523.     if (c == ')')
  524.       parencnt--;
  525.   } while (parencnt != 0);   /* readParens */
  526. }
  527.  
  528. Local Void readInput()
  529. {
  530.   Char c;
  531.  
  532.   fputs(PROMPT, stdout);
  533.   pos_ = 0;
  534.   do {
  535.     pos_++;
  536.     if (pos_ == MAXINPUT) {
  537.       printf("User input too long\n");
  538.       longjmp(_JL99, 1);
  539.     }
  540.     nextchar(&c);
  541.     userinput[pos_ - 1] = c;
  542.     if (userinput[pos_ - 1] == '(')
  543.       readParens();
  544.   } while (!P_eoln(stdin));
  545.   inputleng = pos_;
  546.   userinput[pos_] = ';';   /* sentinel */
  547. }  /* readInput */
  548.  
  549.  
  550. /* reader - read char's into userinput; be sure input not blank  */
  551. Static Void reader()
  552. {
  553.  
  554.   /* readInput - read char's into userinput                        */
  555.   do {
  556.     readInput();
  557.     pos_ = skipblanks(1L);   /* ignore blank lines */
  558.   } while (pos_ > inputleng);   /* reader */
  559. }
  560.  
  561.  
  562. /* parseName - return (installed) NAME starting at userinput[pos]*/
  563. Static char parseName()
  564. {
  565.   NAMESTRING nm;   /* array to accumulate characters */
  566.   char leng;   /* length of name */
  567.  
  568.   leng = 0;
  569.   while ((pos_ <= inputleng) & (!isDelim(userinput[pos_ - 1]))) {
  570.     if (leng == NAMELENG) {
  571.       printf("Name too long, begins: %.*s\n", NAMELENG, nm);
  572.       longjmp(_JL99, 1);
  573.     }
  574.     leng++;
  575.     nm[leng - 1] = userinput[pos_ - 1];
  576.     pos_++;
  577.   }
  578.   if (leng == 0) {
  579.     printf("Error: expected name, instead read: %c\n", userinput[pos_ - 1]);
  580.     longjmp(_JL99, 1);
  581.   }
  582.   for (; leng < NAMELENG; leng++)
  583.     nm[leng] = ' ';
  584.   pos_ = skipblanks((long)pos_);   /* skip blanks after name */
  585.   return (install(nm));
  586. }  /* parseName */
  587.  
  588.  
  589. Local boolean isDigits(pos)
  590. long pos;
  591. {
  592.   boolean Result;
  593.  
  594.   if (!isdigit(userinput[pos - 1]))
  595.     return false;
  596.   Result = true;
  597.   while (isdigit(userinput[pos - 1]))
  598.     pos++;
  599.   if (!isDelim(userinput[pos - 1]))
  600.     return false;
  601.   return Result;
  602. }  /* isDigits */
  603.  
  604.  
  605. /* isNumber - check if a number begins at pos                    */
  606. Static boolean isNumber(pos)
  607. long pos;
  608. {
  609.  
  610.   /* isDigits - check if sequence of digits begins at pos          */
  611.   return (isDigits(pos) | ((userinput[pos - 1] == '-') & isDigits(pos + 1)));
  612. }  /* isNumber */
  613.  
  614.  
  615. /* isValue - check if a number or vector const begins at pos     */
  616. Static boolean isValue(pos)
  617. long pos;
  618. {
  619.   return ((userinput[pos - 1] == '\'') | isNumber(pos));
  620. }  /* isValue */
  621.  
  622.  
  623. /* parseInt - return number starting at userinput[pos]            */
  624. Local long parseInt()
  625. {
  626.   long n, sign;
  627.  
  628.   n = 0;
  629.   sign = 1;
  630.   if (userinput[pos_ - 1] == '-') {
  631.     sign = -1;
  632.     pos_++;
  633.   }
  634.   while (isdigit(userinput[pos_ - 1])) {
  635.     n = n * 10 + userinput[pos_ - 1] - '0';
  636.     pos_++;
  637.   }
  638.   pos_ = skipblanks((long)pos_);   /* skip blanks after number */
  639.   return (n * sign);
  640. }  /* parseInt */
  641.  
  642. /* parseVec - return INTLIST starting at userinput[pos]           */
  643. Local INTLISTREC *parseVec()
  644. {
  645.   INTLISTREC *il;
  646.  
  647.   if (userinput[pos_ - 1] == ')') {
  648.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ...' */
  649.     il = NULL;
  650.     return il;
  651.   }
  652.   il = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  653.   il->int_ = parseInt();
  654.   il->nextint = parseVec();
  655.   return il;
  656. }  /* parseVec */
  657.  
  658.  
  659. /* parseVal - return APL value starting at userinput[pos]         */
  660. Static APLVALUEREC *parseVal()
  661. {
  662.   APLVALUEREC *result;
  663.  
  664.   result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  665.   if (userinput[pos_ - 1] == '\'') {
  666.     result->rnk = VECTOR;
  667.     pos_ = skipblanks(pos_ + 2L);   /* skip "'(..." */
  668.     result->intvals = parseVec();
  669.     result->UU.leng = lengthIL(result->intvals);
  670.     return result;
  671.   }
  672.   result->rnk = SCALAR;
  673.   result->intvals = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  674.   result->intvals->int_ = parseInt();
  675.   result->intvals->nextint = NULL;
  676.   return result;
  677. }  /* parseVal */
  678.  
  679.  
  680. Static EXPLISTREC *parseEL PV();
  681.  
  682.  
  683. /* parseExp - return EXP starting at userinput[pos]              */
  684. Static EXPREC *parseExp()
  685. {
  686.   char nm;
  687.   EXPLISTREC *el;
  688.  
  689.   if (userinput[pos_ - 1] == '(') {  /* APEXP */
  690.     pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  691.     nm = parseName();
  692.     el = parseEL();
  693.     return (mkAPEXP(nm, el));
  694.   } else if (isValue((long)pos_))
  695.     return (mkVALEXP(parseVal()));   /* VALEXP */
  696.   else
  697.     return (mkVAREXP(parseName()));   /* VAREXP */
  698. }  /* parseExp */
  699.  
  700.  
  701. /* parseEL - return EXPLIST starting at userinput[pos]           */
  702. Static EXPLISTREC *parseEL()
  703. {
  704.   EXPREC *e;
  705.   EXPLISTREC *el;
  706.  
  707.   if (userinput[pos_ - 1] == ')') {
  708.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  709.     return NULL;
  710.   } else {
  711.     e = parseExp();
  712.     el = parseEL();
  713.     return (mkExplist(e, el));
  714.   }
  715. }  /* parseEL */
  716.  
  717.  
  718. /* parseNL - return NAMELIST starting at userinput[pos]          */
  719. Static NAMELISTREC *parseNL()
  720. {
  721.   char nm;
  722.   NAMELISTREC *nl;
  723.  
  724.   if (userinput[pos_ - 1] == ')') {
  725.     pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  726.     return NULL;
  727.   } else {
  728.     nm = parseName();
  729.     nl = parseNL();
  730.     return (mkNamelist(nm, nl));
  731.   }
  732. }  /* parseNL */
  733.  
  734.  
  735. /* parseDef - parse function definition at userinput[pos]        */
  736. Static char parseDef()
  737. {
  738.   char fname;   /* function name */
  739.   NAMELISTREC *nl;   /* formal parameters */
  740.   EXPREC *e;   /* body */
  741.  
  742.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  743.   pos_ = skipblanks(pos_ + 6L);   /* skip 'define ..' */
  744.   fname = parseName();
  745.   pos_ = skipblanks(pos_ + 1L);   /* skip '( ..' */
  746.   nl = parseNL();
  747.   e = parseExp();
  748.   pos_ = skipblanks(pos_ + 1L);   /* skip ') ..' */
  749.   newFunDef(fname, nl, e);
  750.   return fname;
  751. }  /* parseDef */
  752.  
  753.  
  754. /*****************************************************************
  755.  *                     ENVIRONMENTS                              *
  756.  *****************************************************************/
  757.  
  758. /* emptyEnv - return an environment with no bindings             */
  759. Static ENVREC *emptyEnv()
  760. {
  761.   return (mkEnv(NULL, NULL));
  762. }  /* emptyEnv */
  763.  
  764.  
  765. /* bindVar - bind variable nm to value a in environment rho      */
  766. Static Void bindVar(nm, a, rho)
  767. char nm;
  768. APLVALUEREC *a;
  769. ENVREC *rho;
  770. {
  771.   rho->vars = mkNamelist(nm, rho->vars);
  772.   rho->values = mkValuelist(a, rho->values);
  773. }  /* bindVar */
  774.  
  775.  
  776. /* findVar - look up nm in rho                                   */
  777. Static VALUELISTREC *findVar(nm, rho)
  778. char nm;
  779. ENVREC *rho;
  780. {
  781.   NAMELISTREC *nl;
  782.   VALUELISTREC *vl;
  783.   boolean found;
  784.  
  785.   found = false;
  786.   nl = rho->vars;
  787.   vl = rho->values;
  788.   while (nl != NULL && !found) {
  789.     if (nl->head == nm)
  790.       found = true;
  791.     else {
  792.       nl = nl->tail;
  793.       vl = vl->tail;
  794.     }
  795.   }
  796.   return vl;
  797. }  /* findVar */
  798.  
  799.  
  800. /* assign - assign value a to variable nm in rho                 */
  801. Static Void assign(nm, a, rho)
  802. char nm;
  803. APLVALUEREC *a;
  804. ENVREC *rho;
  805. {
  806.   VALUELISTREC *varloc;
  807.  
  808.   varloc = findVar(nm, rho);
  809.   varloc->head = a;
  810. }  /* assign */
  811.  
  812.  
  813. /* fetch - return number bound to nm in rho                      */
  814. Static APLVALUEREC *fetch(nm, rho)
  815. char nm;
  816. ENVREC *rho;
  817. {
  818.   VALUELISTREC *vl;
  819.  
  820.   vl = findVar(nm, rho);
  821.   return (vl->head);
  822. }  /* fetch */
  823.  
  824.  
  825. /* isBound - check if nm is bound in rho                         */
  826. Static boolean isBound(nm, rho)
  827. char nm;
  828. ENVREC *rho;
  829. {
  830.   return (findVar(nm, rho) != NULL);
  831. }  /* isBound */
  832.  
  833.  
  834. Local Void prIntlist(il, dim1, dim2)
  835. INTLISTREC *il;
  836. long dim1, dim2;
  837. {
  838.   long i, j;
  839.  
  840.   for (i = 1; i <= dim1; i++) {
  841.     for (j = 1; j <= dim2; j++) {
  842.       printf("%6ld ", il->int_);
  843.       il = il->nextint;
  844.     }
  845.     putchar('\n');
  846.   }
  847. }  /* prIntlist */
  848.  
  849.  
  850. /*****************************************************************
  851.  *                     APL VALUES                                *
  852.  *****************************************************************/
  853.  
  854. /* prValue - print APL value a                                   */
  855. Static Void prValue(a)
  856. APLVALUEREC *a;
  857. {
  858.  
  859.   /* prIntlist - print INTLIST il as dim1 x dim2 matrix            */
  860.   switch (a->rnk) {
  861.  
  862.   case SCALAR:
  863.     prIntlist(a->intvals, 1L, 1L);
  864.     break;
  865.  
  866.   case VECTOR:
  867.     prIntlist(a->intvals, 1L, a->UU.leng);
  868.     break;
  869.  
  870.   case MATRIX:
  871.     prIntlist(a->intvals, a->UU.U2.rows, a->UU.U2.cols);
  872.     break;
  873.   }
  874. }  /* prValue */
  875.  
  876.  
  877. /* isTrueVal - return true if first value in a is one            */
  878. Static boolean isTrueVal(a)
  879. APLVALUEREC *a;
  880. {
  881.   if (a->intvals == NULL)
  882.     return false;
  883.   else
  884.     return (a->intvals->int_ == 1);
  885. }  /* isTrueVal */
  886.  
  887.  
  888. /* Local variables for applyValueOp: */
  889. struct LOC_applyValueOp {
  890.   APLVALUEREC *result;
  891. } ;
  892.  
  893. /* size - return number of elements in a                         */
  894. Local long size(a, LINK)
  895. APLVALUEREC *a;
  896. struct LOC_applyValueOp *LINK;
  897. {
  898.   long Result;
  899.  
  900.   switch (a->rnk) {
  901.  
  902.   case SCALAR:
  903.     Result = 1;
  904.     break;
  905.  
  906.   case VECTOR:
  907.     Result = a->UU.leng;
  908.     break;
  909.  
  910.   case MATRIX:
  911.     Result = a->UU.U2.rows * a->UU.U2.cols;
  912.     break;
  913.   }
  914.   return Result;
  915. }  /* size */
  916.  
  917. /* skipover - return pointer to nth record in il                 */
  918. Local INTLISTREC *skipover(n, il, LINK)
  919. long n;
  920. INTLISTREC *il;
  921. struct LOC_applyValueOp *LINK;
  922. {
  923.   while (n > 0) {
  924.     il = il->nextint;
  925.     n--;
  926.   }
  927.   return il;
  928. }  /* skipover */
  929.  
  930. Local Void copyrank(a, r)
  931. APLVALUEREC *a, *r;
  932. {
  933.   r->rnk = a->rnk;
  934.   switch (r->rnk) {   /* with */
  935.  
  936.   case SCALAR:
  937.     /* blank case */
  938.     break;
  939.  
  940.   case VECTOR:
  941.     r->UU.leng = a->UU.leng;
  942.     break;
  943.  
  944.   case MATRIX:
  945.     r->UU.U2.rows = a->UU.U2.rows;
  946.     r->UU.U2.cols = a->UU.U2.cols;
  947.     break;
  948.   }/* case */
  949. }  /* copyrank */
  950.  
  951. /* applyOp - apply VALUEOP op to integer arguments               */
  952. Local long applyOp(op, i, j)
  953. BUILTINOP op;
  954. long i, j;
  955. {
  956.   long Result;
  957.  
  958.   switch (op) {
  959.  
  960.   case PLUSOP:
  961.     Result = i + j;
  962.     break;
  963.  
  964.   case MINUSOP:
  965.     Result = i - j;
  966.     break;
  967.  
  968.   case TIMESOP:
  969.     Result = i * j;
  970.     break;
  971.  
  972.   case DIVOP:
  973.     Result = i / j;
  974.     break;
  975.  
  976.   case MAXOP:
  977.     if (i > j)
  978.       Result = i;
  979.     else
  980.       Result = j;
  981.     break;
  982.  
  983.   case OROP:
  984.     if (i == 1 || j == 1)
  985.       Result = 1;
  986.     else
  987.       Result = 0;
  988.     break;
  989.  
  990.   case ANDOP:
  991.     if (i == 1 && j == 1)
  992.       Result = 1;
  993.     else
  994.       Result = 0;
  995.     break;
  996.  
  997.   case EQOP:
  998.     if (i == j)
  999.       Result = 1;
  1000.     else
  1001.       Result = 0;
  1002.     break;
  1003.  
  1004.   case LTOP:
  1005.     if (i < j)
  1006.       Result = 1;
  1007.     else
  1008.       Result = 0;
  1009.     break;
  1010.  
  1011.   case GTOP:
  1012.     if (i > j)
  1013.       Result = 1;
  1014.     else
  1015.       Result = 0;
  1016.     break;
  1017.   }/* case */
  1018.   return Result;
  1019. }  /* applyOp */
  1020.  
  1021. /* applyIntlis - apply op to two lists, extending appropriately  */
  1022. Local INTLISTREC *applyIntlis(op, il1, il2, il1leng, il2leng)
  1023. BUILTINOP op;
  1024. INTLISTREC *il1, *il2;
  1025. long il1leng, il2leng;
  1026. {
  1027.   INTLISTREC *il;
  1028.  
  1029.   if (il1 == NULL || il2 == NULL)
  1030.     return NULL;
  1031.   else {
  1032.     il = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1033.     il->int_ = applyOp(op, il1->int_, il2->int_);
  1034.     if (il1leng == 1) {
  1035.       il->nextint = applyIntlis(op, il1, il2->nextint, il1leng, il2leng);
  1036.       return il;
  1037.     }
  1038.     if (il2leng == 1)
  1039.       il->nextint = applyIntlis(op, il1->nextint, il2, il1leng, il2leng);
  1040.     else
  1041.       il->nextint = applyIntlis(op, il1->nextint, il2->nextint, il1leng,
  1042.                 il2leng);
  1043.     return il;   /* with */
  1044.   }
  1045. }  /* applyIntlis */
  1046.  
  1047. /* applyArithOp - apply binary operator to a1 and a2              */
  1048. Local Void applyArithOp(op, a1, a2, LINK)
  1049. BUILTINOP op;
  1050. APLVALUEREC *a1, *a2;
  1051. struct LOC_applyValueOp *LINK;
  1052. {
  1053.  
  1054.   /* copyrank - copy rank and shape of a to r                      */
  1055.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1056.   if (a1->rnk == SCALAR)
  1057.     copyrank(a2, LINK->result);
  1058.   else if (a2->rnk == SCALAR)
  1059.     copyrank(a1, LINK->result);
  1060.   else if (size(a1, LINK) == 1)
  1061.     copyrank(a2, LINK->result);
  1062.   else
  1063.     copyrank(a1, LINK->result);
  1064.   LINK->result->intvals = applyIntlis(op, a1->intvals, a2->intvals,
  1065.                       size(a1, LINK), size(a2, LINK));
  1066. }  /* applyArithOp */
  1067.  
  1068. /* Local variables for applyRedOp: */
  1069. struct LOC_applyRedOp {
  1070.   struct LOC_applyValueOp *LINK;
  1071.   BUILTINOP op;
  1072. } ;
  1073.  
  1074. Local long applyOp_(op, i, j, LINK)
  1075. BUILTINOP op;
  1076. long i, j;
  1077. struct LOC_applyRedOp *LINK;
  1078. {
  1079.   long Result;
  1080.  
  1081.   switch (op) {
  1082.  
  1083.   case REDPLUSOP:
  1084.     Result = i + j;
  1085.     break;
  1086.  
  1087.   case REDMINUSOP:
  1088.     Result = i - j;
  1089.     break;
  1090.  
  1091.   case REDTIMESOP:
  1092.     Result = i * j;
  1093.     break;
  1094.  
  1095.   case REDDIVOP:
  1096.     Result = i / j;
  1097.     break;
  1098.  
  1099.   case REDMAXOP:
  1100.     if (i > j)
  1101.       Result = i;
  1102.     else
  1103.       Result = j;
  1104.     break;
  1105.  
  1106.   case REDOROP:
  1107.     if (i == 1 || j == 1)
  1108.       Result = 1;
  1109.     else
  1110.       Result = 0;
  1111.     break;
  1112.  
  1113.   case REDANDOP:
  1114.     if (i == 1 && j == 1)
  1115.       Result = 1;
  1116.     else
  1117.       Result = 0;
  1118.     break;
  1119.   }/* case */
  1120.   return Result;
  1121. }  /* applyOp */
  1122.  
  1123. /* redVec - reduce op (argument to applyRedOp) over list         */
  1124. Local long redVec(il, leng, LINK)
  1125. INTLISTREC *il;
  1126. long leng;
  1127. struct LOC_applyRedOp *LINK;
  1128. {
  1129.   if (leng == 0)
  1130.     return 0;
  1131.   else if (leng == 1)
  1132.     return (il->int_);
  1133.   else
  1134.     return (applyOp_(LINK->op, il->int_, redVec(il->nextint, leng - 1, LINK),
  1135.              LINK));
  1136. }  /* redVec */
  1137.  
  1138. /* redMat - reduce op (argument to applyRedOp) over matrix       */
  1139. Local INTLISTREC *redMat(il, cols, rows, LINK)
  1140. INTLISTREC *il;
  1141. long cols, rows;
  1142. struct LOC_applyRedOp *LINK;
  1143. {
  1144.   INTLISTREC *ilnew;
  1145.  
  1146.   if (rows == 0)
  1147.     return NULL;
  1148.   else {
  1149.     ilnew = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1150.     ilnew->int_ = redVec(il, cols, LINK);
  1151.     ilnew->nextint = redMat(skipover(cols, il, LINK->LINK), cols, rows - 1,
  1152.                 LINK);
  1153.     return ilnew;
  1154.   }
  1155. }  /* redmat */
  1156.  
  1157. /* applyRedOp - apply reduction operator                         */
  1158. Local Void applyRedOp(op_, a, LINK)
  1159. BUILTINOP op_;
  1160. APLVALUEREC *a;
  1161. struct LOC_applyValueOp *LINK;
  1162. {
  1163.  
  1164.   /* applyOp - apply base operator of reduction operator           */
  1165.   struct LOC_applyRedOp V;
  1166.   APLVALUEREC *WITH;
  1167.  
  1168.   V.LINK = LINK;
  1169.   V.op = op_;
  1170.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1171.   switch (a->rnk) {
  1172.  
  1173.   case SCALAR:
  1174.     LINK->result = a;
  1175.     break;
  1176.  
  1177.   case VECTOR:
  1178.     WITH = LINK->result;
  1179.     WITH->rnk = SCALAR;
  1180.     WITH->intvals = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1181.     WITH->intvals->int_ = redVec(a->intvals, a->UU.leng, &V);
  1182.     WITH->intvals->nextint = NULL;
  1183.     break;
  1184.  
  1185.   case MATRIX:
  1186.     WITH = LINK->result;
  1187.     WITH->rnk = VECTOR;
  1188.     WITH->UU.leng = a->UU.U2.rows;
  1189.     WITH->intvals = redMat(a->intvals, a->UU.U2.cols, WITH->UU.leng, &V);
  1190.     break;
  1191.   }/* case */
  1192. }  /* applyRedOp */
  1193.  
  1194. /* append - append il2 to il1; il1 is altered                    */
  1195. Local INTLISTREC *append(il1, il2, LINK)
  1196. INTLISTREC *il1, *il2;
  1197. struct LOC_applyValueOp *LINK;
  1198. {
  1199.   INTLISTREC *Result;
  1200.  
  1201.   if (il1 == NULL)
  1202.     return il2;
  1203.   Result = il1;
  1204.   while (il1->nextint != NULL)
  1205.     il1 = il1->nextint;
  1206.   il1->nextint = il2;
  1207.   return Result;
  1208. }  /* append */
  1209.  
  1210. /* ncopy - copy elements of src until list has reps elements     */
  1211. Local INTLISTREC *ncopy(src, reps, LINK)
  1212. INTLISTREC *src;
  1213. long reps;
  1214. struct LOC_applyValueOp *LINK;
  1215. {
  1216.   INTLISTREC *Result, *il, *suffix;
  1217.   long i;
  1218.  
  1219.   if (reps == 0)
  1220.     return NULL;
  1221.   il = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1222.   Result = il;
  1223.   il->int_ = src->int_;
  1224.   suffix = src->nextint;
  1225.   for (i = 2; i <= reps; i++) {
  1226.     if (suffix == NULL)   /* exhausted src */
  1227.       suffix = src;
  1228.     /* start over */
  1229.     il->nextint = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1230.     il = il->nextint;
  1231.     il->int_ = suffix->int_;
  1232.     suffix = suffix->nextint;
  1233.   }
  1234.   il->nextint = NULL;
  1235.   return Result;
  1236. }  /* ncopy */
  1237.  
  1238. /* Local variables for compress: */
  1239. struct LOC_compress {
  1240.   struct LOC_applyValueOp *LINK;
  1241. } ;
  1242.  
  1243. /* ilcompress - il1 over il2, taking il2 in chunks of size width */
  1244. Local INTLISTREC *ilcompress(il1, il2, width, LINK)
  1245. INTLISTREC *il1, *il2;
  1246. long width;
  1247. struct LOC_compress *LINK;
  1248. {
  1249.   INTLISTREC *il;
  1250.  
  1251.   if (il1 == NULL)
  1252.     return NULL;
  1253.   else if (il1->int_ == 1) {
  1254.     il = ncopy(il2, width, LINK->LINK);
  1255.     il = append(il, ilcompress(il1->nextint, skipover(width, il2, LINK->LINK),
  1256.                    width, LINK), LINK->LINK);
  1257.     return il;
  1258.   } else
  1259.     return (ilcompress(il1->nextint, skipover(width, il2, LINK->LINK), width,
  1260.                LINK));
  1261. }  /* ilcompress */
  1262.  
  1263. /* countones - count ones in il                                  */
  1264. Local long countones(il, LINK)
  1265. INTLISTREC *il;
  1266. struct LOC_compress *LINK;
  1267. {
  1268.   long i;
  1269.  
  1270.   i = 0;
  1271.   while (il != NULL) {
  1272.     if (il->int_ == 1)
  1273.       i++;
  1274.     il = il->nextint;
  1275.   }
  1276.   return i;
  1277. }  /* countones */
  1278.  
  1279. /* compress - compress a1 over a2                                */
  1280. Local Void compress(a1, a2, LINK)
  1281. APLVALUEREC *a1, *a2;
  1282. struct LOC_applyValueOp *LINK;
  1283. {
  1284.   struct LOC_compress V;
  1285.   long width;
  1286.   APLVALUEREC *WITH;
  1287.  
  1288.   V.LINK = LINK;
  1289.   if (a2->rnk == VECTOR)
  1290.     width = 1;
  1291.   else
  1292.     width = a2->UU.U2.cols;
  1293.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1294.   WITH = LINK->result;
  1295.   WITH->rnk = a2->rnk;
  1296.   WITH->intvals = ilcompress(a1->intvals, a2->intvals, width, &V);
  1297.   if (WITH->rnk == VECTOR)   /* with */
  1298.     WITH->UU.leng = countones(a1->intvals, &V);
  1299.   else {
  1300.     WITH->UU.U2.cols = a2->UU.U2.cols;
  1301.     WITH->UU.U2.rows = countones(a1->intvals, &V);
  1302.   }
  1303. }  /* compress */
  1304.  
  1305. /* shape - return vector giving dimensions of a                  */
  1306. Local Void shape(a, LINK)
  1307. APLVALUEREC *a;
  1308. struct LOC_applyValueOp *LINK;
  1309. {
  1310.   INTLISTREC *il;
  1311.  
  1312.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1313.   LINK->result->rnk = VECTOR;
  1314.   switch (a->rnk) {
  1315.  
  1316.   case SCALAR:
  1317.     LINK->result->UU.leng = 0;
  1318.     LINK->result->intvals = NULL;
  1319.     break;
  1320.  
  1321.   case VECTOR:
  1322.     LINK->result->UU.leng = 1;
  1323.     il = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1324.     LINK->result->intvals = il;
  1325.     il->int_ = a->UU.leng;
  1326.     il->nextint = NULL;
  1327.     break;
  1328.  
  1329.   case MATRIX:
  1330.     LINK->result->UU.leng = 2;
  1331.     il = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1332.     LINK->result->intvals = il;
  1333.     il->int_ = a->UU.U2.rows;
  1334.     il->nextint = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1335.     il = il->nextint;
  1336.     il->int_ = a->UU.U2.cols;
  1337.     il->nextint = NULL;
  1338.     break;
  1339.   }/* case */
  1340. }  /* shape */
  1341.  
  1342. /* ravel - transform a to a vector without changing elements     */
  1343. Local Void ravel(a, LINK)
  1344. APLVALUEREC *a;
  1345. struct LOC_applyValueOp *LINK;
  1346. {
  1347.   long size;
  1348.   APLVALUEREC *WITH;
  1349.  
  1350.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1351.   switch (a->rnk) {
  1352.  
  1353.   case SCALAR:
  1354.     size = 1;
  1355.     break;
  1356.  
  1357.   case VECTOR:
  1358.     size = a->UU.leng;
  1359.     break;
  1360.  
  1361.   case MATRIX:
  1362.     size = a->UU.U2.rows * a->UU.U2.cols;
  1363.     break;
  1364.   }
  1365.   WITH = LINK->result;
  1366.   WITH->rnk = VECTOR;
  1367.   WITH->UU.leng = size;
  1368.   WITH->intvals = a->intvals;
  1369. }  /* ravel */
  1370.  
  1371. /* restruct - restructure valuevec according to shapevec         */
  1372. Local Void restruct(shapevec, valuevec, LINK)
  1373. APLVALUEREC *shapevec, *valuevec;
  1374. struct LOC_applyValueOp *LINK;
  1375. {
  1376.   RANK newrank;
  1377.   long dim1, dim2;
  1378.   APLVALUEREC *WITH;
  1379.  
  1380.   if (valuevec->intvals == NULL) {
  1381.     printf("Cannot restructure null vector\n");
  1382.     longjmp(_JL99, 1);
  1383.   }
  1384.   if (shapevec->rnk == SCALAR) {
  1385.     newrank = VECTOR;
  1386.     dim1 = shapevec->intvals->int_;
  1387.     dim2 = 1;
  1388.   } else if (shapevec->UU.leng == 0) {
  1389.     newrank = SCALAR;
  1390.     dim1 = 1;
  1391.     dim2 = 1;
  1392.   } else if (shapevec->UU.leng == 1) {
  1393.     newrank = VECTOR;
  1394.     dim1 = shapevec->intvals->int_;
  1395.     dim2 = 1;
  1396.   } else {
  1397.     newrank = MATRIX;
  1398.     dim1 = shapevec->intvals->int_;
  1399.     dim2 = shapevec->intvals->nextint->int_;
  1400.   }
  1401.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1402.   WITH = LINK->result;
  1403.   WITH->rnk = newrank;
  1404.   if (WITH->rnk == VECTOR)
  1405.     WITH->UU.leng = dim1;
  1406.   else if (WITH->rnk == MATRIX) {
  1407.     WITH->UU.U2.rows = dim1;
  1408.     WITH->UU.U2.cols = dim2;
  1409.   }
  1410.   WITH->intvals = ncopy(valuevec->intvals, dim1 * dim2, LINK);   /* with */
  1411.  
  1412.   /* with */
  1413. }  /* restruct */
  1414.  
  1415. /* copyIntlis - make a fresh copy of il                          */
  1416. Local INTLISTREC *copyIntlis(il, LINK)
  1417. INTLISTREC *il;
  1418. struct LOC_applyValueOp *LINK;
  1419. {
  1420.   return (ncopy(il, lengthIL(il), LINK));
  1421. }  /* copyIntlis */
  1422.  
  1423. /* cat - create a vector by joining ravels of a1 and a2          */
  1424. Local Void cat(a1, a2, LINK)
  1425. APLVALUEREC *a1, *a2;
  1426. struct LOC_applyValueOp *LINK;
  1427. {
  1428.   APLVALUEREC *WITH;
  1429.  
  1430.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1431.   WITH = LINK->result;
  1432.   WITH->rnk = VECTOR;
  1433.   WITH->UU.leng = size(a1, LINK) + size(a2, LINK);
  1434.   WITH->intvals = copyIntlis(a1->intvals, LINK);
  1435.   WITH->intvals = append(WITH->intvals, a2->intvals, LINK);
  1436. }  /* cat */
  1437.  
  1438. /* indx - perform index generation, using first value in a       */
  1439. Local Void indx(a, LINK)
  1440. APLVALUEREC *a;
  1441. struct LOC_applyValueOp *LINK;
  1442. {
  1443.   long i;
  1444.   INTLISTREC *il;
  1445.   APLVALUEREC *WITH;
  1446.  
  1447.   i = a->intvals->int_;
  1448.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1449.   WITH = LINK->result;
  1450.   WITH->rnk = VECTOR;
  1451.   WITH->intvals = NULL;
  1452.   WITH->UU.leng = i;
  1453.   while (i > 0) {   /* with */
  1454.     il = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1455.     il->int_ = i;
  1456.     il->nextint = WITH->intvals;
  1457.     WITH->intvals = il;
  1458.     i--;
  1459.   }  /* while */
  1460. }  /* indx */
  1461.  
  1462. /* Local variables for trans: */
  1463. struct LOC_trans {
  1464.   struct LOC_applyValueOp *LINK;
  1465. } ;
  1466.  
  1467. /* skiplist - subscript il by cols and rows                      */
  1468. Local INTLISTREC *skiplist(il, cols, rows, LINK)
  1469. INTLISTREC *il;
  1470. long cols, rows;
  1471. struct LOC_trans *LINK;
  1472. {
  1473.   INTLISTREC *ilnew;
  1474.  
  1475.   ilnew = (INTLISTREC *)Malloc(sizeof(INTLISTREC));
  1476.   if (rows == 1) {
  1477.     ilnew->int_ = il->int_;
  1478.     ilnew->nextint = NULL;
  1479.   } else {
  1480.     ilnew->int_ = il->int_;
  1481.     ilnew->nextint = skiplist(skipover(cols, il, LINK->LINK), cols, rows - 1,
  1482.                   LINK);
  1483.   }
  1484.   return ilnew;
  1485. }  /* skiplist */
  1486.  
  1487. /* trans - perform "trans"                                       */
  1488. Local Void trans(a, LINK)
  1489. APLVALUEREC *a;
  1490. struct LOC_applyValueOp *LINK;
  1491. {
  1492.   struct LOC_trans V;
  1493.   INTLISTREC *il, *ilnew;
  1494.   long i;
  1495.   APLVALUEREC *WITH;
  1496.   long FORLIM;
  1497.  
  1498.   V.LINK = LINK;
  1499.   if (a->rnk != MATRIX || a->intvals == NULL) {
  1500.     LINK->result = a;
  1501.     return;
  1502.   }
  1503.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1504.   WITH = LINK->result;
  1505.   WITH->rnk = MATRIX;
  1506.   WITH->UU.U2.cols = a->UU.U2.rows;
  1507.   WITH->UU.U2.rows = a->UU.U2.cols;
  1508.   il = a->intvals;
  1509.   ilnew = NULL;
  1510.   FORLIM = WITH->UU.U2.rows;
  1511.   for (i = 1; i <= FORLIM; i++) {
  1512.     ilnew = append(ilnew,
  1513.            skiplist(il, WITH->UU.U2.rows, WITH->UU.U2.cols, &V),
  1514.            LINK);
  1515.     il = il->nextint;
  1516.   }
  1517.   WITH->intvals = ilnew;   /* with */
  1518. }  /* trans */
  1519.  
  1520. /* Local variables for subscript: */
  1521. struct LOC_subscript {
  1522.   struct LOC_applyValueOp *LINK;
  1523. } ;
  1524.  
  1525. /* sub - find nth chunk in il, each chunk having width elements  */
  1526. Local INTLISTREC *sub(il, n, width, LINK)
  1527. INTLISTREC *il;
  1528. long n, width;
  1529. struct LOC_subscript *LINK;
  1530. {
  1531.   long i, j;
  1532.  
  1533.   for (i = 1; i < n; i++) {
  1534.     for (j = 1; j <= width; j++)
  1535.       il = il->nextint;
  1536.   }
  1537.   return il;
  1538. }  /* sub */
  1539.  
  1540. /* ilsub - subscript src by subs in chunks of size width         */
  1541. Local INTLISTREC *ilsub(src, subs, width, LINK)
  1542. INTLISTREC *src, *subs;
  1543. long width;
  1544. struct LOC_subscript *LINK;
  1545. {
  1546.   INTLISTREC *il;
  1547.  
  1548.   if (subs == NULL) {
  1549.     il = NULL;
  1550.     return il;
  1551.   }
  1552.   il = sub(src, subs->int_, width, LINK);
  1553.   il = ncopy(il, width, LINK->LINK);
  1554.   il = append(il, ilsub(src, subs->nextint, width, LINK), LINK->LINK);
  1555.   return il;
  1556. }  /* ilsub */
  1557.  
  1558. /* subscript - "[]" operation; a1 a vector or matrix, a2 vector  */
  1559. Local Void subscript(a1, a2, LINK)
  1560. APLVALUEREC *a1, *a2;
  1561. struct LOC_applyValueOp *LINK;
  1562. {
  1563.   struct LOC_subscript V;
  1564.   long width;
  1565.   APLVALUEREC *WITH;
  1566.  
  1567.   V.LINK = LINK;
  1568.   LINK->result = (APLVALUEREC *)Malloc(sizeof(APLVALUEREC));
  1569.   WITH = LINK->result;
  1570.   WITH->rnk = a1->rnk;
  1571.   if (WITH->rnk == VECTOR) {
  1572.     if (a2->rnk == SCALAR)
  1573.       WITH->UU.leng = 1;
  1574.     else
  1575.       WITH->UU.leng = a2->UU.leng;
  1576.     width = 1;
  1577.   } else {
  1578.     if (a2->rnk == SCALAR)
  1579.       WITH->UU.U2.rows = 1;
  1580.     else
  1581.       WITH->UU.U2.rows = a2->UU.leng;
  1582.     WITH->UU.U2.cols = a1->UU.U2.cols;
  1583.     width = WITH->UU.U2.cols;
  1584.   }
  1585.   WITH->intvals = ilsub(a1->intvals, a2->intvals, width, &V);   /* with */
  1586. }  /* subscript */
  1587.  
  1588. /* arity - return number of arguments expected by op             */
  1589. Local long arity(op, LINK)
  1590. BUILTINOP op;
  1591. struct LOC_applyValueOp *LINK;
  1592. {
  1593.   if (((1L << ((long)op)) & (((1L << ((long)GTOP + 1)) - (1 << ((long)PLUSOP))) |
  1594.      (1 << ((long)COMPRESSOP)) | (1 << ((long)RESTRUCTOP)) |
  1595.      (1 << ((long)CATOP)) | (1 << ((long)SUBOP)))) != 0)
  1596.     return 2;
  1597.   else
  1598.     return 1;
  1599. }  /* arity */
  1600.  
  1601.  
  1602. /* applyValueOp - apply VALUEOP op to arguments in VALUELIST vl  */
  1603. Static APLVALUEREC *applyValueOp(op, vl)
  1604. BUILTINOP op;
  1605. VALUELISTREC *vl;
  1606. {
  1607.   struct LOC_applyValueOp V;
  1608.   APLVALUEREC *a1, *a2;
  1609.  
  1610.   if (arity(op, &V) != lengthVL(vl)) {
  1611.     printf("Wrong number of arguments to ");
  1612.     prName((int)op + 1);
  1613.     putchar('\n');
  1614.     longjmp(_JL99, 1);
  1615.   }
  1616.   a1 = vl->head;   /* 1st actual */
  1617.   if (arity(op, &V) == 2)   /* 2nd actual */
  1618.     a2 = vl->tail->head;
  1619.   switch (op) {
  1620.  
  1621.   case PLUSOP:
  1622.   case MINUSOP:
  1623.   case TIMESOP:
  1624.   case DIVOP:
  1625.   case MAXOP:
  1626.   case OROP:
  1627.   case ANDOP:
  1628.   case EQOP:
  1629.   case LTOP:
  1630.   case GTOP:
  1631.     applyArithOp(op, a1, a2, &V);
  1632.     break;
  1633.  
  1634.   case REDPLUSOP:
  1635.   case REDMINUSOP:
  1636.   case REDTIMESOP:
  1637.   case REDDIVOP:
  1638.   case REDMAXOP:
  1639.   case REDOROP:
  1640.   case REDANDOP:
  1641.     applyRedOp(op, a1, &V);
  1642.     break;
  1643.  
  1644.   case COMPRESSOP:
  1645.     compress(a1, a2, &V);
  1646.     break;
  1647.  
  1648.   case SHAPEOP:
  1649.     shape(a1, &V);
  1650.     break;
  1651.  
  1652.   case RAVELOP:
  1653.     ravel(a1, &V);
  1654.     break;
  1655.  
  1656.   case RESTRUCTOP:
  1657.     restruct(a1, a2, &V);
  1658.     break;
  1659.  
  1660.   case CATOP:
  1661.     cat(a1, a2, &V);
  1662.     break;
  1663.  
  1664.   case INDXOP:
  1665.     indx(a1, &V);
  1666.     break;
  1667.  
  1668.   case TRANSOP:
  1669.     trans(a1, &V);
  1670.     break;
  1671.  
  1672.   case SUBOP:
  1673.     subscript(a1, a2, &V);
  1674.     break;
  1675.  
  1676.   case PRINTOP:
  1677.     prValue(a1);
  1678.     V.result = a1;
  1679.     break;
  1680.   }/* case */
  1681.   return V.result;
  1682. }  /* applyValueOp */
  1683.  
  1684.  
  1685. Static APLVALUEREC *eval PP((EXPREC *e, ENVREC *rho));
  1686.  
  1687. /* Local variables for eval: */
  1688. struct LOC_eval {
  1689.   ENVREC *rho;
  1690. } ;
  1691.  
  1692. /* evalList - evaluate each expression in el                     */
  1693. Local VALUELISTREC *evalList(el, LINK)
  1694. EXPLISTREC *el;
  1695. struct LOC_eval *LINK;
  1696. {
  1697.   APLVALUEREC *h;
  1698.   VALUELISTREC *t;
  1699.  
  1700.   if (el == NULL)
  1701.     return NULL;
  1702.   else {
  1703.     h = eval(el->head, LINK->rho);
  1704.     t = evalList(el->tail, LINK);
  1705.     return (mkValuelist(h, t));
  1706.   }
  1707. }  /* evalList */
  1708.  
  1709. /* applyUserFun - look up definition of nm and apply to actuals  */
  1710. Local APLVALUEREC *applyUserFun(nm, actuals, LINK)
  1711. char nm;
  1712. VALUELISTREC *actuals;
  1713. struct LOC_eval *LINK;
  1714. {
  1715.   FUNDEFREC *f;
  1716.   ENVREC *rho;
  1717.  
  1718.   f = fetchFun(nm);
  1719.   if (f == NULL) {
  1720.     printf("Undefined function: ");
  1721.     prName(nm);
  1722.     putchar('\n');
  1723.     longjmp(_JL99, 1);
  1724.   }
  1725.   if (lengthNL(f->formals) != lengthVL(actuals)) {
  1726.     printf("Wrong number of arguments to: ");
  1727.     prName(nm);
  1728.     putchar('\n');
  1729.     longjmp(_JL99, 1);
  1730.   }
  1731.   rho = mkEnv(f->formals, actuals);
  1732.   return (eval(f->body, rho));
  1733. }  /* applyUserFun */
  1734.  
  1735. /* applyCtrlOp - apply CONTROLOP op to args in rho               */
  1736. Local APLVALUEREC *applyCtrlOp(op, args, LINK)
  1737. BUILTINOP op;
  1738. EXPLISTREC *args;
  1739. struct LOC_eval *LINK;
  1740. {
  1741.   APLVALUEREC *Result, *a;
  1742.   EXPLISTREC *WITH;
  1743.  
  1744.   WITH = args;
  1745.   switch (op) {
  1746.  
  1747.   case IFOP:
  1748.     if (isTrueVal(eval(WITH->head, LINK->rho)))
  1749.       Result = eval(WITH->tail->head, LINK->rho);
  1750.     else
  1751.       Result = eval(WITH->tail->tail->head, LINK->rho);
  1752.     break;
  1753.  
  1754.   case WHILEOP:
  1755.     a = eval(WITH->head, LINK->rho);
  1756.     while (isTrueVal(a)) {
  1757.       a = eval(WITH->tail->head, LINK->rho);
  1758.       a = eval(WITH->head, LINK->rho);
  1759.     }
  1760.     Result = a;
  1761.     break;
  1762.  
  1763.   case SETOP:
  1764.     a = eval(WITH->tail->head, LINK->rho);
  1765.     if (isBound(WITH->head->UU.varble, LINK->rho))
  1766.       assign(WITH->head->UU.varble, a, LINK->rho);
  1767.     else if (isBound(WITH->head->UU.varble, globalEnv))
  1768.       assign(WITH->head->UU.varble, a, globalEnv);
  1769.     else
  1770.       bindVar(WITH->head->UU.varble, a, globalEnv);
  1771.     Result = a;
  1772.     break;
  1773.  
  1774.   case BEGINOP:
  1775.     while (args->tail != NULL) {
  1776.       a = eval(args->head, LINK->rho);
  1777.       args = args->tail;
  1778.     }
  1779.     Result = eval(args->head, LINK->rho);
  1780.     break;
  1781.   }/* case and with */
  1782.   return Result;
  1783. }  /* applyCtrlOp */
  1784.  
  1785.  
  1786. /*****************************************************************
  1787.  *                     EVALUATION                                *
  1788.  *****************************************************************/
  1789.  
  1790. /* eval - return value of expression e in local environment rho  */
  1791. Static APLVALUEREC *eval(e, rho_)
  1792. EXPREC *e;
  1793. ENVREC *rho_;
  1794. {
  1795.   struct LOC_eval V;
  1796.   APLVALUEREC *Result;
  1797.   BUILTINOP op;
  1798.  
  1799.   V.rho = rho_;
  1800.   switch (e->etype) {
  1801.  
  1802.   case VALEXP:
  1803.     Result = e->UU.aplval;
  1804.     break;
  1805.  
  1806.   case VAREXP:
  1807.     if (isBound(e->UU.varble, V.rho))
  1808.       Result = fetch(e->UU.varble, V.rho);
  1809.     else if (isBound(e->UU.varble, globalEnv))
  1810.       Result = fetch(e->UU.varble, globalEnv);
  1811.     else {
  1812.       printf("Undefined variable: ");
  1813.       prName(e->UU.varble);
  1814.       putchar('\n');
  1815.       longjmp(_JL99, 1);
  1816.     }
  1817.     break;
  1818.  
  1819.   case APEXP:
  1820.     if (e->UU.U2.optr > numBuiltins)
  1821.       Result = applyUserFun(e->UU.U2.optr, evalList(e->UU.U2.args, &V), &V);
  1822.     else {
  1823.       op = primOp(e->UU.U2.optr);
  1824.       if (((1L << ((long)op)) &
  1825.        ((1 << ((long)BEGINOP + 1)) - (1 << ((long)IFOP)))) != 0)
  1826.     Result = applyCtrlOp(op, e->UU.U2.args, &V);
  1827.       else
  1828.     Result = applyValueOp(op, evalList(e->UU.U2.args, &V));
  1829.     }
  1830.     break;
  1831.   }/* case and with */
  1832.   return Result;
  1833. }  /* eval */
  1834.  
  1835.  
  1836. /*****************************************************************
  1837.  *                     READ-EVAL-PRINT LOOP                      *
  1838.  *****************************************************************/
  1839.  
  1840. main(argc, argv)
  1841. int argc;
  1842. Char *argv[];
  1843. {  /* apl main */
  1844.   PASCAL_MAIN(argc, argv);
  1845.   if (setjmp(_JL99))
  1846.     goto _L99;
  1847.   initNames();
  1848.   globalEnv = emptyEnv();
  1849.  
  1850.   quittingtime = false;
  1851. _L99:
  1852.   while (!quittingtime) {
  1853.     reader();
  1854.     if (matches((long)pos_, 4, "quit                ")) {
  1855.       quittingtime = true;
  1856.       break;
  1857.     }
  1858.     if ((userinput[pos_ - 1] == '(') & matches(skipblanks(pos_ + 1L), 6,
  1859.                            "define              ")) {
  1860.       prName(parseDef());
  1861.       putchar('\n');
  1862.     } else {
  1863.       currentExp = parseExp();
  1864.       prValue(eval(currentExp, emptyEnv()));
  1865.       printf("\n\n");
  1866.     }
  1867.   }  /* while */
  1868.   exit(0);
  1869. }  /* apl */
  1870.  
  1871.  
  1872.  
  1873.  
  1874.  
  1875.  
  1876. /* End. */
  1877.