![[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] / 43BSD / ucb / pascal / src|
Return to proc.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / pascal / src |
1.1 root 1: /*
2: * Copyright (c) 1980 Regents of the University of California.
3: * All rights reserved. The Berkeley software License Agreement
4: * specifies the terms and conditions for redistribution.
5: */
6:
7: #ifndef lint
8: static char sccsid[] = "@(#)proc.c 5.1 (Berkeley) 6/5/85";
9: #endif not lint
10:
11: #include "whoami.h"
12: #ifdef OBJ
13: /*
14: * and the rest of the file
15: */
16: #include "0.h"
17: #include "tree.h"
18: #include "opcode.h"
19: #include "objfmt.h"
20: #include "tmps.h"
21: #include "tree_ty.h"
22:
23: /*
24: * The constant EXPOSIZE specifies the number of digits in the exponent
25: * of real numbers.
26: *
27: * The constant REALSPC defines the amount of forced padding preceeding
28: * real numbers when they are printed. If REALSPC == 0, then no padding
29: * is added, REALSPC == 1 adds one extra blank irregardless of the width
30: * specified by the user.
31: *
32: * N.B. - Values greater than one require program mods.
33: */
34: #define EXPOSIZE 2
35: #define REALSPC 0
36:
37: /*
38: * The following array is used to determine which classes may be read
39: * from textfiles. It is indexed by the return value from classify.
40: */
41: #define rdops(x) rdxxxx[(x)-(TFIRST)]
42:
43: int rdxxxx[] = {
44: 0, /* -7 file types */
45: 0, /* -6 record types */
46: 0, /* -5 array types */
47: O_READE, /* -4 scalar types */
48: 0, /* -3 pointer types */
49: 0, /* -2 set types */
50: 0, /* -1 string types */
51: 0, /* 0 nil, no type */
52: O_READE, /* 1 boolean */
53: O_READC, /* 2 character */
54: O_READ4, /* 3 integer */
55: O_READ8 /* 4 real */
56: };
57:
58: /*
59: * Proc handles procedure calls.
60: * Non-builtin procedures are "buck-passed" to func (with a flag
61: * indicating that they are actually procedures.
62: * builtin procedures are handled here.
63: */
64: proc(r)
65: struct tnode *r;
66: {
67: register struct nl *p;
68: register struct tnode *alv, *al;
69: register int op;
70: struct nl *filetype, *ap, *al1;
71: int argc, typ, fmtspec, strfmt, stkcnt;
72: struct tnode *argv;
73: char fmt, format[20], *strptr, *pu;
74: int prec, field, strnglen, fmtlen, fmtstart;
75: struct tnode *pua, *pui, *puz, *file;
76: int i, j, k;
77: int itemwidth;
78: struct tmps soffset;
79: struct nl *tempnlp;
80:
81: #define CONPREC 4
82: #define VARPREC 8
83: #define CONWIDTH 1
84: #define VARWIDTH 2
85: #define SKIP 16
86:
87: /*
88: * Verify that the name is
89: * defined and is that of a
90: * procedure.
91: */
92: p = lookup(r->pcall_node.proc_id);
93: if (p == NIL) {
94: rvlist(r->pcall_node.arg);
95: return;
96: }
97: if (p->class != PROC && p->class != FPROC) {
98: error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]);
99: rvlist(r->pcall_node.arg);
100: return;
101: }
102: argv = r->pcall_node.arg;
103:
104: /*
105: * Call handles user defined
106: * procedures and functions.
107: */
108: if (bn != 0) {
109: (void) call(p, argv, PROC, bn);
110: return;
111: }
112:
113: /*
114: * Call to built-in procedure.
115: * Count the arguments.
116: */
117: argc = 0;
118: for (al = argv; al != TR_NIL; al = al->list_node.next)
119: argc++;
120:
121: /*
122: * Switch on the operator
123: * associated with the built-in
124: * procedure in the namelist
125: */
126: op = p->value[0] &~ NSTAND;
127: if (opt('s') && (p->value[0] & NSTAND)) {
128: standard();
129: error("%s is a nonstandard procedure", p->symbol);
130: }
131: switch (op) {
132:
133: case O_ABORT:
134: if (argc != 0)
135: error("null takes no arguments");
136: return;
137:
138: case O_FLUSH:
139: if (argc == 0) {
140: (void) put(1, O_MESSAGE);
141: return;
142: }
143: if (argc != 1) {
144: error("flush takes at most one argument");
145: return;
146: }
147: ap = stklval(argv->list_node.list, NIL );
148: if (ap == NLNIL)
149: return;
150: if (ap->class != FILET) {
151: error("flush's argument must be a file, not %s", nameof(ap));
152: return;
153: }
154: (void) put(1, op);
155: return;
156:
157: case O_MESSAGE:
158: case O_WRITEF:
159: case O_WRITLN:
160: /*
161: * Set up default file "output"'s type
162: */
163: file = NIL;
164: filetype = nl+T1CHAR;
165: /*
166: * Determine the file implied
167: * for the write and generate
168: * code to make it the active file.
169: */
170: if (op == O_MESSAGE) {
171: /*
172: * For message, all that matters
173: * is that the filetype is
174: * a character file.
175: * Thus "output" will suit us fine.
176: */
177: (void) put(1, O_MESSAGE);
178: } else if (argv != TR_NIL && (al = argv->list_node.list)->tag !=
179: T_WEXP) {
180: /*
181: * If there is a first argument which has
182: * no write widths, then it is potentially
183: * a file name.
184: */
185: codeoff();
186: ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
187: codeon();
188: if (ap == NLNIL)
189: argv = argv->list_node.next;
190: if (ap != NLNIL && ap->class == FILET) {
191: /*
192: * Got "write(f, ...", make
193: * f the active file, and save
194: * it and its type for use in
195: * processing the rest of the
196: * arguments to write.
197: */
198: file = argv->list_node.list;
199: filetype = ap->type;
200: (void) stklval(argv->list_node.list, NIL );
201: (void) put(1, O_UNIT);
202: /*
203: * Skip over the first argument
204: */
205: argv = argv->list_node.next;
206: argc--;
207: } else {
208: /*
209: * Set up for writing on
210: * standard output.
211: */
212: (void) put(1, O_UNITOUT);
213: output->nl_flags |= NUSED;
214: }
215: } else {
216: (void) put(1, O_UNITOUT);
217: output->nl_flags |= NUSED;
218: }
219: /*
220: * Loop and process each
221: * of the arguments.
222: */
223: for (; argv != TR_NIL; argv = argv->list_node.next) {
224: /*
225: * fmtspec indicates the type (CONstant or VARiable)
226: * and number (none, WIDTH, and/or PRECision)
227: * of the fields in the printf format for this
228: * output variable.
229: * stkcnt is the number of bytes pushed on the stack
230: * fmt is the format output indicator (D, E, F, O, X, S)
231: * fmtstart = 0 for leading blank; = 1 for no blank
232: */
233: fmtspec = NIL;
234: stkcnt = 0;
235: fmt = 'D';
236: fmtstart = 1;
237: al = argv->list_node.list;
238: if (al == TR_NIL)
239: continue;
240: if (al->tag == T_WEXP)
241: alv = al->wexpr_node.expr1;
242: else
243: alv = al;
244: if (alv == TR_NIL)
245: continue;
246: codeoff();
247: ap = stkrval(alv, NLNIL , (long) RREQ );
248: codeon();
249: if (ap == NLNIL)
250: continue;
251: typ = classify(ap);
252: if (al->tag == T_WEXP) {
253: /*
254: * Handle width expressions.
255: * The basic game here is that width
256: * expressions get evaluated. If they
257: * are constant, the value is placed
258: * directly in the format string.
259: * Otherwise the value is pushed onto
260: * the stack and an indirection is
261: * put into the format string.
262: */
263: if (al->wexpr_node.expr3 ==
264: (struct tnode *) OCT)
265: fmt = 'O';
266: else if (al->wexpr_node.expr3 ==
267: (struct tnode *) HEX)
268: fmt = 'X';
269: else if (al->wexpr_node.expr3 != TR_NIL) {
270: /*
271: * Evaluate second format spec
272: */
273: if ( constval(al->wexpr_node.expr3)
274: && isa( con.ctype , "i" ) ) {
275: fmtspec += CONPREC;
276: prec = con.crval;
277: } else {
278: fmtspec += VARPREC;
279: }
280: fmt = 'f';
281: switch ( typ ) {
282: case TINT:
283: if ( opt( 's' ) ) {
284: standard();
285: error("Writing %ss with two write widths is non-standard", clnames[typ]);
286: }
287: /* and fall through */
288: case TDOUBLE:
289: break;
290: default:
291: error("Cannot write %ss with two write widths", clnames[typ]);
292: continue;
293: }
294: }
295: /*
296: * Evaluate first format spec
297: */
298: if (al->wexpr_node.expr2 != TR_NIL) {
299: if ( constval(al->wexpr_node.expr2)
300: && isa( con.ctype , "i" ) ) {
301: fmtspec += CONWIDTH;
302: field = con.crval;
303: } else {
304: fmtspec += VARWIDTH;
305: }
306: }
307: if ((fmtspec & CONPREC) && prec < 0 ||
308: (fmtspec & CONWIDTH) && field < 0) {
309: error("Negative widths are not allowed");
310: continue;
311: }
312: if ( opt('s') &&
313: ((fmtspec & CONPREC) && prec == 0 ||
314: (fmtspec & CONWIDTH) && field == 0)) {
315: standard();
316: error("Zero widths are non-standard");
317: }
318: }
319: if (filetype != nl+T1CHAR) {
320: if (fmt == 'O' || fmt == 'X') {
321: error("Oct/hex allowed only on text files");
322: continue;
323: }
324: if (fmtspec) {
325: error("Write widths allowed only on text files");
326: continue;
327: }
328: /*
329: * Generalized write, i.e.
330: * to a non-textfile.
331: */
332: (void) stklval(file, NIL );
333: (void) put(1, O_FNIL);
334: /*
335: * file^ := ...
336: */
337: ap = rvalue(argv->list_node.list, NLNIL, LREQ);
338: if (ap == NLNIL)
339: continue;
340: if (incompat(ap, filetype,
341: argv->list_node.list)) {
342: cerror("Type mismatch in write to non-text file");
343: continue;
344: }
345: convert(ap, filetype);
346: (void) put(2, O_AS, width(filetype));
347: /*
348: * put(file)
349: */
350: (void) put(1, O_PUT);
351: continue;
352: }
353: /*
354: * Write to a textfile
355: *
356: * Evaluate the expression
357: * to be written.
358: */
359: if (fmt == 'O' || fmt == 'X') {
360: if (opt('s')) {
361: standard();
362: error("Oct and hex are non-standard");
363: }
364: if (typ == TSTR || typ == TDOUBLE) {
365: error("Can't write %ss with oct/hex", clnames[typ]);
366: continue;
367: }
368: if (typ == TCHAR || typ == TBOOL)
369: typ = TINT;
370: }
371: /*
372: * Place the arguement on the stack. If there is
373: * no format specified by the programmer, implement
374: * the default.
375: */
376: switch (typ) {
377: case TPTR:
378: warning();
379: if (opt('s')) {
380: standard();
381: }
382: error("Writing %ss to text files is non-standard",
383: clnames[typ]);
384: /* and fall through */
385: case TINT:
386: if (fmt != 'f') {
387: ap = stkrval(alv, NLNIL, (long) RREQ );
388: stkcnt += sizeof(long);
389: } else {
390: ap = stkrval(alv, NLNIL, (long) RREQ );
391: (void) put(1, O_ITOD);
392: stkcnt += sizeof(double);
393: typ = TDOUBLE;
394: goto tdouble;
395: }
396: if (fmtspec == NIL) {
397: if (fmt == 'D')
398: field = 10;
399: else if (fmt == 'X')
400: field = 8;
401: else if (fmt == 'O')
402: field = 11;
403: else
404: panic("fmt1");
405: fmtspec = CONWIDTH;
406: }
407: break;
408: case TCHAR:
409: tchar:
410: if (fmtspec == NIL) {
411: (void) put(1, O_FILE);
412: ap = stkrval(alv, NLNIL, (long) RREQ );
413: convert(nl + T4INT, INT_TYP);
414: (void) put(2, O_WRITEC,
415: sizeof(char *) + sizeof(int));
416: fmtspec = SKIP;
417: break;
418: }
419: ap = stkrval(alv, NLNIL , (long) RREQ );
420: convert(nl + T4INT, INT_TYP);
421: stkcnt += sizeof(int);
422: fmt = 'c';
423: break;
424: case TSCAL:
425: warning();
426: if (opt('s')) {
427: standard();
428: }
429: error("Writing %ss to text files is non-standard",
430: clnames[typ]);
431: /* and fall through */
432: case TBOOL:
433: (void) stkrval(alv, NLNIL , (long) RREQ );
434: (void) put(2, O_NAM, (long)listnames(ap));
435: stkcnt += sizeof(char *);
436: fmt = 's';
437: break;
438: case TDOUBLE:
439: ap = stkrval(alv, (struct nl *) TDOUBLE , (long) RREQ );
440: stkcnt += sizeof(double);
441: tdouble:
442: switch (fmtspec) {
443: case NIL:
444: field = 14 + (5 + EXPOSIZE);
445: prec = field - (5 + EXPOSIZE);
446: fmt = 'e';
447: fmtspec = CONWIDTH + CONPREC;
448: break;
449: case CONWIDTH:
450: field -= REALSPC;
451: if (field < 1)
452: field = 1;
453: prec = field - (5 + EXPOSIZE);
454: if (prec < 1)
455: prec = 1;
456: fmtspec += CONPREC;
457: fmt = 'e';
458: break;
459: case CONWIDTH + CONPREC:
460: case CONWIDTH + VARPREC:
461: field -= REALSPC;
462: if (field < 1)
463: field = 1;
464: }
465: format[0] = ' ';
466: fmtstart = 1 - REALSPC;
467: break;
468: case TSTR:
469: (void) constval( alv );
470: switch ( classify( con.ctype ) ) {
471: case TCHAR:
472: typ = TCHAR;
473: goto tchar;
474: case TSTR:
475: strptr = con.cpval;
476: for (strnglen = 0; *strptr++; strnglen++) /* void */;
477: strptr = con.cpval;
478: break;
479: default:
480: strnglen = width(ap);
481: break;
482: }
483: fmt = 's';
484: strfmt = fmtspec;
485: if (fmtspec == NIL) {
486: fmtspec = SKIP;
487: break;
488: }
489: if (fmtspec & CONWIDTH) {
490: if (field <= strnglen) {
491: fmtspec = SKIP;
492: break;
493: } else
494: field -= strnglen;
495: }
496: /*
497: * push string to implement leading blank padding
498: */
499: (void) put(2, O_LVCON, 2);
500: putstr("", 0);
501: stkcnt += sizeof(char *);
502: break;
503: default:
504: error("Can't write %ss to a text file", clnames[typ]);
505: continue;
506: }
507: /*
508: * If there is a variable precision, evaluate it onto
509: * the stack
510: */
511: if (fmtspec & VARPREC) {
512: ap = stkrval(al->wexpr_node.expr3, NLNIL ,
513: (long) RREQ );
514: if (ap == NIL)
515: continue;
516: if (isnta(ap,"i")) {
517: error("Second write width must be integer, not %s", nameof(ap));
518: continue;
519: }
520: if ( opt( 't' ) ) {
521: (void) put(3, O_MAX, 0, 0);
522: }
523: convert(nl+T4INT, INT_TYP);
524: stkcnt += sizeof(int);
525: }
526: /*
527: * If there is a variable width, evaluate it onto
528: * the stack
529: */
530: if (fmtspec & VARWIDTH) {
531: if ( ( typ == TDOUBLE && fmtspec == VARWIDTH )
532: || typ == TSTR ) {
533: soffset = sizes[cbn].curtmps;
534: tempnlp = tmpalloc((long) (sizeof(long)),
535: nl+T4INT, REGOK);
536: (void) put(2, O_LV | cbn << 8 + INDX,
537: tempnlp -> value[ NL_OFFS ] );
538: }
539: ap = stkrval(al->wexpr_node.expr2, NLNIL, (long) RREQ );
540: if (ap == NIL)
541: continue;
542: if (isnta(ap,"i")) {
543: error("First write width must be integer, not %s", nameof(ap));
544: continue;
545: }
546: /*
547: * Perform special processing on widths based
548: * on data type
549: */
550: switch (typ) {
551: case TDOUBLE:
552: if (fmtspec == VARWIDTH) {
553: fmt = 'e';
554: (void) put(1, O_AS4);
555: (void) put(2, O_RV4 | cbn << 8 + INDX,
556: tempnlp -> value[NL_OFFS] );
557: (void) put(3, O_MAX,
558: 5 + EXPOSIZE + REALSPC, 1);
559: convert(nl+T4INT, INT_TYP);
560: stkcnt += sizeof(int);
561: (void) put(2, O_RV4 | cbn << 8 + INDX,
562: tempnlp->value[NL_OFFS] );
563: fmtspec += VARPREC;
564: tmpfree(&soffset);
565: }
566: (void) put(3, O_MAX, REALSPC, 1);
567: break;
568: case TSTR:
569: (void) put(1, O_AS4);
570: (void) put(2, O_RV4 | cbn << 8 + INDX,
571: tempnlp -> value[ NL_OFFS ] );
572: (void) put(3, O_MAX, strnglen, 0);
573: break;
574: default:
575: if ( opt( 't' ) ) {
576: (void) put(3, O_MAX, 0, 0);
577: }
578: break;
579: }
580: convert(nl+T4INT, INT_TYP);
581: stkcnt += sizeof(int);
582: }
583: /*
584: * Generate the format string
585: */
586: switch (fmtspec) {
587: default:
588: panic("fmt2");
589: case SKIP:
590: break;
591: case NIL:
592: sprintf(&format[1], "%%%c", fmt);
593: goto fmtgen;
594: case CONWIDTH:
595: sprintf(&format[1], "%%%d%c", field, fmt);
596: goto fmtgen;
597: case VARWIDTH:
598: sprintf(&format[1], "%%*%c", fmt);
599: goto fmtgen;
600: case CONWIDTH + CONPREC:
601: sprintf(&format[1], "%%%d.%d%c", field, prec, fmt);
602: goto fmtgen;
603: case CONWIDTH + VARPREC:
604: sprintf(&format[1], "%%%d.*%c", field, fmt);
605: goto fmtgen;
606: case VARWIDTH + CONPREC:
607: sprintf(&format[1], "%%*.%d%c", prec, fmt);
608: goto fmtgen;
609: case VARWIDTH + VARPREC:
610: sprintf(&format[1], "%%*.*%c", fmt);
611: fmtgen:
612: fmtlen = lenstr(&format[fmtstart], 0);
613: (void) put(2, O_LVCON, fmtlen);
614: putstr(&format[fmtstart], 0);
615: (void) put(1, O_FILE);
616: stkcnt += 2 * sizeof(char *);
617: (void) put(2, O_WRITEF, stkcnt);
618: }
619: /*
620: * Write the string after its blank padding
621: */
622: if (typ == TSTR) {
623: (void) put(1, O_FILE);
624: (void) put(2, CON_INT, 1);
625: if (strfmt & VARWIDTH) {
626: (void) put(2, O_RV4 | cbn << 8 + INDX ,
627: tempnlp -> value[ NL_OFFS ] );
628: (void) put(2, O_MIN, strnglen);
629: convert(nl+T4INT, INT_TYP);
630: tmpfree(&soffset);
631: } else {
632: if ((fmtspec & SKIP) &&
633: (strfmt & CONWIDTH)) {
634: strnglen = field;
635: }
636: (void) put(2, CON_INT, strnglen);
637: }
638: ap = stkrval(alv, NLNIL , (long) RREQ );
639: (void) put(2, O_WRITES,
640: 2 * sizeof(char *) + 2 * sizeof(int));
641: }
642: }
643: /*
644: * Done with arguments.
645: * Handle writeln and
646: * insufficent number of args.
647: */
648: switch (p->value[0] &~ NSTAND) {
649: case O_WRITEF:
650: if (argc == 0)
651: error("Write requires an argument");
652: break;
653: case O_MESSAGE:
654: if (argc == 0)
655: error("Message requires an argument");
656: case O_WRITLN:
657: if (filetype != nl+T1CHAR)
658: error("Can't 'writeln' a non text file");
659: (void) put(1, O_WRITLN);
660: break;
661: }
662: return;
663:
664: case O_READ4:
665: case O_READLN:
666: /*
667: * Set up default
668: * file "input".
669: */
670: file = NIL;
671: filetype = nl+T1CHAR;
672: /*
673: * Determine the file implied
674: * for the read and generate
675: * code to make it the active file.
676: */
677: if (argv != TR_NIL) {
678: codeoff();
679: ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
680: codeon();
681: if (ap == NLNIL)
682: argv = argv->list_node.next;
683: if (ap != NLNIL && ap->class == FILET) {
684: /*
685: * Got "read(f, ...", make
686: * f the active file, and save
687: * it and its type for use in
688: * processing the rest of the
689: * arguments to read.
690: */
691: file = argv->list_node.list;
692: filetype = ap->type;
693: (void) stklval(argv->list_node.list, NIL );
694: (void) put(1, O_UNIT);
695: argv = argv->list_node.next;
696: argc--;
697: } else {
698: /*
699: * Default is read from
700: * standard input.
701: */
702: (void) put(1, O_UNITINP);
703: input->nl_flags |= NUSED;
704: }
705: } else {
706: (void) put(1, O_UNITINP);
707: input->nl_flags |= NUSED;
708: }
709: /*
710: * Loop and process each
711: * of the arguments.
712: */
713: for (; argv != TR_NIL; argv = argv->list_node.next) {
714: /*
715: * Get the address of the target
716: * on the stack.
717: */
718: al = argv->list_node.list;
719: if (al == TR_NIL)
720: continue;
721: if (al->tag != T_VAR) {
722: error("Arguments to %s must be variables, not expressions", p->symbol);
723: continue;
724: }
725: ap = stklval(al, MOD|ASGN|NOUSE);
726: if (ap == NLNIL)
727: continue;
728: if (filetype != nl+T1CHAR) {
729: /*
730: * Generalized read, i.e.
731: * from a non-textfile.
732: */
733: if (incompat(filetype, ap,
734: argv->list_node.list )) {
735: error("Type mismatch in read from non-text file");
736: continue;
737: }
738: /*
739: * var := file ^;
740: */
741: if (file != NIL)
742: (void) stklval(file, NIL);
743: else /* Magic */
744: (void) put(2, PTR_RV, (int)input->value[0]);
745: (void) put(1, O_FNIL);
746: if (isa(filetype, "bcsi")) {
747: int filewidth = width(filetype);
748:
749: switch (filewidth) {
750: case 4:
751: (void) put(1, O_IND4);
752: break;
753: case 2:
754: (void) put(1, O_IND2);
755: break;
756: case 1:
757: (void) put(1, O_IND1);
758: break;
759: default:
760: (void) put(2, O_IND, filewidth);
761: }
762: convert(filetype, ap);
763: rangechk(ap, ap);
764: (void) gen(O_AS2, O_AS2,
765: filewidth, width(ap));
766: } else {
767: (void) put(2, O_IND, width(filetype));
768: convert(filetype, ap);
769: (void) put(2, O_AS, width(ap));
770: }
771: /*
772: * get(file);
773: */
774: (void) put(1, O_GET);
775: continue;
776: }
777: typ = classify(ap);
778: op = rdops(typ);
779: if (op == NIL) {
780: error("Can't read %ss from a text file", clnames[typ]);
781: continue;
782: }
783: if (op != O_READE)
784: (void) put(1, op);
785: else {
786: (void) put(2, op, (long)listnames(ap));
787: warning();
788: if (opt('s')) {
789: standard();
790: }
791: error("Reading scalars from text files is non-standard");
792: }
793: /*
794: * Data read is on the stack.
795: * Assign it.
796: */
797: if (op != O_READ8 && op != O_READE)
798: rangechk(ap, op == O_READC ? ap : nl+T4INT);
799: (void) gen(O_AS2, O_AS2, width(ap),
800: op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2);
801: }
802: /*
803: * Done with arguments.
804: * Handle readln and
805: * insufficient number of args.
806: */
807: if (p->value[0] == O_READLN) {
808: if (filetype != nl+T1CHAR)
809: error("Can't 'readln' a non text file");
810: (void) put(1, O_READLN);
811: }
812: else if (argc == 0)
813: error("read requires an argument");
814: return;
815:
816: case O_GET:
817: case O_PUT:
818: if (argc != 1) {
819: error("%s expects one argument", p->symbol);
820: return;
821: }
822: ap = stklval(argv->list_node.list, NIL );
823: if (ap == NLNIL)
824: return;
825: if (ap->class != FILET) {
826: error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
827: return;
828: }
829: (void) put(1, O_UNIT);
830: (void) put(1, op);
831: return;
832:
833: case O_RESET:
834: case O_REWRITE:
835: if (argc == 0 || argc > 2) {
836: error("%s expects one or two arguments", p->symbol);
837: return;
838: }
839: if (opt('s') && argc == 2) {
840: standard();
841: error("Two argument forms of reset and rewrite are non-standard");
842: }
843: codeoff();
844: ap = stklval(argv->list_node.list, MOD|NOUSE);
845: codeon();
846: if (ap == NLNIL)
847: return;
848: if (ap->class != FILET) {
849: error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
850: return;
851: }
852: (void) put(2, O_CON24, text(ap) ? 0: width(ap->type));
853: if (argc == 2) {
854: /*
855: * Optional second argument
856: * is a string name of a
857: * UNIX (R) file to be associated.
858: */
859: al = argv->list_node.next;
860: codeoff();
861: al = (struct tnode *) stkrval(al->list_node.list,
862: (struct nl *) NOFLAGS , (long) RREQ );
863: codeon();
864: if (al == TR_NIL)
865: return;
866: if (classify((struct nl *) al) != TSTR) {
867: error("Second argument to %s must be a string, not %s", p->symbol, nameof((struct nl *) al));
868: return;
869: }
870: (void) put(2, O_CON24, width((struct nl *) al));
871: al = argv->list_node.next;
872: al = (struct tnode *) stkrval(al->list_node.list,
873: (struct nl *) NOFLAGS , (long) RREQ );
874: } else {
875: (void) put(2, O_CON24, 0);
876: (void) put(2, PTR_CON, NIL);
877: }
878: ap = stklval(argv->list_node.list, MOD|NOUSE);
879: (void) put(1, op);
880: return;
881:
882: case O_NEW:
883: case O_DISPOSE:
884: if (argc == 0) {
885: error("%s expects at least one argument", p->symbol);
886: return;
887: }
888: ap = stklval(argv->list_node.list,
889: op == O_NEW ? ( MOD | NOUSE ) : MOD );
890: if (ap == NLNIL)
891: return;
892: if (ap->class != PTR) {
893: error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap));
894: return;
895: }
896: ap = ap->type;
897: if (ap == NIL)
898: return;
899: if ((ap->nl_flags & NFILES) && op == O_DISPOSE)
900: op = O_DFDISP;
901: argv = argv->list_node.next;
902: if (argv != TR_NIL) {
903: if (ap->class != RECORD) {
904: error("Record required when specifying variant tags");
905: return;
906: }
907: for (; argv != TR_NIL; argv = argv->list_node.next) {
908: if (ap->ptr[NL_VARNT] == NIL) {
909: error("Too many tag fields");
910: return;
911: }
912: if (!isconst(argv->list_node.list)) {
913: error("Second and successive arguments to %s must be constants", p->symbol);
914: return;
915: }
916: gconst(argv->list_node.list);
917: if (con.ctype == NIL)
918: return;
919: if (incompat(con.ctype, (
920: ap->ptr[NL_TAG])->type , TR_NIL )) {
921: cerror("Specified tag constant type clashed with variant case selector type");
922: return;
923: }
924: for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain)
925: if (ap->range[0] == con.crval)
926: break;
927: if (ap == NIL) {
928: error("No variant case label value equals specified constant value");
929: return;
930: }
931: ap = ap->ptr[NL_VTOREC];
932: }
933: }
934: (void) put(2, op, width(ap));
935: return;
936:
937: case O_DATE:
938: case O_TIME:
939: if (argc != 1) {
940: error("%s expects one argument", p->symbol);
941: return;
942: }
943: ap = stklval(argv->list_node.list, MOD|NOUSE);
944: if (ap == NLNIL)
945: return;
946: if (classify(ap) != TSTR || width(ap) != 10) {
947: error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
948: return;
949: }
950: (void) put(1, op);
951: return;
952:
953: case O_HALT:
954: if (argc != 0) {
955: error("halt takes no arguments");
956: return;
957: }
958: (void) put(1, op);
959: noreach = TRUE; /* used to be 1 */
960: return;
961:
962: case O_ARGV:
963: if (argc != 2) {
964: error("argv takes two arguments");
965: return;
966: }
967: ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
968: if (ap == NLNIL)
969: return;
970: if (isnta(ap, "i")) {
971: error("argv's first argument must be an integer, not %s", nameof(ap));
972: return;
973: }
974: al = argv->list_node.next;
975: ap = stklval(al->list_node.list, MOD|NOUSE);
976: if (ap == NLNIL)
977: return;
978: if (classify(ap) != TSTR) {
979: error("argv's second argument must be a string, not %s", nameof(ap));
980: return;
981: }
982: (void) put(2, op, width(ap));
983: return;
984:
985: case O_STLIM:
986: if (argc != 1) {
987: error("stlimit requires one argument");
988: return;
989: }
990: ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
991: if (ap == NLNIL)
992: return;
993: if (isnta(ap, "i")) {
994: error("stlimit's argument must be an integer, not %s", nameof(ap));
995: return;
996: }
997: if (width(ap) != 4)
998: (void) put(1, O_STOI);
999: (void) put(1, op);
1000: return;
1001:
1002: case O_REMOVE:
1003: if (argc != 1) {
1004: error("remove expects one argument");
1005: return;
1006: }
1007: codeoff();
1008: ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS,
1009: (long) RREQ );
1010: codeon();
1011: if (ap == NLNIL)
1012: return;
1013: if (classify(ap) != TSTR) {
1014: error("remove's argument must be a string, not %s", nameof(ap));
1015: return;
1016: }
1017: (void) put(2, O_CON24, width(ap));
1018: ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS,
1019: (long) RREQ );
1020: (void) put(1, op);
1021: return;
1022:
1023: case O_LLIMIT:
1024: if (argc != 2) {
1025: error("linelimit expects two arguments");
1026: return;
1027: }
1028: al = argv->list_node.next;
1029: ap = stkrval(al->list_node.list, NLNIL , (long) RREQ );
1030: if (ap == NIL)
1031: return;
1032: if (isnta(ap, "i")) {
1033: error("linelimit's second argument must be an integer, not %s", nameof(ap));
1034: return;
1035: }
1036: ap = stklval(argv->list_node.list, NOFLAGS|NOUSE);
1037: if (ap == NLNIL)
1038: return;
1039: if (!text(ap)) {
1040: error("linelimit's first argument must be a text file, not %s", nameof(ap));
1041: return;
1042: }
1043: (void) put(1, op);
1044: return;
1045: case O_PAGE:
1046: if (argc != 1) {
1047: error("page expects one argument");
1048: return;
1049: }
1050: ap = stklval(argv->list_node.list, NIL );
1051: if (ap == NLNIL)
1052: return;
1053: if (!text(ap)) {
1054: error("Argument to page must be a text file, not %s", nameof(ap));
1055: return;
1056: }
1057: (void) put(1, O_UNIT);
1058: (void) put(1, op);
1059: return;
1060:
1061: case O_ASRT:
1062: if (!opt('t'))
1063: return;
1064: if (argc == 0 || argc > 2) {
1065: error("Assert expects one or two arguments");
1066: return;
1067: }
1068: if (argc == 2) {
1069: /*
1070: * Optional second argument is a string specifying
1071: * why the assertion failed.
1072: */
1073: al = argv->list_node.next;
1074: al1 = stkrval(al->list_node.list, NLNIL , (long) RREQ );
1075: if (al1 == NIL)
1076: return;
1077: if (classify(al1) != TSTR) {
1078: error("Second argument to assert must be a string, not %s", nameof(al1));
1079: return;
1080: }
1081: } else {
1082: (void) put(2, PTR_CON, NIL);
1083: }
1084: ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
1085: if (ap == NIL)
1086: return;
1087: if (isnta(ap, "b"))
1088: error("Assert expression must be Boolean, not %ss", nameof(ap));
1089: (void) put(1, O_ASRT);
1090: return;
1091:
1092: case O_PACK:
1093: if (argc != 3) {
1094: error("pack expects three arguments");
1095: return;
1096: }
1097: pu = "pack(a,i,z)";
1098: pua = argv->list_node.list;
1099: al = argv->list_node.next;
1100: pui = al->list_node.list;
1101: alv = al->list_node.next;
1102: puz = alv->list_node.list;
1103: goto packunp;
1104: case O_UNPACK:
1105: if (argc != 3) {
1106: error("unpack expects three arguments");
1107: return;
1108: }
1109: pu = "unpack(z,a,i)";
1110: puz = argv->list_node.list;
1111: al = argv->list_node.next;
1112: pua = al->list_node.list;
1113: alv = al->list_node.next;
1114: pui = alv->list_node.list;
1115: packunp:
1116: codeoff();
1117: ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
1118: al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
1119: codeon();
1120: if (ap == NIL)
1121: return;
1122: if (ap->class != ARRAY) {
1123: error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
1124: return;
1125: }
1126: if (al1->class != ARRAY) {
1127: error("%s requires z to be a packed array, not %s", pu, nameof(ap));
1128: return;
1129: }
1130: if (al1->type == NIL || ap->type == NIL)
1131: return;
1132: if (al1->type != ap->type) {
1133: error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
1134: return;
1135: }
1136: k = width(al1);
1137: itemwidth = width(ap->type);
1138: ap = ap->chain;
1139: al1 = al1->chain;
1140: if (ap->chain != NIL || al1->chain != NIL) {
1141: error("%s requires a and z to be single dimension arrays", pu);
1142: return;
1143: }
1144: if (ap == NIL || al1 == NIL)
1145: return;
1146: /*
1147: * al1 is the range for z i.e. u..v
1148: * ap is the range for a i.e. m..n
1149: * i will be n-m+1
1150: * j will be v-u+1
1151: */
1152: i = ap->range[1] - ap->range[0] + 1;
1153: j = al1->range[1] - al1->range[0] + 1;
1154: if (i < j) {
1155: error("%s cannot have more elements in a (%d) than in z (%d)", pu, (char *) j, (char *) i);
1156: return;
1157: }
1158: /*
1159: * get n-m-(v-u) and m for the interpreter
1160: */
1161: i -= j;
1162: j = ap->range[0];
1163: (void) put(2, O_CON24, k);
1164: (void) put(2, O_CON24, i);
1165: (void) put(2, O_CON24, j);
1166: (void) put(2, O_CON24, itemwidth);
1167: al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
1168: ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
1169: ap = stkrval(pui, NLNIL , (long) RREQ );
1170: if (ap == NIL)
1171: return;
1172: (void) put(1, op);
1173: return;
1174: case 0:
1175: error("%s is an unimplemented extension", p->symbol);
1176: return;
1177:
1178: default:
1179: panic("proc case");
1180: }
1181: }
1182: #endif OBJ
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.