![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pcproc.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 pcproc.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[] = "@(#)pcproc.c 1.21 4/8/83";
4:
5: #include "whoami.h"
6: #ifdef PC
7: /*
8: * and to the end of the file
9: */
10: #include "0.h"
11: #include "tree.h"
12: #include "objfmt.h"
13: #include "opcode.h"
14: #include "pc.h"
15: #include "pcops.h"
16: #include "tmps.h"
17:
18: /*
19: * The constant EXPOSIZE specifies the number of digits in the exponent
20: * of real numbers.
21: *
22: * The constant REALSPC defines the amount of forced padding preceeding
23: * real numbers when they are printed. If REALSPC == 0, then no padding
24: * is added, REALSPC == 1 adds one extra blank irregardless of the width
25: * specified by the user.
26: *
27: * N.B. - Values greater than one require program mods.
28: */
29: #define EXPOSIZE 2
30: #define REALSPC 0
31:
32: /*
33: * The following array is used to determine which classes may be read
34: * from textfiles. It is indexed by the return value from classify.
35: */
36: #define rdops(x) rdxxxx[(x)-(TFIRST)]
37:
38: int rdxxxx[] = {
39: 0, /* -7 file types */
40: 0, /* -6 record types */
41: 0, /* -5 array types */
42: O_READE, /* -4 scalar types */
43: 0, /* -3 pointer types */
44: 0, /* -2 set types */
45: 0, /* -1 string types */
46: 0, /* 0 nil, no type */
47: O_READE, /* 1 boolean */
48: O_READC, /* 2 character */
49: O_READ4, /* 3 integer */
50: O_READ8 /* 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: pcproc(r)
60: int *r;
61: {
62: register struct nl *p;
63: register int *alv, *al, op;
64: struct nl *filetype, *ap;
65: int argc, *argv, typ, fmtspec, strfmt, stkcnt, *file;
66: char fmt, format[20], *strptr, *cmd;
67: int prec, field, strnglen, fmtlen, fmtstart, pu;
68: int *pua, *pui, *puz;
69: int i, j, k;
70: int itemwidth;
71: char *readname;
72: struct nl *tempnlp;
73: long readtype;
74: struct tmps soffset;
75:
76: #define CONPREC 4
77: #define VARPREC 8
78: #define CONWIDTH 1
79: #define VARWIDTH 2
80: #define SKIP 16
81:
82: /*
83: * Verify that the name is
84: * defined and is that of a
85: * procedure.
86: */
87: p = lookup(r[2]);
88: if (p == NIL) {
89: rvlist(r[3]);
90: return;
91: }
92: if (p->class != PROC && p->class != FPROC) {
93: error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]);
94: rvlist(r[3]);
95: return;
96: }
97: argv = r[3];
98:
99: /*
100: * Call handles user defined
101: * procedures and functions.
102: */
103: if (bn != 0) {
104: call(p, argv, PROC, bn);
105: return;
106: }
107:
108: /*
109: * Call to built-in procedure.
110: * Count the arguments.
111: */
112: argc = 0;
113: for (al = argv; al != NIL; al = al[2])
114: argc++;
115:
116: /*
117: * Switch on the operator
118: * associated with the built-in
119: * procedure in the namelist
120: */
121: op = p->value[0] &~ NSTAND;
122: if (opt('s') && (p->value[0] & NSTAND)) {
123: standard();
124: error("%s is a nonstandard procedure", p->symbol);
125: }
126: switch (op) {
127:
128: case O_ABORT:
129: if (argc != 0)
130: error("null takes no arguments");
131: return;
132:
133: case O_FLUSH:
134: if (argc == 0) {
135: putleaf( P2ICON , 0 , 0 , P2INT , "_PFLUSH" );
136: putop( P2UNARY P2CALL , P2INT );
137: putdot( filename , line );
138: return;
139: }
140: if (argc != 1) {
141: error("flush takes at most one argument");
142: return;
143: }
144: putleaf( P2ICON , 0 , 0
145: , ADDTYPE( P2FTN | P2INT , P2PTR )
146: , "_FLUSH" );
147: ap = stklval(argv[1], NOFLAGS);
148: if (ap == NIL)
149: return;
150: if (ap->class != FILET) {
151: error("flush's argument must be a file, not %s", nameof(ap));
152: return;
153: }
154: putop( P2CALL , P2INT );
155: putdot( filename , line );
156: return;
157:
158: case O_MESSAGE:
159: case O_WRITEF:
160: case O_WRITLN:
161: /*
162: * Set up default file "output"'s type
163: */
164: file = NIL;
165: filetype = nl+T1CHAR;
166: /*
167: * Determine the file implied
168: * for the write and generate
169: * code to make it the active file.
170: */
171: if (op == O_MESSAGE) {
172: /*
173: * For message, all that matters
174: * is that the filetype is
175: * a character file.
176: * Thus "output" will suit us fine.
177: */
178: putleaf( P2ICON , 0 , 0 , P2INT , "_PFLUSH" );
179: putop( P2UNARY P2CALL , P2INT );
180: putdot( filename , line );
181: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
182: P2PTR|P2STRTY );
183: putLV( "__err" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY );
184: putop( P2ASSIGN , P2PTR|P2STRTY );
185: putdot( filename , line );
186: } else if (argv != NIL && (al = argv[1])[0] != T_WEXP) {
187: /*
188: * If there is a first argument which has
189: * no write widths, then it is potentially
190: * a file name.
191: */
192: codeoff();
193: ap = stkrval(argv[1], NIL , RREQ );
194: codeon();
195: if (ap == NIL)
196: argv = argv[2];
197: if (ap != NIL && ap->class == FILET) {
198: /*
199: * Got "write(f, ...", make
200: * f the active file, and save
201: * it and its type for use in
202: * processing the rest of the
203: * arguments to write.
204: */
205: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
206: P2PTR|P2STRTY );
207: putleaf( P2ICON , 0 , 0
208: , ADDTYPE( P2FTN | P2INT , P2PTR )
209: , "_UNIT" );
210: file = argv[1];
211: filetype = ap->type;
212: stklval(argv[1], NOFLAGS);
213: putop( P2CALL , P2INT );
214: putop( P2ASSIGN , P2PTR|P2STRTY );
215: putdot( filename , line );
216: /*
217: * Skip over the first argument
218: */
219: argv = argv[2];
220: argc--;
221: } else {
222: /*
223: * Set up for writing on
224: * standard output.
225: */
226: putRV( 0, cbn , CURFILEOFFSET ,
227: NLOCAL , P2PTR|P2STRTY );
228: putLV( "_output" , 0 , 0 , NGLOBAL ,
229: P2PTR|P2STRTY );
230: putop( P2ASSIGN , P2PTR|P2STRTY );
231: putdot( filename , line );
232: output->nl_flags |= NUSED;
233: }
234: } else {
235: putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
236: P2PTR|P2STRTY );
237: putLV( "_output" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY );
238: putop( P2ASSIGN , P2PTR|P2STRTY );
239: putdot( filename , line );
240: output->nl_flags |= NUSED;
241: }
242: /*
243: * Loop and process each
244: * of the arguments.
245: */
246: for (; argv != NIL; argv = argv[2]) {
247: /*
248: * fmtspec indicates the type (CONstant or VARiable)
249: * and number (none, WIDTH, and/or PRECision)
250: * of the fields in the printf format for this
251: * output variable.
252: * stkcnt is the number of longs pushed on the stack
253: * fmt is the format output indicator (D, E, F, O, X, S)
254: * fmtstart = 0 for leading blank; = 1 for no blank
255: */
256: fmtspec = NIL;
257: stkcnt = 0;
258: fmt = 'D';
259: fmtstart = 1;
260: al = argv[1];
261: if (al == NIL)
262: continue;
263: if (al[0] == T_WEXP)
264: alv = al[1];
265: else
266: alv = al;
267: if (alv == NIL)
268: continue;
269: codeoff();
270: ap = stkrval(alv, NIL , RREQ );
271: codeon();
272: if (ap == NIL)
273: continue;
274: typ = classify(ap);
275: if (al[0] == T_WEXP) {
276: /*
277: * Handle width expressions.
278: * The basic game here is that width
279: * expressions get evaluated. If they
280: * are constant, the value is placed
281: * directly in the format string.
282: * Otherwise the value is pushed onto
283: * the stack and an indirection is
284: * put into the format string.
285: */
286: if (al[3] == OCT)
287: fmt = 'O';
288: else if (al[3] == HEX)
289: fmt = 'X';
290: else if (al[3] != NIL) {
291: /*
292: * Evaluate second format spec
293: */
294: if ( constval(al[3])
295: && isa( con.ctype , "i" ) ) {
296: fmtspec += CONPREC;
297: prec = con.crval;
298: } else {
299: fmtspec += VARPREC;
300: }
301: fmt = 'f';
302: switch ( typ ) {
303: case TINT:
304: if ( opt( 's' ) ) {
305: standard();
306: error("Writing %ss with two write widths is non-standard", clnames[typ]);
307: }
308: /* and fall through */
309: case TDOUBLE:
310: break;
311: default:
312: error("Cannot write %ss with two write widths", clnames[typ]);
313: continue;
314: }
315: }
316: /*
317: * Evaluate first format spec
318: */
319: if (al[2] != NIL) {
320: if ( constval(al[2])
321: && isa( con.ctype , "i" ) ) {
322: fmtspec += CONWIDTH;
323: field = con.crval;
324: } else {
325: fmtspec += VARWIDTH;
326: }
327: }
328: if ((fmtspec & CONPREC) && prec < 0 ||
329: (fmtspec & CONWIDTH) && field < 0) {
330: error("Negative widths are not allowed");
331: continue;
332: }
333: if ( opt('s') &&
334: ((fmtspec & CONPREC) && prec == 0 ||
335: (fmtspec & CONWIDTH) && field == 0)) {
336: standard();
337: error("Zero widths are non-standard");
338: }
339: }
340: if (filetype != nl+T1CHAR) {
341: if (fmt == 'O' || fmt == 'X') {
342: error("Oct/hex allowed only on text files");
343: continue;
344: }
345: if (fmtspec) {
346: error("Write widths allowed only on text files");
347: continue;
348: }
349: /*
350: * Generalized write, i.e.
351: * to a non-textfile.
352: */
353: putleaf( P2ICON , 0 , 0
354: , ADDTYPE(
355: ADDTYPE(
356: ADDTYPE( p2type( filetype )
357: , P2PTR )
358: , P2FTN )
359: , P2PTR )
360: , "_FNIL" );
361: stklval(file, NOFLAGS);
362: putop( P2CALL
363: , ADDTYPE( p2type( filetype ) , P2PTR ) );
364: putop( P2UNARY P2MUL , p2type( filetype ) );
365: /*
366: * file^ := ...
367: */
368: switch ( classify( filetype ) ) {
369: case TBOOL:
370: case TCHAR:
371: case TINT:
372: case TSCAL:
373: precheck( filetype , "_RANG4" , "_RSNG4" );
374: /* and fall through */
375: case TDOUBLE:
376: case TPTR:
377: ap = rvalue( argv[1] , filetype , RREQ );
378: break;
379: default:
380: ap = rvalue( argv[1] , filetype , LREQ );
381: break;
382: }
383: if (ap == NIL)
384: continue;
385: if (incompat(ap, filetype, argv[1])) {
386: cerror("Type mismatch in write to non-text file");
387: continue;
388: }
389: switch ( classify( filetype ) ) {
390: case TBOOL:
391: case TCHAR:
392: case TINT:
393: case TSCAL:
394: postcheck(filetype, ap);
395: sconv(p2type(ap), p2type(filetype));
396: /* and fall through */
397: case TDOUBLE:
398: case TPTR:
399: putop( P2ASSIGN , p2type( filetype ) );
400: putdot( filename , line );
401: break;
402: default:
403: putstrop(P2STASG,
404: ADDTYPE(p2type(filetype),
405: P2PTR),
406: lwidth(filetype),
407: align(filetype));
408: putdot( filename , line );
409: break;
410: }
411: /*
412: * put(file)
413: */
414: putleaf( P2ICON , 0 , 0
415: , ADDTYPE( P2FTN | P2INT , P2PTR )
416: , "_PUT" );
417: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
418: P2PTR|P2STRTY );
419: putop( P2CALL , P2INT );
420: putdot( filename , line );
421: continue;
422: }
423: /*
424: * Write to a textfile
425: *
426: * Evaluate the expression
427: * to be written.
428: */
429: if (fmt == 'O' || fmt == 'X') {
430: if (opt('s')) {
431: standard();
432: error("Oct and hex are non-standard");
433: }
434: if (typ == TSTR || typ == TDOUBLE) {
435: error("Can't write %ss with oct/hex", clnames[typ]);
436: continue;
437: }
438: if (typ == TCHAR || typ == TBOOL)
439: typ = TINT;
440: }
441: /*
442: * If there is no format specified by the programmer,
443: * implement the default.
444: */
445: switch (typ) {
446: case TPTR:
447: warning();
448: if (opt('s')) {
449: standard();
450: }
451: error("Writing %ss to text files is non-standard",
452: clnames[typ]);
453: /* and fall through */
454: case TINT:
455: if (fmt == 'f') {
456: typ = TDOUBLE;
457: goto tdouble;
458: }
459: if (fmtspec == NIL) {
460: if (fmt == 'D')
461: field = 10;
462: else if (fmt == 'X')
463: field = 8;
464: else if (fmt == 'O')
465: field = 11;
466: else
467: panic("fmt1");
468: fmtspec = CONWIDTH;
469: }
470: break;
471: case TCHAR:
472: tchar:
473: fmt = 'c';
474: break;
475: case TSCAL:
476: warning();
477: if (opt('s')) {
478: standard();
479: }
480: error("Writing %ss to text files is non-standard",
481: clnames[typ]);
482: case TBOOL:
483: fmt = 's';
484: break;
485: case TDOUBLE:
486: tdouble:
487: switch (fmtspec) {
488: case NIL:
489: field = 14 + (5 + EXPOSIZE);
490: prec = field - (5 + EXPOSIZE);
491: fmt = 'e';
492: fmtspec = CONWIDTH + CONPREC;
493: break;
494: case CONWIDTH:
495: field -= REALSPC;
496: if (field < 1)
497: field = 1;
498: prec = field - (5 + EXPOSIZE);
499: if (prec < 1)
500: prec = 1;
501: fmtspec += CONPREC;
502: fmt = 'e';
503: break;
504: case VARWIDTH:
505: fmtspec += VARPREC;
506: fmt = 'e';
507: break;
508: case CONWIDTH + CONPREC:
509: case CONWIDTH + VARPREC:
510: field -= REALSPC;
511: if (field < 1)
512: field = 1;
513: }
514: format[0] = ' ';
515: fmtstart = 1 - REALSPC;
516: break;
517: case TSTR:
518: constval( alv );
519: switch ( classify( con.ctype ) ) {
520: case TCHAR:
521: typ = TCHAR;
522: goto tchar;
523: case TSTR:
524: strptr = con.cpval;
525: for (strnglen = 0; *strptr++; strnglen++) /* void */;
526: strptr = con.cpval;
527: break;
528: default:
529: strnglen = width(ap);
530: break;
531: }
532: fmt = 's';
533: strfmt = fmtspec;
534: if (fmtspec == NIL) {
535: fmtspec = SKIP;
536: break;
537: }
538: if (fmtspec & CONWIDTH) {
539: if (field <= strnglen)
540: fmtspec = SKIP;
541: else
542: field -= strnglen;
543: }
544: break;
545: default:
546: error("Can't write %ss to a text file", clnames[typ]);
547: continue;
548: }
549: /*
550: * Generate the format string
551: */
552: switch (fmtspec) {
553: default:
554: panic("fmt2");
555: case NIL:
556: if (fmt == 'c') {
557: if ( opt( 't' ) ) {
558: putleaf( P2ICON , 0 , 0
559: , ADDTYPE( P2FTN|P2INT , P2PTR )
560: , "_WRITEC" );
561: putRV( 0 , cbn , CURFILEOFFSET ,
562: NLOCAL , P2PTR|P2STRTY );
563: stkrval( alv , NIL , RREQ );
564: putop( P2LISTOP , P2INT );
565: } else {
566: putleaf( P2ICON , 0 , 0
567: , ADDTYPE( P2FTN|P2INT , P2PTR )
568: , "_fputc" );
569: stkrval( alv , NIL , RREQ );
570: }
571: putleaf( P2ICON , 0 , 0
572: , ADDTYPE( P2FTN | P2INT , P2PTR )
573: , "_ACTFILE" );
574: putRV( 0, cbn , CURFILEOFFSET ,
575: NLOCAL , P2PTR|P2STRTY );
576: putop( P2CALL , P2INT );
577: putop( P2LISTOP , P2INT );
578: putop( P2CALL , P2INT );
579: putdot( filename , line );
580: } else {
581: sprintf(&format[1], "%%%c", fmt);
582: goto fmtgen;
583: }
584: case SKIP:
585: break;
586: case CONWIDTH:
587: sprintf(&format[1], "%%%1D%c", field, fmt);
588: goto fmtgen;
589: case VARWIDTH:
590: sprintf(&format[1], "%%*%c", fmt);
591: goto fmtgen;
592: case CONWIDTH + CONPREC:
593: sprintf(&format[1], "%%%1D.%1D%c", field, prec, fmt);
594: goto fmtgen;
595: case CONWIDTH + VARPREC:
596: sprintf(&format[1], "%%%1D.*%c", field, fmt);
597: goto fmtgen;
598: case VARWIDTH + CONPREC:
599: sprintf(&format[1], "%%*.%1D%c", prec, fmt);
600: goto fmtgen;
601: case VARWIDTH + VARPREC:
602: sprintf(&format[1], "%%*.*%c", fmt);
603: fmtgen:
604: if ( opt( 't' ) ) {
605: putleaf( P2ICON , 0 , 0
606: , ADDTYPE( P2FTN | P2INT , P2PTR )
607: , "_WRITEF" );
608: putRV( 0 , cbn , CURFILEOFFSET ,
609: NLOCAL , P2PTR|P2STRTY );
610: putleaf( P2ICON , 0 , 0
611: , ADDTYPE( P2FTN | P2INT , P2PTR )
612: , "_ACTFILE" );
613: putRV( 0 , cbn , CURFILEOFFSET ,
614: NLOCAL , P2PTR|P2STRTY );
615: putop( P2CALL , P2INT );
616: putop( P2LISTOP , P2INT );
617: } else {
618: putleaf( P2ICON , 0 , 0
619: , ADDTYPE( P2FTN | P2INT , P2PTR )
620: , "_fprintf" );
621: putleaf( P2ICON , 0 , 0
622: , ADDTYPE( P2FTN | P2INT , P2PTR )
623: , "_ACTFILE" );
624: putRV( 0 , cbn , CURFILEOFFSET ,
625: NLOCAL , P2PTR|P2STRTY );
626: putop( P2CALL , P2INT );
627: }
628: putCONG( &format[ fmtstart ]
629: , strlen( &format[ fmtstart ] )
630: , LREQ );
631: putop( P2LISTOP , P2INT );
632: if ( fmtspec & VARWIDTH ) {
633: /*
634: * either
635: * ,(temp=width,MAX(temp,...)),
636: * or
637: * , MAX( width , ... ) ,
638: */
639: if ( ( typ == TDOUBLE && al[3] == NIL )
640: || typ == TSTR ) {
641: soffset = sizes[cbn].curtmps;
642: tempnlp = tmpalloc(sizeof(long),
643: nl+T4INT, REGOK);
644: putRV( 0 , cbn ,
645: tempnlp -> value[ NL_OFFS ] ,
646: tempnlp -> extra_flags , P2INT );
647: ap = stkrval( al[2] , NIL , RREQ );
648: putop( P2ASSIGN , P2INT );
649: putleaf( P2ICON , 0 , 0
650: , ADDTYPE( P2FTN | P2INT , P2PTR )
651: , "_MAX" );
652: putRV( 0 , cbn ,
653: tempnlp -> value[ NL_OFFS ] ,
654: tempnlp -> extra_flags , P2INT );
655: } else {
656: if (opt('t')
657: || typ == TSTR || typ == TDOUBLE) {
658: putleaf( P2ICON , 0 , 0
659: ,ADDTYPE( P2FTN | P2INT, P2PTR )
660: ,"_MAX" );
661: }
662: ap = stkrval( al[2] , NIL , RREQ );
663: }
664: if (ap == NIL)
665: continue;
666: if (isnta(ap,"i")) {
667: error("First write width must be integer, not %s", nameof(ap));
668: continue;
669: }
670: switch ( typ ) {
671: case TDOUBLE:
672: putleaf( P2ICON , REALSPC , 0 , P2INT , 0 );
673: putop( P2LISTOP , P2INT );
674: putleaf( P2ICON , 1 , 0 , P2INT , 0 );
675: putop( P2LISTOP , P2INT );
676: putop( P2CALL , P2INT );
677: if ( al[3] == NIL ) {
678: /*
679: * finish up the comma op
680: */
681: putop( P2COMOP , P2INT );
682: fmtspec &= ~VARPREC;
683: putop( P2LISTOP , P2INT );
684: putleaf( P2ICON , 0 , 0
685: , ADDTYPE( P2FTN | P2INT , P2PTR )
686: , "_MAX" );
687: putRV( 0 , cbn ,
688: tempnlp -> value[ NL_OFFS ] ,
689: tempnlp -> extra_flags ,
690: P2INT );
691: tmpfree(&soffset);
692: putleaf( P2ICON ,
693: 5 + EXPOSIZE + REALSPC ,
694: 0 , P2INT , 0 );
695: putop( P2LISTOP , P2INT );
696: putleaf( P2ICON , 1 , 0 , P2INT , 0 );
697: putop( P2LISTOP , P2INT );
698: putop( P2CALL , P2INT );
699: }
700: putop( P2LISTOP , P2INT );
701: break;
702: case TSTR:
703: putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
704: putop( P2LISTOP , P2INT );
705: putleaf( P2ICON , 0 , 0 , P2INT , 0 );
706: putop( P2LISTOP , P2INT );
707: putop( P2CALL , P2INT );
708: putop( P2COMOP , P2INT );
709: putop( P2LISTOP , P2INT );
710: break;
711: default:
712: if (opt('t')) {
713: putleaf( P2ICON , 0 , 0 , P2INT , 0 );
714: putop( P2LISTOP , P2INT );
715: putleaf( P2ICON , 0 , 0 , P2INT , 0 );
716: putop( P2LISTOP , P2INT );
717: putop( P2CALL , P2INT );
718: }
719: putop( P2LISTOP , P2INT );
720: break;
721: }
722: }
723: /*
724: * If there is a variable precision,
725: * evaluate it
726: */
727: if (fmtspec & VARPREC) {
728: if (opt('t')) {
729: putleaf( P2ICON , 0 , 0
730: , ADDTYPE( P2FTN | P2INT , P2PTR )
731: , "_MAX" );
732: }
733: ap = stkrval( al[3] , NIL , RREQ );
734: if (ap == NIL)
735: continue;
736: if (isnta(ap,"i")) {
737: error("Second write width must be integer, not %s", nameof(ap));
738: continue;
739: }
740: if (opt('t')) {
741: putleaf( P2ICON , 0 , 0 , P2INT , 0 );
742: putop( P2LISTOP , P2INT );
743: putleaf( P2ICON , 0 , 0 , P2INT , 0 );
744: putop( P2LISTOP , P2INT );
745: putop( P2CALL , P2INT );
746: }
747: putop( P2LISTOP , P2INT );
748: }
749: /*
750: * evaluate the thing we want printed.
751: */
752: switch ( typ ) {
753: case TPTR:
754: case TCHAR:
755: case TINT:
756: stkrval( alv , NIL , RREQ );
757: putop( P2LISTOP , P2INT );
758: break;
759: case TDOUBLE:
760: ap = stkrval( alv , NIL , RREQ );
761: if (isnta(ap, "d")) {
762: sconv(p2type(ap), P2DOUBLE);
763: }
764: putop( P2LISTOP , P2INT );
765: break;
766: case TSCAL:
767: case TBOOL:
768: putleaf( P2ICON , 0 , 0
769: , ADDTYPE( P2FTN | P2INT , P2PTR )
770: , "_NAM" );
771: ap = stkrval( alv , NIL , RREQ );
772: sprintf( format , PREFIXFORMAT , LABELPREFIX
773: , listnames( ap ) );
774: putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR
775: , format );
776: putop( P2LISTOP , P2INT );
777: putop( P2CALL , P2INT );
778: putop( P2LISTOP , P2INT );
779: break;
780: case TSTR:
781: putCONG( "" , 0 , LREQ );
782: putop( P2LISTOP , P2INT );
783: break;
784: default:
785: panic("fmt3");
786: break;
787: }
788: putop( P2CALL , P2INT );
789: putdot( filename , line );
790: }
791: /*
792: * Write the string after its blank padding
793: */
794: if (typ == TSTR ) {
795: if ( opt( 't' ) ) {
796: putleaf( P2ICON , 0 , 0
797: , ADDTYPE( P2FTN | P2INT , P2PTR )
798: , "_WRITES" );
799: putRV( 0 , cbn , CURFILEOFFSET ,
800: NLOCAL , P2PTR|P2STRTY );
801: ap = stkrval(alv, NIL , RREQ );
802: putop( P2LISTOP , P2INT );
803: } else {
804: putleaf( P2ICON , 0 , 0
805: , ADDTYPE( P2FTN | P2INT , P2PTR )
806: , "_fwrite" );
807: ap = stkrval(alv, NIL , RREQ );
808: }
809: if (strfmt & VARWIDTH) {
810: /*
811: * min, inline expanded as
812: * temp < len ? temp : len
813: */
814: putRV( 0 , cbn ,
815: tempnlp -> value[ NL_OFFS ] ,
816: tempnlp -> extra_flags , P2INT );
817: putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
818: putop( P2LT , P2INT );
819: putRV( 0 , cbn ,
820: tempnlp -> value[ NL_OFFS ] ,
821: tempnlp -> extra_flags , P2INT );
822: putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
823: putop( P2COLON , P2INT );
824: putop( P2QUEST , P2INT );
825: tmpfree(&soffset);
826: } else {
827: if ( ( fmtspec & SKIP )
828: && ( strfmt & CONWIDTH ) ) {
829: strnglen = field;
830: }
831: putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
832: }
833: putop( P2LISTOP , P2INT );
834: putleaf( P2ICON , 1 , 0 , P2INT , 0 );
835: putop( P2LISTOP , P2INT );
836: putleaf( P2ICON , 0 , 0
837: , ADDTYPE( P2FTN | P2INT , P2PTR )
838: , "_ACTFILE" );
839: putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
840: P2PTR|P2STRTY );
841: putop( P2CALL , P2INT );
842: putop( P2LISTOP , P2INT );
843: putop( P2CALL , P2INT );
844: putdot( filename , line );
845: }
846: }
847: /*
848: * Done with arguments.
849: * Handle writeln and
850: * insufficent number of args.
851: */
852: switch (p->value[0] &~ NSTAND) {
853: case O_WRITEF:
854: if (argc == 0)
855: error("Write requires an argument");
856: break;
857: case O_MESSAGE:
858: if (argc == 0)
859: error("Message requires an argument");
860: case O_WRITLN:
861: if (filetype != nl+T1CHAR)
862: error("Can't 'writeln' a non text file");
863: if ( opt( 't' ) ) {
864: putleaf( P2ICON , 0 , 0
865: , ADDTYPE( P2FTN | P2INT , P2PTR )
866: , "_WRITLN" );
867: putRV( 0 , cbn , CURFILEOFFSET ,
868: NLOCAL , P2PTR|P2STRTY );
869: } else {
870: putleaf( P2ICON , 0 , 0
871: , ADDTYPE( P2FTN | P2INT , P2PTR )
872: , "_fputc" );
873: putleaf( P2ICON , '\n' , 0 , P2CHAR , 0 );
874: putleaf( P2ICON , 0 , 0
875: , ADDTYPE( P2FTN | P2INT , P2PTR )
876: , "_ACTFILE" );
877: putRV( 0 , cbn , CURFILEOFFSET ,
878: NLOCAL , P2PTR|P2STRTY );
879: putop( P2CALL , P2INT );
880: putop( P2LISTOP , P2INT );
881: }
882: putop( P2CALL , P2INT );
883: putdot( filename , line );
884: break;
885: }
886: return;
887:
888: case O_READ4:
889: case O_READLN:
890: /*
891: * Set up default
892: * file "input".
893: */
894: file = NIL;
895: filetype = nl+T1CHAR;
896: /*
897: * Determine the file implied
898: * for the read and generate
899: * code to make it the active file.
900: */
901: if (argv != NIL) {
902: codeoff();
903: ap = stkrval(argv[1], NIL , RREQ );
904: codeon();
905: if (ap == NIL)
906: argv = argv[2];
907: if (ap != NIL && ap->class == FILET) {
908: /*
909: * Got "read(f, ...", make
910: * f the active file, and save
911: * it and its type for use in
912: * processing the rest of the
913: * arguments to read.
914: */
915: file = argv[1];
916: filetype = ap->type;
917: putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
918: P2PTR|P2STRTY );
919: putleaf( P2ICON , 0 , 0
920: , ADDTYPE( P2FTN | P2INT , P2PTR )
921: , "_UNIT" );
922: stklval(argv[1], NOFLAGS);
923: putop( P2CALL , P2INT );
924: putop( P2ASSIGN , P2PTR|P2STRTY );
925: putdot( filename , line );
926: argv = argv[2];
927: argc--;
928: } else {
929: /*
930: * Default is read from
931: * standard input.
932: */
933: putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
934: P2PTR|P2STRTY );
935: putLV( "_input" , 0 , 0 , NGLOBAL ,
936: P2PTR|P2STRTY );
937: putop( P2ASSIGN , P2PTR|P2STRTY );
938: putdot( filename , line );
939: input->nl_flags |= NUSED;
940: }
941: } else {
942: putRV( 0, cbn , CURFILEOFFSET , NLOCAL ,
943: P2PTR|P2STRTY );
944: putLV( "_input" , 0 , 0 , NGLOBAL , P2PTR|P2STRTY );
945: putop( P2ASSIGN , P2PTR|P2STRTY );
946: putdot( filename , line );
947: input->nl_flags |= NUSED;
948: }
949: /*
950: * Loop and process each
951: * of the arguments.
952: */
953: for (; argv != NIL; argv = argv[2]) {
954: /*
955: * Get the address of the target
956: * on the stack.
957: */
958: al = argv[1];
959: if (al == NIL)
960: continue;
961: if (al[0] != T_VAR) {
962: error("Arguments to %s must be variables, not expressions", p->symbol);
963: continue;
964: }
965: codeoff();
966: ap = stklval(al, MOD|ASGN|NOUSE);
967: codeon();
968: if (ap == NIL)
969: continue;
970: if (filetype != nl+T1CHAR) {
971: /*
972: * Generalized read, i.e.
973: * from a non-textfile.
974: */
975: if (incompat(filetype, ap, argv[1] )) {
976: error("Type mismatch in read from non-text file");
977: continue;
978: }
979: /*
980: * var := file ^;
981: */
982: ap = lvalue( al , MOD | ASGN | NOUSE , RREQ );
983: if ( isa( ap , "bsci" ) ) {
984: precheck( ap , "_RANG4" , "_RSNG4" );
985: }
986: putleaf( P2ICON , 0 , 0
987: , ADDTYPE(
988: ADDTYPE(
989: ADDTYPE(
990: p2type( filetype ) , P2PTR )
991: , P2FTN )
992: , P2PTR )
993: , "_FNIL" );
994: if (file != NIL)
995: stklval(file, NOFLAGS);
996: else /* Magic */
997: putRV( "_input" , 0 , 0 , NGLOBAL ,
998: P2PTR | P2STRTY );
999: putop(P2CALL, ADDTYPE(p2type(filetype), P2PTR));
1000: switch ( classify( filetype ) ) {
1001: case TBOOL:
1002: case TCHAR:
1003: case TINT:
1004: case TSCAL:
1005: case TDOUBLE:
1006: case TPTR:
1007: putop( P2UNARY P2MUL
1008: , p2type( filetype ) );
1009: }
1010: switch ( classify( filetype ) ) {
1011: case TBOOL:
1012: case TCHAR:
1013: case TINT:
1014: case TSCAL:
1015: postcheck(ap, filetype);
1016: sconv(p2type(filetype), p2type(ap));
1017: /* and fall through */
1018: case TDOUBLE:
1019: case TPTR:
1020: putop( P2ASSIGN , p2type( ap ) );
1021: putdot( filename , line );
1022: break;
1023: default:
1024: putstrop(P2STASG,
1025: ADDTYPE(p2type(ap), P2PTR),
1026: lwidth(ap),
1027: align(ap));
1028: putdot( filename , line );
1029: break;
1030: }
1031: /*
1032: * get(file);
1033: */
1034: putleaf( P2ICON , 0 , 0
1035: , ADDTYPE( P2FTN | P2INT , P2PTR )
1036: , "_GET" );
1037: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
1038: P2PTR|P2STRTY );
1039: putop( P2CALL , P2INT );
1040: putdot( filename , line );
1041: continue;
1042: }
1043: /*
1044: * if you get to here, you are reading from
1045: * a text file. only possiblities are:
1046: * character, integer, real, or scalar.
1047: * read( f , foo , ... ) is done as
1048: * foo := read( f ) with rangechecking
1049: * if appropriate.
1050: */
1051: typ = classify(ap);
1052: op = rdops(typ);
1053: if (op == NIL) {
1054: error("Can't read %ss from a text file", clnames[typ]);
1055: continue;
1056: }
1057: /*
1058: * left hand side of foo := read( f )
1059: */
1060: ap = lvalue( al , MOD|ASGN|NOUSE , RREQ );
1061: if ( isa( ap , "bsci" ) ) {
1062: precheck( ap , "_RANG4" , "_RSNG4" );
1063: }
1064: switch ( op ) {
1065: case O_READC:
1066: readname = "_READC";
1067: readtype = P2INT;
1068: break;
1069: case O_READ4:
1070: readname = "_READ4";
1071: readtype = P2INT;
1072: break;
1073: case O_READ8:
1074: readname = "_READ8";
1075: readtype = P2DOUBLE;
1076: break;
1077: case O_READE:
1078: readname = "_READE";
1079: readtype = P2INT;
1080: break;
1081: }
1082: putleaf( P2ICON , 0 , 0
1083: , ADDTYPE( P2FTN | readtype , P2PTR )
1084: , readname );
1085: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
1086: P2PTR|P2STRTY );
1087: if ( op == O_READE ) {
1088: sprintf( format , PREFIXFORMAT , LABELPREFIX
1089: , listnames( ap ) );
1090: putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR
1091: , format );
1092: putop( P2LISTOP , P2INT );
1093: warning();
1094: if (opt('s')) {
1095: standard();
1096: }
1097: error("Reading scalars from text files is non-standard");
1098: }
1099: putop( P2CALL , readtype );
1100: if ( isa( ap , "bcsi" ) ) {
1101: postcheck(ap, readtype==P2INT?nl+T4INT:nl+TDOUBLE);
1102: }
1103: sconv(readtype, p2type(ap));
1104: putop( P2ASSIGN , p2type( ap ) );
1105: putdot( filename , line );
1106: }
1107: /*
1108: * Done with arguments.
1109: * Handle readln and
1110: * insufficient number of args.
1111: */
1112: if (p->value[0] == O_READLN) {
1113: if (filetype != nl+T1CHAR)
1114: error("Can't 'readln' a non text file");
1115: putleaf( P2ICON , 0 , 0
1116: , ADDTYPE( P2FTN | P2INT , P2PTR )
1117: , "_READLN" );
1118: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL ,
1119: P2PTR|P2STRTY );
1120: putop( P2CALL , P2INT );
1121: putdot( filename , line );
1122: } else if (argc == 0)
1123: error("read requires an argument");
1124: return;
1125:
1126: case O_GET:
1127: case O_PUT:
1128: if (argc != 1) {
1129: error("%s expects one argument", p->symbol);
1130: return;
1131: }
1132: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
1133: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1134: , "_UNIT" );
1135: ap = stklval(argv[1], NOFLAGS);
1136: if (ap == NIL)
1137: return;
1138: if (ap->class != FILET) {
1139: error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
1140: return;
1141: }
1142: putop( P2CALL , P2INT );
1143: putop( P2ASSIGN , P2PTR|P2STRTY );
1144: putdot( filename , line );
1145: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1146: , op == O_GET ? "_GET" : "_PUT" );
1147: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
1148: putop( P2CALL , P2INT );
1149: putdot( filename , line );
1150: return;
1151:
1152: case O_RESET:
1153: case O_REWRITE:
1154: if (argc == 0 || argc > 2) {
1155: error("%s expects one or two arguments", p->symbol);
1156: return;
1157: }
1158: if (opt('s') && argc == 2) {
1159: standard();
1160: error("Two argument forms of reset and rewrite are non-standard");
1161: }
1162: putleaf( P2ICON , 0 , 0 , P2INT
1163: , op == O_RESET ? "_RESET" : "_REWRITE" );
1164: ap = stklval(argv[1], MOD|NOUSE);
1165: if (ap == NIL)
1166: return;
1167: if (ap->class != FILET) {
1168: error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
1169: return;
1170: }
1171: if (argc == 2) {
1172: /*
1173: * Optional second argument
1174: * is a string name of a
1175: * UNIX (R) file to be associated.
1176: */
1177: al = argv[2];
1178: al = stkrval(al[1], NOFLAGS , RREQ );
1179: if (al == NIL)
1180: return;
1181: if (classify(al) != TSTR) {
1182: error("Second argument to %s must be a string, not %s", p->symbol, nameof(al));
1183: return;
1184: }
1185: strnglen = width(al);
1186: } else {
1187: putleaf( P2ICON , 0 , 0 , P2INT , 0 );
1188: strnglen = 0;
1189: }
1190: putop( P2LISTOP , P2INT );
1191: putleaf( P2ICON , strnglen , 0 , P2INT , 0 );
1192: putop( P2LISTOP , P2INT );
1193: putleaf( P2ICON , text(ap) ? 0: width(ap->type) , 0 , P2INT , 0 );
1194: putop( P2LISTOP , P2INT );
1195: putop( P2CALL , P2INT );
1196: putdot( filename , line );
1197: return;
1198:
1199: case O_NEW:
1200: case O_DISPOSE:
1201: if (argc == 0) {
1202: error("%s expects at least one argument", p->symbol);
1203: return;
1204: }
1205: alv = argv[1];
1206: codeoff();
1207: ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD );
1208: codeon();
1209: if (ap == NIL)
1210: return;
1211: if (ap->class != PTR) {
1212: error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap));
1213: return;
1214: }
1215: ap = ap->type;
1216: if (ap == NIL)
1217: return;
1218: if (op == O_NEW)
1219: cmd = "_NEW";
1220: else /* op == O_DISPOSE */
1221: if ((ap->nl_flags & NFILES) != 0)
1222: cmd = "_DFDISPOSE";
1223: else
1224: cmd = "_DISPOSE";
1225: putleaf( P2ICON, 0, 0, ADDTYPE( P2FTN | P2INT , P2PTR ), cmd);
1226: stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD );
1227: argv = argv[2];
1228: if (argv != NIL) {
1229: if (ap->class != RECORD) {
1230: error("Record required when specifying variant tags");
1231: return;
1232: }
1233: for (; argv != NIL; argv = argv[2]) {
1234: if (ap->ptr[NL_VARNT] == NIL) {
1235: error("Too many tag fields");
1236: return;
1237: }
1238: if (!isconst(argv[1])) {
1239: error("Second and successive arguments to %s must be constants", p->symbol);
1240: return;
1241: }
1242: gconst(argv[1]);
1243: if (con.ctype == NIL)
1244: return;
1245: if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , NIL )) {
1246: cerror("Specified tag constant type clashed with variant case selector type");
1247: return;
1248: }
1249: for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain)
1250: if (ap->range[0] == con.crval)
1251: break;
1252: if (ap == NIL) {
1253: error("No variant case label value equals specified constant value");
1254: return;
1255: }
1256: ap = ap->ptr[NL_VTOREC];
1257: }
1258: }
1259: putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 );
1260: putop( P2LISTOP , P2INT );
1261: putop( P2CALL , P2INT );
1262: putdot( filename , line );
1263: if (opt('t') && op == O_NEW) {
1264: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1265: , "_blkclr" );
1266: stkrval(alv, NIL , RREQ );
1267: putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 );
1268: putop( P2LISTOP , P2INT );
1269: putop( P2CALL , P2INT );
1270: putdot( filename , line );
1271: }
1272: return;
1273:
1274: case O_DATE:
1275: case O_TIME:
1276: if (argc != 1) {
1277: error("%s expects one argument", p->symbol);
1278: return;
1279: }
1280: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1281: , op == O_DATE ? "_DATE" : "_TIME" );
1282: ap = stklval(argv[1], MOD|NOUSE);
1283: if (ap == NIL)
1284: return;
1285: if (classify(ap) != TSTR || width(ap) != 10) {
1286: error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
1287: return;
1288: }
1289: putop( P2CALL , P2INT );
1290: putdot( filename , line );
1291: return;
1292:
1293: case O_HALT:
1294: if (argc != 0) {
1295: error("halt takes no arguments");
1296: return;
1297: }
1298: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1299: , "_HALT" );
1300:
1301: putop( P2UNARY P2CALL , P2INT );
1302: putdot( filename , line );
1303: noreach = 1;
1304: return;
1305:
1306: case O_ARGV:
1307: if (argc != 2) {
1308: error("argv takes two arguments");
1309: return;
1310: }
1311: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1312: , "_ARGV" );
1313: ap = stkrval(argv[1], NIL , RREQ );
1314: if (ap == NIL)
1315: return;
1316: if (isnta(ap, "i")) {
1317: error("argv's first argument must be an integer, not %s", nameof(ap));
1318: return;
1319: }
1320: al = argv[2];
1321: ap = stklval(al[1], MOD|NOUSE);
1322: if (ap == NIL)
1323: return;
1324: if (classify(ap) != TSTR) {
1325: error("argv's second argument must be a string, not %s", nameof(ap));
1326: return;
1327: }
1328: putop( P2LISTOP , P2INT );
1329: putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 );
1330: putop( P2LISTOP , P2INT );
1331: putop( P2CALL , P2INT );
1332: putdot( filename , line );
1333: return;
1334:
1335: case O_STLIM:
1336: if (argc != 1) {
1337: error("stlimit requires one argument");
1338: return;
1339: }
1340: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1341: , "_STLIM" );
1342: ap = stkrval(argv[1], NIL , RREQ );
1343: if (ap == NIL)
1344: return;
1345: if (isnta(ap, "i")) {
1346: error("stlimit's argument must be an integer, not %s", nameof(ap));
1347: return;
1348: }
1349: putop( P2CALL , P2INT );
1350: putdot( filename , line );
1351: return;
1352:
1353: case O_REMOVE:
1354: if (argc != 1) {
1355: error("remove expects one argument");
1356: return;
1357: }
1358: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1359: , "_REMOVE" );
1360: ap = stkrval(argv[1], NOFLAGS , RREQ );
1361: if (ap == NIL)
1362: return;
1363: if (classify(ap) != TSTR) {
1364: error("remove's argument must be a string, not %s", nameof(ap));
1365: return;
1366: }
1367: putleaf( P2ICON , width( ap ) , 0 , P2INT , 0 );
1368: putop( P2LISTOP , P2INT );
1369: putop( P2CALL , P2INT );
1370: putdot( filename , line );
1371: return;
1372:
1373: case O_LLIMIT:
1374: if (argc != 2) {
1375: error("linelimit expects two arguments");
1376: return;
1377: }
1378: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1379: , "_LLIMIT" );
1380: ap = stklval(argv[1], NOFLAGS|NOUSE);
1381: if (ap == NIL)
1382: return;
1383: if (!text(ap)) {
1384: error("linelimit's first argument must be a text file, not %s", nameof(ap));
1385: return;
1386: }
1387: al = argv[2];
1388: ap = stkrval(al[1], NIL , RREQ );
1389: if (ap == NIL)
1390: return;
1391: if (isnta(ap, "i")) {
1392: error("linelimit's second argument must be an integer, not %s", nameof(ap));
1393: return;
1394: }
1395: putop( P2LISTOP , P2INT );
1396: putop( P2CALL , P2INT );
1397: putdot( filename , line );
1398: return;
1399: case O_PAGE:
1400: if (argc != 1) {
1401: error("page expects one argument");
1402: return;
1403: }
1404: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
1405: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1406: , "_UNIT" );
1407: ap = stklval(argv[1], NOFLAGS);
1408: if (ap == NIL)
1409: return;
1410: if (!text(ap)) {
1411: error("Argument to page must be a text file, not %s", nameof(ap));
1412: return;
1413: }
1414: putop( P2CALL , P2INT );
1415: putop( P2ASSIGN , P2PTR|P2STRTY );
1416: putdot( filename , line );
1417: if ( opt( 't' ) ) {
1418: putleaf( P2ICON , 0 , 0
1419: , ADDTYPE( P2FTN | P2INT , P2PTR )
1420: , "_PAGE" );
1421: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
1422: } else {
1423: putleaf( P2ICON , 0 , 0
1424: , ADDTYPE( P2FTN | P2INT , P2PTR )
1425: , "_fputc" );
1426: putleaf( P2ICON , '\f' , 0 , P2CHAR , 0 );
1427: putleaf( P2ICON , 0 , 0
1428: , ADDTYPE( P2FTN | P2INT , P2PTR )
1429: , "_ACTFILE" );
1430: putRV( 0 , cbn , CURFILEOFFSET , NLOCAL , P2PTR|P2STRTY );
1431: putop( P2CALL , P2INT );
1432: putop( P2LISTOP , P2INT );
1433: }
1434: putop( P2CALL , P2INT );
1435: putdot( filename , line );
1436: return;
1437:
1438: case O_ASRT:
1439: if (!opt('t'))
1440: return;
1441: if (argc == 0 || argc > 2) {
1442: error("Assert expects one or two arguments");
1443: return;
1444: }
1445: if (argc == 2)
1446: cmd = "_ASRTS";
1447: else
1448: cmd = "_ASRT";
1449: putleaf( P2ICON , 0 , 0
1450: , ADDTYPE( P2FTN | P2INT , P2PTR ) , cmd );
1451: ap = stkrval(argv[1], NIL , RREQ );
1452: if (ap == NIL)
1453: return;
1454: if (isnta(ap, "b"))
1455: error("Assert expression must be Boolean, not %ss", nameof(ap));
1456: if (argc == 2) {
1457: /*
1458: * Optional second argument is a string specifying
1459: * why the assertion failed.
1460: */
1461: al = argv[2];
1462: al = stkrval(al[1], NIL , RREQ );
1463: if (al == NIL)
1464: return;
1465: if (classify(al) != TSTR) {
1466: error("Second argument to assert must be a string, not %s", nameof(al));
1467: return;
1468: }
1469: putop( P2LISTOP , P2INT );
1470: }
1471: putop( P2CALL , P2INT );
1472: putdot( filename , line );
1473: return;
1474:
1475: case O_PACK:
1476: if (argc != 3) {
1477: error("pack expects three arguments");
1478: return;
1479: }
1480: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1481: , "_PACK" );
1482: pu = "pack(a,i,z)";
1483: pua = (al = argv)[1];
1484: pui = (al = al[2])[1];
1485: puz = (al = al[2])[1];
1486: goto packunp;
1487: case O_UNPACK:
1488: if (argc != 3) {
1489: error("unpack expects three arguments");
1490: return;
1491: }
1492: putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
1493: , "_UNPACK" );
1494: pu = "unpack(z,a,i)";
1495: puz = (al = argv)[1];
1496: pua = (al = al[2])[1];
1497: pui = (al = al[2])[1];
1498: packunp:
1499: ap = stkrval((int *) pui, NLNIL , RREQ );
1500: if (ap == NIL)
1501: return;
1502: ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
1503: if (ap == NIL)
1504: return;
1505: if (ap->class != ARRAY) {
1506: error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
1507: return;
1508: }
1509: putop( P2LISTOP , P2INT );
1510: al = (struct nl *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
1511: if (al->class != ARRAY) {
1512: error("%s requires z to be a packed array, not %s", pu, nameof(ap));
1513: return;
1514: }
1515: if (al->type == NIL || ap->type == NIL)
1516: return;
1517: if (al->type != ap->type) {
1518: error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
1519: return;
1520: }
1521: putop( P2LISTOP , P2INT );
1522: k = width(al);
1523: itemwidth = width(ap->type);
1524: ap = ap->chain;
1525: al = al->chain;
1526: if (ap->chain != NIL || al->chain != NIL) {
1527: error("%s requires a and z to be single dimension arrays", pu);
1528: return;
1529: }
1530: if (ap == NIL || al == NIL)
1531: return;
1532: /*
1533: * al is the range for z i.e. u..v
1534: * ap is the range for a i.e. m..n
1535: * i will be n-m+1
1536: * j will be v-u+1
1537: */
1538: i = ap->range[1] - ap->range[0] + 1;
1539: j = al->range[1] - al->range[0] + 1;
1540: if (i < j) {
1541: error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i);
1542: return;
1543: }
1544: /*
1545: * get n-m-(v-u) and m for the interpreter
1546: */
1547: i -= j;
1548: j = ap->range[0];
1549: putleaf( P2ICON , itemwidth , 0 , P2INT , 0 );
1550: putop( P2LISTOP , P2INT );
1551: putleaf( P2ICON , j , 0 , P2INT , 0 );
1552: putop( P2LISTOP , P2INT );
1553: putleaf( P2ICON , i , 0 , P2INT , 0 );
1554: putop( P2LISTOP , P2INT );
1555: putleaf( P2ICON , k , 0 , P2INT , 0 );
1556: putop( P2LISTOP , P2INT );
1557: putop( P2CALL , P2INT );
1558: putdot( filename , line );
1559: return;
1560: case 0:
1561: error("%s is an unimplemented extension", p->symbol);
1562: return;
1563:
1564: default:
1565: panic("proc case");
1566: }
1567: }
1568: #endif PC
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.