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