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
Defined variables
Defined macros
|
Last modified: 1981-07-10
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 1667 |
|