home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Distributions / ucb / spencer_2bsd.tar.gz / 2bsd.tar / src / pi1 / proc.c < prev    next >
C/C++ Source or Header  |  1980-02-17  |  17KB  |  794 lines
  1. /* Copyright (c) 1979 Regents of the University of California */
  2. #
  3. /*
  4.  * pi - Pascal interpreter code translator
  5.  *
  6.  * Charles Haley, Bill Joy UCB
  7.  * Version 1.2 January 1979
  8.  */
  9.  
  10. #include "0.h"
  11. #include "tree.h"
  12. #include "opcode.h"
  13.  
  14. /*
  15.  * The following arrays are used to determine which classes may be
  16.  * read and written to/from text files.
  17.  * They are indexed by the return types from classify.
  18.  */
  19. #define rdops(x) rdxxxx[(x)-(TFIRST)]
  20. #define wrops(x) wrxxxx[(x)-(TFIRST)]
  21.  
  22. int rdxxxx[] {
  23.     0,        /* -7  file types */
  24.     0,        /* -6  record types */
  25.     0,        /* -5  array types */
  26.     0,        /* -4  scalar types */
  27.     0,        /* -3  pointer types */
  28.     0,        /* -2  set types */
  29.     0,        /* -1  string types */
  30.     0,        /*  0  nil - i.e. no type */
  31.     0,        /*  1  booleans */
  32.     O_READC,    /*  2  character */
  33.     O_READ4,    /*  3  integer */
  34.     O_READ8        /*  4  real */
  35. };
  36.  
  37. int wrxxxx[] {
  38.     0,        /* -7  file types */
  39.     0,        /* -6  record types */
  40.     0,        /* -5  array types */
  41.     0,        /* -4  scalar types */
  42.     0,        /* -3  pointer types */
  43.     0,        /* -2  set types */
  44.     O_WRITG,    /* -1  string types */
  45.     0,        /*  0  nil - i.e. no type */
  46.     O_WRITB,    /*  1  booleans */
  47.     O_WRITC,    /*  2  character */
  48.     O_WRIT4,    /*  3  integer */
  49.     O_WRIT8,    /*  4  real */
  50. };
  51.  
  52. /*
  53.  * Proc handles procedure calls.
  54.  * Non-builtin procedures are "buck-passed" to func (with a flag
  55.  * indicating that they are actually procedures.
  56.  * builtin procedures are handled here.
  57.  */
  58. proc(r)
  59.     int *r;
  60. {
  61.     register struct nl *p;
  62.     register int *al, op;
  63.     struct nl *filetype, *ap;
  64.     int argc, *argv, c, two, oct, hex, *file;
  65.     int pu;
  66.     int *pua, *pui, *puz;
  67.     int i, j, k;
  68.  
  69.     /*
  70.      * Verify that the name is
  71.      * defined and is that of a
  72.      * procedure.
  73.      */
  74.     p = lookup(r[2]);
  75.     if (p == NIL) {
  76.         rvlist(r[3]);
  77.         return;
  78.     }
  79.     if (p->class != PROC) {
  80.         error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]);
  81.         rvlist(r[3]);
  82.         return;
  83.     }
  84.     argv = r[3];
  85.  
  86.     /*
  87.      * Call handles user defined
  88.      * procedures and functions.
  89.      */
  90.     if (bn != 0) {
  91.         call(p, argv, PROC, bn);
  92.         return;
  93.     }
  94.  
  95.     /*
  96.      * Call to built-in procedure.
  97.      * Count the arguments.
  98.      */
  99.     argc = 0;
  100.     for (al = argv; al != NIL; al = al[2])
  101.         argc++;
  102.  
  103.     /*
  104.      * Switch on the operator
  105.      * associated with the built-in
  106.      * procedure in the namelist
  107.      */
  108.     op = p->value[0] &~ NSTAND;
  109.     if (opt('s') && (p->value[0] & NSTAND)) {
  110.         standard();
  111.         error("%s is a nonstandard procedure", p->symbol);
  112.     }
  113.     switch (op) {
  114.  
  115.     case O_NULL:
  116.         if (argc != 0)
  117.             error("null takes no arguments");
  118.         return;
  119.  
  120.     case O_FLUSH:
  121.         if (argc == 0) {
  122.             put1(O_MESSAGE);
  123.             return;
  124.         }
  125.         if (argc != 1) {
  126.             error("flush takes at most one argument");
  127.             return;
  128.         }
  129.         ap = rvalue(argv[1], NIL);
  130.         if (ap == NIL)
  131.             return;
  132.         if (ap->class != FILE) {
  133.             error("flush's argument must be a file, not %s", nameof(ap));
  134.             return;
  135.         }
  136.         put1(op);
  137.         return;
  138.  
  139.     case O_MESSAGE:
  140.     case O_WRIT2:
  141.     case O_WRITLN:
  142.         /*
  143.          * Set up default file "output"'s type
  144.          */
  145.         file = NIL;
  146.         filetype = nl+T1CHAR;
  147.         /*
  148.          * Determine the file implied
  149.          * for the write and generate
  150.          * code to make it the active file.
  151.          */
  152.         if (op == O_MESSAGE) {
  153.             /*
  154.              * For message, all that matters
  155.              * is that the filetype is
  156.              * a character file.
  157.              * Thus "output" will suit us fine.
  158.              */
  159.             put1(O_MESSAGE);
  160.         } else if (argv != NIL && (al = argv[1])[0] != T_WEXP) {
  161.             /*
  162.              * If there is a first argument which has
  163.              * no write widths, then it is potentially
  164.              * a file name.
  165.              */
  166.             codeoff();
  167.             ap = rvalue(argv[1], NIL);
  168.             codeon();
  169.             if (ap == NIL)
  170.                 argv = argv[2];
  171.             if (ap != NIL && ap->class == FILE) {
  172.                 /*
  173.                  * Got "write(f, ...", make
  174.                  * f the active file, and save
  175.                  * it and its type for use in
  176.                  * processing the rest of the
  177.                  * arguments to write.
  178.                  */
  179.                 file = argv[1];
  180.                 filetype = ap->type;
  181.                 rvalue(argv[1], NIL);
  182.                 put1(O_UNIT);
  183.                 /*
  184.                  * Skip over the first argument
  185.                  */
  186.                 argv = argv[2];
  187.                 argc--;
  188.             } else
  189.                 /*
  190.                  * Set up for writing on 
  191.                  * standard output.
  192.                  */
  193.                 put1(O_UNITOUT);
  194.         } else
  195.             put1(O_UNITOUT);
  196.         /*
  197.          * Loop and process each
  198.          * of the arguments.
  199.          */
  200.         for (; argv != NIL; argv = argv[2]) {
  201.             al = argv[1];
  202.             if (al == NIL)
  203.                 continue;
  204.             /*
  205.              * Op will be used to
  206.              * accumulate width information,
  207.              * and two records the fact
  208.              * that we saw two write widths
  209.              */
  210.             op = 0;
  211.             two = 0;
  212.             oct = 0;
  213.             hex = 0;
  214.             if (al[0] == T_WEXP) {
  215.                 if (filetype != nl+T1CHAR) {
  216.                     error("Write widths allowed only with text files");
  217.                     continue;
  218.                 }
  219.                 /*
  220.                  * Handle width expressions.
  221.                  * The basic game here is that width
  222.                  * expressions get evaluated and left
  223.                  * on the stack and their width's get
  224.                  * packed into the high byte of the
  225.                  * affected opcode (subop).
  226.                  */
  227.                 if (al[3] == OCT) 
  228.                     oct++;
  229.                 else if (al[3] == HEX)
  230.                     hex++;
  231.                 else if (al[3] != NIL) {
  232.                     two++;
  233.                     /*
  234.                      * Arrange for the write
  235.                      * opcode that takes two widths
  236.                      */
  237.                     op =| O_WRIT82-O_WRIT8;
  238.                     ap = rvalue(al[3], NIL);
  239.                     if (ap == NIL)
  240.                         continue;
  241.                     if (isnta(ap, "i")) {
  242.                         error("Second write width must be integer, not %s", nameof(ap));
  243.                         continue;
  244.                     }
  245.                     op =| even(width(ap)) << 11;
  246.                 }
  247.                 if (al[2] != NIL) {
  248.                     ap = rvalue(al[2], NIL);
  249.                     if (ap == NIL)
  250.                         continue;
  251.                     if (isnta(ap, "i")) {
  252.                         error("First write width must be integer, not %s", nameof(ap));
  253.                         continue;
  254.                     }
  255.                     op =| even(width(ap)) << 8;
  256.                 }
  257.                 al = al[1];
  258.                 if (al == NIL)
  259.                     continue;
  260.             }
  261.             if (filetype != nl+T1CHAR) {
  262.                 if (oct || hex) {
  263.                     error("Oct/hex allowed only on text files");
  264.                     continue;
  265.                 }
  266.                 if (op) {
  267.                     error("Write widths allowed only on text files");
  268.                     continue;
  269.                 }
  270.                 /*
  271.                  * Generalized write, i.e.
  272.                  * to a non-textfile.
  273.                  */
  274.                 rvalue(file, NIL);
  275.                 put1(O_FNIL);
  276.                 /*
  277.                  * file^ := ...
  278.                  */
  279.                 ap = rvalue(argv[1], NIL);
  280.                 if (ap == NIL)
  281.                     continue;
  282.                 if (incompat(ap, filetype, argv[1])) {
  283.                     cerror("Type mismatch in write to non-text file");
  284.                     continue;
  285.                 }
  286.                 convert(ap, filetype);
  287.                 put2(O_AS, width(filetype));
  288.                 /*
  289.                  * put(file)
  290.                  */
  291.                 put1(O_PUT);
  292.                 continue;
  293.             }
  294.             /*
  295.              * Write to a textfile
  296.              *
  297.              * Evaluate the expression
  298.              * to be written.
  299.              */
  300.             ap = rvalue(al, NIL);
  301.             if (ap == NIL)
  302.                 continue;
  303.             c = classify(ap);
  304.             if (two && c != TDOUBLE) {
  305.                 if (isnta(ap, "i")) {
  306.                     error("Only reals can have two write widths");
  307.                     continue;
  308.                 }
  309.                 convert(ap, nl+TDOUBLE);
  310.                 c = TDOUBLE;
  311.             }
  312.             if (oct || hex) {
  313.                 if (opt('s')) {
  314.                     standard();
  315.                     error("Oct and hex are non-standard");
  316.                 }
  317.                 switch (c) {
  318.                     case TREC:
  319.                     case TARY:
  320.                     case TFILE:
  321.                     case TSTR:
  322.                     case TSET:
  323.                     case TDOUBLE:
  324.                         error("Can't write %ss with oct/hex", clnames[c]);
  325.                         continue;
  326.                 }
  327.                 put1(op | (oct ? O_WROCT2 : O_WRHEX2) | (width(ap) >> 2));
  328.                 continue;
  329.             }
  330.             if (wrops(c) == NIL) {
  331.                 error("Can't write %ss to a text file", clnames[c]);
  332.                 continue;
  333.             }
  334.             if (c == TINT && width(ap) != 4)
  335.                 op =| O_WRIT2;
  336.             else
  337.                 op =| wrops(c);
  338.             if (c == TSTR)
  339.                 put2(op, width(ap));
  340.             else
  341.                 put1(op);
  342.         }
  343.         /*
  344.          * Done with arguments.
  345.          * Handle writeln and
  346.          * insufficent number of args.
  347.          */
  348.         switch (p->value[0] &~ NSTAND) {
  349.             case O_WRIT2:
  350.                 if (argc == 0)
  351.                     error("Write requires an argument");
  352.                 break;
  353.             case O_MESSAGE:
  354.                 if (argc == 0)
  355.                     error("Message requires an argument");
  356.             case O_WRITLN:
  357.                 if (filetype != nl+T1CHAR)
  358.                     error("Can't 'writeln' a non text file");
  359.                 put1(O_WRITLN);
  360.                 break;
  361.         }
  362.         return;
  363.  
  364.     case O_READ4:
  365.     case O_READLN:
  366.         /*
  367.          * Set up default
  368.          * file "input".
  369.          */
  370.         file = NIL;
  371.         filetype = nl+T1CHAR;
  372.         /*
  373.          * Determine the file implied
  374.          * for the read and generate
  375.          * code to make it the active file.
  376.          */
  377.         if (argv != NIL) {
  378.             codeoff();
  379.             ap = rvalue(argv[1], NIL);
  380.             codeon();
  381.             if (ap == NIL)
  382.                 argv = argv[2];
  383.             if (ap != NIL && ap->class == FILE) {
  384.                 /*
  385.                  * Got "read(f, ...", make
  386.                  * f the active file, and save
  387.                  * it and its type for use in
  388.                  * processing the rest of the
  389.                  * arguments to read.
  390.                  */
  391.                 file = argv[1];
  392.                 filetype = ap->type;
  393.                 rvalue(argv[1], NIL);
  394.                 put1(O_UNIT);
  395.                 argv = argv[2];
  396.                 argc--;
  397.             } else {
  398.                 /*
  399.                  * Default is read from
  400.                  * standard input.
  401.                  */
  402.                 put1(O_UNITINP);
  403.                 input->nl_flags =| NUSED;
  404.             }
  405.         } else {
  406.             put1(O_UNITINP);
  407.             input->nl_flags =| NUSED;
  408.         }
  409.         /*
  410.          * Loop and process each
  411.          * of the arguments.
  412.          */
  413.         for (; argv != NIL; argv = argv[2]) {
  414.             /*
  415.              * Get the address of the target
  416.              * on the stack.
  417.              */
  418.             al = argv[1];
  419.             if (al == NIL)
  420.                 continue;
  421.             if (al[0] != T_VAR) {
  422.                 error("Arguments to %s must be variables, not expressions", p->symbol);
  423.                 continue;
  424.             }
  425.             ap = lvalue(al, MOD|ASGN|NOUSE);
  426.             if (ap == NIL)
  427.                 continue;
  428.             if (filetype != nl+T1CHAR) {
  429.                 /*
  430.                  * Generalized read, i.e.
  431.                  * from a non-textfile.
  432.                  */
  433.                 if (incompat(filetype, ap, NIL)) {
  434.                     error("Type mismatch in read from non-text file");
  435.                     continue;
  436.                 }
  437.                 /*
  438.                  * var := file ^;
  439.                  */
  440.                 if (file != NIL)
  441.                     rvalue(file, NIL);
  442.                 else /* Magic */
  443.                     put2(O_RV2, input->value[0]);
  444.                 put1(O_FNIL);
  445.                 put2(O_IND, width(filetype));
  446.                 convert(filetype, ap);
  447.                 if (isa(ap, "bsci"))
  448.                     rangechk(ap, ap);
  449.                 put2(O_AS, width(ap));
  450.                 /*
  451.                  * get(file);
  452.                  */
  453.                 put1(O_GET);
  454.                 continue;
  455.             }
  456.             c = classify(ap);
  457.             op = rdops(c);
  458.             if (op == NIL) {
  459.                 error("Can't read %ss from a text file", clnames[c]);
  460.                 continue;
  461.             }
  462.             put1(op);
  463.             /*
  464.              * Data read is on the stack.
  465.              * Assign it.
  466.              */
  467.             if (op != O_READ8)
  468.                 rangechk(ap, op == O_READC ? ap : nl+T4INT);
  469.             gen(O_AS2, O_AS2, width(ap),
  470.                 op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2);
  471.         }
  472.         /*
  473.          * Done with arguments.
  474.          * Handle readln and
  475.          * insufficient number of args.
  476.          */
  477.         if (p->value[0] == O_READLN) {
  478.             if (filetype != nl+T1CHAR)
  479.                 error("Can't 'readln' a non text file");
  480.             put1(O_READLN);
  481.         }
  482.         else if (argc == 0)
  483.             error("read requires an argument");
  484.         return;
  485.  
  486.     case O_GET:
  487.     case O_PUT:
  488.         if (argc != 1) {
  489.             error("%s expects one argument", p->symbol);
  490.             return;
  491.         }
  492.         ap = rvalue(argv[1], NIL);
  493.         if (ap == NIL)
  494.             return;
  495.         if (ap->class != FILE) {
  496.             error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
  497.             return;
  498.         }
  499.         put1(O_UNIT);
  500.         put1(op);
  501.         return;
  502.  
  503.     case O_RESET:
  504.     case O_REWRITE:
  505.         if (argc == 0 || argc > 2) {
  506.             error("%s expects one or two arguments", p->symbol);
  507.             return;
  508.         }
  509.         if (opt('s') && argc == 2) {
  510.             standard();
  511.             error("Two argument forms of reset and rewrite are non-standard");
  512.         }
  513.         ap = lvalue(argv[1], MOD|NOUSE);
  514.         if (ap == NIL)
  515.             return;
  516.         if (ap->class != FILE) {
  517.             error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
  518.             return;
  519.         }
  520.         if (argc == 2) {
  521.             /*
  522.              * Optional second argument
  523.              * is a string name of a
  524.              * UNIX (R) file to be associated.
  525.              */
  526.             al = argv[2];
  527.             al = rvalue(al[1], NIL);
  528.             if (al == NIL)
  529.                 return;
  530.             if (classify(al) != TSTR) {
  531.                 error("Second argument to %s must be a string, not %s", p->symbol, nameof(al));
  532.                 return;
  533.             }
  534.             c = width(al);
  535.         } else
  536.             c = 0;
  537.         if (c > 127) {
  538.             error("File name too long");
  539.             return;
  540.         }
  541.         put2(op | c << 8, text(ap) ? 0: width(ap->type));
  542.         return;
  543.  
  544.     case O_NEW:
  545.     case O_DISPOSE:
  546.         if (argc == 0) {
  547.             error("%s expects at least one argument", p->symbol);
  548.             return;
  549.         }
  550.         ap = lvalue(argv[1], MOD|NOUSE);
  551.         if (ap == NIL)
  552.             return;
  553.         if (ap->class != PTR) {
  554.             error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap));
  555.             return;
  556.         }
  557.         ap = ap->type;
  558.         if (ap == NIL)
  559.             return;
  560.         argv = argv[2];
  561.         if (argv != NIL) {
  562.             if (ap->class != RECORD) {
  563.                 error("Record required when specifying variant tags");
  564.                 return;
  565.             }
  566.             for (; argv != NIL; argv = argv[2]) {
  567.                 if (ap->value[NL_VARNT] == NIL) {
  568.                     error("Too many tag fields");
  569.                     return;
  570.                 }
  571.                 if (!isconst(argv[1])) {
  572.                     error("Second and successive arguments to %s must be constants", p->symbol);
  573.                     return;
  574.                 }
  575.                 gconst(argv[1]);
  576.                 if (con.ctype == NIL)
  577.                     return;
  578.                 if (incompat(con.ctype, ap->value[NL_TAG]->type)) {
  579.                     cerror("Specified tag constant type clashed with variant case selector type");
  580.                     return;
  581.                 }
  582.                 for (ap = ap->value[NL_VARNT]; ap != NIL; ap = ap->chain)
  583.                     if (ap->range[0] == con.crval)
  584.                         break;
  585.                 if (ap == NIL) {
  586.                     error("No variant case label value equals specified constant value");
  587.                     return;
  588.                 }
  589.                 ap = ap->value[NL_VTOREC];
  590.             }
  591.         }
  592.         put2(op, width(ap));
  593.         return;
  594.  
  595.     case O_DATE:
  596.     case O_TIME:
  597.         if (argc != 1) {
  598.             error("%s expects one argument", p->symbol);
  599.             return;
  600.         }
  601.         ap = lvalue(argv[1], MOD|NOUSE);
  602.         if (ap == NIL)
  603.             return;
  604.         if (classify(ap) != TSTR || width(ap) != 10) {
  605.             error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
  606.             return;
  607.         }
  608.         put1(op);
  609.         return;
  610.  
  611.     case O_HALT:
  612.         if (argc != 0) {
  613.             error("halt takes no arguments");
  614.             return;
  615.         }
  616.         put1(op);
  617.         noreach = 1;
  618.         return;
  619.  
  620.     case O_ARGV:
  621.         if (argc != 2) {
  622.             error("argv takes two arguments");
  623.             return;
  624.         }
  625.         ap = rvalue(argv[1], NIL);
  626.         if (ap == NIL)
  627.             return;
  628.         if (isnta(ap, "i")) {
  629.             error("argv's first argument must be an integer, not %s", nameof(ap));
  630.             return;
  631.         }
  632.         convert(ap, nl+T2INT);
  633.         al = argv[2];
  634.         ap = lvalue(al[1], MOD|NOUSE);
  635.         if (ap == NIL)
  636.             return;
  637.         if (classify(ap) != TSTR) {
  638.             error("argv's second argument must be a string, not %s", nameof(ap));
  639.             return;
  640.         }
  641.         put2(op, width(ap));
  642.         return;
  643.  
  644.     case O_STLIM:
  645.         if (argc != 1) {
  646.             error("stlimit requires one argument");
  647.             return;
  648.         }
  649.         ap = rvalue(argv[1], NIL);
  650.         if (ap == NIL)
  651.             return;
  652.         if (isnta(ap, "i")) {
  653.             error("stlimit's argument must be an integer, not %s", nameof(ap));
  654.             return;
  655.         }
  656.         if (width(ap) != 4)
  657.             put1(O_STOI);
  658.         put1(op);
  659.         return;
  660.  
  661.     case O_REMOVE:
  662.         if (argc != 1) {
  663.             error("remove expects one argument");
  664.             return;
  665.         }
  666.         ap = rvalue(argv[1], NIL);
  667.         if (ap == NIL)
  668.             return;
  669.         if (classify(ap) != TSTR) {
  670.             error("remove's argument must be a string, not %s", nameof(ap));
  671.             return;
  672.         }
  673.         put2(op, width(ap));
  674.         return;
  675.  
  676.     case O_LLIMIT:
  677.         if (argc != 2) {
  678.             error("linelimit expects two arguments");
  679.             return;
  680.         }
  681.         ap = lvalue(argv[1], NOMOD|NOUSE);
  682.         if (ap == NIL)
  683.             return;
  684.         if (!text(ap)) {
  685.             error("linelimit's first argument must be a text file, not %s", nameof(ap));
  686.             return;
  687.         }
  688.         al = argv[2];
  689.         ap = rvalue(al[1], NIL);
  690.         if (ap == NIL)
  691.             return;
  692.         if (isnta(ap, "i")) {
  693.             error("linelimit's second argument must be an integer, not %s", nameof(ap));
  694.             return;
  695.         }
  696.         convert(ap, nl+T2INT);
  697.         put1(op);
  698.         return;
  699.     case O_PAGE:
  700.         if (argc != 1) {
  701.             error("page expects one argument");
  702.             return;
  703.         }
  704.         ap = rvalue(argv[1], NIL);
  705.         if (ap == NIL)
  706.             return;
  707.         if (!text(ap)) {
  708.             error("Argument to page must be a text file, not %s", nameof(ap));
  709.             return;
  710.         }
  711.         put1(O_UNIT);
  712.         put1(op);
  713.         return;
  714.  
  715.     case O_PACK:
  716.         if (argc != 3) {
  717.             error("pack expects three arguments");
  718.             return;
  719.         }
  720.         pu = "pack(a,i,z)";
  721.         pua = (al = argv)[1];
  722.         pui = (al = al[2])[1];
  723.         puz = (al = al[2])[1];
  724.         goto packunp;
  725.     case O_UNPACK:
  726.         if (argc != 3) {
  727.             error("unpack expects three arguments");
  728.             return;
  729.         }
  730.         pu = "unpack(z,a,i)";
  731.         puz = (al = argv)[1];
  732.         pua = (al = al[2])[1];
  733.         pui = (al = al[2])[1];
  734. packunp:
  735.         ap = rvalue(pui, NIL);
  736.         if (ap == NIL)
  737.             return;
  738.         if (width(ap) == 4)
  739.             put1(O_ITOS);
  740.         ap = lvalue(pua, op == O_PACK ? NOMOD : MOD|NOUSE);
  741.         if (ap == NIL)
  742.             return;
  743.         if (ap->class != ARRAY) {
  744.             error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
  745.             return;
  746.         }
  747.         al = lvalue(puz, op == O_UNPACK ? NOMOD : MOD|NOUSE);
  748.         if (al->class != ARRAY) {
  749.             error("%s requires z to be a packed array, not %s", pu, nameof(ap));
  750.             return;
  751.         }
  752.         if (al->type == NIL || ap->type == NIL)
  753.             return;
  754.         if (al->type != ap->type) {
  755.             error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
  756.             return;
  757.         }
  758.         k = width(al);
  759.         ap = ap->chain;
  760.         al = al->chain;
  761.         if (ap->chain != NIL || al->chain != NIL) {
  762.             error("%s requires a and z to be single dimension arrays", pu);
  763.             return;
  764.         }
  765.         if (ap == NIL || al == NIL)
  766.             return;
  767.         /*
  768.          * al is the range for z i.e. u..v
  769.          * ap is the range for a i.e. m..n
  770.          * i will be n-m+1
  771.          * j will be v-u+1
  772.          */
  773.         i = ap->range[1] - ap->range[0] + 1;
  774.         j = al->range[1] - al->range[0] + 1;
  775.         if (i < j) {
  776.             error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i);
  777.             return;
  778.         }
  779.         /*
  780.          * get n-m-(v-u) and m for the interpreter
  781.          */
  782.         i =- j;
  783.         j = ap->range[0];
  784.         put(5, op, width(ap), j, i, k);
  785.         return;
  786.     case 0:
  787.         error("%s is an unimplemented 6400 extension", p->symbol);
  788.         return;
  789.  
  790.     default:
  791.         panic("proc case");
  792.     }
  793. }
  794.