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