1 /*-
2 * Copyright (c) 1980, 1993
3 * The Regents of the University of California. All rights reserved.
4 *
5 * %sccs.include.redist.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)nl.c 8.1 (Berkeley) 06/06/93";
10 #endif /* not lint */
11
12 #include "whoami.h"
13 #include "0.h"
14 #ifdef PI
15 #include "opcode.h"
16 #include "objfmt.h"
17
18 /*
19 * NAMELIST SEGMENT DEFINITIONS
20 */
21 struct nls {
22 struct nl *nls_low;
23 struct nl *nls_high;
24 } ntab[MAXNL], *nlact;
25
26 struct nl nl[INL];
27 struct nl *nlp = nl;
28 struct nls *nlact = ntab;
29
30 /*
31 * all these strings must be places where people can find them
32 * since lookup only looks at the string pointer, not the chars.
33 * see, for example, pTreeInit.
34 */
35
36 /*
37 * built in constants
38 */
39 char *in_consts[] = {
40 "true" ,
41 "false" ,
42 "TRUE",
43 "FALSE",
44 "minint" ,
45 "maxint" ,
46 "minchar" ,
47 "maxchar" ,
48 "bell" ,
49 "tab" ,
50 0
51 };
52
53 /*
54 * built in simple types
55 */
56 char *in_types[] =
57 {
58 "boolean",
59 "char",
60 "integer",
61 "real",
62 "_nil", /* dummy name */
63 0
64 };
65
66 int in_rclasses[] =
67 {
68 TINT ,
69 TINT ,
70 TINT ,
71 TCHAR ,
72 TBOOL ,
73 TDOUBLE ,
74 0
75 };
76
77 long in_ranges[] =
78 {
79 -128L , 127L ,
80 -32768L , 32767L ,
81 -2147483648L , 2147483647L ,
82 0L , 127L ,
83 0L , 1L ,
84 0L , 0L /* fake for reals */
85 };
86
87 /*
88 * built in constructed types
89 */
90 char *in_ctypes[] = {
91 "Boolean" ,
92 "intset" ,
93 "alfa" ,
94 "text" ,
95 0
96 };
97
98 /*
99 * built in variables
100 */
101 char *in_vars[] = {
102 "input" ,
103 "output" ,
104 0
105 };
106
107 /*
108 * built in functions
109 */
110 char *in_funcs[] =
111 {
112 "abs" ,
113 "arctan" ,
114 "card" ,
115 "chr" ,
116 "clock" ,
117 "cos" ,
118 "eof" ,
119 "eoln" ,
120 "eos" ,
121 "exp" ,
122 "expo" ,
123 "ln" ,
124 "odd" ,
125 "ord" ,
126 "pred" ,
127 "round" ,
128 "sin" ,
129 "sqr" ,
130 "sqrt" ,
131 "succ" ,
132 "trunc" ,
133 "undefined" ,
134 /*
135 * Extensions
136 */
137 "argc" ,
138 "random" ,
139 "seed" ,
140 "wallclock" ,
141 "sysclock" ,
142 0
143 };
144
145 /*
146 * Built-in procedures
147 */
148 char *in_procs[] =
149 {
150 "assert",
151 "date" ,
152 "dispose" ,
153 "flush" ,
154 "get" ,
155 "getseg" ,
156 "halt" ,
157 "linelimit" ,
158 "message" ,
159 "new" ,
160 "pack" ,
161 "page" ,
162 "put" ,
163 "putseg" ,
164 "read" ,
165 "readln" ,
166 "remove" ,
167 "reset" ,
168 "rewrite" ,
169 "time" ,
170 "unpack" ,
171 "write" ,
172 "writeln" ,
173 /*
174 * Extensions
175 */
176 "argv" ,
177 "null" ,
178 "stlimit" ,
179 0
180 };
181
182 #ifndef PI0
183 /*
184 * and their opcodes
185 */
186 int in_fops[] =
187 {
188 O_ABS2,
189 O_ATAN,
190 O_CARD|NSTAND,
191 O_CHR2,
192 O_CLCK|NSTAND,
193 O_COS,
194 O_EOF,
195 O_EOLN,
196 0,
197 O_EXP,
198 O_EXPO|NSTAND,
199 O_LN,
200 O_ODD2,
201 O_ORD2,
202 O_PRED2,
203 O_ROUND,
204 O_SIN,
205 O_SQR2,
206 O_SQRT,
207 O_SUCC2,
208 O_TRUNC,
209 O_UNDEF|NSTAND,
210 /*
211 * Extensions
212 */
213 O_ARGC|NSTAND,
214 O_RANDOM|NSTAND,
215 O_SEED|NSTAND,
216 O_WCLCK|NSTAND,
217 O_SCLCK|NSTAND
218 };
219
220 /*
221 * Built-in procedures
222 */
223 int in_pops[] =
224 {
225 O_ASRT|NSTAND,
226 O_DATE|NSTAND,
227 O_DISPOSE,
228 O_FLUSH|NSTAND,
229 O_GET,
230 0,
231 O_HALT|NSTAND,
232 O_LLIMIT|NSTAND,
233 O_MESSAGE|NSTAND,
234 O_NEW,
235 O_PACK,
236 O_PAGE,
237 O_PUT,
238 0,
239 O_READ4,
240 O_READLN,
241 O_REMOVE|NSTAND,
242 O_RESET,
243 O_REWRITE,
244 O_TIME|NSTAND,
245 O_UNPACK,
246 O_WRITEF,
247 O_WRITLN,
248 /*
249 * Extensions
250 */
251 O_ARGV|NSTAND,
252 O_ABORT|NSTAND,
253 O_STLIM|NSTAND
254 };
255 #endif
256
257 /*
258 * Initnl initializes the first namelist segment and then
259 * initializes the name list for block 0.
260 */
initnl()261 initnl()
262 {
263 register char **cp;
264 register struct nl *np;
265 struct nl *fp;
266 int *ip;
267 long *lp;
268
269 #ifdef DEBUG
270 if ( hp21mx )
271 {
272 MININT = -32768.;
273 MAXINT = 32767.;
274 #ifndef PI0
275 #ifdef OBJ
276 genmx();
277 #endif OBJ
278 #endif
279 }
280 #endif
281 ntab[0].nls_low = nl;
282 ntab[0].nls_high = &nl[INL];
283 (void) defnl ( (char *) 0 , 0 , NLNIL , 0 );
284
285 /*
286 * Types
287 */
288 for ( cp = in_types ; *cp != 0 ; cp ++ )
289 (void) hdefnl ( *cp , TYPE , nlp , 0 );
290
291 /*
292 * Ranges
293 */
294 lp = in_ranges;
295 for ( ip = in_rclasses ; *ip != 0 ; ip ++ )
296 {
297 np = defnl ( (char *) 0 , RANGE , nl+(*ip) , 0 );
298 nl[*ip].type = np;
299 np -> range[0] = *lp ++ ;
300 np -> range[1] = *lp ++ ;
301
302 };
303
304 /*
305 * built in constructed types
306 */
307
308 cp = in_ctypes;
309 /*
310 * Boolean = boolean;
311 */
312 (void) hdefnl ( *cp++ , TYPE , (struct nl *) (nl+T1BOOL) , 0 );
313
314 /*
315 * intset = set of 0 .. 127;
316 */
317 intset = ((struct nl *) *cp++);
318 (void) hdefnl( (char *) intset , TYPE , nlp+1 , 0 );
319 (void) defnl ( (char *) 0 , SET , nlp+1 , 0 );
320 np = defnl ( (char *) 0 , RANGE , nl+TINT , 0 );
321 np -> range[0] = 0L;
322 np -> range[1] = 127L;
323
324 /*
325 * alfa = array [ 1 .. 10 ] of char;
326 */
327 np = defnl ( (char *) 0 , RANGE , nl+TINT , 0 );
328 np -> range[0] = 1L;
329 np -> range[1] = 10L;
330 defnl ( (char *) 0 , ARRAY , nl+T1CHAR , 1 ) -> chain = np;
331 (void) hdefnl ( *cp++ , TYPE , nlp-1 , 0 );
332
333 /*
334 * text = file of char;
335 */
336 (void) hdefnl ( *cp++ , TYPE , nlp+1 , 0 );
337 np = defnl ( (char *) 0 , FILET , nl+T1CHAR , 0 );
338 np -> nl_flags |= NFILES;
339
340 /*
341 * input,output : text;
342 */
343 cp = in_vars;
344 # ifndef PI0
345 input = hdefnl ( *cp++ , VAR , np , INPUT_OFF );
346 output = hdefnl ( *cp++ , VAR , np , OUTPUT_OFF );
347 # else
348 input = hdefnl ( *cp++ , VAR , np , 0 );
349 output = hdefnl ( *cp++ , VAR , np , 0 );
350 # endif
351 # ifdef PC
352 input -> extra_flags |= NGLOBAL;
353 output -> extra_flags |= NGLOBAL;
354 # endif PC
355
356 /*
357 * built in constants
358 */
359 cp = in_consts;
360 np = hdefnl ( *cp++ , CONST , nl + TBOOL , 1 );
361 fp = hdefnl ( *cp++ , CONST , nl + TBOOL , 0 );
362 (nl + TBOOL)->chain = fp;
363 fp->chain = np;
364 np = hdefnl ( *cp++ , CONST , nl + TBOOL , 1 );
365 fp = hdefnl ( *cp++ , CONST , nl + TBOOL , 0 );
366 fp->chain = np;
367 if (opt('s'))
368 (nl + TBOOL)->chain = fp;
369 hdefnl ( *cp++ , CONST , nl + T4INT , 0 ) -> range[0] = MININT;
370 hdefnl ( *cp++ , CONST , nl + T4INT , 0 ) -> range[0] = MAXINT;
371 (void) hdefnl ( *cp++ , CONST , nl + T1CHAR , 0 );
372 (void) hdefnl ( *cp++ , CONST , nl + T1CHAR , 127 );
373 (void) hdefnl ( *cp++ , CONST , nl + T1CHAR , '\007' );
374 (void) hdefnl ( *cp++ , CONST , nl + T1CHAR , '\t' );
375
376 /*
377 * Built-in functions and procedures
378 */
379 #ifndef PI0
380 ip = in_fops;
381 for ( cp = in_funcs ; *cp != 0 ; cp ++ )
382 (void) hdefnl ( *cp , FUNC , NLNIL , * ip ++ );
383 ip = in_pops;
384 for ( cp = in_procs ; *cp != 0 ; cp ++ )
385 (void) hdefnl ( *cp , PROC , NLNIL , * ip ++ );
386 #else
387 for ( cp = in_funcs ; *cp != 0 ; cp ++ )
388 (void) hdefnl ( *cp , FUNC , NLNIL , 0 );
389 for ( cp = in_procs ; *cp != 0 , cp ++ )
390 (void) hdefnl ( *cp , PROC , NLNIL , 0 );
391 #endif
392 # ifdef PTREE
393 pTreeInit();
394 # endif
395 }
396
397 struct nl *
hdefnl(sym,cls,typ,val)398 hdefnl(sym, cls, typ, val)
399 char *sym;
400 int cls;
401 struct nl *typ;
402 int val;
403 {
404 register struct nl *p;
405
406 #ifndef PI1
407 if (sym)
408 (void) hash(sym, 0);
409 #endif
410 p = defnl(sym, cls, typ, val);
411 if (sym)
412 (void) enter(p);
413 return (p);
414 }
415
416 /*
417 * Free up the name list segments
418 * at the end of a statement/proc/func
419 * All segments are freed down to the one in which
420 * p points.
421 */
422 nlfree(p)
423 struct nl *p;
424 {
425
426 nlp = p;
427 while (nlact->nls_low > nlp || nlact->nls_high < nlp) {
428 free((char *) nlact->nls_low);
429 nlact->nls_low = NIL;
430 nlact->nls_high = NIL;
431 --nlact;
432 if (nlact < &ntab[0])
433 panic("nlfree");
434 }
435 }
436 #endif PI
437
438
439 #ifndef PC
440 #ifndef OBJ
441 char *VARIABLE = "variable";
442 #endif PC
443 #endif OBJ
444
445 char *classes[ ] = {
446 "undefined",
447 "constant",
448 "type",
449 "variable", /* VARIABLE */
450 "array",
451 "pointer or file",
452 "record",
453 "field",
454 "procedure",
455 "function",
456 "variable", /* VARIABLE */
457 "variable", /* VARIABLE */
458 "pointer",
459 "file",
460 "set",
461 "subrange",
462 "label",
463 "withptr",
464 "scalar",
465 "string",
466 "program",
467 "improper",
468 "variant",
469 "formal procedure",
470 "formal function"
471 };
472
473 #ifndef PC
474 #ifndef OBJ
475 char *snark = "SNARK";
476 #endif
477 #endif
478
479 #ifdef PI
480 #ifdef DEBUG
481 char *ctext[] =
482 {
483 "BADUSE",
484 "CONST",
485 "TYPE",
486 "VAR",
487 "ARRAY",
488 "PTRFILE",
489 "RECORD",
490 "FIELD",
491 "PROC",
492 "FUNC",
493 "FVAR",
494 "REF",
495 "PTR",
496 "FILET",
497 "SET",
498 "RANGE",
499 "LABEL",
500 "WITHPTR",
501 "SCAL",
502 "STR",
503 "PROG",
504 "IMPROPER",
505 "VARNT",
506 "FPROC",
507 "FFUNC",
508 "CRANGE"
509 };
510
511 char *stars = "\t***";
512
513 /*
514 * Dump the namelist from the
515 * current nlp down to 'to'.
516 * All the namelist is dumped if
517 * to is NIL.
518 */
519 /*VARARGS*/
520 dumpnl(to, rout)
521 struct nl *to;
522 {
523 register struct nl *p;
524 struct nls *nlsp;
525 int v, head;
526
527 if (opt('y') == 0)
528 return;
529 if (to != NIL)
530 printf("\n\"%s\" Block=%d\n", rout, cbn);
531 nlsp = nlact;
532 head = NIL;
533 for (p = nlp; p != to;) {
534 if (p == nlsp->nls_low) {
535 if (nlsp == &ntab[0])
536 break;
537 nlsp--;
538 p = nlsp->nls_high;
539 }
540 p--;
541 if (head == NIL) {
542 printf("\tName\tClass Bn+Flags\tType\tVal\tChn\n");
543 head++;
544 }
545 printf("%3d:", nloff(p));
546 if (p->symbol)
547 printf("\t%.7s", p->symbol);
548 else
549 printf(stars);
550 if (p->class)
551 printf("\t%s", ctext[p->class]);
552 else
553 printf(stars);
554 if (p->nl_flags) {
555 pchr('\t');
556 if (p->nl_flags & 037)
557 printf("%d ", p->nl_flags & 037);
558 #ifndef PI0
559 if (p->nl_flags & NMOD)
560 pchr('M');
561 if (p->nl_flags & NUSED)
562 pchr('U');
563 #endif
564 if (p->nl_flags & NFILES)
565 pchr('F');
566 } else
567 printf(stars);
568 if (p->type)
569 printf("\t[%d]", nloff(p->type));
570 else
571 printf(stars);
572 v = p->value[0];
573 switch (p->class) {
574 case TYPE:
575 break;
576 case VARNT:
577 goto con;
578 case CONST:
579 switch (nloff(p->type)) {
580 default:
581 printf("\t%d", v);
582 break;
583 case TDOUBLE:
584 printf("\t%f", p->real);
585 break;
586 case TINT:
587 case T4INT:
588 con:
589 printf("\t%ld", p->range[0]);
590 break;
591 case TSTR:
592 printf("\t'%s'", p->ptr[0]);
593 break;
594 }
595 break;
596 case VAR:
597 case REF:
598 case WITHPTR:
599 case FFUNC:
600 case FPROC:
601 printf("\t%d,%d", cbn, v);
602 break;
603 case SCAL:
604 case RANGE:
605 printf("\t%ld..%ld", p->range[0], p->range[1]);
606 break;
607 case CRANGE:
608 printf("\t%s..%s", p->nptr[0]->symbol,
609 p->nptr[1]->symbol);
610 break;
611 case RECORD:
612 printf("\t%d", v);
613 break;
614 case FIELD:
615 printf("\t%d", v);
616 break;
617 case STR:
618 printf("\t|%d|", p->value[0]);
619 break;
620 case FVAR:
621 case FUNC:
622 case PROC:
623 case PROG:
624 if (cbn == 0) {
625 printf("\t<%o>", p->value[0] & 0377);
626 #ifndef PI0
627 if (p->value[0] & NSTAND)
628 printf("\tNSTAND");
629 #endif
630 break;
631 }
632 v = p->value[1];
633 default:
634
635 if (v)
636 printf("\t<%d>", v);
637 else
638 printf(stars);
639 }
640 if (p->chain)
641 printf("\t[%d]", nloff(p->chain));
642 switch (p->class) {
643 case RECORD:
644 printf("\tALIGN=%d", p->align_info);
645 if (p->ptr[NL_FIELDLIST]) {
646 printf(" FLIST=[%d]",
647 nloff(p->ptr[NL_FIELDLIST]));
648 } else {
649 printf(" FLIST=[]");
650 }
651 if (p->ptr[NL_TAG]) {
652 printf(" TAG=[%d]",
653 nloff(p->ptr[NL_TAG]));
654 } else {
655 printf(" TAG=[]");
656 }
657 if (p->ptr[NL_VARNT]) {
658 printf(" VARNT=[%d]",
659 nloff(p->ptr[NL_VARNT]));
660 } else {
661 printf(" VARNT=[]");
662 }
663 break;
664 case FIELD:
665 if (p->ptr[NL_FIELDLIST]) {
666 printf("\tFLIST=[%d]",
667 nloff(p->ptr[NL_FIELDLIST]));
668 } else {
669 printf("\tFLIST=[]");
670 }
671 break;
672 case VARNT:
673 printf("\tVTOREC=[%d]",
674 nloff(p->ptr[NL_VTOREC]));
675 break;
676 }
677 # ifdef PC
678 if ( p -> extra_flags != 0 ) {
679 pchr( '\t' );
680 if ( p -> extra_flags & NEXTERN )
681 printf( "NEXTERN " );
682 if ( p -> extra_flags & NLOCAL )
683 printf( "NLOCAL " );
684 if ( p -> extra_flags & NPARAM )
685 printf( "NPARAM " );
686 if ( p -> extra_flags & NGLOBAL )
687 printf( "NGLOBAL " );
688 if ( p -> extra_flags & NREGVAR )
689 printf( "NREGVAR " );
690 }
691 # endif PC
692 # ifdef PTREE
693 pchr( '\t' );
694 pPrintPointer( stdout , "%s" , p -> inTree );
695 # endif
696 pchr('\n');
697 }
698 if (head == 0)
699 printf("\tNo entries\n");
700 }
701 #endif
702
703
704 /*
705 * Define a new name list entry
706 * with initial symbol, class, type
707 * and value[0] as given. A new name
708 * list segment is allocated to hold
709 * the next name list slot if necessary.
710 */
711 struct nl *
defnl(sym,cls,typ,val)712 defnl(sym, cls, typ, val)
713 char *sym;
714 int cls;
715 struct nl *typ;
716 int val;
717 {
718 register struct nl *p;
719 register int *q, i;
720 char *cp;
721
722 p = nlp;
723
724 /*
725 * Zero out this entry
726 */
727 q = ((int *) p);
728 i = (sizeof *p)/(sizeof (int));
729 do
730 *q++ = 0;
731 while (--i);
732
733 /*
734 * Insert the values
735 */
736 p->symbol = sym;
737 p->class = cls;
738 p->type = typ;
739 p->nl_block = cbn;
740 p->value[0] = val;
741
742 /*
743 * Insure that the next namelist
744 * entry actually exists. This is
745 * really not needed here, it would
746 * suffice to do it at entry if we
747 * need the slot. It is done this
748 * way because, historically, nlp
749 * always pointed at the next namelist
750 * slot.
751 */
752 nlp++;
753 if (nlp >= nlact->nls_high) {
754 i = NLINC;
755 cp = (char *) malloc(NLINC * sizeof *nlp);
756 if (cp == 0) {
757 i = NLINC / 2;
758 cp = (char *) malloc((NLINC / 2) * sizeof *nlp);
759 }
760 if (cp == 0) {
761 error("Ran out of memory (defnl)");
762 pexit(DIED);
763 }
764 nlact++;
765 if (nlact >= &ntab[MAXNL]) {
766 error("Ran out of name list tables");
767 pexit(DIED);
768 }
769 nlp = (struct nl *) cp;
770 nlact->nls_low = nlp;
771 nlact->nls_high = nlact->nls_low + i;
772 }
773 return (p);
774 }
775
776 /*
777 * Make a duplicate of the argument
778 * namelist entry for, e.g., type
779 * declarations of the form 'type a = b'
780 * and array indicies.
781 */
782 struct nl *
nlcopy(p)783 nlcopy(p)
784 struct nl *p;
785 {
786 register struct nl *p1, *p2;
787
788 p1 = p;
789 p2 = defnl((char *) 0, 0, NLNIL, 0);
790 *p2 = *p1;
791 p2->chain = NLNIL;
792 return (p2);
793 }
794
795 /*
796 * Compute a namelist offset
797 */
798 nloff(p)
799 struct nl *p;
800 {
801
802 return (p - nl);
803 }
804
805 /*
806 * Enter a symbol into the block
807 * symbol table. Symbols are hashed
808 * 64 ways based on low 6 bits of the
809 * character pointer into the string
810 * table.
811 */
812 struct nl *
enter(np)813 enter(np)
814 struct nl *np;
815 {
816 register struct nl *rp, *hp;
817 register struct nl *p;
818 int i;
819
820 rp = np;
821 if (rp == NIL)
822 return (NIL);
823 #ifndef PI1
824 if (cbn > 0)
825 if (rp->symbol == input->symbol || rp->symbol == output->symbol)
826 error("Pre-defined files input and output must not be redefined");
827 #endif
828 i = (int) rp->symbol;
829 i &= 077;
830 hp = disptab[i];
831 if (rp->class != BADUSE && rp->class != FIELD)
832 for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next)
833 if (p->symbol == rp->symbol && p->symbol != NIL &&
834 p->class != BADUSE && p->class != FIELD) {
835 #ifndef PI1
836 error("%s is already defined in this block", rp->symbol);
837 #endif
838 break;
839
840 }
841 rp->nl_next = hp;
842 disptab[i] = rp;
843 return (rp);
844 }
845 #endif
846