From 53e3cd60d07584a28ae435c9d8470a082dc7ac3a Mon Sep 17 00:00:00 2001 From: ceriel Date: Mon, 28 Apr 1986 18:06:58 +0000 Subject: [PATCH] newer version --- lang/m2/comp/LLlex.c | 4 +- lang/m2/comp/LLlex.h | 2 +- lang/m2/comp/chk_expr.c | 56 ++++++++---- lang/m2/comp/declar.g | 11 +-- lang/m2/comp/def.H | 13 +-- lang/m2/comp/def.c | 188 +++++++++++++++++++++++--------------- lang/m2/comp/enter.c | 34 +++---- lang/m2/comp/expression.g | 26 +++--- lang/m2/comp/program.g | 50 +++++----- lang/m2/comp/scope.C | 43 +++++---- lang/m2/comp/scope.h | 15 ++- lang/m2/comp/statement.g | 1 + lang/m2/comp/type.H | 3 +- lang/m2/comp/type.c | 9 +- lang/m2/comp/typequiv.c | 68 ++++++++++---- lang/m2/comp/walk.c | 82 ++++++++++++----- 16 files changed, 378 insertions(+), 227 deletions(-) diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index a1ccd14a4..8ebb1d8bf 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -76,7 +76,7 @@ GetString(upto) register struct string *str = &string; register char *p; - str->s_str = p = Malloc(str->s_length = ISTRSIZE); + str->s_str = p = Malloc((unsigned int) (str->s_length = ISTRSIZE)); LoadChar(ch); while (ch != upto) { if (class(ch) == STNL) { @@ -91,7 +91,7 @@ GetString(upto) *p++ = ch; if (p - str->s_str == str->s_length) { str->s_str = Srealloc(str->s_str, - str->s_length + RSTRSIZE); + (unsigned int) str->s_length + RSTRSIZE); p = str->s_str + str->s_length; str->s_length += RSTRSIZE; } diff --git a/lang/m2/comp/LLlex.h b/lang/m2/comp/LLlex.h index 69573dd00..0fcddecc4 100644 --- a/lang/m2/comp/LLlex.h +++ b/lang/m2/comp/LLlex.h @@ -3,7 +3,7 @@ /* $Header$ */ struct string { - unsigned int s_length; /* length of a string */ + arith s_length; /* length of a string */ char *s_str; /* the string itself */ }; diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 938fc6f0e..95f333842 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -388,6 +388,8 @@ FlagCheck(expp, df, flag) "flag". Here, a definition "df" is checked against it. */ + if (df->df_kind == D_ERROR) return 0; + if ((flag & VARIABLE) && !(df->df_kind & (D_FIELD|D_VARIABLE))) { node_error(expp, "variable expected"); @@ -432,7 +434,7 @@ chk_designator(expp, flag) expp->nd_type = error_type; if (expp->nd_class == Name) { - expp->nd_def = lookfor(expp, CurrentScope, 1); + expp->nd_def = lookfor(expp, CurrVis, 1); expp->nd_class = Def; expp->nd_type = expp->nd_def->df_type; if (expp->nd_type == error_type) return 0; @@ -489,8 +491,15 @@ df->df_idf->id_text); expp->nd_symb = INTEGER; } else { + char *fn; + int ln; + assert(df->df_kind == D_CONST); + ln = expp->nd_lineno; + fn = expp->nd_filename; *expp = *(df->con_const); + expp->nd_lineno = ln; + expp->nd_filename = fn; } } @@ -591,7 +600,7 @@ node_error(expp, "RHS of IN operator not a SET type"); } if (!TstAssCompat(tpl, tpr->next)) { /* Assignment compatible ??? - I don't know! Should we be allowed th check + I don't know! Should we be allowed to check if a CARDINAL is a member of a BITSET??? */ @@ -620,6 +629,9 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R case '-': case '*': switch(tpl->tp_fund) { + case T_POINTER: + if (tpl != address_type) break; + /* Fall through */ case T_INTEGER: case T_CARDINAL: case T_INTORCARD: @@ -654,7 +666,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R case DIV: case MOD: - if (tpl->tp_fund & T_INTORCARD) { + if ((tpl->tp_fund & T_INTORCARD) || tpl == address_type) { if (left->nd_class==Value && right->nd_class==Value) { cstbin(expp); } @@ -736,7 +748,8 @@ chk_uoper(expp) { /* Check an unary operation. */ - register struct type *tpr = expp->nd_right->nd_type; + register struct node *right = expp->nd_right; + register struct type *tpr = right->nd_type; if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next; expp->nd_type = tpr; @@ -744,8 +757,8 @@ chk_uoper(expp) switch(expp->nd_symb) { case '+': if (tpr->tp_fund & T_NUMERIC) { - expp->nd_token = expp->nd_right->nd_token; - FreeNode(expp->nd_right); + expp->nd_token = right->nd_token; + FreeNode(right); expp->nd_right = 0; return 1; } @@ -753,19 +766,19 @@ chk_uoper(expp) case '-': if (tpr->tp_fund & T_INTORCARD) { - if (expp->nd_right->nd_class == Value) { + if (right->nd_class == Value) { cstunary(expp); } return 1; } else if (tpr->tp_fund == T_REAL) { - if (expp->nd_right->nd_class == Value) { - expp->nd_token = expp->nd_right->nd_token; + if (right->nd_class == Value) { + expp->nd_token = right->nd_token; if (*(expp->nd_REL) == '-') { expp->nd_REL++; } else expp->nd_REL--; - FreeNode(expp->nd_right); + FreeNode(right); expp->nd_right = 0; } return 1; @@ -775,7 +788,7 @@ chk_uoper(expp) case NOT: case '~': if (tpr == bool_type) { - if (expp->nd_right->nd_class == Value) { + if (right->nd_class == Value) { cstunary(expp); } return 1; @@ -794,19 +807,27 @@ struct node * getvariable(arg) register struct node *arg; { + struct def *df; + register struct node *left; + arg = arg->nd_right; if (!arg) { node_error(arg, "too few parameters supplied"); return 0; } - if (! chk_designator(arg->nd_left, DESIGNATOR)) return 0; - if (arg->nd_left->nd_class == Oper || arg->nd_left->nd_class == Uoper) { + left = arg->nd_left; + + if (! chk_designator(left, DESIGNATOR)) return 0; + if (left->nd_class == Oper || left->nd_class == Uoper) { return arg; } - if (arg->nd_left->nd_class != Def || - !(arg->nd_left->nd_def->df_kind & (D_VARIABLE|D_FIELD))) { + df = 0; + if (left->nd_class == Link) df = left->nd_right->nd_def; + else if (left->nd_class == Def) df = left->nd_def; + + if (!df || !(df->df_kind & (D_VARIABLE|D_FIELD))) { node_error(arg, "variable expected"); return 0; } @@ -947,7 +968,10 @@ node_error(arg, "EXCL and INCL expect a SET parameter"); return 0; } if (!(arg = getarg(arg, T_DISCRETE))) return 0; - if (!TstCompat(tp->next, arg->nd_left->nd_type)) { + if (!TstAssCompat(tp->next, arg->nd_left->nd_type)) { + /* What type of compatibility do we want here? + apparently assignment compatibility! ??? ??? + */ node_error(arg, "unexpected type"); return 0; } diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index ad2bcd17c..924f63e26 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -37,7 +37,7 @@ ProcedureDeclaration ';' block(&(df->prc_body)) IDENT { match_id(dot.TOK_IDF, df->df_idf); - df->prc_scope = CurrentScope; + df->prc_vis = CurrVis; close_scope(SC_CHKFORW|SC_REVERSE); proclevel--; currentdef = savecurr; @@ -182,14 +182,9 @@ TypeDeclaration '=' type(&tp) { if (df->df_type) free_type(df->df_type); df->df_type = tp; - if ((df->df_flags&D_EXPORTED) && - tp->tp_fund == T_ENUMERATION) { - exprt_literals(tp->enm_enums, - enclosing(CurrentScope)); - } if (df->df_kind == D_HTYPE && tp->tp_fund != T_POINTER) { -error("Opaque type \"%s\" is not a pointer type", df->df_idf->id_text); +error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text); } } ; @@ -493,7 +488,7 @@ PointerType(struct type **ptp;) else tp = df->df_type; } | %if ( nd = new_node(), nd->nd_token = dot, - df = lookfor(nd, CurrentScope, 0), free_node(nd), + df = lookfor(nd, CurrVis, 0), free_node(nd), df->df_kind == D_MODULE) type(&tp) | diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index 9810bd298..131f67f1a 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -4,11 +4,11 @@ struct module { arith mo_priority; /* priority of a module */ - struct scope *mo_scope; /* scope of this module */ + struct scopelist *mo_vis;/* scope of this module */ struct node *mo_body; /* body of this module */ int mo_number; /* number of this module */ #define mod_priority df_value.df_module.mo_priority -#define mod_scope df_value.df_module.mo_scope +#define mod_vis df_value.df_module.mo_vis #define mod_body df_value.df_module.mo_body #define mod_number df_value.df_module.mo_number }; @@ -51,11 +51,11 @@ struct field { }; struct dfproc { - struct scope *pr_scope; /* scope of procedure */ + struct scopelist *pr_vis; /* scope of procedure */ short pr_level; /* depth level of this procedure */ arith pr_nbpar; /* number of bytes parameters */ struct node *pr_body; /* body of this procedure */ -#define prc_scope df_value.df_proc.pr_scope +#define prc_vis df_value.df_proc.pr_vis #define prc_level df_value.df_proc.pr_level #define prc_nbpar df_value.df_proc.pr_nbpar #define prc_body df_value.df_proc.pr_body @@ -67,11 +67,12 @@ struct import { }; struct dforward { - struct scope *fo_scope; + struct scopelist *fo_vis; struct node *fo_node; char *fo_name; #define for_node df_value.df_forward.fo_node -#define for_scope df_value.df_forward.fo_scope +#define for_vis df_value.df_forward.fo_vis +#define for_scopes df_value.df_forward.fo_scopes #define for_name df_value.df_forward.fo_name }; diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c index 64e8adbff..295e5c4ae 100644 --- a/lang/m2/comp/def.c +++ b/lang/m2/comp/def.c @@ -35,11 +35,10 @@ MkDef(id, scope, kind) register struct def *df; df = new_def(); - df->df_flags = 0; + clear((char *) df, sizeof (*df)); df->df_idf = id; df->df_scope = scope; df->df_kind = kind; - df->df_type = 0; df->next = id->id_def; id->id_def = df; @@ -66,8 +65,7 @@ define(id, scope, kind) if ( /* Already in this scope */ df || /* A closed scope, and id defined in the pervasive scope */ - ( CurrentScope == scope - && + ( scopeclosed(scope) && (df = lookup(id, PervasiveScope))) @@ -79,31 +77,40 @@ define(id, scope, kind) return df; } break; + case D_FORWMODULE: if (kind == D_FORWMODULE) { return df; } + if (kind == D_MODULE) { FreeNode(df->for_node); - df->mod_scope = df->for_scope; + df->mod_vis = df->for_vis; df->df_kind = kind; return df; } break; + case D_FORWARD: if (kind != D_FORWARD) { FreeNode(df->for_node); } - /* Fall Through */ + + df->df_kind = kind; + return df; + case D_ERROR: df->df_kind = kind; return df; } + if (kind != D_ERROR) { error("identifier \"%s\" already declared", id->id_text); } + return df; } + return MkDef(id, scope, kind); } @@ -129,7 +136,6 @@ lookup(id, scope) retval = df->imp_def; assert(retval != 0); } - if (df1) { df1->next = df->next; df->next = id->id_def; @@ -143,8 +149,38 @@ lookup(id, scope) return 0; } -Export(ids, qualified) +DoImport(df, scope) + struct def *df; + struct scope *scope; +{ + register struct def *df1; + + if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) { + /* Also import all enumeration literals + */ + df1 = df->df_type->enm_enums; + while (df1) { + define(df1->df_idf, scope, D_IMPORT)->imp_def = df1; + df1 = df1->enm_next; + } + } + else if (df->df_kind == D_MODULE) { + /* Also import all definitions that are exported from this + module + */ + df1 = df->mod_vis->sc_scope->sc_def; + while (df1) { + if (df1->df_flags & D_EXPORTED) { + define(df1->df_idf, scope, D_IMPORT)->imp_def = df1; + } + df1 = df1->df_nextinscope; + } + } +} + +Export(ids, qualified, moddef) register struct node *ids; + struct def *moddef; { /* From the current scope, the list of identifiers "ids" is exported. Note this fact. If the export is not qualified, make @@ -152,47 +188,71 @@ Export(ids, qualified) in this scope as "imported". */ register struct def *df, *df1; - struct node *nd = ids; + register struct def *impmod; - while (ids) { + for (;ids; ids = ids->next) { df = lookup(ids->nd_IDF, CurrentScope); - if (df && (df->df_flags & (D_EXPORTED|D_QEXPORTED))) { + + if (!df) { + /* undefined item in export list + */ +node_error(ids, "identifier \"%s\" not defined", ids->nd_IDF->id_text); + continue; + } + + if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) { node_error(ids, "Identifier \"%s\" occurs more than once in export list", df->df_idf->id_text); } - else if (!df) { - df = define(ids->nd_IDF, CurrentScope, D_FORWARD); - df->for_node = MkNode(Name,NULLNODE,NULLNODE, - &(ids->nd_token)); - } + if (qualified) { df->df_flags |= D_QEXPORTED; } else { + /* Export, but not qualified. + Find all imports of the module in which this export + occurs, and export the current definition to it + */ + impmod = moddef->df_idf->id_def; + while (impmod) { + if (impmod->df_kind == D_IMPORT && + impmod->imp_def == moddef) { + DoImport(df, impmod->df_scope); + } + impmod = impmod->next; + } + df->df_flags |= D_EXPORTED; - df1 = lookup(ids->nd_IDF, enclosing(CurrentScope)); - if (! df1 || !(df1->df_kind & (D_PROCHEAD|D_HIDDEN))) { - df1 = define(ids->nd_IDF, - enclosing(CurrentScope), - D_IMPORT); + df1 = lookup(ids->nd_IDF, enclosing(CurrVis)->sc_scope); + if (df1 && df1->df_kind == D_PROCHEAD) { + if (df->df_kind == D_PROCEDURE) { + df1->df_kind = D_IMPORT; + df1->imp_def = df; + continue; + } } - else { - /* A hidden type or a procedure of which only - the head is seen. Apparently, they are - exported from a local module! - */ - df->df_kind = df1->df_kind; - df->df_value.df_forward = df1->df_value.df_forward; - df1->df_kind = D_IMPORT; + else if (df1 && df1->df_kind == D_HIDDEN) { + if (df->df_kind == D_TYPE) { + if (df->df_type->tp_fund != T_POINTER) { +error("Opaque type \"%s\" is not a pointer type", df->df_idf->id_text); + } + df->df_kind = D_HTYPE; + df1->df_kind = D_IMPORT; + df1->imp_def = df; + continue; + } } + + df1 = define(ids->nd_IDF, + enclosing(CurrVis)->sc_scope, + D_IMPORT); df1->imp_def = df; + DoImport(df, enclosing(CurrVis)->sc_scope); } - ids = ids->next; } - FreeNode(nd); } -static struct scope * +static struct scopelist * ForwModule(df, idn) register struct def *df; struct node *idn; @@ -200,22 +260,22 @@ ForwModule(df, idn) /* An import is done from a not yet defined module "idn". Create a declaration and a scope for this module. */ - struct scope *scope; + struct scopelist *vis; - df->df_scope = enclosing(CurrentScope); + df->df_scope = enclosing(CurrVis)->sc_scope; df->df_kind = D_FORWMODULE; open_scope(CLOSEDSCOPE); - scope = CurrentScope; /* The new scope, but watch out, it's "next" + vis = CurrVis; /* The new scope, but watch out, it's "sc_encl" field is not set right. It must indicate the enclosing scope, but this must be done AFTER closing this one */ - df->for_scope = scope; + df->for_vis = vis; df->for_node = MkNode(Name, NULLNODE, NULLNODE, &(idn->nd_token)); close_scope(0); - scope->next = df->df_scope; + vis->sc_encl = enclosing(CurrVis); /* Here ! */ - return scope; + return vis; } static struct def * @@ -253,8 +313,7 @@ Import(ids, idn, local) identifiers defined in this module. */ register struct def *df; - struct scope *scope = enclosing(CurrentScope); - int kind = D_IMPORT; + struct scopelist *vis = enclosing(CurrVis); int forwflag = 0; #define FROM_MODULE 0 #define FROM_ENCLOSING 1 @@ -264,7 +323,7 @@ Import(ids, idn, local) if (idn) { imp_kind = FROM_MODULE; if (local) { - df = lookfor(idn, scope, 0); + df = lookfor(idn, vis, 0); switch(df->df_kind) { case D_ERROR: /* The module from which the import was done @@ -272,23 +331,22 @@ Import(ids, idn, local) accept this, but for the time being I will. ??? */ - scope = ForwModule(df, idn); + vis = ForwModule(df, idn); forwflag = 1; break; case D_FORWMODULE: - scope = df->for_scope; + vis = df->for_vis; break; case D_MODULE: - scope = df->mod_scope; + vis = df->mod_vis; break; default: - kind = D_ERROR; node_error(idn, "identifier \"%s\" does not represent a module", idn->nd_IDF->id_text); break; } } - else scope = GetDefinitionModule(idn->nd_IDF)->mod_scope; + else vis = GetDefinitionModule(idn->nd_IDF)->mod_vis; FreeNode(idn); } @@ -297,9 +355,9 @@ idn->nd_IDF->id_text); while (ids) { if (imp_kind == FROM_MODULE) { if (forwflag) { - df = ForwDef(ids, scope); + df = ForwDef(ids, vis->sc_scope); } - else if (!(df = lookup(ids->nd_IDF, scope))) { + else if (!(df = lookup(ids->nd_IDF, vis->sc_scope))) { node_error(ids, "identifier \"%s\" not declared in qualifying module", ids->nd_IDF->id_text); df = ill_df; @@ -310,40 +368,20 @@ ids->nd_IDF->id_text); } } else { - if (local) df = ForwDef(ids, scope); + if (local) df = ForwDef(ids, vis->sc_scope); else df = GetDefinitionModule(ids->nd_IDF); } DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text, df->df_kind)); - define(ids->nd_IDF, CurrentScope, kind)->imp_def = df; - if (df->df_kind == D_TYPE && - df->df_type->tp_fund == T_ENUMERATION) { - /* Also import all enumeration literals - */ - exprt_literals(df->df_type->enm_enums, CurrentScope); - } + define(df->df_idf, CurrentScope, D_IMPORT)->imp_def = df; + DoImport(df, CurrentScope); ids = ids->next; } FreeNode(idn); } -exprt_literals(df, toscope) - register struct def *df; - struct scope *toscope; -{ - /* A list of enumeration literals is exported. This is implemented - as an import from the scope "toscope". - */ - DO_DEBUG(3, debug("enumeration import:")); - while (df) { - DO_DEBUG(3, debug(df->df_idf->id_text)); - define(df->df_idf, toscope, D_IMPORT)->imp_def = df; - df = df->enm_next; - } -} - RemImports(pdf) struct def **pdf; { @@ -417,18 +455,18 @@ DeclProc(type) df->df_kind = D_PROCEDURE; open_scope(OPENSCOPE); CurrentScope->sc_name = df->for_name; - df->prc_scope = CurrentScope; + df->prc_vis = CurrVis; } else { df = define(dot.TOK_IDF, CurrentScope, type); - if (CurrentScope != Defined->mod_scope) { + if (CurrVis != Defined->mod_vis) { sprint(buf, "_%d_%s", ++nmcount, df->df_idf->id_text); } - else (sprint(buf, "%s_%s",df->df_scope->sc_name, + else (sprint(buf, "%s_%s",CurrentScope->sc_name, df->df_idf->id_text)); open_scope(OPENSCOPE); - df->prc_scope = CurrentScope; + df->prc_vis = CurrVis; CurrentScope->sc_name = Malloc((unsigned)(strlen(buf)+1)); strcpy(CurrentScope->sc_name, buf); C_inp(buf); diff --git a/lang/m2/comp/enter.c b/lang/m2/comp/enter.c index 338b12702..b96d7a171 100644 --- a/lang/m2/comp/enter.c +++ b/lang/m2/comp/enter.c @@ -103,17 +103,17 @@ EnterVarList(IdList, type, local) procedure */ register struct def *df; - register struct scope *scope; + register struct scopelist *sc; char buf[256]; extern char *sprint(), *Malloc(), *strcpy(); - scope = CurrentScope; + sc = CurrVis; if (local) { /* Find the closest enclosing open scope. This is the procedure that we are dealing with */ - while (scope->sc_scopeclosed) scope = scope->next; + while (sc->sc_scope->sc_scopeclosed) sc = enclosing(sc); } while (IdList) { @@ -133,23 +133,25 @@ node_error(IdList->nd_left,"Illegal type for address"); as the variable list exists only local to a procedure */ - scope->sc_off = -align(type->tp_size - scope->sc_off, + sc->sc_scope->sc_off = + -align(type->tp_size - sc->sc_scope->sc_off, type->tp_align); - df->var_off = scope->sc_off; + df->var_off = sc->sc_scope->sc_off; } else if (!DefinitionModule && - CurrentScope != Defined->mod_scope) { + CurrVis != Defined->mod_vis) { /* variable list belongs to an internal global module. Align offset and add size */ - scope->sc_off = align(scope->sc_off, type->tp_align); - df->var_off = scope->sc_off; - scope->sc_off += type->tp_size; + sc->sc_scope->sc_off = + align(sc->sc_scope->sc_off, type->tp_align); + df->var_off = sc->sc_scope->sc_off; + sc->sc_scope->sc_off += type->tp_size; } else { /* Global name, possibly external */ - sprint(buf,"%s_%s", df->df_scope->sc_name, + sprint(buf,"%s_%s", sc->sc_scope->sc_name, df->df_idf->id_text); df->var_name = Malloc((unsigned)(strlen(buf)+1)); strcpy(df->var_name, buf); @@ -165,26 +167,26 @@ node_error(IdList->nd_left,"Illegal type for address"); } struct def * -lookfor(id, scope, give_error) +lookfor(id, vis, give_error) struct node *id; - struct scope *scope; + struct scopelist *vis; { /* Look for an identifier in the visibility range started by - "scope". + "vis". If it is not defined, maybe give an error message, and create a dummy definition. */ struct def *df; - register struct scope *sc = scope; + register struct scopelist *sc = vis; struct def *MkDef(); while (sc) { - df = lookup(id->nd_IDF, sc); + df = lookup(id->nd_IDF, sc->sc_scope); if (df) return df; sc = nextvisible(sc); } if (give_error) id_not_declared(id); - return MkDef(id->nd_IDF, scope, D_ERROR); + return MkDef(id->nd_IDF, vis->sc_scope, D_ERROR); } diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index a3b122ec7..1509eb949 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -10,7 +10,6 @@ static char *RcsId = "$Header$"; #include "LLlex.h" #include "idf.h" #include "def.h" -#include "scope.h" #include "node.h" #include "const.h" #include "type.h" @@ -170,6 +169,7 @@ factor(struct node **p;) { struct def *df; struct node *nd; + register struct type *tp; } : qualident(0, &df, (char *) 0, p) [ @@ -189,18 +189,20 @@ factor(struct node **p;) | %default number(p) | - STRING { - *p = MkNode(Value, NULLNODE, NULLNODE, &dot); - if (dot.TOK_SLE == 1) { - int i; + STRING { + *p = MkNode(Value, NULLNODE, NULLNODE, &dot); + if (dot.TOK_SLE == 1) { + int i; - i = *(dot.TOK_STR) & 0377; - (*p)->nd_type = charc_type; - free(dot.TOK_STR); - dot.TOK_INT = i; - } - else (*p)->nd_type = string_type; - } + tp = charc_type; + i = *(dot.TOK_STR) & 0377; + free(dot.TOK_STR); + free((char *) dot.tk_data.tk_str); + dot.TOK_INT = i; + } + else tp = standard_type(T_STRING, 1, dot.TOK_SLE); + (*p)->nd_type = tp; + } | '(' expression(p) ')' | diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g index 298bd74e2..3a54619e0 100644 --- a/lang/m2/comp/program.g +++ b/lang/m2/comp/program.g @@ -52,6 +52,8 @@ ModuleDeclaration static int modulecount = 0; char buf[256]; struct node *nd; + struct node *exportlist = 0; + int qualified; extern char *sprint(), *Malloc(), *strcpy(); } : MODULE IDENT { @@ -59,14 +61,14 @@ ModuleDeclaration df = define(id, CurrentScope, D_MODULE); currentdef = df; - if (!df->mod_scope) { + if (!df->mod_vis) { open_scope(CLOSEDSCOPE); - df->mod_scope = CurrentScope; + df->mod_vis = CurrVis; } - else CurrentScope = df->mod_scope; + else CurrVis = df->mod_vis; df->df_type = standard_type(T_RECORD, 0, (arith) 0); - df->df_type->rec_scope = df->mod_scope; + df->df_type->rec_scope = df->mod_vis->sc_scope; df->mod_number = ++modulecount; sprint(buf, "__%d%s", df->mod_number, id->id_text); CurrentScope->sc_name = @@ -78,9 +80,13 @@ ModuleDeclaration priority(&(df->mod_priority))? ';' import(1)* - export(0)? + export(&qualified, &exportlist, 0)? block(&nd) IDENT { InitProc(nd, df); + if (exportlist) { + Export(exportlist, qualified, df); + FreeNode(exportlist); + } close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE); match_id(id, dot.TOK_IDF); currentdef = savecurr; @@ -100,24 +106,21 @@ priority(arith *pprio;) } ; -export(int def;) +export(int *QUALflag; struct node **ExportList; int def;) { - struct node *ExportList; - int QUALflag = 0; } : EXPORT [ QUALIFIED - { QUALflag = 1; } - ]? - IdentList(&ExportList) ';' + { *QUALflag = 1; } + | + { *QUALflag = 0; } + ] + IdentList(ExportList) ';' { - if (!def) { - Export(ExportList, QUALflag); - } - else { -node_warning(ExportList, "export list in definition module ignored"); - FreeNode(ExportList); + if (def) { +node_warning(*ExportList, "export list in definition module ignored"); + FreeNode(*ExportList); } } ; @@ -146,6 +149,8 @@ DefinitionModule { register struct def *df; struct idf *id; + struct node *exportlist; + int dummy; } : DEFINITION MODULE IDENT { @@ -153,18 +158,18 @@ DefinitionModule df = define(id, GlobalScope, D_MODULE); if (!SYSTEMModule) open_scope(CLOSEDSCOPE); if (!Defined) Defined = df; - df->mod_scope = CurrentScope; + df->mod_vis = CurrVis; df->mod_number = 0; CurrentScope->sc_name = id->id_text; df->df_type = standard_type(T_RECORD, 0, (arith) 0); - df->df_type->rec_scope = df->mod_scope; + df->df_type->rec_scope = df->mod_vis->sc_scope; DefinitionModule++; DO_DEBUG(1, debug("Definition module \"%s\" %d", id->id_text, DefinitionModule)); } ';' import(0)* - export(1)? + export(&dummy, &exportlist, 1)? /* New Modula-2 does not have export lists in definition modules. For the time being, we ignore export lists here, and a warning is issued. @@ -237,14 +242,15 @@ ProgramModule(int state;) DEFofIMPL = 1; df = GetDefinitionModule(id); currentdef = df; - CurrentScope = df->mod_scope; + CurrVis = df->mod_vis; + CurrentScope = CurrVis->sc_scope; DEFofIMPL = 0; } else { df = define(id, CurrentScope, D_MODULE); Defined = df; open_scope(CLOSEDSCOPE); - df->mod_scope = CurrentScope; + df->mod_vis = CurrVis; df->mod_number = 0; CurrentScope->sc_name = id->id_text; } diff --git a/lang/m2/comp/scope.C b/lang/m2/comp/scope.C index 9aad947ad..fbb6f6c4a 100644 --- a/lang/m2/comp/scope.C +++ b/lang/m2/comp/scope.C @@ -16,16 +16,21 @@ static char *RcsId = "$Header$"; #include "debug.h" -struct scope *CurrentScope, *PervasiveScope, *GlobalScope; +struct scope *PervasiveScope, *GlobalScope; +struct scopelist *CurrVis; static int scp_level; +static struct scopelist *PervVis; /* STATICALLOCDEF "scope" */ +/* STATICALLOCDEF "scopelist" */ + open_scope(scopetype) { /* Open a scope that is either open (automatic imports) or closed. */ register struct scope *sc = new_scope(); + register struct scopelist *ls = new_scopelist(); assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE); sc->sc_scopeclosed = scopetype == CLOSEDSCOPE; @@ -33,26 +38,30 @@ open_scope(scopetype) sc->sc_forw = 0; sc->sc_def = 0; sc->sc_off = 0; - sc->next = 0; - DO_DEBUG(1, debug("Opening a %s scope", - scopetype == OPENSCOPE ? "open" : "closed")); - if (CurrentScope != PervasiveScope) { - sc->next = CurrentScope; + if (scopetype == OPENSCOPE) { + ls->next = CurrVis; } - CurrentScope = sc; + else ls->next = PervVis; + ls->sc_scope = sc; + ls->sc_encl = CurrVis; + CurrVis = ls; } init_scope() { register struct scope *sc = new_scope(); + register struct scopelist *ls = new_scopelist(); sc->sc_scopeclosed = 0; sc->sc_forw = 0; sc->sc_def = 0; sc->sc_level = scp_level++; - sc->next = 0; PervasiveScope = sc; - CurrentScope = sc; + ls->next = 0; + ls->sc_encl = 0; + ls->sc_scope = PervasiveScope; + PervVis = ls; + CurrVis = ls; } struct forwards { @@ -127,15 +136,15 @@ node_error((*pdf)->for_node, "identifier \"%s\" has not been declared", Maybe the definitions are in the enclosing scope? */ - struct scope *sc; + struct scopelist *ls; - sc = enclosing(CurrentScope); + ls = nextvisible(CurrVis); if ((*pdf)->df_kind == D_FORWMODULE) { - (*pdf)->for_scope->next = sc; + (*pdf)->for_vis->next = ls; } - (*pdf)->df_nextinscope = sc->sc_def; - sc->sc_def = *pdf; - (*pdf)->df_scope = sc; + (*pdf)->df_nextinscope = ls->sc_scope->sc_def; + ls->sc_scope->sc_def = *pdf; + (*pdf)->df_scope = ls->sc_scope; *pdf = df1; } } @@ -154,7 +163,7 @@ rem_forwards(fo) struct def *lookfor(); while (f = fo) { - df = lookfor(&(f->fo_tok), CurrentScope, 1); + df = lookfor(&(f->fo_tok), CurrVis, 1); if (!(df->df_kind & (D_TYPE|D_HTYPE|D_ERROR))) { node_error(&(f->fo_tok), "identifier \"%s\" not a type", df->df_idf->id_text); @@ -216,7 +225,7 @@ close_scope(flag) if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def)); if (flag & SC_REVERSE) Reverse(&(sc->sc_def)); } - CurrentScope = sc->next; + CurrVis = enclosing(CurrVis); scp_level = CurrentScope->sc_level; } diff --git a/lang/m2/comp/scope.h b/lang/m2/comp/scope.h index adddeef58..4bee7e82b 100644 --- a/lang/m2/comp/scope.h +++ b/lang/m2/comp/scope.h @@ -25,11 +25,20 @@ struct scope { int sc_level; /* level of this scope */ }; +struct scopelist { + struct scopelist *next; + struct scopelist *sc_encl; + struct scope *sc_scope; +}; + extern struct scope - *CurrentScope, *PervasiveScope, *GlobalScope; -#define enclosing(x) ((x)->next) +extern struct scopelist + *CurrVis; + +#define CurrentScope (CurrVis->sc_scope) +#define enclosing(x) ((x)->sc_encl) #define scopeclosed(x) ((x)->sc_scopeclosed) -#define nextvisible(x) (scopeclosed(x) ? PervasiveScope : enclosing(x)) +#define nextvisible(x) ((x)->next) /* use with scopelists */ diff --git a/lang/m2/comp/statement.g b/lang/m2/comp/statement.g index 1b0688268..c60104736 100644 --- a/lang/m2/comp/statement.g +++ b/lang/m2/comp/statement.g @@ -5,6 +5,7 @@ static char *RcsId = "$Header$"; #include #include + #include "idf.h" #include "LLlex.h" #include "scope.h" diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index f206e6cd8..e1595d4f5 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -97,7 +97,6 @@ extern struct type *word_type, *address_type, *intorcard_type, - *string_type, *bitset_type, *std_type, *error_type; /* All from type.c */ @@ -130,3 +129,5 @@ struct type *subr_type(); /* All from type.c */ #define NULLTYPE ((struct type *) 0) + +#define IsConformantArray(tpx) ((tpx)->tp_fund == T_ARRAY && (tpx)->next == 0) diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index 41d1e255b..f54240230 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -50,7 +50,6 @@ struct type *word_type, *address_type, *intorcard_type, - *string_type, *bitset_type, *std_type, *error_type; @@ -152,8 +151,8 @@ init_types() char_type = standard_type(T_CHAR, 1, (arith) 1); char_type->enm_ncst = 256; - /* character constant, different from char because of compatibility - with ARRAY OF CHAR + /* character constant type, different from character type because + of compatibility with character array's */ charc_type = standard_type(T_CHAR, 1, (arith) 1); charc_type->enm_ncst = 256; @@ -176,10 +175,6 @@ init_types() real_type = standard_type(T_REAL, float_align, float_size); longreal_type = standard_type(T_REAL, double_align, double_size); - /* string constant type - */ - string_type = standard_type(T_STRING, 1, (arith) -1); - /* SYSTEM types */ word_type = standard_type(T_WORD, word_align, word_size); diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 80c23318e..6ccd9aa7c 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -39,13 +39,9 @@ TstParEquiv(tp1, tp2) TstTypeEquiv(tp1, tp2) || ( - tp1->tp_fund == T_ARRAY + IsConformantArray(tp1) && - tp1->next == 0 - && - tp2->tp_fund == T_ARRAY - && - tp2->next == 0 + IsConformantArray(tp2) && TstTypeEquiv(tp1->arr_elem, tp2->arr_elem) ); @@ -61,11 +57,15 @@ TstProcEquiv(tp1, tp2) */ register struct paramlist *p1, *p2; - if (!TstTypeEquiv(tp1->next, tp2->next)) return 0; + /* First check if the result types are equivalent + */ + if (! TstTypeEquiv(tp1->next, tp2->next)) return 0; p1 = tp1->prc_params; p2 = tp2->prc_params; + /* Now check the parameters + */ while (p1 && p2) { if (p1->par_var != p2->par_var || !TstParEquiv(p1->par_type, p2->par_type)) return 0; @@ -123,10 +123,12 @@ TstCompat(tp1, tp2) ; } -int TstAssCompat(tp1, tp2) +int +TstAssCompat(tp1, tp2) struct type *tp1, *tp2; { /* Test if two types are assignment compatible. + See Def 9.1. */ if (TstCompat(tp1, tp2)) return 1; @@ -138,24 +140,39 @@ int TstAssCompat(tp1, tp2) (tp2->tp_fund & T_INTORCARD)) return 1; if (tp1 == char_type && tp2 == charc_type) return 1; - if (tp1->tp_fund == T_ARRAY && - (tp2 == charc_type || tp2 == string_type)) { - /* Unfortunately the length of the string is not - available here, so this must be tested somewhere else (???) - */ + + if (tp1->tp_fund == T_ARRAY) { + arith size; + + if (! tp1->next) return 0; + + size = tp1->arr_ub - tp1->arr_lb + 1; tp1 = tp1->arr_elem; if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next; - return tp1 == char_type; + return + tp1 == char_type + && + ( + tp2 == charc_type + || + (tp2->tp_fund == T_STRING && size >= tp2->tp_size) + ); } return 0; } -int TstParCompat(formaltype, actualtype, VARflag) +int +TstParCompat(formaltype, actualtype, VARflag) struct type *formaltype, *actualtype; { /* Check type compatibility for a parameter in a procedure - call + call. Ordinary type compatibility is sufficient in any case. + Assignment compatibility may do if the parameter is + a value parameter. + Otherwise, a conformant array may do, or an ARRAY OF WORD + may do too. + Or: a WORD may do. */ return @@ -163,8 +180,19 @@ int TstParCompat(formaltype, actualtype, VARflag) || ( !VARflag && TstAssCompat(formaltype, actualtype)) || - ( formaltype->tp_fund == T_ARRAY - && formaltype->next == 0 - && actualtype->tp_fund == T_ARRAY - && TstTypeEquiv(formaltype->arr_elem, actualtype->arr_elem)); + ( formaltype == word_type && actualtype->tp_size == word_size) + || + ( IsConformantArray(formaltype) + && + ( formaltype->arr_elem == word_type + || + ( actualtype->tp_fund == T_ARRAY + && TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem) + ) + || + ( actualtype->tp_fund == T_STRING + && TstTypeEquiv(formaltype->arr_elem, char_type) + ) + ) + ); } diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index 9e7c2e73a..dfd8d6437 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -34,11 +34,11 @@ WalkModule(module) /* Walk through a module, and all its local definitions. Also generate code for its body. */ - register struct def *df = module->mod_scope->sc_def; - struct scope *scope; + register struct def *df = module->mod_vis->sc_scope->sc_def; + struct scopelist *vis; - scope = CurrentScope; - CurrentScope = module->mod_scope; + vis = CurrVis; + CurrVis = module->mod_vis; if (!prclev && module->mod_number) { /* This module is a local module, but not within a @@ -46,13 +46,13 @@ WalkModule(module) variables. This is done by generating a "bss", with label "_". */ - arith size = align(CurrentScope->sc_off, word_size); + arith size = align(CurrentScope->sc_off, word_align); if (size == 0) size = word_size; C_df_dnam(&(CurrentScope->sc_name[1])); C_bss_cst(size, (arith) 0, 0); } - else if (CurrentScope == Defined->mod_scope) { + else if (CurrVis == Defined->mod_vis) { /* This module is the module currently being compiled. Again, generate code to allocate storage for its variables, which all have an explicit name. @@ -83,9 +83,9 @@ WalkModule(module) WalkNode(module->mod_body, (label) 0); C_df_ilb(return_label); C_ret((label) 0); - C_end(align(-CurrentScope->sc_off, word_size)); + C_end(align(-CurrentScope->sc_off, word_align)); - CurrentScope = scope; + CurrVis = vis; } WalkProcedure(procedure) @@ -94,11 +94,10 @@ WalkProcedure(procedure) /* Walk through the definition of a procedure and all its local definitions */ - struct scope *scope = CurrentScope; - register struct def *df; + struct scopelist *vis = CurrVis; prclev++; - CurrentScope = procedure->prc_scope; + CurrVis = procedure->prc_vis; WalkDef(CurrentScope->sc_def); @@ -117,7 +116,7 @@ WalkProcedure(procedure) if (func_type) C_ret((arith) align(func_type->tp_size, word_align)); else C_ret((arith) 0); C_end(align(-CurrentScope->sc_off, word_size)); - CurrentScope = scope; + CurrVis = vis; prclev--; } @@ -126,6 +125,7 @@ WalkDef(df) { /* Walk through a list of definitions */ + while (df) { if (df->df_kind == D_MODULE) { WalkModule(df); @@ -142,10 +142,11 @@ MkCalls(df) { /* Generate calls to initialization routines of modules */ + while (df) { if (df->df_kind == D_MODULE) { C_lxl((arith) 0); - C_cal(df->mod_scope->sc_name); + C_cal(df->mod_vis->sc_scope->sc_name); } df = df->df_nextinscope; } @@ -160,7 +161,7 @@ WalkNode(nd, lab) "lab" represents the label that must be jumped to on encountering an EXIT statement. */ - + while (nd->nd_class == Link) { /* statement list */ WalkStat(nd->nd_left, lab); nd = nd->nd_right; @@ -191,8 +192,13 @@ WalkStat(nd, lab) switch(nd->nd_symb) { case BECOMES: - WalkExpr(nd->nd_right); - WalkDesignator(nd->nd_left); + WalkDesignator(left); + WalkExpr(right); + + if (! TstAssCompat(left->nd_type, right->nd_type)) { + node_error(nd, "type incompatibility in assignment"); + break; + } /* ??? */ break; @@ -217,8 +223,23 @@ WalkStat(nd, lab) } case CASE: - /* ??? */ - break; + { + WalkExpr(left); + + while (right) { + if (right->nd_class == Link && right->nd_symb == '|') { + WalkNode(right->nd_left->nd_right, lab); + right = right->nd_right; + } + else { + WalkNode(right, lab); + right = 0; + } + } + + /* ??? */ + break; + } case WHILE: { label l1, l2; @@ -259,11 +280,27 @@ WalkStat(nd, lab) case FOR: /* ??? */ + WalkNode(right, lab); break; case WITH: - /* ??? */ - break; + { + struct scopelist link; + + WalkDesignator(left); + if (left->nd_type->tp_fund != T_RECORD) { + node_error(left, "record variable expected"); + break; + } + + link.sc_scope = left->nd_type->rec_scope; + link.next = CurrVis; + CurrVis = &link; + WalkNode(right, lab); + CurrVis = link.next; + /* ??? */ + break; + } case EXIT: assert(lab != 0); @@ -274,7 +311,10 @@ WalkStat(nd, lab) case RETURN: if (right) { WalkExpr(right); - if (!TstCompat(right->nd_type, func_type)) { + /* What kind of compatibility do we need here ??? + assignment compatibility? + */ + if (!TstAssCompat(func_type, right->nd_type)) { node_error(right, "type incompatibility in RETURN statement"); } } -- 2.34.1