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