![[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] / 43BSDReno / pgrm / pascal / src|
Return to nl.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / 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[] = "@(#)nl.c 5.1 (Berkeley) 6/5/85";
9: #endif not lint
10:
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: */
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 *
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 *
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 *
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 *
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
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.