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