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