# 2.11BSD#431 - /usr/src/ucb/pascal/pi/proc.c

##### Functions

    proc              X

##### Variables

    rdxxxx            X
    wrxxxx            X

##### Macros

    rdops             X
    wrops             X

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

#### Defined functions

proc defined in line 60; used 1 times

- in /usr/src/ucb/pascal/pi/stat.c line 65

#### Defined variables

rdxxxx defined in line 24; used 1 times

- in line 21

wrxxxx defined in line 39; used 1 times

- in line 22

#### Defined macros

rdops defined in line 21; used 1 times

- in line 460

wrops defined in line 22; used 2 times

- in line 333, 340

Last modified: 1981-07-10 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 1412 |