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