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