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