xref: /csrg-svn/old/dbx/modula-2.c (revision 21613)
1*21613Sdist /*
2*21613Sdist  * Copyright (c) 1983 Regents of the University of California.
3*21613Sdist  * All rights reserved.  The Berkeley software License Agreement
4*21613Sdist  * specifies the terms and conditions for redistribution.
5*21613Sdist  */
618261Slinton 
716622Ssam #ifndef lint
8*21613Sdist static char sccsid[] = "@(#)modula-2.c	5.1 (Berkeley) 05/31/85";
9*21613Sdist #endif not lint
1016622Ssam 
1116622Ssam /*
1216622Ssam  * Modula-2 specific symbol routines.
1316622Ssam  */
1416622Ssam 
1518261Slinton static char rcsid[] = "$Header: modula-2.c,v 1.6 84/12/26 10:40:33 linton Exp $";
1618261Slinton 
1716622Ssam #include "defs.h"
1816622Ssam #include "symbols.h"
1916622Ssam #include "modula-2.h"
2016622Ssam #include "languages.h"
2116622Ssam #include "tree.h"
2216622Ssam #include "eval.h"
2316622Ssam #include "mappings.h"
2416622Ssam #include "process.h"
2516622Ssam #include "runtime.h"
2616622Ssam #include "machine.h"
2716622Ssam 
2816622Ssam #ifndef public
2916622Ssam #endif
3016622Ssam 
3116622Ssam private Language mod2;
3216622Ssam private boolean initialized;
3316622Ssam 
3418261Slinton 
3518261Slinton #define ischar(t) ( \
3618261Slinton     (t) == t_char->type or \
3718261Slinton     ((t)->class == RANGE and istypename((t)->type, "char")) \
3818261Slinton )
3918261Slinton 
4016622Ssam /*
4116622Ssam  * Initialize Modula-2 information.
4216622Ssam  */
4316622Ssam 
4416622Ssam public modula2_init ()
4516622Ssam {
4616622Ssam     mod2 = language_define("modula-2", ".mod");
4716622Ssam     language_setop(mod2, L_PRINTDECL, modula2_printdecl);
4816622Ssam     language_setop(mod2, L_PRINTVAL, modula2_printval);
4916622Ssam     language_setop(mod2, L_TYPEMATCH, modula2_typematch);
5016622Ssam     language_setop(mod2, L_BUILDAREF, modula2_buildaref);
5116622Ssam     language_setop(mod2, L_EVALAREF, modula2_evalaref);
5216622Ssam     language_setop(mod2, L_MODINIT, modula2_modinit);
5316622Ssam     language_setop(mod2, L_HASMODULES, modula2_hasmodules);
5416622Ssam     language_setop(mod2, L_PASSADDR, modula2_passaddr);
5516622Ssam     initialized = false;
5616622Ssam }
5716622Ssam 
5816622Ssam /*
5916622Ssam  * Typematch tests if two types are compatible.  The issue
6016622Ssam  * is a bit complicated, so several subfunctions are used for
6116622Ssam  * various kinds of compatibility.
6216622Ssam  */
6316622Ssam 
6418261Slinton private boolean builtinmatch (t1, t2)
6518261Slinton register Symbol t1, t2;
6618261Slinton {
6718261Slinton     boolean b;
6818261Slinton 
6918261Slinton     b = (boolean) (
7018261Slinton 	(
7118261Slinton 	    t2 == t_int->type and t1->class == RANGE and
7218261Slinton 	    (
7318261Slinton 		istypename(t1->type, "integer") or
7418261Slinton 		istypename(t1->type, "cardinal")
7518261Slinton 	    )
7618261Slinton 	) or (
7718261Slinton 	    t2 == t_char->type and
7818261Slinton 	    t1->class == RANGE and istypename(t1->type, "char")
7918261Slinton 	) or (
8018261Slinton 	    t2 == t_real->type and
8118261Slinton 	    t1->class == RANGE and (
8218261Slinton 		istypename(t1->type, "real") or
8318261Slinton 		istypename(t1->type, "longreal")
8418261Slinton 	    )
8518261Slinton 	) or (
8618261Slinton 	    t2 == t_boolean->type and
8718261Slinton 	    t1->class == RANGE and istypename(t1->type, "boolean")
8818261Slinton 	)
8918261Slinton     );
9018261Slinton     return b;
9118261Slinton }
9218261Slinton 
9318261Slinton private boolean rangematch (t1, t2)
9418261Slinton register Symbol t1, t2;
9518261Slinton {
9618261Slinton     boolean b;
9718261Slinton     register Symbol rt1, rt2;
9818261Slinton 
9918261Slinton     if (t1->class == RANGE and t2->class == RANGE) {
10018261Slinton 	b = (boolean) (
10118261Slinton 	    t1->symvalue.rangev.lower == t2->symvalue.rangev.lower and
10218261Slinton 	    t1->symvalue.rangev.upper == t2->symvalue.rangev.upper
10318261Slinton 	);
10418261Slinton     } else {
10518261Slinton 	b = false;
10618261Slinton     }
10718261Slinton     return b;
10818261Slinton }
10918261Slinton 
11016622Ssam private boolean nilMatch (t1, t2)
11116622Ssam register Symbol t1, t2;
11216622Ssam {
11316622Ssam     boolean b;
11416622Ssam 
11516622Ssam     b = (boolean) (
11616622Ssam 	(t1 == t_nil and t2->class == PTR) or
11716622Ssam 	(t1->class == PTR and t2 == t_nil)
11816622Ssam     );
11916622Ssam     return b;
12016622Ssam }
12116622Ssam 
12216622Ssam private boolean enumMatch (t1, t2)
12316622Ssam register Symbol t1, t2;
12416622Ssam {
12516622Ssam     boolean b;
12616622Ssam 
12716622Ssam     b = (boolean) (
12818261Slinton 	(t1->class == SCAL and t2->class == CONST and t2->type == t1) or
12918261Slinton 	(t1->class == CONST and t2->class == SCAL and t1->type == t2)
13016622Ssam     );
13116622Ssam     return b;
13216622Ssam }
13316622Ssam 
13416622Ssam private boolean openArrayMatch (t1, t2)
13516622Ssam register Symbol t1, t2;
13616622Ssam {
13716622Ssam     boolean b;
13816622Ssam 
13916622Ssam     b = (boolean) (
14016622Ssam 	(
14118261Slinton 	    t1->class == DYNARRAY and t1->symvalue.ndims == 1 and
14216622Ssam 	    t2->class == ARRAY and
14316622Ssam 	    compatible(rtype(t2->chain)->type, t_int) and
14416622Ssam 	    compatible(t1->type, t2->type)
14516622Ssam 	) or (
14618261Slinton 	    t2->class == DYNARRAY and t2->symvalue.ndims == 1 and
14716622Ssam 	    t1->class == ARRAY and
14816622Ssam 	    compatible(rtype(t1->chain)->type, t_int) and
14916622Ssam 	    compatible(t1->type, t2->type)
15016622Ssam 	)
15116622Ssam     );
15216622Ssam     return b;
15316622Ssam }
15416622Ssam 
15516622Ssam private boolean isConstString (t)
15616622Ssam register Symbol t;
15716622Ssam {
15816622Ssam     boolean b;
15916622Ssam 
16016622Ssam     b = (boolean) (
16116622Ssam 	t->language == primlang and t->class == ARRAY and t->type == t_char
16216622Ssam     );
16316622Ssam     return b;
16416622Ssam }
16516622Ssam 
16616622Ssam private boolean stringArrayMatch (t1, t2)
16716622Ssam register Symbol t1, t2;
16816622Ssam {
16916622Ssam     boolean b;
17016622Ssam 
17116622Ssam     b = (boolean) (
17216622Ssam 	(
17316622Ssam 	    isConstString(t1) and
17416622Ssam 	    t2->class == ARRAY and compatible(t2->type, t_char->type)
17516622Ssam 	) or (
17616622Ssam 	    isConstString(t2) and
17716622Ssam 	    t1->class == ARRAY and compatible(t1->type, t_char->type)
17816622Ssam 	)
17916622Ssam     );
18016622Ssam     return b;
18116622Ssam }
18216622Ssam 
18316622Ssam public boolean modula2_typematch (type1, type2)
18416622Ssam Symbol type1, type2;
18516622Ssam {
18618261Slinton     boolean b;
18716622Ssam     Symbol t1, t2, tmp;
18816622Ssam 
18916622Ssam     t1 = rtype(type1);
19016622Ssam     t2 = rtype(type2);
19116622Ssam     if (t1 == t2) {
19216622Ssam 	b = true;
19316622Ssam     } else {
19418261Slinton 	if (t1 == t_char->type or t1 == t_int->type or
19518261Slinton 	    t1 == t_real->type or t1 == t_boolean->type
19618261Slinton 	) {
19716622Ssam 	    tmp = t1;
19816622Ssam 	    t1 = t2;
19916622Ssam 	    t2 = tmp;
20016622Ssam 	}
20116622Ssam 	b = (Boolean) (
20218261Slinton 	    builtinmatch(t1, t2) or rangematch(t1, t2) or
20318261Slinton 	    nilMatch(t1, t2) or enumMatch(t1, t2) or
20418261Slinton 	    openArrayMatch(t1, t2) or stringArrayMatch(t1, t2)
20516622Ssam 	);
20616622Ssam     }
20716622Ssam     return b;
20816622Ssam }
20916622Ssam 
21016622Ssam /*
21116622Ssam  * Indent n spaces.
21216622Ssam  */
21316622Ssam 
21416622Ssam private indent (n)
21516622Ssam int n;
21616622Ssam {
21716622Ssam     if (n > 0) {
21816622Ssam 	printf("%*c", n, ' ');
21916622Ssam     }
22016622Ssam }
22116622Ssam 
22216622Ssam public modula2_printdecl (s)
22316622Ssam Symbol s;
22416622Ssam {
22516622Ssam     register Symbol t;
22616622Ssam     Boolean semicolon;
22716622Ssam 
22816622Ssam     semicolon = true;
22916622Ssam     if (s->class == TYPEREF) {
23016622Ssam 	resolveRef(t);
23116622Ssam     }
23216622Ssam     switch (s->class) {
23316622Ssam 	case CONST:
23416622Ssam 	    if (s->type->class == SCAL) {
23518261Slinton 		semicolon = false;
23618261Slinton 		printf("enumeration constant with value ");
23718261Slinton 		eval(s->symvalue.constval);
23818261Slinton 		modula2_printval(s);
23916622Ssam 	    } else {
24016622Ssam 		printf("const %s = ", symname(s));
24118261Slinton 		eval(s->symvalue.constval);
24216622Ssam 		modula2_printval(s);
24316622Ssam 	    }
24416622Ssam 	    break;
24516622Ssam 
24616622Ssam 	case TYPE:
24716622Ssam 	    printf("type %s = ", symname(s));
24816622Ssam 	    printtype(s, s->type, 0);
24916622Ssam 	    break;
25016622Ssam 
25116622Ssam 	case TYPEREF:
25216622Ssam 	    printf("type %s", symname(s));
25316622Ssam 	    break;
25416622Ssam 
25516622Ssam 	case VAR:
25616622Ssam 	    if (isparam(s)) {
25716622Ssam 		printf("(parameter) %s : ", symname(s));
25816622Ssam 	    } else {
25916622Ssam 		printf("var %s : ", symname(s));
26016622Ssam 	    }
26116622Ssam 	    printtype(s, s->type, 0);
26216622Ssam 	    break;
26316622Ssam 
26416622Ssam 	case REF:
26516622Ssam 	    printf("(var parameter) %s : ", symname(s));
26616622Ssam 	    printtype(s, s->type, 0);
26716622Ssam 	    break;
26816622Ssam 
26916622Ssam 	case RANGE:
27016622Ssam 	case ARRAY:
27118261Slinton 	case DYNARRAY:
27218261Slinton 	case SUBARRAY:
27316622Ssam 	case RECORD:
27416622Ssam 	case VARNT:
27516622Ssam 	case PTR:
27616622Ssam 	    printtype(s, s, 0);
27716622Ssam 	    semicolon = false;
27816622Ssam 	    break;
27916622Ssam 
28016622Ssam 	case FVAR:
28116622Ssam 	    printf("(function variable) %s : ", symname(s));
28216622Ssam 	    printtype(s, s->type, 0);
28316622Ssam 	    break;
28416622Ssam 
28516622Ssam 	case FIELD:
28616622Ssam 	    printf("(field) %s : ", symname(s));
28716622Ssam 	    printtype(s, s->type, 0);
28816622Ssam 	    break;
28916622Ssam 
29016622Ssam 	case PROC:
29116622Ssam 	    printf("procedure %s", symname(s));
29216622Ssam 	    listparams(s);
29316622Ssam 	    break;
29416622Ssam 
29516622Ssam 	case PROG:
29616622Ssam 	    printf("program %s", symname(s));
29716622Ssam 	    listparams(s);
29816622Ssam 	    break;
29916622Ssam 
30016622Ssam 	case FUNC:
30118261Slinton 	    printf("procedure %s", symname(s));
30216622Ssam 	    listparams(s);
30316622Ssam 	    printf(" : ");
30416622Ssam 	    printtype(s, s->type, 0);
30516622Ssam 	    break;
30616622Ssam 
30716622Ssam 	case MODULE:
30816622Ssam 	    printf("module %s", symname(s));
30916622Ssam 	    break;
31016622Ssam 
31116622Ssam 	default:
31218261Slinton 	    printf("[%s]", classname(s));
31316622Ssam 	    break;
31416622Ssam     }
31516622Ssam     if (semicolon) {
31616622Ssam 	putchar(';');
31716622Ssam     }
31816622Ssam     putchar('\n');
31916622Ssam }
32016622Ssam 
32116622Ssam /*
32216622Ssam  * Recursive whiz-bang procedure to print the type portion
32316622Ssam  * of a declaration.
32416622Ssam  *
32516622Ssam  * The symbol associated with the type is passed to allow
32616622Ssam  * searching for type names without getting "type blah = blah".
32716622Ssam  */
32816622Ssam 
32916622Ssam private printtype (s, t, n)
33016622Ssam Symbol s;
33116622Ssam Symbol t;
33216622Ssam int n;
33316622Ssam {
33418261Slinton     Symbol tmp;
33518261Slinton     int i;
33616622Ssam 
33716622Ssam     if (t->class == TYPEREF) {
33816622Ssam 	resolveRef(t);
33916622Ssam     }
34016622Ssam     switch (t->class) {
34116622Ssam 	case VAR:
34216622Ssam 	case CONST:
34316622Ssam 	case FUNC:
34416622Ssam 	case PROC:
34516622Ssam 	    panic("printtype: class %s", classname(t));
34616622Ssam 	    break;
34716622Ssam 
34816622Ssam 	case ARRAY:
34916622Ssam 	    printf("array[");
35016622Ssam 	    tmp = t->chain;
35116622Ssam 	    if (tmp != nil) {
35216622Ssam 		for (;;) {
35316622Ssam 		    printtype(tmp, tmp, n);
35416622Ssam 		    tmp = tmp->chain;
35516622Ssam 		    if (tmp == nil) {
35616622Ssam 			break;
35716622Ssam 		    }
35816622Ssam 		    printf(", ");
35916622Ssam 		}
36016622Ssam 	    }
36116622Ssam 	    printf("] of ");
36216622Ssam 	    printtype(t, t->type, n);
36316622Ssam 	    break;
36416622Ssam 
36518261Slinton 	case DYNARRAY:
36618261Slinton 	    printf("dynarray of ");
36718261Slinton 	    for (i = 1; i < t->symvalue.ndims; i++) {
36818261Slinton 		printf("array of ");
36918261Slinton 	    }
37018261Slinton 	    printtype(t, t->type, n);
37118261Slinton 	    break;
37218261Slinton 
37318261Slinton 	case SUBARRAY:
37418261Slinton 	    printf("subarray of ");
37518261Slinton 	    for (i = 1; i < t->symvalue.ndims; i++) {
37618261Slinton 		printf("array of ");
37718261Slinton 	    }
37818261Slinton 	    printtype(t, t->type, n);
37918261Slinton 	    break;
38018261Slinton 
38116622Ssam 	case RECORD:
38216622Ssam 	    printRecordDecl(t, n);
38316622Ssam 	    break;
38416622Ssam 
38516622Ssam 	case FIELD:
38616622Ssam 	    if (t->chain != nil) {
38716622Ssam 		printtype(t->chain, t->chain, n);
38816622Ssam 	    }
38916622Ssam 	    printf("\t%s : ", symname(t));
39016622Ssam 	    printtype(t, t->type, n);
39116622Ssam 	    printf(";\n");
39216622Ssam 	    break;
39316622Ssam 
39416622Ssam 	case RANGE:
39516622Ssam 	    printRangeDecl(t);
39616622Ssam 	    break;
39716622Ssam 
39816622Ssam 	case PTR:
39916622Ssam 	    printf("pointer to ");
40016622Ssam 	    printtype(t, t->type, n);
40116622Ssam 	    break;
40216622Ssam 
40316622Ssam 	case TYPE:
40416622Ssam 	    if (t->name != nil and ident(t->name)[0] != '\0') {
40516622Ssam 		printname(stdout, t);
40616622Ssam 	    } else {
40716622Ssam 		printtype(t, t->type, n);
40816622Ssam 	    }
40916622Ssam 	    break;
41016622Ssam 
41116622Ssam 	case SCAL:
41216622Ssam 	    printEnumDecl(t, n);
41316622Ssam 	    break;
41416622Ssam 
41516622Ssam 	case SET:
41616622Ssam 	    printf("set of ");
41716622Ssam 	    printtype(t, t->type, n);
41816622Ssam 	    break;
41916622Ssam 
42016622Ssam 	case TYPEREF:
42116622Ssam 	    break;
42216622Ssam 
42318261Slinton 	case FPROC:
42418261Slinton 	case FFUNC:
42518261Slinton 	    printf("procedure");
42618261Slinton 	    break;
42718261Slinton 
42816622Ssam 	default:
42918261Slinton 	    printf("[%s]", classname(t));
43016622Ssam 	    break;
43116622Ssam     }
43216622Ssam }
43316622Ssam 
43416622Ssam /*
43516622Ssam  * Print out a record declaration.
43616622Ssam  */
43716622Ssam 
43816622Ssam private printRecordDecl (t, n)
43916622Ssam Symbol t;
44016622Ssam int n;
44116622Ssam {
44216622Ssam     register Symbol f;
44316622Ssam 
44416622Ssam     if (t->chain == nil) {
44516622Ssam 	printf("record end");
44616622Ssam     } else {
44716622Ssam 	printf("record\n");
44816622Ssam 	for (f = t->chain; f != nil; f = f->chain) {
44916622Ssam 	    indent(n+4);
45016622Ssam 	    printf("%s : ", symname(f));
45116622Ssam 	    printtype(f->type, f->type, n+4);
45216622Ssam 	    printf(";\n");
45316622Ssam 	}
45416622Ssam 	indent(n);
45516622Ssam 	printf("end");
45616622Ssam     }
45716622Ssam }
45816622Ssam 
45916622Ssam /*
46016622Ssam  * Print out the declaration of a range type.
46116622Ssam  */
46216622Ssam 
46316622Ssam private printRangeDecl (t)
46416622Ssam Symbol t;
46516622Ssam {
46616622Ssam     long r0, r1;
46716622Ssam 
46816622Ssam     r0 = t->symvalue.rangev.lower;
46916622Ssam     r1 = t->symvalue.rangev.upper;
47018261Slinton     if (ischar(t)) {
47116622Ssam 	if (r0 < 0x20 or r0 > 0x7e) {
47216622Ssam 	    printf("%ld..", r0);
47316622Ssam 	} else {
47416622Ssam 	    printf("'%c'..", (char) r0);
47516622Ssam 	}
47616622Ssam 	if (r1 < 0x20 or r1 > 0x7e) {
47716622Ssam 	    printf("\\%lo", r1);
47816622Ssam 	} else {
47916622Ssam 	    printf("'%c'", (char) r1);
48016622Ssam 	}
48116622Ssam     } else if (r0 > 0 and r1 == 0) {
48216622Ssam 	printf("%ld byte real", r0);
48316622Ssam     } else if (r0 >= 0) {
48416622Ssam 	printf("%lu..%lu", r0, r1);
48516622Ssam     } else {
48616622Ssam 	printf("%ld..%ld", r0, r1);
48716622Ssam     }
48816622Ssam }
48916622Ssam 
49016622Ssam /*
49116622Ssam  * Print out an enumeration declaration.
49216622Ssam  */
49316622Ssam 
49416622Ssam private printEnumDecl (e, n)
49516622Ssam Symbol e;
49616622Ssam int n;
49716622Ssam {
49816622Ssam     Symbol t;
49916622Ssam 
50016622Ssam     printf("(");
50116622Ssam     t = e->chain;
50216622Ssam     if (t != nil) {
50316622Ssam 	printf("%s", symname(t));
50416622Ssam 	t = t->chain;
50516622Ssam 	while (t != nil) {
50616622Ssam 	    printf(", %s", symname(t));
50716622Ssam 	    t = t->chain;
50816622Ssam 	}
50916622Ssam     }
51016622Ssam     printf(")");
51116622Ssam }
51216622Ssam 
51316622Ssam /*
51416622Ssam  * List the parameters of a procedure or function.
51516622Ssam  * No attempt is made to combine like types.
51616622Ssam  */
51716622Ssam 
51816622Ssam private listparams (s)
51916622Ssam Symbol s;
52016622Ssam {
52116622Ssam     Symbol t;
52216622Ssam 
52316622Ssam     if (s->chain != nil) {
52416622Ssam 	putchar('(');
52516622Ssam 	for (t = s->chain; t != nil; t = t->chain) {
52616622Ssam 	    switch (t->class) {
52716622Ssam 		case REF:
52816622Ssam 		    printf("var ");
52916622Ssam 		    break;
53016622Ssam 
53116622Ssam 		case FPROC:
53216622Ssam 		case FFUNC:
53316622Ssam 		    printf("procedure ");
53416622Ssam 		    break;
53516622Ssam 
53616622Ssam 		case VAR:
53716622Ssam 		    break;
53816622Ssam 
53916622Ssam 		default:
54016622Ssam 		    panic("unexpected class %d for parameter", t->class);
54116622Ssam 	    }
54216622Ssam 	    printf("%s", symname(t));
54316622Ssam 	    if (s->class == PROG) {
54416622Ssam 		printf(", ");
54516622Ssam 	    } else {
54616622Ssam 		printf(" : ");
54716622Ssam 		printtype(t, t->type, 0);
54816622Ssam 		if (t->chain != nil) {
54916622Ssam 		    printf("; ");
55016622Ssam 		}
55116622Ssam 	    }
55216622Ssam 	}
55316622Ssam 	putchar(')');
55416622Ssam     }
55516622Ssam }
55616622Ssam 
55716622Ssam /*
55818261Slinton  * Test if a pointer type should be treated as a null-terminated string.
55918261Slinton  * The type given is the type that is pointed to.
56018261Slinton  */
56118261Slinton 
56218261Slinton private boolean isCstring (type)
56318261Slinton Symbol type;
56418261Slinton {
56518261Slinton     boolean b;
56618261Slinton     register Symbol a, t;
56718261Slinton 
56818261Slinton     a = rtype(type);
56918261Slinton     if (a->class == ARRAY) {
57018261Slinton 	t = rtype(a->chain);
57118261Slinton 	b = (boolean) (
57218261Slinton 	    t->class == RANGE and istypename(a->type, "char") and
57318261Slinton 	    (t->symvalue.rangev.upper - t->symvalue.rangev.lower + 1) <= 0
57418261Slinton 	);
57518261Slinton     } else {
57618261Slinton 	b = false;
57718261Slinton     }
57818261Slinton     return b;
57918261Slinton }
58018261Slinton 
58118261Slinton /*
58216622Ssam  * Modula 2 interface to printval.
58316622Ssam  */
58416622Ssam 
58516622Ssam public modula2_printval (s)
58616622Ssam Symbol s;
58716622Ssam {
58816622Ssam     prval(s, size(s));
58916622Ssam }
59016622Ssam 
59116622Ssam /*
59216622Ssam  * Print out the value on the top of the expression stack
59316622Ssam  * in the format for the type of the given symbol, assuming
59416622Ssam  * the size of the object is n bytes.
59516622Ssam  */
59616622Ssam 
59716622Ssam private prval (s, n)
59816622Ssam Symbol s;
59916622Ssam integer n;
60016622Ssam {
60116622Ssam     Symbol t;
60216622Ssam     Address a;
60316622Ssam     integer len;
60416622Ssam     double r;
60518261Slinton     integer i;
60616622Ssam 
60716622Ssam     if (s->class == TYPEREF) {
60816622Ssam 	resolveRef(s);
60916622Ssam     }
61016622Ssam     switch (s->class) {
61116622Ssam 	case CONST:
61216622Ssam 	case TYPE:
61318261Slinton 	case REF:
61416622Ssam 	case VAR:
61516622Ssam 	case FVAR:
61616622Ssam 	case TAG:
61716622Ssam 	    prval(s->type, n);
61816622Ssam 	    break;
61916622Ssam 
62018261Slinton 	case FIELD:
62118261Slinton 	    if (isbitfield(s)) {
62218261Slinton 		i = 0;
62318261Slinton 		popn(size(s), &i);
62418261Slinton 		i >>= (s->symvalue.field.offset mod BITSPERBYTE);
62518261Slinton 		i &= ((1 << s->symvalue.field.length) - 1);
62618261Slinton 		t = rtype(s->type);
62718261Slinton 		if (t->class == SCAL) {
62818261Slinton 		    printEnum(i, t);
62918261Slinton 		} else {
63018261Slinton 		    printRangeVal(i, t);
63118261Slinton 		}
63218261Slinton 	    } else {
63318261Slinton 		prval(s->type, n);
63418261Slinton 	    }
63518261Slinton 	    break;
63618261Slinton 
63716622Ssam 	case ARRAY:
63816622Ssam 	    t = rtype(s->type);
63918261Slinton 	    if (ischar(t)) {
64016622Ssam 		len = size(s);
64116622Ssam 		sp -= len;
64218261Slinton 		printf("\"%.*s\"", len, sp);
64316622Ssam 		break;
64416622Ssam 	    } else {
64516622Ssam 		printarray(s);
64616622Ssam 	    }
64716622Ssam 	    break;
64816622Ssam 
64918261Slinton 	case DYNARRAY:
65018261Slinton 	    printDynarray(s);
65118261Slinton 	    break;
65218261Slinton 
65318261Slinton 	case SUBARRAY:
65418261Slinton 	    printSubarray(s);
65518261Slinton 	    break;
65618261Slinton 
65716622Ssam 	case RECORD:
65816622Ssam 	    printrecord(s);
65916622Ssam 	    break;
66016622Ssam 
66116622Ssam 	case VARNT:
66218261Slinton 	    printf("[variant]");
66316622Ssam 	    break;
66416622Ssam 
66516622Ssam 	case RANGE:
66616622Ssam 	    printrange(s, n);
66716622Ssam 	    break;
66816622Ssam 
66918261Slinton 	/*
67018261Slinton 	 * Unresolved opaque type.
67118261Slinton 	 * Probably a pointer.
67218261Slinton 	 */
67318261Slinton 	case TYPEREF:
67418261Slinton 	    a = pop(Address);
67518261Slinton 	    printf("@%x", a);
67618261Slinton 	    break;
67718261Slinton 
67816622Ssam 	case FILET:
67918261Slinton 	    a = pop(Address);
68018261Slinton 	    if (a == 0) {
68118261Slinton 		printf("nil");
68218261Slinton 	    } else {
68318261Slinton 		printf("0x%x", a);
68418261Slinton 	    }
68518261Slinton 	    break;
68618261Slinton 
68716622Ssam 	case PTR:
68816622Ssam 	    a = pop(Address);
68916622Ssam 	    if (a == 0) {
69016622Ssam 		printf("nil");
69118261Slinton 	    } else if (isCstring(s->type)) {
69218261Slinton 		printString(a, true);
69316622Ssam 	    } else {
69416622Ssam 		printf("0x%x", a);
69516622Ssam 	    }
69616622Ssam 	    break;
69716622Ssam 
69816622Ssam 	case SCAL:
69918261Slinton 	    i = 0;
70018261Slinton 	    popn(n, &i);
70118261Slinton 	    printEnum(i, s);
70216622Ssam 	    break;
70316622Ssam 
70416622Ssam 	case FPROC:
70516622Ssam 	case FFUNC:
70616622Ssam 	    a = pop(long);
70716622Ssam 	    t = whatblock(a);
70816622Ssam 	    if (t == nil) {
70918261Slinton 		printf("0x%x", a);
71016622Ssam 	    } else {
71118261Slinton 		printname(stdout, t);
71216622Ssam 	    }
71316622Ssam 	    break;
71416622Ssam 
71516622Ssam 	case SET:
71616622Ssam 	    printSet(s);
71716622Ssam 	    break;
71816622Ssam 
71916622Ssam 	default:
72016622Ssam 	    if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
72116622Ssam 		panic("printval: bad class %d", ord(s->class));
72216622Ssam 	    }
72316622Ssam 	    printf("[%s]", classname(s));
72416622Ssam 	    break;
72516622Ssam     }
72616622Ssam }
72716622Ssam 
72816622Ssam /*
72918261Slinton  * Print out a dynamic array.
73018261Slinton  */
73118261Slinton 
73218261Slinton private Address printDynSlice();
73318261Slinton 
73418261Slinton private printDynarray (t)
73518261Slinton Symbol t;
73618261Slinton {
73718261Slinton     Address base;
73818261Slinton     integer n;
73918261Slinton     Stack *savesp, *newsp;
74018261Slinton     Symbol eltype;
74118261Slinton 
74218261Slinton     savesp = sp;
74318261Slinton     sp -= (t->symvalue.ndims * sizeof(Word));
74418261Slinton     base = pop(Address);
74518261Slinton     newsp = sp;
74618261Slinton     sp = savesp;
74718261Slinton     eltype = rtype(t->type);
74818261Slinton     if (t->symvalue.ndims == 0) {
74918261Slinton 	if (ischar(eltype)) {
75018261Slinton 	    printString(base, true);
75118261Slinton 	} else {
75218261Slinton 	    printf("[dynarray @nocount]");
75318261Slinton 	}
75418261Slinton     } else {
75518261Slinton 	n = ((long *) sp)[-(t->symvalue.ndims)];
75618261Slinton 	base = printDynSlice(base, n, t->symvalue.ndims, eltype, size(eltype));
75718261Slinton     }
75818261Slinton     sp = newsp;
75918261Slinton }
76018261Slinton 
76118261Slinton /*
76218261Slinton  * Print out one dimension of a multi-dimension dynamic array.
76318261Slinton  *
76418261Slinton  * Return the address of the element that follows the printed elements.
76518261Slinton  */
76618261Slinton 
76718261Slinton private Address printDynSlice (base, count, ndims, eltype, elsize)
76818261Slinton Address base;
76918261Slinton integer count, ndims;
77018261Slinton Symbol eltype;
77118261Slinton integer elsize;
77218261Slinton {
77318261Slinton     Address b;
77418261Slinton     integer i, n;
77518261Slinton     char *slice;
77618261Slinton     Stack *savesp;
77718261Slinton 
77818261Slinton     b = base;
77918261Slinton     if (ndims > 1) {
78018261Slinton 	n = ((long *) sp)[-ndims + 1];
78118261Slinton     }
78218261Slinton     if (ndims == 1 and ischar(eltype)) {
78318261Slinton 	slice = newarr(char, count);
78418261Slinton 	dread(slice, b, count);
78518261Slinton 	printf("\"%.*s\"", count, slice);
78618261Slinton 	dispose(slice);
78718261Slinton 	b += count;
78818261Slinton     } else {
78918261Slinton 	printf("(");
79018261Slinton 	for (i = 0; i < count; i++) {
79118261Slinton 	    if (i != 0) {
79218261Slinton 		printf(", ");
79318261Slinton 	    }
79418261Slinton 	    if (ndims == 1) {
79518261Slinton 		slice = newarr(char, elsize);
79618261Slinton 		dread(slice, b, elsize);
79718261Slinton 		savesp = sp;
79818261Slinton 		sp = slice + elsize;
79918261Slinton 		printval(eltype);
80018261Slinton 		sp = savesp;
80118261Slinton 		dispose(slice);
80218261Slinton 		b += elsize;
80318261Slinton 	    } else {
80418261Slinton 		b = printDynSlice(b, n, ndims - 1, eltype, elsize);
80518261Slinton 	    }
80618261Slinton 	}
80718261Slinton 	printf(")");
80818261Slinton     }
80918261Slinton     return b;
81018261Slinton }
81118261Slinton 
81218261Slinton private printSubarray (t)
81318261Slinton Symbol t;
81418261Slinton {
81518261Slinton     printf("[subarray]");
81618261Slinton }
81718261Slinton 
81818261Slinton /*
81916622Ssam  * Print out the value of a scalar (non-enumeration) type.
82016622Ssam  */
82116622Ssam 
82216622Ssam private printrange (s, n)
82316622Ssam Symbol s;
82416622Ssam integer n;
82516622Ssam {
82616622Ssam     double d;
82716622Ssam     float f;
82816622Ssam     integer i;
82916622Ssam 
83016622Ssam     if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) {
83116622Ssam 	if (n == sizeof(float)) {
83216622Ssam 	    popn(n, &f);
83316622Ssam 	    d = f;
83416622Ssam 	} else {
83516622Ssam 	    popn(n, &d);
83616622Ssam 	}
83716622Ssam 	prtreal(d);
83816622Ssam     } else {
83916622Ssam 	i = 0;
84016622Ssam 	popn(n, &i);
84118261Slinton 	printRangeVal(i, s);
84216622Ssam     }
84316622Ssam }
84416622Ssam 
84516622Ssam /*
84616622Ssam  * Print out a set.
84716622Ssam  */
84816622Ssam 
84916622Ssam private printSet (s)
85016622Ssam Symbol s;
85116622Ssam {
85216622Ssam     Symbol t;
85316622Ssam     integer nbytes;
85416622Ssam 
85516622Ssam     nbytes = size(s);
85616622Ssam     t = rtype(s->type);
85716622Ssam     printf("{");
85816622Ssam     sp -= nbytes;
85916622Ssam     if (t->class == SCAL) {
86016622Ssam 	printSetOfEnum(t);
86116622Ssam     } else if (t->class == RANGE) {
86216622Ssam 	printSetOfRange(t);
86316622Ssam     } else {
86416622Ssam 	panic("expected range or enumerated base type for set");
86516622Ssam     }
86616622Ssam     printf("}");
86716622Ssam }
86816622Ssam 
86916622Ssam /*
87016622Ssam  * Print out a set of an enumeration.
87116622Ssam  */
87216622Ssam 
87316622Ssam private printSetOfEnum (t)
87416622Ssam Symbol t;
87516622Ssam {
87616622Ssam     register Symbol e;
87716622Ssam     register integer i, j, *p;
87816622Ssam     boolean first;
87916622Ssam 
88016622Ssam     p = (int *) sp;
88116622Ssam     i = *p;
88216622Ssam     j = 0;
88316622Ssam     e = t->chain;
88416622Ssam     first = true;
88516622Ssam     while (e != nil) {
88616622Ssam 	if ((i&1) == 1) {
88716622Ssam 	    if (first) {
88816622Ssam 		first = false;
88916622Ssam 		printf("%s", symname(e));
89016622Ssam 	    } else {
89116622Ssam 		printf(", %s", symname(e));
89216622Ssam 	    }
89316622Ssam 	}
89416622Ssam 	i >>= 1;
89516622Ssam 	++j;
89616622Ssam 	if (j >= sizeof(integer)*BITSPERBYTE) {
89716622Ssam 	    j = 0;
89816622Ssam 	    ++p;
89916622Ssam 	    i = *p;
90016622Ssam 	}
90116622Ssam 	e = e->chain;
90216622Ssam     }
90316622Ssam }
90416622Ssam 
90516622Ssam /*
90616622Ssam  * Print out a set of a subrange type.
90716622Ssam  */
90816622Ssam 
90916622Ssam private printSetOfRange (t)
91016622Ssam Symbol t;
91116622Ssam {
91216622Ssam     register integer i, j, *p;
91316622Ssam     long v;
91416622Ssam     boolean first;
91516622Ssam 
91616622Ssam     p = (int *) sp;
91716622Ssam     i = *p;
91816622Ssam     j = 0;
91916622Ssam     v = t->symvalue.rangev.lower;
92016622Ssam     first = true;
92116622Ssam     while (v <= t->symvalue.rangev.upper) {
92216622Ssam 	if ((i&1) == 1) {
92316622Ssam 	    if (first) {
92416622Ssam 		first = false;
92516622Ssam 		printf("%ld", v);
92616622Ssam 	    } else {
92716622Ssam 		printf(", %ld", v);
92816622Ssam 	    }
92916622Ssam 	}
93016622Ssam 	i >>= 1;
93116622Ssam 	++j;
93216622Ssam 	if (j >= sizeof(integer)*BITSPERBYTE) {
93316622Ssam 	    j = 0;
93416622Ssam 	    ++p;
93516622Ssam 	    i = *p;
93616622Ssam 	}
93716622Ssam 	++v;
93816622Ssam     }
93916622Ssam }
94016622Ssam 
94116622Ssam /*
94218261Slinton  * Construct a node for subscripting a dynamic or subarray.
94318261Slinton  * The list of indices is left for processing in evalaref,
94418261Slinton  * unlike normal subscripting in which the list is expanded
94518261Slinton  * across individual INDEX nodes.
94618261Slinton  */
94718261Slinton 
94818261Slinton private Node dynref (a, t, slist)
94918261Slinton Node a;
95018261Slinton Symbol t;
95118261Slinton Node slist;
95218261Slinton {
95318261Slinton     Node p, r;
95418261Slinton     integer n;
95518261Slinton 
95618261Slinton     p = slist;
95718261Slinton     n = 0;
95818261Slinton     while (p != nil) {
95918261Slinton 	if (not compatible(p->value.arg[0]->nodetype, t_int)) {
96018261Slinton 	    suberror("subscript \"", p->value.arg[0], "\" is the wrong type");
96118261Slinton 	}
96218261Slinton 	++n;
96318261Slinton 	p = p->value.arg[1];
96418261Slinton     }
96518261Slinton     if (n > t->symvalue.ndims and (t->symvalue.ndims != 0 or n != 1)) {
96618261Slinton 	suberror("too many subscripts for ", a, nil);
96718261Slinton     } else if (n < t->symvalue.ndims) {
96818261Slinton 	suberror("not enough subscripts for ", a, nil);
96918261Slinton     }
97018261Slinton     r = build(O_INDEX, a, slist);
97118261Slinton     r->nodetype = rtype(t->type);
97218261Slinton     return r;
97318261Slinton }
97418261Slinton 
97518261Slinton /*
97616622Ssam  * Construct a node for subscripting.
97716622Ssam  */
97816622Ssam 
97916622Ssam public Node modula2_buildaref (a, slist)
98016622Ssam Node a, slist;
98116622Ssam {
98216622Ssam     register Symbol t;
98316622Ssam     register Node p;
98418261Slinton     Symbol eltype;
98516622Ssam     Node esub, r;
98618261Slinton     integer n;
98716622Ssam 
98816622Ssam     t = rtype(a->nodetype);
98918261Slinton     if (t->class == DYNARRAY or t->class == SUBARRAY) {
99018261Slinton 	r = dynref(a, t, slist);
99118261Slinton     } else if (t->class == ARRAY) {
99218261Slinton 	r = a;
99318261Slinton 	eltype = rtype(t->type);
99416622Ssam 	p = slist;
99516622Ssam 	t = t->chain;
99618261Slinton 	while (p != nil and t != nil) {
99716622Ssam 	    esub = p->value.arg[0];
99818261Slinton 	    if (not compatible(rtype(t), rtype(esub->nodetype))) {
99918261Slinton 		suberror("subscript \"", esub, "\" is the wrong type");
100016622Ssam 	    }
100116622Ssam 	    r = build(O_INDEX, r, esub);
100216622Ssam 	    r->nodetype = eltype;
100318261Slinton 	    p = p->value.arg[1];
100418261Slinton 	    t = t->chain;
100516622Ssam 	}
100618261Slinton 	if (p != nil) {
100718261Slinton 	    suberror("too many subscripts for ", a, nil);
100818261Slinton 	} else if (t != nil) {
100918261Slinton 	    suberror("not enough subscripts for ", a, nil);
101016622Ssam 	}
101118261Slinton     } else {
101218261Slinton 	suberror("\"", a, "\" is not an array");
101316622Ssam     }
101416622Ssam     return r;
101516622Ssam }
101616622Ssam 
101716622Ssam /*
101818261Slinton  * Subscript usage error reporting.
101918261Slinton  */
102018261Slinton 
102118261Slinton private suberror (s1, e1, s2)
102218261Slinton String s1, s2;
102318261Slinton Node e1;
102418261Slinton {
102518261Slinton     beginerrmsg();
102618261Slinton     if (s1 != nil) {
102718261Slinton 	fprintf(stderr, s1);
102818261Slinton     }
102918261Slinton     if (e1 != nil) {
103018261Slinton 	prtree(stderr, e1);
103118261Slinton     }
103218261Slinton     if (s2 != nil) {
103318261Slinton 	fprintf(stderr, s2);
103418261Slinton     }
103518261Slinton     enderrmsg();
103618261Slinton }
103718261Slinton 
103818261Slinton /*
103918261Slinton  * Check that a subscript value is in the appropriate range.
104018261Slinton  */
104118261Slinton 
104218261Slinton private subchk (value, lower, upper)
104318261Slinton long value, lower, upper;
104418261Slinton {
104518261Slinton     if (value < lower or value > upper) {
104618261Slinton 	error("subscript value %d out of range [%d..%d]", value, lower, upper);
104718261Slinton     }
104818261Slinton }
104918261Slinton 
105018261Slinton /*
105118261Slinton  * Compute the offset for subscripting a dynamic array.
105218261Slinton  */
105318261Slinton 
105418261Slinton private getdynoff (ndims, sub)
105518261Slinton integer ndims;
105618261Slinton long *sub;
105718261Slinton {
105818261Slinton     long k, off, *count;
105918261Slinton 
106018261Slinton     count = (long *) sp;
106118261Slinton     off = 0;
106218261Slinton     for (k = 0; k < ndims - 1; k++) {
106318261Slinton 	subchk(sub[k], 0, count[k] - 1);
106418261Slinton 	off += (sub[k] * count[k+1]);
106518261Slinton     }
106618261Slinton     subchk(sub[ndims - 1], 0, count[ndims - 1] - 1);
106718261Slinton     return off + sub[ndims - 1];
106818261Slinton }
106918261Slinton 
107018261Slinton /*
107118261Slinton  * Compute the offset associated with a subarray.
107218261Slinton  */
107318261Slinton 
107418261Slinton private getsuboff (ndims, sub)
107518261Slinton integer ndims;
107618261Slinton long *sub;
107718261Slinton {
107818261Slinton     long k, off;
107918261Slinton     struct subarrayinfo {
108018261Slinton 	long count;
108118261Slinton 	long mult;
108218261Slinton     } *info;
108318261Slinton 
108418261Slinton     info = (struct subarrayinfo *) sp;
108518261Slinton     off = 0;
108618261Slinton     for (k = 0; k < ndims; k++) {
108718261Slinton 	subchk(sub[k], 0, info[k].count - 1);
108818261Slinton 	off += sub[k] * info[k].mult;
108918261Slinton     }
109018261Slinton     return off;
109118261Slinton }
109218261Slinton 
109318261Slinton /*
109416622Ssam  * Evaluate a subscript index.
109516622Ssam  */
109616622Ssam 
109718261Slinton public modula2_evalaref (s, base, i)
109816622Ssam Symbol s;
109918261Slinton Address base;
110016622Ssam long i;
110116622Ssam {
110218261Slinton     Symbol t;
110318261Slinton     long lb, ub, off;
110418261Slinton     long *sub;
110518261Slinton     Address b;
110616622Ssam 
110718261Slinton     t = rtype(s);
110818261Slinton     if (t->class == ARRAY) {
110918261Slinton 	findbounds(rtype(t->chain), &lb, &ub);
111018261Slinton 	if (i < lb or i > ub) {
111118261Slinton 	    error("subscript %d out of range [%d..%d]", i, lb, ub);
111218261Slinton 	}
111318261Slinton 	push(long, base + (i - lb) * size(t->type));
111418261Slinton     } else if (t->class == DYNARRAY and t->symvalue.ndims == 0) {
111518261Slinton 	push(long, base + i * size(t->type));
111618261Slinton     } else if (t->class == DYNARRAY or t->class == SUBARRAY) {
111718261Slinton 	push(long, i);
111818261Slinton 	sub = (long *) (sp - (t->symvalue.ndims * sizeof(long)));
111918261Slinton 	rpush(base, size(t));
112018261Slinton 	sp -= (t->symvalue.ndims * sizeof(long));
112118261Slinton 	b = pop(Address);
112218261Slinton 	sp += sizeof(Address);
112318261Slinton 	if (t->class == SUBARRAY) {
112418261Slinton 	    off = getsuboff(t->symvalue.ndims, sub);
112518261Slinton 	} else {
112618261Slinton 	    off = getdynoff(t->symvalue.ndims, sub);
112718261Slinton 	}
112818261Slinton 	sp = (Stack *) sub;
112918261Slinton 	push(long, b + off * size(t->type));
113018261Slinton     } else {
113118261Slinton 	error("[internal error: expected array in evalaref]");
113216622Ssam     }
113316622Ssam }
113416622Ssam 
113516622Ssam /*
113616622Ssam  * Initial Modula-2 type information.
113716622Ssam  */
113816622Ssam 
113916622Ssam #define NTYPES 12
114016622Ssam 
114116622Ssam private Symbol inittype[NTYPES + 1];
114216622Ssam 
114316622Ssam private addType (n, s, lower, upper)
114416622Ssam integer n;
114516622Ssam String s;
114616622Ssam long lower, upper;
114716622Ssam {
114816622Ssam     register Symbol t;
114916622Ssam 
115016622Ssam     if (n > NTYPES) {
115116622Ssam 	panic("initial Modula-2 type number too large for '%s'", s);
115216622Ssam     }
115316622Ssam     t = insert(identname(s, true));
115416622Ssam     t->language = mod2;
115516622Ssam     t->class = TYPE;
115616622Ssam     t->type = newSymbol(nil, 0, RANGE, t, nil);
115716622Ssam     t->type->symvalue.rangev.lower = lower;
115816622Ssam     t->type->symvalue.rangev.upper = upper;
115916622Ssam     t->type->language = mod2;
116016622Ssam     inittype[n] = t;
116116622Ssam }
116216622Ssam 
116316622Ssam private initModTypes ()
116416622Ssam {
116516622Ssam     addType(1, "integer", 0x80000000L, 0x7fffffffL);
116616622Ssam     addType(2, "char", 0L, 255L);
116716622Ssam     addType(3, "boolean", 0L, 1L);
116816622Ssam     addType(4, "unsigned", 0L, 0xffffffffL);
116916622Ssam     addType(5, "real", 4L, 0L);
117016622Ssam     addType(6, "longreal", 8L, 0L);
117116622Ssam     addType(7, "word", 0L, 0xffffffffL);
117216622Ssam     addType(8, "byte", 0L, 255L);
117316622Ssam     addType(9, "address", 0L, 0xffffffffL);
117416622Ssam     addType(10, "file", 0L, 0xffffffffL);
117516622Ssam     addType(11, "process", 0L, 0xffffffffL);
117616622Ssam     addType(12, "cardinal", 0L, 0x7fffffffL);
117716622Ssam }
117816622Ssam 
117916622Ssam /*
118016622Ssam  * Initialize typetable.
118116622Ssam  */
118216622Ssam 
118316622Ssam public modula2_modinit (typetable)
118416622Ssam Symbol typetable[];
118516622Ssam {
118616622Ssam     register integer i;
118716622Ssam 
118816622Ssam     if (not initialized) {
118916622Ssam 	initModTypes();
119018261Slinton 	initialized = true;
119116622Ssam     }
119216622Ssam     for (i = 1; i <= NTYPES; i++) {
119316622Ssam 	typetable[i] = inittype[i];
119416622Ssam     }
119516622Ssam }
119616622Ssam 
119716622Ssam public boolean modula2_hasmodules ()
119816622Ssam {
119916622Ssam     return true;
120016622Ssam }
120116622Ssam 
120216622Ssam public boolean modula2_passaddr (param, exprtype)
120316622Ssam Symbol param, exprtype;
120416622Ssam {
120516622Ssam     return false;
120616622Ssam }
1207