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