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