![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to modula-2.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / lib / old_compiler / dbx|
Return to modula-2.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / lib / old_compiler / 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[] = "@(#)modula-2.c 5.2 (Berkeley) 1/12/88";
9: #endif not lint
10:
11: /*
12: * Modula-2 specific symbol routines.
13: */
14:
15: static char rcsid[] = "$Header: modula-2.c,v 1.2 87/03/26 20:12:54 donn Exp $";
16:
17: #include "defs.h"
18: #include "symbols.h"
19: #include "modula-2.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 mod2;
32: private boolean initialized;
33:
34:
35: #define ischar(t) ( \
36: (t) == t_char->type or \
37: ((t)->class == RANGE and istypename((t)->type, "char")) \
38: )
39:
40: /*
41: * Initialize Modula-2 information.
42: */
43:
44: public modula2_init ()
45: {
46: mod2 = language_define("modula-2", ".mod");
47: language_setop(mod2, L_PRINTDECL, modula2_printdecl);
48: language_setop(mod2, L_PRINTVAL, modula2_printval);
49: language_setop(mod2, L_TYPEMATCH, modula2_typematch);
50: language_setop(mod2, L_BUILDAREF, modula2_buildaref);
51: language_setop(mod2, L_EVALAREF, modula2_evalaref);
52: language_setop(mod2, L_MODINIT, modula2_modinit);
53: language_setop(mod2, L_HASMODULES, modula2_hasmodules);
54: language_setop(mod2, L_PASSADDR, modula2_passaddr);
55: initialized = false;
56: }
57:
58: /*
59: * Typematch tests if two types are compatible. The issue
60: * is a bit complicated, so several subfunctions are used for
61: * various kinds of compatibility.
62: */
63:
64: private boolean builtinmatch (t1, t2)
65: register Symbol t1, t2;
66: {
67: boolean b;
68:
69: b = (boolean) (
70: (
71: t2 == t_int->type and t1->class == RANGE and
72: (
73: istypename(t1->type, "integer") or
74: istypename(t1->type, "cardinal")
75: )
76: ) or (
77: t2 == t_char->type and
78: t1->class == RANGE and istypename(t1->type, "char")
79: ) or (
80: t2 == t_real->type and
81: t1->class == RANGE and (
82: istypename(t1->type, "real") or
83: istypename(t1->type, "longreal")
84: )
85: ) or (
86: t2 == t_boolean->type and
87: t1->class == RANGE and istypename(t1->type, "boolean")
88: )
89: );
90: return b;
91: }
92:
93: private boolean nilMatch (t1, t2)
94: register Symbol t1, t2;
95: {
96: boolean b;
97:
98: b = (boolean) (
99: (t1 == t_nil and t2->class == PTR) or
100: (t1->class == PTR and t2 == t_nil)
101: );
102: return b;
103: }
104:
105: private boolean enumMatch (t1, t2)
106: register Symbol t1, t2;
107: {
108: boolean b;
109:
110: b = (boolean) (
111: (t1->class == SCAL and t2->class == CONST and t2->type == t1) or
112: (t1->class == CONST and t2->class == SCAL and t1->type == t2)
113: );
114: return b;
115: }
116:
117: private boolean openArrayMatch (t1, t2)
118: register Symbol t1, t2;
119: {
120: boolean b;
121:
122: b = (boolean) (
123: (
124: t1->class == OPENARRAY and t1->symvalue.ndims == 1 and
125: t2->class == ARRAY and
126: compatible(rtype(t2->chain)->type, t_int) and
127: compatible(t1->type, t2->type)
128: ) or (
129: t2->class == OPENARRAY and t2->symvalue.ndims == 1 and
130: t1->class == ARRAY and
131: compatible(rtype(t1->chain)->type, t_int) and
132: compatible(t1->type, t2->type)
133: )
134: );
135: return b;
136: }
137:
138: private boolean isConstString (t)
139: register Symbol t;
140: {
141: boolean b;
142:
143: b = (boolean) (
144: t->language == primlang and t->class == ARRAY and t->type == t_char
145: );
146: return b;
147: }
148:
149: private boolean stringArrayMatch (t1, t2)
150: register Symbol t1, t2;
151: {
152: boolean b;
153:
154: b = (boolean) (
155: (
156: isConstString(t1) and
157: t2->class == ARRAY and compatible(t2->type, t_char->type)
158: ) or (
159: isConstString(t2) and
160: t1->class == ARRAY and compatible(t1->type, t_char->type)
161: )
162: );
163: return b;
164: }
165:
166: public boolean modula2_typematch (type1, type2)
167: Symbol type1, type2;
168: {
169: boolean b;
170: Symbol t1, t2, tmp;
171:
172: t1 = rtype(type1);
173: t2 = rtype(type2);
174: if (t1 == t2) {
175: b = true;
176: } else {
177: if (t1 == t_char->type or t1 == t_int->type or
178: t1 == t_real->type or t1 == t_boolean->type
179: ) {
180: tmp = t1;
181: t1 = t2;
182: t2 = tmp;
183: }
184: b = (Boolean) (
185: builtinmatch(t1, t2) or
186: nilMatch(t1, t2) or enumMatch(t1, t2) or
187: openArrayMatch(t1, t2) or stringArrayMatch(t1, t2)
188: );
189: }
190: return b;
191: }
192:
193: /*
194: * Indent n spaces.
195: */
196:
197: private indent (n)
198: int n;
199: {
200: if (n > 0) {
201: printf("%*c", n, ' ');
202: }
203: }
204:
205: public modula2_printdecl (s)
206: Symbol s;
207: {
208: register Symbol t;
209: Boolean semicolon;
210:
211: semicolon = true;
212: if (s->class == TYPEREF) {
213: resolveRef(t);
214: }
215: switch (s->class) {
216: case CONST:
217: if (s->type->class == SCAL) {
218: semicolon = false;
219: printf("enumeration constant with value ");
220: eval(s->symvalue.constval);
221: modula2_printval(s);
222: } else {
223: printf("const %s = ", symname(s));
224: eval(s->symvalue.constval);
225: modula2_printval(s);
226: }
227: break;
228:
229: case TYPE:
230: printf("type %s = ", symname(s));
231: printtype(s, s->type, 0);
232: break;
233:
234: case TYPEREF:
235: printf("type %s", symname(s));
236: break;
237:
238: case VAR:
239: if (isparam(s)) {
240: printf("(parameter) %s : ", symname(s));
241: } else {
242: printf("var %s : ", symname(s));
243: }
244: printtype(s, s->type, 0);
245: break;
246:
247: case REF:
248: printf("(var parameter) %s : ", symname(s));
249: printtype(s, s->type, 0);
250: break;
251:
252: case RANGE:
253: case ARRAY:
254: case OPENARRAY:
255: case DYNARRAY:
256: case SUBARRAY:
257: case RECORD:
258: case VARNT:
259: case PTR:
260: printtype(s, s, 0);
261: semicolon = false;
262: break;
263:
264: case FVAR:
265: printf("(function variable) %s : ", symname(s));
266: printtype(s, s->type, 0);
267: break;
268:
269: case FIELD:
270: printf("(field) %s : ", symname(s));
271: printtype(s, s->type, 0);
272: break;
273:
274: case PROC:
275: printf("procedure %s", symname(s));
276: listparams(s);
277: break;
278:
279: case PROG:
280: printf("program %s", symname(s));
281: listparams(s);
282: break;
283:
284: case FUNC:
285: printf("procedure %s", symname(s));
286: listparams(s);
287: printf(" : ");
288: printtype(s, s->type, 0);
289: break;
290:
291: case MODULE:
292: printf("module %s", symname(s));
293: break;
294:
295: default:
296: printf("[%s]", classname(s));
297: break;
298: }
299: if (semicolon) {
300: putchar(';');
301: }
302: putchar('\n');
303: }
304:
305: /*
306: * Recursive whiz-bang procedure to print the type portion
307: * of a declaration.
308: *
309: * The symbol associated with the type is passed to allow
310: * searching for type names without getting "type blah = blah".
311: */
312:
313: private printtype (s, t, n)
314: Symbol s;
315: Symbol t;
316: int n;
317: {
318: Symbol tmp;
319: int i;
320:
321: if (t->class == TYPEREF) {
322: resolveRef(t);
323: }
324: switch (t->class) {
325: case VAR:
326: case CONST:
327: case FUNC:
328: case PROC:
329: panic("printtype: class %s", classname(t));
330: break;
331:
332: case ARRAY:
333: printf("array[");
334: tmp = t->chain;
335: if (tmp != nil) {
336: for (;;) {
337: printtype(tmp, tmp, n);
338: tmp = tmp->chain;
339: if (tmp == nil) {
340: break;
341: }
342: printf(", ");
343: }
344: }
345: printf("] of ");
346: printtype(t, t->type, n);
347: break;
348:
349: case OPENARRAY:
350: printf("array of ");
351: for (i = 1; i < t->symvalue.ndims; i++) {
352: printf("array of ");
353: }
354: printtype(t, t->type, n);
355: break;
356:
357: case DYNARRAY:
358: printf("dynarray of ");
359: for (i = 1; i < t->symvalue.ndims; i++) {
360: printf("array of ");
361: }
362: printtype(t, t->type, n);
363: break;
364:
365: case SUBARRAY:
366: printf("subarray of ");
367: for (i = 1; i < t->symvalue.ndims; i++) {
368: printf("array of ");
369: }
370: printtype(t, t->type, n);
371: break;
372:
373: case RECORD:
374: printRecordDecl(t, n);
375: break;
376:
377: case FIELD:
378: if (t->chain != nil) {
379: printtype(t->chain, t->chain, n);
380: }
381: printf("\t%s : ", symname(t));
382: printtype(t, t->type, n);
383: printf(";\n");
384: break;
385:
386: case RANGE:
387: printRangeDecl(t);
388: break;
389:
390: case PTR:
391: printf("pointer to ");
392: printtype(t, t->type, n);
393: break;
394:
395: case TYPE:
396: if (t->name != nil and ident(t->name)[0] != '\0') {
397: printname(stdout, t);
398: } else {
399: printtype(t, t->type, n);
400: }
401: break;
402:
403: case SCAL:
404: printEnumDecl(t, n);
405: break;
406:
407: case SET:
408: printf("set of ");
409: printtype(t, t->type, n);
410: break;
411:
412: case TYPEREF:
413: break;
414:
415: case FPROC:
416: case FFUNC:
417: printf("procedure");
418: break;
419:
420: default:
421: printf("[%s]", classname(t));
422: break;
423: }
424: }
425:
426: /*
427: * Print out a record declaration.
428: */
429:
430: private printRecordDecl (t, n)
431: Symbol t;
432: int n;
433: {
434: register Symbol f;
435:
436: if (t->chain == nil) {
437: printf("record end");
438: } else {
439: printf("record\n");
440: for (f = t->chain; f != nil; f = f->chain) {
441: indent(n+4);
442: printf("%s : ", symname(f));
443: printtype(f->type, f->type, n+4);
444: printf(";\n");
445: }
446: indent(n);
447: printf("end");
448: }
449: }
450:
451: /*
452: * Print out the declaration of a range type.
453: */
454:
455: private printRangeDecl (t)
456: Symbol t;
457: {
458: long r0, r1;
459:
460: r0 = t->symvalue.rangev.lower;
461: r1 = t->symvalue.rangev.upper;
462: if (ischar(t)) {
463: if (r0 < 0x20 or r0 > 0x7e) {
464: printf("%ld..", r0);
465: } else {
466: printf("'%c'..", (char) r0);
467: }
468: if (r1 < 0x20 or r1 > 0x7e) {
469: printf("\\%lo", r1);
470: } else {
471: printf("'%c'", (char) r1);
472: }
473: } else if (r0 > 0 and r1 == 0) {
474: printf("%ld byte real", r0);
475: } else if (r0 >= 0) {
476: printf("%lu..%lu", r0, r1);
477: } else {
478: printf("%ld..%ld", r0, r1);
479: }
480: }
481:
482: /*
483: * Print out an enumeration declaration.
484: */
485:
486: private printEnumDecl (e, n)
487: Symbol e;
488: int n;
489: {
490: Symbol t;
491:
492: printf("(");
493: t = e->chain;
494: if (t != nil) {
495: printf("%s", symname(t));
496: t = t->chain;
497: while (t != nil) {
498: printf(", %s", symname(t));
499: t = t->chain;
500: }
501: }
502: printf(")");
503: }
504:
505: /*
506: * List the parameters of a procedure or function.
507: * No attempt is made to combine like types.
508: */
509:
510: private listparams (s)
511: Symbol s;
512: {
513: Symbol t;
514:
515: if (s->chain != nil) {
516: putchar('(');
517: for (t = s->chain; t != nil; t = t->chain) {
518: switch (t->class) {
519: case REF:
520: printf("var ");
521: break;
522:
523: case FPROC:
524: case FFUNC:
525: printf("procedure ");
526: break;
527:
528: case VAR:
529: break;
530:
531: default:
532: panic("unexpected class %d for parameter", t->class);
533: }
534: printf("%s", symname(t));
535: if (s->class == PROG) {
536: printf(", ");
537: } else {
538: printf(" : ");
539: printtype(t, t->type, 0);
540: if (t->chain != nil) {
541: printf("; ");
542: }
543: }
544: }
545: putchar(')');
546: }
547: }
548:
549: /*
550: * Test if a pointer type should be treated as a null-terminated string.
551: * The type given is the type that is pointed to.
552: */
553:
554: private boolean isCstring (type)
555: Symbol type;
556: {
557: boolean b;
558: register Symbol a, t;
559:
560: a = rtype(type);
561: if (a->class == ARRAY) {
562: t = rtype(a->chain);
563: b = (boolean) (
564: t->class == RANGE and istypename(a->type, "char") and
565: (t->symvalue.rangev.upper - t->symvalue.rangev.lower + 1) <= 0
566: );
567: } else {
568: b = false;
569: }
570: return b;
571: }
572:
573: /*
574: * Modula 2 interface to printval.
575: */
576:
577: public modula2_printval (s)
578: Symbol s;
579: {
580: prval(s, size(s));
581: }
582:
583: /*
584: * Print out the value on the top of the expression stack
585: * in the format for the type of the given symbol, assuming
586: * the size of the object is n bytes.
587: */
588:
589: private prval (s, n)
590: Symbol s;
591: integer n;
592: {
593: Symbol t;
594: Address a;
595: integer len;
596: double r;
597: integer i;
598:
599: if (s->class == TYPEREF) {
600: resolveRef(s);
601: }
602: switch (s->class) {
603: case CONST:
604: case TYPE:
605: case REF:
606: case VAR:
607: case FVAR:
608: case TAG:
609: prval(s->type, n);
610: break;
611:
612: case FIELD:
613: if (isbitfield(s)) {
614: i = extractField(s);
615: t = rtype(s->type);
616: if (t->class == SCAL) {
617: printEnum(i, t);
618: } else {
619: printRangeVal(i, t);
620: }
621: } else {
622: prval(s->type, n);
623: }
624: break;
625:
626: case ARRAY:
627: t = rtype(s->type);
628: if (ischar(t)) {
629: len = size(s);
630: sp -= len;
631: printf("\"%.*s\"", len, sp);
632: break;
633: } else {
634: printarray(s);
635: }
636: break;
637:
638: case OPENARRAY:
639: case DYNARRAY:
640: printDynarray(s);
641: break;
642:
643: case SUBARRAY:
644: printSubarray(s);
645: break;
646:
647: case RECORD:
648: printrecord(s);
649: break;
650:
651: case VARNT:
652: printf("[variant]");
653: break;
654:
655: case RANGE:
656: printrange(s, n);
657: break;
658:
659: /*
660: * Unresolved opaque type.
661: * Probably a pointer.
662: */
663: case TYPEREF:
664: a = pop(Address);
665: printf("@%x", a);
666: break;
667:
668: case FILET:
669: a = pop(Address);
670: if (a == 0) {
671: printf("nil");
672: } else {
673: printf("0x%x", a);
674: }
675: break;
676:
677: case PTR:
678: a = pop(Address);
679: if (a == 0) {
680: printf("nil");
681: } else if (isCstring(s->type)) {
682: printString(a, true);
683: } else {
684: printf("0x%x", a);
685: }
686: break;
687:
688: case SCAL:
689: i = 0;
690: popn(n, &i);
691: printEnum(i, s);
692: break;
693:
694: case FPROC:
695: case FFUNC:
696: a = pop(long);
697: t = whatblock(a);
698: if (t == nil) {
699: printf("0x%x", a);
700: } else {
701: printname(stdout, t);
702: }
703: break;
704:
705: case SET:
706: printSet(s);
707: break;
708:
709: default:
710: if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
711: panic("printval: bad class %d", ord(s->class));
712: }
713: printf("[%s]", classname(s));
714: break;
715: }
716: }
717:
718: /*
719: * Print out a dynamic array.
720: */
721:
722: private Address printDynSlice();
723:
724: private printDynarray (t)
725: Symbol t;
726: {
727: Address base;
728: integer n;
729: Stack *savesp, *newsp;
730: Symbol eltype;
731:
732: savesp = sp;
733: sp -= (t->symvalue.ndims * sizeof(Word));
734: base = pop(Address);
735: newsp = sp;
736: sp = savesp;
737: eltype = rtype(t->type);
738: if (t->symvalue.ndims == 0) {
739: if (ischar(eltype)) {
740: printString(base, true);
741: } else {
742: printf("[dynarray @nocount]");
743: }
744: } else {
745: n = ((long *) sp)[-(t->symvalue.ndims)];
746: base = printDynSlice(base, n, t->symvalue.ndims, eltype, size(eltype));
747: }
748: sp = newsp;
749: }
750:
751: /*
752: * Print out one dimension of a multi-dimension dynamic array.
753: *
754: * Return the address of the element that follows the printed elements.
755: */
756:
757: private Address printDynSlice (base, count, ndims, eltype, elsize)
758: Address base;
759: integer count, ndims;
760: Symbol eltype;
761: integer elsize;
762: {
763: Address b;
764: integer i, n;
765: char *slice;
766: Stack *savesp;
767:
768: b = base;
769: if (ndims > 1) {
770: n = ((long *) sp)[-ndims + 1];
771: }
772: if (ndims == 1 and ischar(eltype)) {
773: slice = newarr(char, count);
774: dread(slice, b, count);
775: printf("\"%.*s\"", count, slice);
776: dispose(slice);
777: b += count;
778: } else {
779: printf("(");
780: for (i = 0; i < count; i++) {
781: if (i != 0) {
782: printf(", ");
783: }
784: if (ndims == 1) {
785: slice = newarr(char, elsize);
786: dread(slice, b, elsize);
787: savesp = sp;
788: sp = slice + elsize;
789: printval(eltype);
790: sp = savesp;
791: dispose(slice);
792: b += elsize;
793: } else {
794: b = printDynSlice(b, n, ndims - 1, eltype, elsize);
795: }
796: }
797: printf(")");
798: }
799: return b;
800: }
801:
802: private printSubarray (t)
803: Symbol t;
804: {
805: printf("[subarray]");
806: }
807:
808: /*
809: * Print out the value of a scalar (non-enumeration) type.
810: */
811:
812: private printrange (s, n)
813: Symbol s;
814: integer n;
815: {
816: double d;
817: float f;
818: integer i;
819:
820: if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) {
821: if (n == sizeof(float)) {
822: popn(n, &f);
823: d = f;
824: } else {
825: popn(n, &d);
826: }
827: prtreal(d);
828: } else {
829: i = 0;
830: popn(n, &i);
831: printRangeVal(i, s);
832: }
833: }
834:
835: /*
836: * Print out a set.
837: */
838:
839: private printSet (s)
840: Symbol s;
841: {
842: Symbol t;
843: integer nbytes;
844:
845: nbytes = size(s);
846: t = rtype(s->type);
847: printf("{");
848: sp -= nbytes;
849: if (t->class == SCAL) {
850: printSetOfEnum(t);
851: } else if (t->class == RANGE) {
852: printSetOfRange(t);
853: } else {
854: panic("expected range or enumerated base type for set");
855: }
856: printf("}");
857: }
858:
859: /*
860: * Print out a set of an enumeration.
861: */
862:
863: private printSetOfEnum (t)
864: Symbol t;
865: {
866: register Symbol e;
867: register integer i, j, *p;
868: boolean first;
869:
870: p = (int *) sp;
871: i = *p;
872: j = 0;
873: e = t->chain;
874: first = true;
875: while (e != nil) {
876: if ((i&1) == 1) {
877: if (first) {
878: first = false;
879: printf("%s", symname(e));
880: } else {
881: printf(", %s", symname(e));
882: }
883: }
884: i >>= 1;
885: ++j;
886: if (j >= sizeof(integer)*BITSPERBYTE) {
887: j = 0;
888: ++p;
889: i = *p;
890: }
891: e = e->chain;
892: }
893: }
894:
895: /*
896: * Print out a set of a subrange type.
897: */
898:
899: private printSetOfRange (t)
900: Symbol t;
901: {
902: register integer i, j, *p;
903: long v;
904: boolean first;
905:
906: p = (int *) sp;
907: i = *p;
908: j = 0;
909: v = t->symvalue.rangev.lower;
910: first = true;
911: while (v <= t->symvalue.rangev.upper) {
912: if ((i&1) == 1) {
913: if (first) {
914: first = false;
915: printf("%ld", v);
916: } else {
917: printf(", %ld", v);
918: }
919: }
920: i >>= 1;
921: ++j;
922: if (j >= sizeof(integer)*BITSPERBYTE) {
923: j = 0;
924: ++p;
925: i = *p;
926: }
927: ++v;
928: }
929: }
930:
931: /*
932: * Construct a node for subscripting a dynamic or subarray.
933: * The list of indices is left for processing in evalaref,
934: * unlike normal subscripting in which the list is expanded
935: * across individual INDEX nodes.
936: */
937:
938: private Node dynref (a, t, slist)
939: Node a;
940: Symbol t;
941: Node slist;
942: {
943: Node p, r;
944: integer n;
945:
946: p = slist;
947: n = 0;
948: while (p != nil) {
949: if (not compatible(p->value.arg[0]->nodetype, t_int)) {
950: suberror("subscript \"", p->value.arg[0], "\" is the wrong type");
951: }
952: ++n;
953: p = p->value.arg[1];
954: }
955: if (n > t->symvalue.ndims and (t->symvalue.ndims != 0 or n != 1)) {
956: suberror("too many subscripts for ", a, nil);
957: } else if (n < t->symvalue.ndims) {
958: suberror("not enough subscripts for ", a, nil);
959: }
960: r = build(O_INDEX, a, slist);
961: r->nodetype = rtype(t->type);
962: return r;
963: }
964:
965: /*
966: * Construct a node for subscripting.
967: */
968:
969: public Node modula2_buildaref (a, slist)
970: Node a, slist;
971: {
972: register Symbol t;
973: register Node p;
974: Symbol eltype;
975: Node esub, r;
976: integer n;
977:
978: t = rtype(a->nodetype);
979: switch (t->class) {
980: case OPENARRAY:
981: case DYNARRAY:
982: case SUBARRAY:
983: r = dynref(a, t, slist);
984: break;
985:
986: case ARRAY:
987: r = a;
988: eltype = rtype(t->type);
989: p = slist;
990: t = t->chain;
991: while (p != nil and t != nil) {
992: esub = p->value.arg[0];
993: if (not compatible(rtype(t), rtype(esub->nodetype))) {
994: suberror("subscript \"", esub, "\" is the wrong type");
995: }
996: r = build(O_INDEX, r, esub);
997: r->nodetype = eltype;
998: p = p->value.arg[1];
999: t = t->chain;
1000: }
1001: if (p != nil) {
1002: suberror("too many subscripts for ", a, nil);
1003: } else if (t != nil) {
1004: suberror("not enough subscripts for ", a, nil);
1005: }
1006: break;
1007:
1008: default:
1009: suberror("\"", a, "\" is not an array");
1010: break;
1011: }
1012: return r;
1013: }
1014:
1015: /*
1016: * Subscript usage error reporting.
1017: */
1018:
1019: private suberror (s1, e1, s2)
1020: String s1, s2;
1021: Node e1;
1022: {
1023: beginerrmsg();
1024: if (s1 != nil) {
1025: fprintf(stderr, s1);
1026: }
1027: if (e1 != nil) {
1028: prtree(stderr, e1);
1029: }
1030: if (s2 != nil) {
1031: fprintf(stderr, s2);
1032: }
1033: enderrmsg();
1034: }
1035:
1036: /*
1037: * Check that a subscript value is in the appropriate range.
1038: */
1039:
1040: private subchk (value, lower, upper)
1041: long value, lower, upper;
1042: {
1043: if (value < lower or value > upper) {
1044: error("subscript value %d out of range [%d..%d]", value, lower, upper);
1045: }
1046: }
1047:
1048: /*
1049: * Compute the offset for subscripting a dynamic array.
1050: */
1051:
1052: private getdynoff (ndims, sub)
1053: integer ndims;
1054: long *sub;
1055: {
1056: long k, off, *count;
1057:
1058: count = (long *) sp;
1059: off = 0;
1060: for (k = 0; k < ndims - 1; k++) {
1061: subchk(sub[k], 0, count[k] - 1);
1062: off += (sub[k] * count[k+1]);
1063: }
1064: subchk(sub[ndims - 1], 0, count[ndims - 1] - 1);
1065: return off + sub[ndims - 1];
1066: }
1067:
1068: /*
1069: * Compute the offset associated with a subarray.
1070: */
1071:
1072: private getsuboff (ndims, sub)
1073: integer ndims;
1074: long *sub;
1075: {
1076: long k, off;
1077: struct subarrayinfo {
1078: long count;
1079: long mult;
1080: } *info;
1081:
1082: info = (struct subarrayinfo *) sp;
1083: off = 0;
1084: for (k = 0; k < ndims; k++) {
1085: subchk(sub[k], 0, info[k].count - 1);
1086: off += sub[k] * info[k].mult;
1087: }
1088: return off;
1089: }
1090:
1091: /*
1092: * Evaluate a subscript index.
1093: */
1094:
1095: public modula2_evalaref (s, base, i)
1096: Symbol s;
1097: Address base;
1098: long i;
1099: {
1100: Symbol t;
1101: long lb, ub, off;
1102: long *sub;
1103: Address b;
1104:
1105: t = rtype(s);
1106: if (t->class == ARRAY) {
1107: findbounds(rtype(t->chain), &lb, &ub);
1108: if (i < lb or i > ub) {
1109: error("subscript %d out of range [%d..%d]", i, lb, ub);
1110: }
1111: push(long, base + (i - lb) * size(t->type));
1112: } else if ((t->class == OPENARRAY or t->class == DYNARRAY) and
1113: t->symvalue.ndims == 0
1114: ) {
1115: push(long, base + i * size(t->type));
1116: } else if (t->class == OPENARRAY or t->class == DYNARRAY or
1117: t->class == SUBARRAY
1118: ) {
1119: push(long, i);
1120: sub = (long *) (sp - (t->symvalue.ndims * sizeof(long)));
1121: rpush(base, size(t));
1122: sp -= (t->symvalue.ndims * sizeof(long));
1123: b = pop(Address);
1124: sp += sizeof(Address);
1125: if (t->class == SUBARRAY) {
1126: off = getsuboff(t->symvalue.ndims, sub);
1127: } else {
1128: off = getdynoff(t->symvalue.ndims, sub);
1129: }
1130: sp = (Stack *) sub;
1131: push(long, b + off * size(t->type));
1132: } else {
1133: error("[internal error: expected array in evalaref]");
1134: }
1135: }
1136:
1137: /*
1138: * Initial Modula-2 type information.
1139: */
1140:
1141: #define NTYPES 12
1142:
1143: private Symbol inittype[NTYPES + 1];
1144:
1145: private addType (n, s, lower, upper)
1146: integer n;
1147: String s;
1148: long lower, upper;
1149: {
1150: register Symbol t;
1151:
1152: if (n > NTYPES) {
1153: panic("initial Modula-2 type number too large for '%s'", s);
1154: }
1155: t = insert(identname(s, true));
1156: t->language = mod2;
1157: t->class = TYPE;
1158: t->type = newSymbol(nil, 0, RANGE, t, nil);
1159: t->type->symvalue.rangev.lower = lower;
1160: t->type->symvalue.rangev.upper = upper;
1161: t->type->language = mod2;
1162: inittype[n] = t;
1163: }
1164:
1165: private initModTypes ()
1166: {
1167: addType(1, "integer", 0x80000000L, 0x7fffffffL);
1168: addType(2, "char", 0L, 255L);
1169: addType(3, "boolean", 0L, 1L);
1170: addType(4, "unsigned", 0L, 0xffffffffL);
1171: addType(5, "real", 4L, 0L);
1172: addType(6, "longreal", 8L, 0L);
1173: addType(7, "word", 0L, 0xffffffffL);
1174: addType(8, "byte", 0L, 255L);
1175: addType(9, "address", 0L, 0xffffffffL);
1176: addType(10, "file", 0L, 0xffffffffL);
1177: addType(11, "process", 0L, 0xffffffffL);
1178: addType(12, "cardinal", 0L, 0x7fffffffL);
1179: }
1180:
1181: /*
1182: * Initialize typetable.
1183: */
1184:
1185: public modula2_modinit (typetable)
1186: Symbol typetable[];
1187: {
1188: register integer i;
1189:
1190: if (not initialized) {
1191: initModTypes();
1192: initialized = true;
1193: }
1194: for (i = 1; i <= NTYPES; i++) {
1195: typetable[i] = inittype[i];
1196: }
1197: }
1198:
1199: public boolean modula2_hasmodules ()
1200: {
1201: return true;
1202: }
1203:
1204: public boolean modula2_passaddr (param, exprtype)
1205: Symbol param, exprtype;
1206: {
1207: return false;
1208: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.