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