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