121613Sdist /*
238105Sbostic * Copyright (c) 1983 The Regents of the University of California.
338105Sbostic * All rights reserved.
438105Sbostic *
5*42683Sbostic * %sccs.include.redist.c%
621613Sdist */
718261Slinton
816622Ssam #ifndef lint
9*42683Sbostic static char sccsid[] = "@(#)modula-2.c 5.4 (Berkeley) 06/01/90";
1038105Sbostic #endif /* not lint */
1116622Ssam
1216622Ssam /*
1316622Ssam * Modula-2 specific symbol routines.
1416622Ssam */
1516622Ssam
1616622Ssam #include "defs.h"
1716622Ssam #include "symbols.h"
1816622Ssam #include "modula-2.h"
1916622Ssam #include "languages.h"
2016622Ssam #include "tree.h"
2116622Ssam #include "eval.h"
2216622Ssam #include "mappings.h"
2316622Ssam #include "process.h"
2416622Ssam #include "runtime.h"
2516622Ssam #include "machine.h"
2616622Ssam
2716622Ssam #ifndef public
2816622Ssam #endif
2916622Ssam
3016622Ssam private Language mod2;
3116622Ssam private boolean initialized;
3216622Ssam
3318261Slinton
3418261Slinton #define ischar(t) ( \
3518261Slinton (t) == t_char->type or \
3618261Slinton ((t)->class == RANGE and istypename((t)->type, "char")) \
3718261Slinton )
3818261Slinton
3916622Ssam /*
4016622Ssam * Initialize Modula-2 information.
4116622Ssam */
4216622Ssam
modula2_init()4316622Ssam public modula2_init ()
4416622Ssam {
4516622Ssam mod2 = language_define("modula-2", ".mod");
4616622Ssam language_setop(mod2, L_PRINTDECL, modula2_printdecl);
4716622Ssam language_setop(mod2, L_PRINTVAL, modula2_printval);
4816622Ssam language_setop(mod2, L_TYPEMATCH, modula2_typematch);
4916622Ssam language_setop(mod2, L_BUILDAREF, modula2_buildaref);
5016622Ssam language_setop(mod2, L_EVALAREF, modula2_evalaref);
5116622Ssam language_setop(mod2, L_MODINIT, modula2_modinit);
5216622Ssam language_setop(mod2, L_HASMODULES, modula2_hasmodules);
5316622Ssam language_setop(mod2, L_PASSADDR, modula2_passaddr);
5416622Ssam initialized = false;
5516622Ssam }
5616622Ssam
5716622Ssam /*
5816622Ssam * Typematch tests if two types are compatible. The issue
5916622Ssam * is a bit complicated, so several subfunctions are used for
6016622Ssam * various kinds of compatibility.
6116622Ssam */
6216622Ssam
builtinmatch(t1,t2)6318261Slinton private boolean builtinmatch (t1, t2)
6418261Slinton register Symbol t1, t2;
6518261Slinton {
6618261Slinton boolean b;
6718261Slinton
6818261Slinton b = (boolean) (
6918261Slinton (
7018261Slinton t2 == t_int->type and t1->class == RANGE and
7118261Slinton (
7218261Slinton istypename(t1->type, "integer") or
7318261Slinton istypename(t1->type, "cardinal")
7418261Slinton )
7518261Slinton ) or (
7618261Slinton t2 == t_char->type and
7718261Slinton t1->class == RANGE and istypename(t1->type, "char")
7818261Slinton ) or (
7918261Slinton t2 == t_real->type and
8018261Slinton t1->class == RANGE and (
8118261Slinton istypename(t1->type, "real") or
8218261Slinton istypename(t1->type, "longreal")
8318261Slinton )
8418261Slinton ) or (
8518261Slinton t2 == t_boolean->type and
8618261Slinton t1->class == RANGE and istypename(t1->type, "boolean")
8718261Slinton )
8818261Slinton );
8918261Slinton return b;
9018261Slinton }
9118261Slinton
nilMatch(t1,t2)9216622Ssam private boolean nilMatch (t1, t2)
9316622Ssam register Symbol t1, t2;
9416622Ssam {
9516622Ssam boolean b;
9616622Ssam
9716622Ssam b = (boolean) (
9816622Ssam (t1 == t_nil and t2->class == PTR) or
9916622Ssam (t1->class == PTR and t2 == t_nil)
10016622Ssam );
10116622Ssam return b;
10216622Ssam }
10316622Ssam
enumMatch(t1,t2)10416622Ssam private boolean enumMatch (t1, t2)
10516622Ssam register Symbol t1, t2;
10616622Ssam {
10716622Ssam boolean b;
10816622Ssam
10916622Ssam b = (boolean) (
11018261Slinton (t1->class == SCAL and t2->class == CONST and t2->type == t1) or
11118261Slinton (t1->class == CONST and t2->class == SCAL and t1->type == t2)
11216622Ssam );
11316622Ssam return b;
11416622Ssam }
11516622Ssam
openArrayMatch(t1,t2)11616622Ssam private boolean openArrayMatch (t1, t2)
11716622Ssam register Symbol t1, t2;
11816622Ssam {
11916622Ssam boolean b;
12016622Ssam
12116622Ssam b = (boolean) (
12216622Ssam (
12333326Sdonn t1->class == OPENARRAY and t1->symvalue.ndims == 1 and
12416622Ssam t2->class == ARRAY and
12516622Ssam compatible(rtype(t2->chain)->type, t_int) and
12616622Ssam compatible(t1->type, t2->type)
12716622Ssam ) or (
12833326Sdonn t2->class == OPENARRAY and t2->symvalue.ndims == 1 and
12916622Ssam t1->class == ARRAY and
13016622Ssam compatible(rtype(t1->chain)->type, t_int) and
13116622Ssam compatible(t1->type, t2->type)
13216622Ssam )
13316622Ssam );
13416622Ssam return b;
13516622Ssam }
13616622Ssam
isConstString(t)13716622Ssam private boolean isConstString (t)
13816622Ssam register Symbol t;
13916622Ssam {
14016622Ssam boolean b;
14116622Ssam
14216622Ssam b = (boolean) (
14316622Ssam t->language == primlang and t->class == ARRAY and t->type == t_char
14416622Ssam );
14516622Ssam return b;
14616622Ssam }
14716622Ssam
stringArrayMatch(t1,t2)14816622Ssam private boolean stringArrayMatch (t1, t2)
14916622Ssam register Symbol t1, t2;
15016622Ssam {
15116622Ssam boolean b;
15216622Ssam
15316622Ssam b = (boolean) (
15416622Ssam (
15516622Ssam isConstString(t1) and
15616622Ssam t2->class == ARRAY and compatible(t2->type, t_char->type)
15716622Ssam ) or (
15816622Ssam isConstString(t2) and
15916622Ssam t1->class == ARRAY and compatible(t1->type, t_char->type)
16016622Ssam )
16116622Ssam );
16216622Ssam return b;
16316622Ssam }
16416622Ssam
modula2_typematch(type1,type2)16516622Ssam public boolean modula2_typematch (type1, type2)
16616622Ssam Symbol type1, type2;
16716622Ssam {
16818261Slinton boolean b;
16916622Ssam Symbol t1, t2, tmp;
17016622Ssam
17116622Ssam t1 = rtype(type1);
17216622Ssam t2 = rtype(type2);
17316622Ssam if (t1 == t2) {
17416622Ssam b = true;
17516622Ssam } else {
17618261Slinton if (t1 == t_char->type or t1 == t_int->type or
17718261Slinton t1 == t_real->type or t1 == t_boolean->type
17818261Slinton ) {
17916622Ssam tmp = t1;
18016622Ssam t1 = t2;
18116622Ssam t2 = tmp;
18216622Ssam }
18316622Ssam b = (Boolean) (
18433326Sdonn builtinmatch(t1, t2) or
18518261Slinton nilMatch(t1, t2) or enumMatch(t1, t2) or
18618261Slinton openArrayMatch(t1, t2) or stringArrayMatch(t1, t2)
18716622Ssam );
18816622Ssam }
18916622Ssam return b;
19016622Ssam }
19116622Ssam
19216622Ssam /*
19316622Ssam * Indent n spaces.
19416622Ssam */
19516622Ssam
indent(n)19616622Ssam private indent (n)
19716622Ssam int n;
19816622Ssam {
19916622Ssam if (n > 0) {
20016622Ssam printf("%*c", n, ' ');
20116622Ssam }
20216622Ssam }
20316622Ssam
modula2_printdecl(s)20416622Ssam public modula2_printdecl (s)
20516622Ssam Symbol s;
20616622Ssam {
20716622Ssam register Symbol t;
20816622Ssam Boolean semicolon;
20916622Ssam
21016622Ssam semicolon = true;
21116622Ssam if (s->class == TYPEREF) {
21216622Ssam resolveRef(t);
21316622Ssam }
21416622Ssam switch (s->class) {
21516622Ssam case CONST:
21616622Ssam if (s->type->class == SCAL) {
21718261Slinton semicolon = false;
21818261Slinton printf("enumeration constant with value ");
21918261Slinton eval(s->symvalue.constval);
22018261Slinton modula2_printval(s);
22116622Ssam } else {
22216622Ssam printf("const %s = ", symname(s));
22318261Slinton eval(s->symvalue.constval);
22416622Ssam modula2_printval(s);
22516622Ssam }
22616622Ssam break;
22716622Ssam
22816622Ssam case TYPE:
22916622Ssam printf("type %s = ", symname(s));
23016622Ssam printtype(s, s->type, 0);
23116622Ssam break;
23216622Ssam
23316622Ssam case TYPEREF:
23416622Ssam printf("type %s", symname(s));
23516622Ssam break;
23616622Ssam
23716622Ssam case VAR:
23816622Ssam if (isparam(s)) {
23916622Ssam printf("(parameter) %s : ", symname(s));
24016622Ssam } else {
24116622Ssam printf("var %s : ", symname(s));
24216622Ssam }
24316622Ssam printtype(s, s->type, 0);
24416622Ssam break;
24516622Ssam
24616622Ssam case REF:
24716622Ssam printf("(var parameter) %s : ", symname(s));
24816622Ssam printtype(s, s->type, 0);
24916622Ssam break;
25016622Ssam
25116622Ssam case RANGE:
25216622Ssam case ARRAY:
25333326Sdonn case OPENARRAY:
25418261Slinton case DYNARRAY:
25518261Slinton case SUBARRAY:
25616622Ssam case RECORD:
25716622Ssam case VARNT:
25816622Ssam case PTR:
25916622Ssam printtype(s, s, 0);
26016622Ssam semicolon = false;
26116622Ssam break;
26216622Ssam
26316622Ssam case FVAR:
26416622Ssam printf("(function variable) %s : ", symname(s));
26516622Ssam printtype(s, s->type, 0);
26616622Ssam break;
26716622Ssam
26816622Ssam case FIELD:
26916622Ssam printf("(field) %s : ", symname(s));
27016622Ssam printtype(s, s->type, 0);
27116622Ssam break;
27216622Ssam
27316622Ssam case PROC:
27416622Ssam printf("procedure %s", symname(s));
27516622Ssam listparams(s);
27616622Ssam break;
27716622Ssam
27816622Ssam case PROG:
27916622Ssam printf("program %s", symname(s));
28016622Ssam listparams(s);
28116622Ssam break;
28216622Ssam
28316622Ssam case FUNC:
28418261Slinton printf("procedure %s", symname(s));
28516622Ssam listparams(s);
28616622Ssam printf(" : ");
28716622Ssam printtype(s, s->type, 0);
28816622Ssam break;
28916622Ssam
29016622Ssam case MODULE:
29116622Ssam printf("module %s", symname(s));
29216622Ssam break;
29316622Ssam
29416622Ssam default:
29518261Slinton printf("[%s]", classname(s));
29616622Ssam break;
29716622Ssam }
29816622Ssam if (semicolon) {
29916622Ssam putchar(';');
30016622Ssam }
30116622Ssam putchar('\n');
30216622Ssam }
30316622Ssam
30416622Ssam /*
30516622Ssam * Recursive whiz-bang procedure to print the type portion
30616622Ssam * of a declaration.
30716622Ssam *
30816622Ssam * The symbol associated with the type is passed to allow
30916622Ssam * searching for type names without getting "type blah = blah".
31016622Ssam */
31116622Ssam
printtype(s,t,n)31216622Ssam private printtype (s, t, n)
31316622Ssam Symbol s;
31416622Ssam Symbol t;
31516622Ssam int n;
31616622Ssam {
31718261Slinton Symbol tmp;
31818261Slinton int i;
31916622Ssam
32016622Ssam if (t->class == TYPEREF) {
32116622Ssam resolveRef(t);
32216622Ssam }
32316622Ssam switch (t->class) {
32416622Ssam case VAR:
32516622Ssam case CONST:
32616622Ssam case FUNC:
32716622Ssam case PROC:
32816622Ssam panic("printtype: class %s", classname(t));
32916622Ssam break;
33016622Ssam
33116622Ssam case ARRAY:
33216622Ssam printf("array[");
33316622Ssam tmp = t->chain;
33416622Ssam if (tmp != nil) {
33516622Ssam for (;;) {
33616622Ssam printtype(tmp, tmp, n);
33716622Ssam tmp = tmp->chain;
33816622Ssam if (tmp == nil) {
33916622Ssam break;
34016622Ssam }
34116622Ssam printf(", ");
34216622Ssam }
34316622Ssam }
34416622Ssam printf("] of ");
34516622Ssam printtype(t, t->type, n);
34616622Ssam break;
34716622Ssam
34833326Sdonn case OPENARRAY:
34933326Sdonn printf("array of ");
35033326Sdonn for (i = 1; i < t->symvalue.ndims; i++) {
35133326Sdonn printf("array of ");
35233326Sdonn }
35333326Sdonn printtype(t, t->type, n);
35433326Sdonn break;
35533326Sdonn
35618261Slinton case DYNARRAY:
35718261Slinton printf("dynarray of ");
35818261Slinton for (i = 1; i < t->symvalue.ndims; i++) {
35918261Slinton printf("array of ");
36018261Slinton }
36118261Slinton printtype(t, t->type, n);
36218261Slinton break;
36318261Slinton
36418261Slinton case SUBARRAY:
36518261Slinton printf("subarray of ");
36618261Slinton for (i = 1; i < t->symvalue.ndims; i++) {
36718261Slinton printf("array of ");
36818261Slinton }
36918261Slinton printtype(t, t->type, n);
37018261Slinton break;
37118261Slinton
37216622Ssam case RECORD:
37316622Ssam printRecordDecl(t, n);
37416622Ssam break;
37516622Ssam
37616622Ssam case FIELD:
37716622Ssam if (t->chain != nil) {
37816622Ssam printtype(t->chain, t->chain, n);
37916622Ssam }
38016622Ssam printf("\t%s : ", symname(t));
38116622Ssam printtype(t, t->type, n);
38216622Ssam printf(";\n");
38316622Ssam break;
38416622Ssam
38516622Ssam case RANGE:
38616622Ssam printRangeDecl(t);
38716622Ssam break;
38816622Ssam
38916622Ssam case PTR:
39016622Ssam printf("pointer to ");
39116622Ssam printtype(t, t->type, n);
39216622Ssam break;
39316622Ssam
39416622Ssam case TYPE:
39516622Ssam if (t->name != nil and ident(t->name)[0] != '\0') {
39616622Ssam printname(stdout, t);
39716622Ssam } else {
39816622Ssam printtype(t, t->type, n);
39916622Ssam }
40016622Ssam break;
40116622Ssam
40216622Ssam case SCAL:
40316622Ssam printEnumDecl(t, n);
40416622Ssam break;
40516622Ssam
40616622Ssam case SET:
40716622Ssam printf("set of ");
40816622Ssam printtype(t, t->type, n);
40916622Ssam break;
41016622Ssam
41116622Ssam case TYPEREF:
41216622Ssam break;
41316622Ssam
41418261Slinton case FPROC:
41518261Slinton case FFUNC:
41618261Slinton printf("procedure");
41718261Slinton break;
41818261Slinton
41916622Ssam default:
42018261Slinton printf("[%s]", classname(t));
42116622Ssam break;
42216622Ssam }
42316622Ssam }
42416622Ssam
42516622Ssam /*
42616622Ssam * Print out a record declaration.
42716622Ssam */
42816622Ssam
printRecordDecl(t,n)42916622Ssam private printRecordDecl (t, n)
43016622Ssam Symbol t;
43116622Ssam int n;
43216622Ssam {
43316622Ssam register Symbol f;
43416622Ssam
43516622Ssam if (t->chain == nil) {
43616622Ssam printf("record end");
43716622Ssam } else {
43816622Ssam printf("record\n");
43916622Ssam for (f = t->chain; f != nil; f = f->chain) {
44016622Ssam indent(n+4);
44116622Ssam printf("%s : ", symname(f));
44216622Ssam printtype(f->type, f->type, n+4);
44316622Ssam printf(";\n");
44416622Ssam }
44516622Ssam indent(n);
44616622Ssam printf("end");
44716622Ssam }
44816622Ssam }
44916622Ssam
45016622Ssam /*
45116622Ssam * Print out the declaration of a range type.
45216622Ssam */
45316622Ssam
printRangeDecl(t)45416622Ssam private printRangeDecl (t)
45516622Ssam Symbol t;
45616622Ssam {
45716622Ssam long r0, r1;
45816622Ssam
45916622Ssam r0 = t->symvalue.rangev.lower;
46016622Ssam r1 = t->symvalue.rangev.upper;
46118261Slinton if (ischar(t)) {
46216622Ssam if (r0 < 0x20 or r0 > 0x7e) {
46316622Ssam printf("%ld..", r0);
46416622Ssam } else {
46516622Ssam printf("'%c'..", (char) r0);
46616622Ssam }
46716622Ssam if (r1 < 0x20 or r1 > 0x7e) {
46816622Ssam printf("\\%lo", r1);
46916622Ssam } else {
47016622Ssam printf("'%c'", (char) r1);
47116622Ssam }
47216622Ssam } else if (r0 > 0 and r1 == 0) {
47316622Ssam printf("%ld byte real", r0);
47416622Ssam } else if (r0 >= 0) {
47516622Ssam printf("%lu..%lu", r0, r1);
47616622Ssam } else {
47716622Ssam printf("%ld..%ld", r0, r1);
47816622Ssam }
47916622Ssam }
48016622Ssam
48116622Ssam /*
48216622Ssam * Print out an enumeration declaration.
48316622Ssam */
48416622Ssam
printEnumDecl(e,n)48516622Ssam private printEnumDecl (e, n)
48616622Ssam Symbol e;
48716622Ssam int n;
48816622Ssam {
48916622Ssam Symbol t;
49016622Ssam
49116622Ssam printf("(");
49216622Ssam t = e->chain;
49316622Ssam if (t != nil) {
49416622Ssam printf("%s", symname(t));
49516622Ssam t = t->chain;
49616622Ssam while (t != nil) {
49716622Ssam printf(", %s", symname(t));
49816622Ssam t = t->chain;
49916622Ssam }
50016622Ssam }
50116622Ssam printf(")");
50216622Ssam }
50316622Ssam
50416622Ssam /*
50516622Ssam * List the parameters of a procedure or function.
50616622Ssam * No attempt is made to combine like types.
50716622Ssam */
50816622Ssam
listparams(s)50916622Ssam private listparams (s)
51016622Ssam Symbol s;
51116622Ssam {
51216622Ssam Symbol t;
51316622Ssam
51416622Ssam if (s->chain != nil) {
51516622Ssam putchar('(');
51616622Ssam for (t = s->chain; t != nil; t = t->chain) {
51716622Ssam switch (t->class) {
51816622Ssam case REF:
51916622Ssam printf("var ");
52016622Ssam break;
52116622Ssam
52216622Ssam case FPROC:
52316622Ssam case FFUNC:
52416622Ssam printf("procedure ");
52516622Ssam break;
52616622Ssam
52716622Ssam case VAR:
52816622Ssam break;
52916622Ssam
53016622Ssam default:
53116622Ssam panic("unexpected class %d for parameter", t->class);
53216622Ssam }
53316622Ssam printf("%s", symname(t));
53416622Ssam if (s->class == PROG) {
53516622Ssam printf(", ");
53616622Ssam } else {
53716622Ssam printf(" : ");
53816622Ssam printtype(t, t->type, 0);
53916622Ssam if (t->chain != nil) {
54016622Ssam printf("; ");
54116622Ssam }
54216622Ssam }
54316622Ssam }
54416622Ssam putchar(')');
54516622Ssam }
54616622Ssam }
54716622Ssam
54816622Ssam /*
54918261Slinton * Test if a pointer type should be treated as a null-terminated string.
55018261Slinton * The type given is the type that is pointed to.
55118261Slinton */
55218261Slinton
isCstring(type)55318261Slinton private boolean isCstring (type)
55418261Slinton Symbol type;
55518261Slinton {
55618261Slinton boolean b;
55718261Slinton register Symbol a, t;
55818261Slinton
55918261Slinton a = rtype(type);
56018261Slinton if (a->class == ARRAY) {
56118261Slinton t = rtype(a->chain);
56218261Slinton b = (boolean) (
56318261Slinton t->class == RANGE and istypename(a->type, "char") and
56418261Slinton (t->symvalue.rangev.upper - t->symvalue.rangev.lower + 1) <= 0
56518261Slinton );
56618261Slinton } else {
56718261Slinton b = false;
56818261Slinton }
56918261Slinton return b;
57018261Slinton }
57118261Slinton
57218261Slinton /*
57316622Ssam * Modula 2 interface to printval.
57416622Ssam */
57516622Ssam
modula2_printval(s)57616622Ssam public modula2_printval (s)
57716622Ssam Symbol s;
57816622Ssam {
57916622Ssam prval(s, size(s));
58016622Ssam }
58116622Ssam
58216622Ssam /*
58316622Ssam * Print out the value on the top of the expression stack
58416622Ssam * in the format for the type of the given symbol, assuming
58516622Ssam * the size of the object is n bytes.
58616622Ssam */
58716622Ssam
prval(s,n)58816622Ssam private prval (s, n)
58916622Ssam Symbol s;
59016622Ssam integer n;
59116622Ssam {
59216622Ssam Symbol t;
59316622Ssam Address a;
59416622Ssam integer len;
59516622Ssam double r;
59618261Slinton integer i;
59716622Ssam
59816622Ssam if (s->class == TYPEREF) {
59916622Ssam resolveRef(s);
60016622Ssam }
60116622Ssam switch (s->class) {
60216622Ssam case CONST:
60316622Ssam case TYPE:
60418261Slinton case REF:
60516622Ssam case VAR:
60616622Ssam case FVAR:
60716622Ssam case TAG:
60816622Ssam prval(s->type, n);
60916622Ssam break;
61016622Ssam
61118261Slinton case FIELD:
61218261Slinton if (isbitfield(s)) {
61333326Sdonn i = extractField(s);
61418261Slinton t = rtype(s->type);
61518261Slinton if (t->class == SCAL) {
61618261Slinton printEnum(i, t);
61718261Slinton } else {
61818261Slinton printRangeVal(i, t);
61918261Slinton }
62018261Slinton } else {
62118261Slinton prval(s->type, n);
62218261Slinton }
62318261Slinton break;
62418261Slinton
62516622Ssam case ARRAY:
62616622Ssam t = rtype(s->type);
62718261Slinton if (ischar(t)) {
62816622Ssam len = size(s);
62916622Ssam sp -= len;
63018261Slinton printf("\"%.*s\"", len, sp);
63116622Ssam break;
63216622Ssam } else {
63316622Ssam printarray(s);
63416622Ssam }
63516622Ssam break;
63616622Ssam
63733326Sdonn case OPENARRAY:
63818261Slinton case DYNARRAY:
63918261Slinton printDynarray(s);
64018261Slinton break;
64118261Slinton
64218261Slinton case SUBARRAY:
64318261Slinton printSubarray(s);
64418261Slinton break;
64518261Slinton
64616622Ssam case RECORD:
64716622Ssam printrecord(s);
64816622Ssam break;
64916622Ssam
65016622Ssam case VARNT:
65118261Slinton printf("[variant]");
65216622Ssam break;
65316622Ssam
65416622Ssam case RANGE:
65516622Ssam printrange(s, n);
65616622Ssam break;
65716622Ssam
65818261Slinton /*
65918261Slinton * Unresolved opaque type.
66018261Slinton * Probably a pointer.
66118261Slinton */
66218261Slinton case TYPEREF:
66318261Slinton a = pop(Address);
66418261Slinton printf("@%x", a);
66518261Slinton break;
66618261Slinton
66716622Ssam case FILET:
66818261Slinton a = pop(Address);
66918261Slinton if (a == 0) {
67018261Slinton printf("nil");
67118261Slinton } else {
67218261Slinton printf("0x%x", a);
67318261Slinton }
67418261Slinton break;
67518261Slinton
67616622Ssam case PTR:
67716622Ssam a = pop(Address);
67816622Ssam if (a == 0) {
67916622Ssam printf("nil");
68018261Slinton } else if (isCstring(s->type)) {
68118261Slinton printString(a, true);
68216622Ssam } else {
68316622Ssam printf("0x%x", a);
68416622Ssam }
68516622Ssam break;
68616622Ssam
68716622Ssam case SCAL:
68818261Slinton i = 0;
68918261Slinton popn(n, &i);
69018261Slinton printEnum(i, s);
69116622Ssam break;
69216622Ssam
69316622Ssam case FPROC:
69416622Ssam case FFUNC:
69516622Ssam a = pop(long);
69616622Ssam t = whatblock(a);
69716622Ssam if (t == nil) {
69818261Slinton printf("0x%x", a);
69916622Ssam } else {
70018261Slinton printname(stdout, t);
70116622Ssam }
70216622Ssam break;
70316622Ssam
70416622Ssam case SET:
70516622Ssam printSet(s);
70616622Ssam break;
70716622Ssam
70816622Ssam default:
70916622Ssam if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
71016622Ssam panic("printval: bad class %d", ord(s->class));
71116622Ssam }
71216622Ssam printf("[%s]", classname(s));
71316622Ssam break;
71416622Ssam }
71516622Ssam }
71616622Ssam
71716622Ssam /*
71818261Slinton * Print out a dynamic array.
71918261Slinton */
72018261Slinton
72118261Slinton private Address printDynSlice();
72218261Slinton
printDynarray(t)72318261Slinton private printDynarray (t)
72418261Slinton Symbol t;
72518261Slinton {
72618261Slinton Address base;
72718261Slinton integer n;
72818261Slinton Stack *savesp, *newsp;
72918261Slinton Symbol eltype;
73018261Slinton
73118261Slinton savesp = sp;
73218261Slinton sp -= (t->symvalue.ndims * sizeof(Word));
73318261Slinton base = pop(Address);
73418261Slinton newsp = sp;
73518261Slinton sp = savesp;
73618261Slinton eltype = rtype(t->type);
73718261Slinton if (t->symvalue.ndims == 0) {
73818261Slinton if (ischar(eltype)) {
73918261Slinton printString(base, true);
74018261Slinton } else {
74118261Slinton printf("[dynarray @nocount]");
74218261Slinton }
74318261Slinton } else {
74418261Slinton n = ((long *) sp)[-(t->symvalue.ndims)];
74518261Slinton base = printDynSlice(base, n, t->symvalue.ndims, eltype, size(eltype));
74618261Slinton }
74718261Slinton sp = newsp;
74818261Slinton }
74918261Slinton
75018261Slinton /*
75118261Slinton * Print out one dimension of a multi-dimension dynamic array.
75218261Slinton *
75318261Slinton * Return the address of the element that follows the printed elements.
75418261Slinton */
75518261Slinton
printDynSlice(base,count,ndims,eltype,elsize)75618261Slinton private Address printDynSlice (base, count, ndims, eltype, elsize)
75718261Slinton Address base;
75818261Slinton integer count, ndims;
75918261Slinton Symbol eltype;
76018261Slinton integer elsize;
76118261Slinton {
76218261Slinton Address b;
76318261Slinton integer i, n;
76418261Slinton char *slice;
76518261Slinton Stack *savesp;
76618261Slinton
76718261Slinton b = base;
76818261Slinton if (ndims > 1) {
76918261Slinton n = ((long *) sp)[-ndims + 1];
77018261Slinton }
77118261Slinton if (ndims == 1 and ischar(eltype)) {
77218261Slinton slice = newarr(char, count);
77318261Slinton dread(slice, b, count);
77418261Slinton printf("\"%.*s\"", count, slice);
77518261Slinton dispose(slice);
77618261Slinton b += count;
77718261Slinton } else {
77818261Slinton printf("(");
77918261Slinton for (i = 0; i < count; i++) {
78018261Slinton if (i != 0) {
78118261Slinton printf(", ");
78218261Slinton }
78318261Slinton if (ndims == 1) {
78418261Slinton slice = newarr(char, elsize);
78518261Slinton dread(slice, b, elsize);
78618261Slinton savesp = sp;
78718261Slinton sp = slice + elsize;
78818261Slinton printval(eltype);
78918261Slinton sp = savesp;
79018261Slinton dispose(slice);
79118261Slinton b += elsize;
79218261Slinton } else {
79318261Slinton b = printDynSlice(b, n, ndims - 1, eltype, elsize);
79418261Slinton }
79518261Slinton }
79618261Slinton printf(")");
79718261Slinton }
79818261Slinton return b;
79918261Slinton }
80018261Slinton
printSubarray(t)80118261Slinton private printSubarray (t)
80218261Slinton Symbol t;
80318261Slinton {
80418261Slinton printf("[subarray]");
80518261Slinton }
80618261Slinton
80718261Slinton /*
80816622Ssam * Print out the value of a scalar (non-enumeration) type.
80916622Ssam */
81016622Ssam
printrange(s,n)81116622Ssam private printrange (s, n)
81216622Ssam Symbol s;
81316622Ssam integer n;
81416622Ssam {
81516622Ssam double d;
81616622Ssam float f;
81716622Ssam integer i;
81816622Ssam
81916622Ssam if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) {
82016622Ssam if (n == sizeof(float)) {
82116622Ssam popn(n, &f);
82216622Ssam d = f;
82316622Ssam } else {
82416622Ssam popn(n, &d);
82516622Ssam }
82616622Ssam prtreal(d);
82716622Ssam } else {
82816622Ssam i = 0;
82916622Ssam popn(n, &i);
83018261Slinton printRangeVal(i, s);
83116622Ssam }
83216622Ssam }
83316622Ssam
83416622Ssam /*
83516622Ssam * Print out a set.
83616622Ssam */
83716622Ssam
printSet(s)83816622Ssam private printSet (s)
83916622Ssam Symbol s;
84016622Ssam {
84116622Ssam Symbol t;
84216622Ssam integer nbytes;
84316622Ssam
84416622Ssam nbytes = size(s);
84516622Ssam t = rtype(s->type);
84616622Ssam printf("{");
84716622Ssam sp -= nbytes;
84816622Ssam if (t->class == SCAL) {
84916622Ssam printSetOfEnum(t);
85016622Ssam } else if (t->class == RANGE) {
85116622Ssam printSetOfRange(t);
85216622Ssam } else {
85316622Ssam panic("expected range or enumerated base type for set");
85416622Ssam }
85516622Ssam printf("}");
85616622Ssam }
85716622Ssam
85816622Ssam /*
85916622Ssam * Print out a set of an enumeration.
86016622Ssam */
86116622Ssam
printSetOfEnum(t)86216622Ssam private printSetOfEnum (t)
86316622Ssam Symbol t;
86416622Ssam {
86516622Ssam register Symbol e;
86616622Ssam register integer i, j, *p;
86716622Ssam boolean first;
86816622Ssam
86916622Ssam p = (int *) sp;
87016622Ssam i = *p;
87116622Ssam j = 0;
87216622Ssam e = t->chain;
87316622Ssam first = true;
87416622Ssam while (e != nil) {
87516622Ssam if ((i&1) == 1) {
87616622Ssam if (first) {
87716622Ssam first = false;
87816622Ssam printf("%s", symname(e));
87916622Ssam } else {
88016622Ssam printf(", %s", symname(e));
88116622Ssam }
88216622Ssam }
88316622Ssam i >>= 1;
88416622Ssam ++j;
88516622Ssam if (j >= sizeof(integer)*BITSPERBYTE) {
88616622Ssam j = 0;
88716622Ssam ++p;
88816622Ssam i = *p;
88916622Ssam }
89016622Ssam e = e->chain;
89116622Ssam }
89216622Ssam }
89316622Ssam
89416622Ssam /*
89516622Ssam * Print out a set of a subrange type.
89616622Ssam */
89716622Ssam
printSetOfRange(t)89816622Ssam private printSetOfRange (t)
89916622Ssam Symbol t;
90016622Ssam {
90116622Ssam register integer i, j, *p;
90216622Ssam long v;
90316622Ssam boolean first;
90416622Ssam
90516622Ssam p = (int *) sp;
90616622Ssam i = *p;
90716622Ssam j = 0;
90816622Ssam v = t->symvalue.rangev.lower;
90916622Ssam first = true;
91016622Ssam while (v <= t->symvalue.rangev.upper) {
91116622Ssam if ((i&1) == 1) {
91216622Ssam if (first) {
91316622Ssam first = false;
91416622Ssam printf("%ld", v);
91516622Ssam } else {
91616622Ssam printf(", %ld", v);
91716622Ssam }
91816622Ssam }
91916622Ssam i >>= 1;
92016622Ssam ++j;
92116622Ssam if (j >= sizeof(integer)*BITSPERBYTE) {
92216622Ssam j = 0;
92316622Ssam ++p;
92416622Ssam i = *p;
92516622Ssam }
92616622Ssam ++v;
92716622Ssam }
92816622Ssam }
92916622Ssam
93016622Ssam /*
93118261Slinton * Construct a node for subscripting a dynamic or subarray.
93218261Slinton * The list of indices is left for processing in evalaref,
93318261Slinton * unlike normal subscripting in which the list is expanded
93418261Slinton * across individual INDEX nodes.
93518261Slinton */
93618261Slinton
dynref(a,t,slist)93718261Slinton private Node dynref (a, t, slist)
93818261Slinton Node a;
93918261Slinton Symbol t;
94018261Slinton Node slist;
94118261Slinton {
94218261Slinton Node p, r;
94318261Slinton integer n;
94418261Slinton
94518261Slinton p = slist;
94618261Slinton n = 0;
94718261Slinton while (p != nil) {
94818261Slinton if (not compatible(p->value.arg[0]->nodetype, t_int)) {
94918261Slinton suberror("subscript \"", p->value.arg[0], "\" is the wrong type");
95018261Slinton }
95118261Slinton ++n;
95218261Slinton p = p->value.arg[1];
95318261Slinton }
95418261Slinton if (n > t->symvalue.ndims and (t->symvalue.ndims != 0 or n != 1)) {
95518261Slinton suberror("too many subscripts for ", a, nil);
95618261Slinton } else if (n < t->symvalue.ndims) {
95718261Slinton suberror("not enough subscripts for ", a, nil);
95818261Slinton }
95918261Slinton r = build(O_INDEX, a, slist);
96018261Slinton r->nodetype = rtype(t->type);
96118261Slinton return r;
96218261Slinton }
96318261Slinton
96418261Slinton /*
96516622Ssam * Construct a node for subscripting.
96616622Ssam */
96716622Ssam
modula2_buildaref(a,slist)96816622Ssam public Node modula2_buildaref (a, slist)
96916622Ssam Node a, slist;
97016622Ssam {
97116622Ssam register Symbol t;
97216622Ssam register Node p;
97318261Slinton Symbol eltype;
97416622Ssam Node esub, r;
97518261Slinton integer n;
97616622Ssam
97716622Ssam t = rtype(a->nodetype);
97833326Sdonn switch (t->class) {
97933326Sdonn case OPENARRAY:
98033326Sdonn case DYNARRAY:
98133326Sdonn case SUBARRAY:
98233326Sdonn r = dynref(a, t, slist);
98333326Sdonn break;
98433326Sdonn
98533326Sdonn case ARRAY:
98633326Sdonn r = a;
98733326Sdonn eltype = rtype(t->type);
98833326Sdonn p = slist;
98933326Sdonn t = t->chain;
99033326Sdonn while (p != nil and t != nil) {
99133326Sdonn esub = p->value.arg[0];
99233326Sdonn if (not compatible(rtype(t), rtype(esub->nodetype))) {
99333326Sdonn suberror("subscript \"", esub, "\" is the wrong type");
99433326Sdonn }
99533326Sdonn r = build(O_INDEX, r, esub);
99633326Sdonn r->nodetype = eltype;
99733326Sdonn p = p->value.arg[1];
99833326Sdonn t = t->chain;
99916622Ssam }
100033326Sdonn if (p != nil) {
100133326Sdonn suberror("too many subscripts for ", a, nil);
100233326Sdonn } else if (t != nil) {
100333326Sdonn suberror("not enough subscripts for ", a, nil);
100433326Sdonn }
100533326Sdonn break;
100633326Sdonn
100733326Sdonn default:
100833326Sdonn suberror("\"", a, "\" is not an array");
100933326Sdonn break;
101016622Ssam }
101116622Ssam return r;
101216622Ssam }
101316622Ssam
101416622Ssam /*
101518261Slinton * Subscript usage error reporting.
101618261Slinton */
101718261Slinton
suberror(s1,e1,s2)101818261Slinton private suberror (s1, e1, s2)
101918261Slinton String s1, s2;
102018261Slinton Node e1;
102118261Slinton {
102218261Slinton beginerrmsg();
102318261Slinton if (s1 != nil) {
102418261Slinton fprintf(stderr, s1);
102518261Slinton }
102618261Slinton if (e1 != nil) {
102718261Slinton prtree(stderr, e1);
102818261Slinton }
102918261Slinton if (s2 != nil) {
103018261Slinton fprintf(stderr, s2);
103118261Slinton }
103218261Slinton enderrmsg();
103318261Slinton }
103418261Slinton
103518261Slinton /*
103618261Slinton * Check that a subscript value is in the appropriate range.
103718261Slinton */
103818261Slinton
subchk(value,lower,upper)103918261Slinton private subchk (value, lower, upper)
104018261Slinton long value, lower, upper;
104118261Slinton {
104218261Slinton if (value < lower or value > upper) {
104318261Slinton error("subscript value %d out of range [%d..%d]", value, lower, upper);
104418261Slinton }
104518261Slinton }
104618261Slinton
104718261Slinton /*
104818261Slinton * Compute the offset for subscripting a dynamic array.
104918261Slinton */
105018261Slinton
getdynoff(ndims,sub)105118261Slinton private getdynoff (ndims, sub)
105218261Slinton integer ndims;
105318261Slinton long *sub;
105418261Slinton {
105518261Slinton long k, off, *count;
105618261Slinton
105718261Slinton count = (long *) sp;
105818261Slinton off = 0;
105918261Slinton for (k = 0; k < ndims - 1; k++) {
106018261Slinton subchk(sub[k], 0, count[k] - 1);
106118261Slinton off += (sub[k] * count[k+1]);
106218261Slinton }
106318261Slinton subchk(sub[ndims - 1], 0, count[ndims - 1] - 1);
106418261Slinton return off + sub[ndims - 1];
106518261Slinton }
106618261Slinton
106718261Slinton /*
106818261Slinton * Compute the offset associated with a subarray.
106918261Slinton */
107018261Slinton
getsuboff(ndims,sub)107118261Slinton private getsuboff (ndims, sub)
107218261Slinton integer ndims;
107318261Slinton long *sub;
107418261Slinton {
107518261Slinton long k, off;
107618261Slinton struct subarrayinfo {
107718261Slinton long count;
107818261Slinton long mult;
107918261Slinton } *info;
108018261Slinton
108118261Slinton info = (struct subarrayinfo *) sp;
108218261Slinton off = 0;
108318261Slinton for (k = 0; k < ndims; k++) {
108418261Slinton subchk(sub[k], 0, info[k].count - 1);
108518261Slinton off += sub[k] * info[k].mult;
108618261Slinton }
108718261Slinton return off;
108818261Slinton }
108918261Slinton
109018261Slinton /*
109116622Ssam * Evaluate a subscript index.
109216622Ssam */
109316622Ssam
modula2_evalaref(s,base,i)109418261Slinton public modula2_evalaref (s, base, i)
109516622Ssam Symbol s;
109618261Slinton Address base;
109716622Ssam long i;
109816622Ssam {
109918261Slinton Symbol t;
110018261Slinton long lb, ub, off;
110118261Slinton long *sub;
110218261Slinton Address b;
110316622Ssam
110418261Slinton t = rtype(s);
110518261Slinton if (t->class == ARRAY) {
110618261Slinton findbounds(rtype(t->chain), &lb, &ub);
110718261Slinton if (i < lb or i > ub) {
110818261Slinton error("subscript %d out of range [%d..%d]", i, lb, ub);
110918261Slinton }
111018261Slinton push(long, base + (i - lb) * size(t->type));
111133326Sdonn } else if ((t->class == OPENARRAY or t->class == DYNARRAY) and
111233326Sdonn t->symvalue.ndims == 0
111333326Sdonn ) {
111418261Slinton push(long, base + i * size(t->type));
111533326Sdonn } else if (t->class == OPENARRAY or t->class == DYNARRAY or
111633326Sdonn t->class == SUBARRAY
111733326Sdonn ) {
111818261Slinton push(long, i);
111918261Slinton sub = (long *) (sp - (t->symvalue.ndims * sizeof(long)));
112018261Slinton rpush(base, size(t));
112118261Slinton sp -= (t->symvalue.ndims * sizeof(long));
112218261Slinton b = pop(Address);
112318261Slinton sp += sizeof(Address);
112418261Slinton if (t->class == SUBARRAY) {
112518261Slinton off = getsuboff(t->symvalue.ndims, sub);
112618261Slinton } else {
112718261Slinton off = getdynoff(t->symvalue.ndims, sub);
112818261Slinton }
112918261Slinton sp = (Stack *) sub;
113018261Slinton push(long, b + off * size(t->type));
113118261Slinton } else {
113218261Slinton error("[internal error: expected array in evalaref]");
113316622Ssam }
113416622Ssam }
113516622Ssam
113616622Ssam /*
113716622Ssam * Initial Modula-2 type information.
113816622Ssam */
113916622Ssam
114016622Ssam #define NTYPES 12
114116622Ssam
114216622Ssam private Symbol inittype[NTYPES + 1];
114316622Ssam
addType(n,s,lower,upper)114416622Ssam private addType (n, s, lower, upper)
114516622Ssam integer n;
114616622Ssam String s;
114716622Ssam long lower, upper;
114816622Ssam {
114916622Ssam register Symbol t;
115016622Ssam
115116622Ssam if (n > NTYPES) {
115216622Ssam panic("initial Modula-2 type number too large for '%s'", s);
115316622Ssam }
115416622Ssam t = insert(identname(s, true));
115516622Ssam t->language = mod2;
115616622Ssam t->class = TYPE;
115716622Ssam t->type = newSymbol(nil, 0, RANGE, t, nil);
115816622Ssam t->type->symvalue.rangev.lower = lower;
115916622Ssam t->type->symvalue.rangev.upper = upper;
116016622Ssam t->type->language = mod2;
116116622Ssam inittype[n] = t;
116216622Ssam }
116316622Ssam
initModTypes()116416622Ssam private initModTypes ()
116516622Ssam {
116616622Ssam addType(1, "integer", 0x80000000L, 0x7fffffffL);
116716622Ssam addType(2, "char", 0L, 255L);
116816622Ssam addType(3, "boolean", 0L, 1L);
116916622Ssam addType(4, "unsigned", 0L, 0xffffffffL);
117016622Ssam addType(5, "real", 4L, 0L);
117116622Ssam addType(6, "longreal", 8L, 0L);
117216622Ssam addType(7, "word", 0L, 0xffffffffL);
117316622Ssam addType(8, "byte", 0L, 255L);
117416622Ssam addType(9, "address", 0L, 0xffffffffL);
117516622Ssam addType(10, "file", 0L, 0xffffffffL);
117616622Ssam addType(11, "process", 0L, 0xffffffffL);
117716622Ssam addType(12, "cardinal", 0L, 0x7fffffffL);
117816622Ssam }
117916622Ssam
118016622Ssam /*
118116622Ssam * Initialize typetable.
118216622Ssam */
118316622Ssam
modula2_modinit(typetable)118416622Ssam public modula2_modinit (typetable)
118516622Ssam Symbol typetable[];
118616622Ssam {
118716622Ssam register integer i;
118816622Ssam
118916622Ssam if (not initialized) {
119016622Ssam initModTypes();
119118261Slinton initialized = true;
119216622Ssam }
119316622Ssam for (i = 1; i <= NTYPES; i++) {
119416622Ssam typetable[i] = inittype[i];
119516622Ssam }
119616622Ssam }
119716622Ssam
modula2_hasmodules()119816622Ssam public boolean modula2_hasmodules ()
119916622Ssam {
120016622Ssam return true;
120116622Ssam }
120216622Ssam
modula2_passaddr(param,exprtype)120316622Ssam public boolean modula2_passaddr (param, exprtype)
120416622Ssam Symbol param, exprtype;
120516622Ssam {
120616622Ssam return false;
120716622Ssam }
1208