![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pascal.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / dbx|
Return to pascal.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / dbx |
1.1 root 1: /*
2: * Copyright (c) 1983 The Regents of the University of California.
3: * All rights reserved.
4: *
5: * Redistribution and use in source and binary forms are permitted
6: * provided that: (1) source distributions retain this entire copyright
7: * notice and comment, and (2) distributions including binaries display
8: * the following acknowledgement: ``This product includes software
9: * developed by the University of California, Berkeley and its contributors''
10: * in the documentation or other materials provided with the distribution
11: * and in all advertising materials mentioning features or use of this
12: * software. Neither the name of the University nor the names of its
13: * contributors may be used to endorse or promote products derived
14: * from this software without specific prior written permission.
15: * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
16: * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
17: * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
18: */
19:
20: #ifndef lint
21: static char sccsid[] = "@(#)pascal.c 5.3 (Berkeley) 6/1/90";
22: #endif /* not lint */
23:
24: /*
25: * Pascal-dependent symbol routines.
26: */
27:
28: #include "defs.h"
29: #include "symbols.h"
30: #include "pascal.h"
31: #include "languages.h"
32: #include "tree.h"
33: #include "eval.h"
34: #include "mappings.h"
35: #include "process.h"
36: #include "runtime.h"
37: #include "machine.h"
38:
39: #ifndef public
40: #endif
41:
42: private Language pasc;
43: private boolean initialized;
44:
45: /*
46: * Initialize Pascal information.
47: */
48:
49: public pascal_init()
50: {
51: pasc = language_define("pascal", ".p");
52: language_setop(pasc, L_PRINTDECL, pascal_printdecl);
53: language_setop(pasc, L_PRINTVAL, pascal_printval);
54: language_setop(pasc, L_TYPEMATCH, pascal_typematch);
55: language_setop(pasc, L_BUILDAREF, pascal_buildaref);
56: language_setop(pasc, L_EVALAREF, pascal_evalaref);
57: language_setop(pasc, L_MODINIT, pascal_modinit);
58: language_setop(pasc, L_HASMODULES, pascal_hasmodules);
59: language_setop(pasc, L_PASSADDR, pascal_passaddr);
60: initialized = false;
61: }
62:
63: /*
64: * Typematch tests if two types are compatible. The issue
65: * is a bit complicated, so several subfunctions are used for
66: * various kinds of compatibility.
67: */
68:
69: private boolean builtinmatch (t1, t2)
70: register Symbol t1, t2;
71: {
72: boolean b;
73:
74: b = (boolean) (
75: (
76: t2 == t_int->type and
77: t1->class == RANGE and istypename(t1->type, "integer")
78: ) or (
79: t2 == t_char->type and
80: t1->class == RANGE and istypename(t1->type, "char")
81: ) or (
82: t2 == t_real->type and
83: t1->class == RANGE and istypename(t1->type, "real")
84: ) or (
85: t2 == t_boolean->type and
86: t1->class == RANGE and istypename(t1->type, "boolean")
87: )
88: );
89: return b;
90: }
91:
92: private boolean rangematch (t1, t2)
93: register Symbol t1, t2;
94: {
95: boolean b;
96: register Symbol rt1, rt2;
97:
98: if (t1->class == RANGE and t2->class == RANGE) {
99: rt1 = rtype(t1->type);
100: rt2 = rtype(t2->type);
101: b = (boolean) (rt1->type == rt2->type);
102: } else {
103: b = false;
104: }
105: return b;
106: }
107:
108: private boolean nilMatch (t1, t2)
109: register Symbol t1, t2;
110: {
111: boolean b;
112:
113: b = (boolean) (
114: (t1 == t_nil and t2->class == PTR) or
115: (t1->class == PTR and t2 == t_nil)
116: );
117: return b;
118: }
119:
120: private boolean enumMatch (t1, t2)
121: register Symbol t1, t2;
122: {
123: boolean b;
124:
125: b = (boolean) (
126: (t1->class == SCAL and t2->class == CONST and t2->type == t1) or
127: (t1->class == CONST and t2->class == SCAL and t1->type == t2)
128: );
129: return b;
130: }
131:
132: private boolean isConstString (t)
133: register Symbol t;
134: {
135: boolean b;
136:
137: b = (boolean) (
138: t->language == primlang and t->class == ARRAY and t->type == t_char
139: );
140: return b;
141: }
142:
143: private boolean stringArrayMatch (t1, t2)
144: register Symbol t1, t2;
145: {
146: boolean b;
147:
148: b = (boolean) (
149: (
150: isConstString(t1) and
151: t2->class == ARRAY and compatible(t2->type, t_char->type)
152: ) or (
153: isConstString(t2) and
154: t1->class == ARRAY and compatible(t1->type, t_char->type)
155: )
156: );
157: return b;
158: }
159:
160: public boolean pascal_typematch (type1, type2)
161: Symbol type1, type2;
162: {
163: boolean b;
164: Symbol t1, t2, tmp;
165:
166: t1 = rtype(type1);
167: t2 = rtype(type2);
168: if (t1 == t2) {
169: b = true;
170: } else {
171: if (t1 == t_char->type or t1 == t_int->type or
172: t1 == t_real->type or t1 == t_boolean->type
173: ) {
174: tmp = t1;
175: t1 = t2;
176: t2 = tmp;
177: }
178: b = (Boolean) (
179: builtinmatch(t1, t2) or rangematch(t1, t2) or
180: nilMatch(t1, t2) or enumMatch(t1, t2) or
181: stringArrayMatch(t1, t2)
182: );
183: }
184: return b;
185: }
186:
187: /*
188: * Indent n spaces.
189: */
190:
191: private indent (n)
192: int n;
193: {
194: if (n > 0) {
195: printf("%*c", n, ' ');
196: }
197: }
198:
199: public pascal_printdecl (s)
200: Symbol s;
201: {
202: register Symbol t;
203: Boolean semicolon;
204:
205: semicolon = true;
206: if (s->class == TYPEREF) {
207: resolveRef(t);
208: }
209: switch (s->class) {
210: case CONST:
211: if (s->type->class == SCAL) {
212: semicolon = false;
213: printf("enum constant, ord ");
214: eval(s->symvalue.constval);
215: pascal_printval(s);
216: } else {
217: printf("const %s = ", symname(s));
218: eval(s->symvalue.constval);
219: pascal_printval(s);
220: }
221: break;
222:
223: case TYPE:
224: printf("type %s = ", symname(s));
225: printtype(s, s->type, 0);
226: break;
227:
228: case TYPEREF:
229: printf("type %s", symname(s));
230: break;
231:
232: case VAR:
233: if (isparam(s)) {
234: printf("(parameter) %s : ", symname(s));
235: } else {
236: printf("var %s : ", symname(s));
237: }
238: printtype(s, s->type, 0);
239: break;
240:
241: case REF:
242: printf("(var parameter) %s : ", symname(s));
243: printtype(s, s->type, 0);
244: break;
245:
246: case RANGE:
247: case ARRAY:
248: case RECORD:
249: case VARNT:
250: case PTR:
251: case FILET:
252: printtype(s, s, 0);
253: semicolon = false;
254: break;
255:
256: case FVAR:
257: printf("(function variable) %s : ", symname(s));
258: printtype(s, s->type, 0);
259: break;
260:
261: case FIELD:
262: printf("(field) %s : ", symname(s));
263: printtype(s, s->type, 0);
264: break;
265:
266: case PROC:
267: printf("procedure %s", symname(s));
268: listparams(s);
269: break;
270:
271: case PROG:
272: printf("program %s", symname(s));
273: listparams(s);
274: break;
275:
276: case FUNC:
277: printf("function %s", symname(s));
278: listparams(s);
279: printf(" : ");
280: printtype(s, s->type, 0);
281: break;
282:
283: case MODULE:
284: printf("module %s", symname(s));
285: break;
286:
287: /*
288: * the parameter list of the following should be printed
289: * eventually
290: */
291: case FPROC:
292: printf("procedure %s()", symname(s));
293: break;
294:
295: case FFUNC:
296: printf("function %s()", symname(s));
297: break;
298:
299: default:
300: printf("%s : (class %s)", symname(s), classname(s));
301: break;
302: }
303: if (semicolon) {
304: putchar(';');
305: }
306: putchar('\n');
307: }
308:
309: /*
310: * Recursive whiz-bang procedure to print the type portion
311: * of a declaration.
312: *
313: * The symbol associated with the type is passed to allow
314: * searching for type names without getting "type blah = blah".
315: */
316:
317: private printtype (s, t, n)
318: Symbol s;
319: Symbol t;
320: int n;
321: {
322: register Symbol tmp;
323:
324: if (t->class == TYPEREF) {
325: resolveRef(t);
326: }
327: switch (t->class) {
328: case VAR:
329: case CONST:
330: case FUNC:
331: case PROC:
332: panic("printtype: class %s", classname(t));
333: break;
334:
335: case ARRAY:
336: printf("array[");
337: tmp = t->chain;
338: if (tmp != nil) {
339: for (;;) {
340: printtype(tmp, tmp, n);
341: tmp = tmp->chain;
342: if (tmp == nil) {
343: break;
344: }
345: printf(", ");
346: }
347: }
348: printf("] of ");
349: printtype(t, t->type, n);
350: break;
351:
352: case RECORD:
353: printRecordDecl(t, n);
354: break;
355:
356: case FIELD:
357: if (t->chain != nil) {
358: printtype(t->chain, t->chain, n);
359: }
360: printf("\t%s : ", symname(t));
361: printtype(t, t->type, n);
362: printf(";\n");
363: break;
364:
365: case RANGE:
366: printRangeDecl(t);
367: break;
368:
369: case PTR:
370: printf("^");
371: printtype(t, t->type, n);
372: break;
373:
374: case TYPE:
375: if (t->name != nil and ident(t->name)[0] != '\0') {
376: printname(stdout, t);
377: } else {
378: printtype(t, t->type, n);
379: }
380: break;
381:
382: case SCAL:
383: printEnumDecl(t, n);
384: break;
385:
386: case SET:
387: printf("set of ");
388: printtype(t, t->type, n);
389: break;
390:
391: case FILET:
392: printf("file of ");
393: printtype(t, t->type, n);
394: break;
395:
396: case TYPEREF:
397: break;
398:
399: case FPROC:
400: printf("procedure");
401: break;
402:
403: case FFUNC:
404: printf("function");
405: break;
406:
407: default:
408: printf("(class %d)", t->class);
409: break;
410: }
411: }
412:
413: /*
414: * Print out a record declaration.
415: */
416:
417: private printRecordDecl (t, n)
418: Symbol t;
419: int n;
420: {
421: register Symbol f;
422:
423: if (t->chain == nil) {
424: printf("record end");
425: } else {
426: printf("record\n");
427: for (f = t->chain; f != nil; f = f->chain) {
428: indent(n+4);
429: printf("%s : ", symname(f));
430: printtype(f->type, f->type, n+4);
431: printf(";\n");
432: }
433: indent(n);
434: printf("end");
435: }
436: }
437:
438: /*
439: * Print out the declaration of a range type.
440: */
441:
442: private printRangeDecl (t)
443: Symbol t;
444: {
445: long r0, r1;
446:
447: r0 = t->symvalue.rangev.lower;
448: r1 = t->symvalue.rangev.upper;
449: if (t == t_char or istypename(t, "char")) {
450: if (r0 < 0x20 or r0 > 0x7e) {
451: printf("%ld..", r0);
452: } else {
453: printf("'%c'..", (char) r0);
454: }
455: if (r1 < 0x20 or r1 > 0x7e) {
456: printf("\\%lo", r1);
457: } else {
458: printf("'%c'", (char) r1);
459: }
460: } else if (r0 > 0 and r1 == 0) {
461: printf("%ld byte real", r0);
462: } else if (r0 >= 0) {
463: printf("%lu..%lu", r0, r1);
464: } else {
465: printf("%ld..%ld", r0, r1);
466: }
467: }
468:
469: /*
470: * Print out an enumeration declaration.
471: */
472:
473: private printEnumDecl (e, n)
474: Symbol e;
475: int n;
476: {
477: Symbol t;
478:
479: printf("(");
480: t = e->chain;
481: if (t != nil) {
482: printf("%s", symname(t));
483: t = t->chain;
484: while (t != nil) {
485: printf(", %s", symname(t));
486: t = t->chain;
487: }
488: }
489: printf(")");
490: }
491:
492: /*
493: * List the parameters of a procedure or function.
494: * No attempt is made to combine like types.
495: */
496:
497: private listparams(s)
498: Symbol s;
499: {
500: Symbol t;
501:
502: if (s->chain != nil) {
503: putchar('(');
504: for (t = s->chain; t != nil; t = t->chain) {
505: switch (t->class) {
506: case REF:
507: printf("var ");
508: break;
509:
510: case VAR:
511: break;
512:
513: default:
514: panic("unexpected class %d for parameter", t->class);
515: }
516: printf("%s : ", symname(t));
517: printtype(t, t->type);
518: if (t->chain != nil) {
519: printf("; ");
520: }
521: }
522: putchar(')');
523: }
524: }
525:
526: /*
527: * Print out the value on the top of the expression stack
528: * in the format for the type of the given symbol.
529: */
530:
531: public pascal_printval (s)
532: Symbol s;
533: {
534: prval(s, size(s));
535: }
536:
537: private prval (s, n)
538: Symbol s;
539: integer n;
540: {
541: Symbol t;
542: Address a;
543: integer len;
544: double r;
545: integer i;
546:
547: if (s->class == TYPEREF) {
548: resolveRef(s);
549: }
550: switch (s->class) {
551: case CONST:
552: case TYPE:
553: case REF:
554: case VAR:
555: case FVAR:
556: case TAG:
557: prval(s->type, n);
558: break;
559:
560: case FIELD:
561: prval(s->type, n);
562: break;
563:
564: case ARRAY:
565: t = rtype(s->type);
566: if (t == t_char->type or
567: (t->class == RANGE and istypename(t->type, "char"))
568: ) {
569: len = size(s);
570: sp -= len;
571: printf("'%.*s'", len, sp);
572: break;
573: } else {
574: printarray(s);
575: }
576: break;
577:
578: case RECORD:
579: printrecord(s);
580: break;
581:
582: case VARNT:
583: printf("[variant]");
584: break;
585:
586: case RANGE:
587: printrange(s, n);
588: break;
589:
590: case FILET:
591: a = pop(Address);
592: if (a == 0) {
593: printf("nil");
594: } else {
595: printf("0x%x", a);
596: }
597: break;
598:
599: case PTR:
600: a = pop(Address);
601: if (a == 0) {
602: printf("nil");
603: } else {
604: printf("0x%x", a);
605: }
606: break;
607:
608: case SCAL:
609: i = 0;
610: popn(n, &i);
611: if (s->symvalue.iconval < 256) {
612: i &= 0xff;
613: } else if (s->symvalue.iconval < 65536) {
614: i &= 0xffff;
615: }
616: printEnum(i, s);
617: break;
618:
619: case FPROC:
620: case FFUNC:
621: a = pop(long);
622: t = whatblock(a);
623: if (t == nil) {
624: printf("(proc 0x%x)", a);
625: } else {
626: printf("%s", symname(t));
627: }
628: break;
629:
630: case SET:
631: printSet(s);
632: break;
633:
634: default:
635: if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
636: panic("printval: bad class %d", ord(s->class));
637: }
638: printf("[%s]", classname(s));
639: break;
640: }
641: }
642:
643: /*
644: * Print out the value of a scalar (non-enumeration) type.
645: */
646:
647: private printrange (s, n)
648: Symbol s;
649: integer n;
650: {
651: double d;
652: float f;
653: integer i;
654:
655: if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) {
656: if (n == sizeof(float)) {
657: popn(n, &f);
658: d = f;
659: } else {
660: popn(n, &d);
661: }
662: prtreal(d);
663: } else {
664: i = 0;
665: popn(n, &i);
666: printRangeVal(i, s);
667: }
668: }
669:
670: /*
671: * Print out a set.
672: */
673:
674: private printSet (s)
675: Symbol s;
676: {
677: Symbol t;
678: integer nbytes;
679:
680: nbytes = size(s);
681: t = rtype(s->type);
682: printf("[");
683: sp -= nbytes;
684: if (t->class == SCAL) {
685: printSetOfEnum(t);
686: } else if (t->class == RANGE) {
687: printSetOfRange(t);
688: } else {
689: error("internal error: expected range or enumerated base type for set");
690: }
691: printf("]");
692: }
693:
694: /*
695: * Print out a set of an enumeration.
696: */
697:
698: private printSetOfEnum (t)
699: Symbol t;
700: {
701: register Symbol e;
702: register integer i, j, *p;
703: boolean first;
704:
705: p = (int *) sp;
706: i = *p;
707: j = 0;
708: e = t->chain;
709: first = true;
710: while (e != nil) {
711: if ((i&1) == 1) {
712: if (first) {
713: first = false;
714: printf("%s", symname(e));
715: } else {
716: printf(", %s", symname(e));
717: }
718: }
719: i >>= 1;
720: ++j;
721: if (j >= sizeof(integer)*BITSPERBYTE) {
722: j = 0;
723: ++p;
724: i = *p;
725: }
726: e = e->chain;
727: }
728: }
729:
730: /*
731: * Print out a set of a subrange type.
732: */
733:
734: private printSetOfRange (t)
735: Symbol t;
736: {
737: register integer i, j, *p;
738: long v;
739: boolean first;
740:
741: p = (int *) sp;
742: i = *p;
743: j = 0;
744: v = t->symvalue.rangev.lower;
745: first = true;
746: while (v <= t->symvalue.rangev.upper) {
747: if ((i&1) == 1) {
748: if (first) {
749: first = false;
750: printf("%ld", v);
751: } else {
752: printf(", %ld", v);
753: }
754: }
755: i >>= 1;
756: ++j;
757: if (j >= sizeof(integer)*BITSPERBYTE) {
758: j = 0;
759: ++p;
760: i = *p;
761: }
762: ++v;
763: }
764: }
765:
766: /*
767: * Construct a node for subscripting.
768: */
769:
770: public Node pascal_buildaref (a, slist)
771: Node a, slist;
772: {
773: register Symbol t;
774: register Node p;
775: Symbol etype, atype, eltype;
776: Node esub, r;
777:
778: t = rtype(a->nodetype);
779: if (t->class != ARRAY) {
780: beginerrmsg();
781: prtree(stderr, a);
782: fprintf(stderr, " is not an array");
783: enderrmsg();
784: } else {
785: r = a;
786: eltype = t->type;
787: p = slist;
788: t = t->chain;
789: for (; p != nil and t != nil; p = p->value.arg[1], t = t->chain) {
790: esub = p->value.arg[0];
791: etype = rtype(esub->nodetype);
792: atype = rtype(t);
793: if (not compatible(atype, etype)) {
794: beginerrmsg();
795: fprintf(stderr, "subscript ");
796: prtree(stderr, esub);
797: fprintf(stderr, " is the wrong type");
798: enderrmsg();
799: }
800: r = build(O_INDEX, r, esub);
801: r->nodetype = eltype;
802: }
803: if (p != nil or t != nil) {
804: beginerrmsg();
805: if (p != nil) {
806: fprintf(stderr, "too many subscripts for ");
807: } else {
808: fprintf(stderr, "not enough subscripts for ");
809: }
810: prtree(stderr, a);
811: enderrmsg();
812: }
813: }
814: return r;
815: }
816:
817: /*
818: * Evaluate a subscript index.
819: */
820:
821: public pascal_evalaref (s, base, i)
822: Symbol s;
823: Address base;
824: long i;
825: {
826: Symbol t;
827: long lb, ub;
828:
829: t = rtype(s);
830: s = rtype(t->chain);
831: findbounds(s, &lb, &ub);
832: if (i < lb or i > ub) {
833: error("subscript %d out of range [%d..%d]", i, lb, ub);
834: }
835: push(long, base + (i - lb) * size(t->type));
836: }
837:
838: /*
839: * Initial Pascal type information.
840: */
841:
842: #define NTYPES 4
843:
844: private Symbol inittype[NTYPES + 1];
845:
846: private addType (n, s, lower, upper)
847: integer n;
848: String s;
849: long lower, upper;
850: {
851: register Symbol t;
852:
853: if (n > NTYPES) {
854: panic("initial Pascal type number too large for '%s'", s);
855: }
856: t = insert(identname(s, true));
857: t->language = pasc;
858: t->class = TYPE;
859: t->type = newSymbol(nil, 0, RANGE, t, nil);
860: t->type->symvalue.rangev.lower = lower;
861: t->type->symvalue.rangev.upper = upper;
862: t->type->language = pasc;
863: inittype[n] = t;
864: }
865:
866: private initTypes ()
867: {
868: addType(1, "boolean", 0L, 1L);
869: addType(2, "char", 0L, 255L);
870: addType(3, "integer", 0x80000000L, 0x7fffffffL);
871: addType(4, "real", 8L, 0L);
872: initialized = true;
873: }
874:
875: /*
876: * Initialize typetable.
877: */
878:
879: public pascal_modinit (typetable)
880: Symbol typetable[];
881: {
882: register integer i;
883:
884: if (not initialized) {
885: initTypes();
886: initialized = true;
887: }
888: for (i = 1; i <= NTYPES; i++) {
889: typetable[i] = inittype[i];
890: }
891: }
892:
893: public boolean pascal_hasmodules ()
894: {
895: return false;
896: }
897:
898: public boolean pascal_passaddr (param, exprtype)
899: Symbol param, exprtype;
900: {
901: return false;
902: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.