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