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

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
wrops defined in line 22; used 2 times
Last modified: 1981-07-10
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 2201
Valid CSS Valid XHTML 1.0 Strict