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