d0p1/ack
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

newer version

Browse source
This commit is contained in:
ceriel 1986-04-28 18:06:58 +00:00
parent dd5b8dfabf
commit 53e3cd60d0
16 changed files with 379 additions and 228 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
lang/m2/comp/LLlex.c
View file

@ -76,7 +76,7 @@ GetString(upto)
register struct string *str = &string; register struct string *str = &string;
register char *p; 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); LoadChar(ch);
while (ch != upto) { while (ch != upto) {
if (class(ch) == STNL) { if (class(ch) == STNL) {
@ -91,7 +91,7 @@ GetString(upto)
*p++ = ch; *p++ = ch;
if (p - str->s_str == str->s_length) { if (p - str->s_str == str->s_length) {
str->s_str = Srealloc(str->s_str, str->s_str = Srealloc(str->s_str,
str->s_length + RSTRSIZE); (unsigned int) str->s_length + RSTRSIZE);
p = str->s_str + str->s_length; p = str->s_str + str->s_length;
str->s_length += RSTRSIZE; str->s_length += RSTRSIZE;
} }

2
lang/m2/comp/LLlex.h
View file

@ -3,7 +3,7 @@
/* $Header$ */ /* $Header$ */
struct string { struct string {
unsigned int s_length; /* length of a string */ arith s_length; /* length of a string */
char *s_str; /* the string itself */ char *s_str; /* the string itself */
}; };

56
lang/m2/comp/chk_expr.c
View file

@ -388,6 +388,8 @@ FlagCheck(expp, df, flag)
"flag". Here, a definition "df" is checked against it. "flag". Here, a definition "df" is checked against it.
*/ */
if (df->df_kind == D_ERROR) return 0;
if ((flag & VARIABLE) && if ((flag & VARIABLE) &&
!(df->df_kind & (D_FIELD|D_VARIABLE))) { !(df->df_kind & (D_FIELD|D_VARIABLE))) {
node_error(expp, "variable expected"); node_error(expp, "variable expected");
@ -432,7 +434,7 @@ chk_designator(expp, flag)
expp->nd_type = error_type; expp->nd_type = error_type;
if (expp->nd_class == Name) { 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_class = Def;
expp->nd_type = expp->nd_def->df_type; expp->nd_type = expp->nd_def->df_type;
if (expp->nd_type == error_type) return 0; if (expp->nd_type == error_type) return 0;
@ -489,8 +491,15 @@ df->df_idf->id_text);
expp->nd_symb = INTEGER; expp->nd_symb = INTEGER;
} }
else { else {
char *fn;
int ln;
assert(df->df_kind == D_CONST); assert(df->df_kind == D_CONST);
ln = expp->nd_lineno;
fn = expp->nd_filename;
*expp = *(df->con_const); *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)) { if (!TstAssCompat(tpl, tpr->next)) {
/* Assignment compatible ??? /* 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??? 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 '-':
case '*': case '*':
switch(tpl->tp_fund) { switch(tpl->tp_fund) {
case T_POINTER:
if (tpl != address_type) break;
/* Fall through */
case T_INTEGER: case T_INTEGER:
case T_CARDINAL: case T_CARDINAL:
case T_INTORCARD: 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 DIV:
case MOD: 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) { if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp); cstbin(expp);
} }
@ -736,7 +748,8 @@ chk_uoper(expp)
{ {
/* Check an unary operation. /* 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; if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;
expp->nd_type = tpr; expp->nd_type = tpr;
@ -744,8 +757,8 @@ chk_uoper(expp)
switch(expp->nd_symb) { switch(expp->nd_symb) {
case '+': case '+':
if (tpr->tp_fund & T_NUMERIC) { if (tpr->tp_fund & T_NUMERIC) {
expp->nd_token = expp->nd_right->nd_token; expp->nd_token = right->nd_token;
FreeNode(expp->nd_right); FreeNode(right);
expp->nd_right = 0; expp->nd_right = 0;
return 1; return 1;
} }
@ -753,19 +766,19 @@ chk_uoper(expp)
case '-': case '-':
if (tpr->tp_fund & T_INTORCARD) { if (tpr->tp_fund & T_INTORCARD) {
if (expp->nd_right->nd_class == Value) { if (right->nd_class == Value) {
cstunary(expp); cstunary(expp);
} }
return 1; return 1;
} }
else if (tpr->tp_fund == T_REAL) { else if (tpr->tp_fund == T_REAL) {
if (expp->nd_right->nd_class == Value) { if (right->nd_class == Value) {
expp->nd_token = expp->nd_right->nd_token; expp->nd_token = right->nd_token;
if (*(expp->nd_REL) == '-') { if (*(expp->nd_REL) == '-') {
expp->nd_REL++; expp->nd_REL++;
} }
else expp->nd_REL--; else expp->nd_REL--;
FreeNode(expp->nd_right); FreeNode(right);
expp->nd_right = 0; expp->nd_right = 0;
} }
return 1; return 1;
@ -775,7 +788,7 @@ chk_uoper(expp)
case NOT: case NOT:
case '~': case '~':
if (tpr == bool_type) { if (tpr == bool_type) {
if (expp->nd_right->nd_class == Value) { if (right->nd_class == Value) {
cstunary(expp); cstunary(expp);
} }
return 1; return 1;
@ -794,19 +807,27 @@ struct node *
getvariable(arg) getvariable(arg)
register struct node *arg; register struct node *arg;
{ {
struct def *df;
register struct node *left;
arg = arg->nd_right; arg = arg->nd_right;
if (!arg) { if (!arg) {
node_error(arg, "too few parameters supplied"); node_error(arg, "too few parameters supplied");
return 0; return 0;
} }
if (! chk_designator(arg->nd_left, DESIGNATOR)) return 0; left = arg->nd_left;
if (arg->nd_left->nd_class == Oper || arg->nd_left->nd_class == Uoper) {
if (! chk_designator(left, DESIGNATOR)) return 0;
if (left->nd_class == Oper || left->nd_class == Uoper) {
return arg; return arg;
} }
if (arg->nd_left->nd_class != Def || df = 0;
!(arg->nd_left->nd_def->df_kind & (D_VARIABLE|D_FIELD))) { 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"); node_error(arg, "variable expected");
return 0; return 0;
} }
@ -947,7 +968,10 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
return 0; return 0;
} }
if (!(arg = getarg(arg, T_DISCRETE))) 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"); node_error(arg, "unexpected type");
return 0; return 0;
} }

11
lang/m2/comp/declar.g
View file

@ -37,7 +37,7 @@ ProcedureDeclaration
';' block(&(df->prc_body)) IDENT ';' block(&(df->prc_body)) IDENT
{ {
match_id(dot.TOK_IDF, df->df_idf); match_id(dot.TOK_IDF, df->df_idf);
df->prc_scope = CurrentScope; df->prc_vis = CurrVis;
close_scope(SC_CHKFORW|SC_REVERSE); close_scope(SC_CHKFORW|SC_REVERSE);
proclevel--; proclevel--;
currentdef = savecurr; currentdef = savecurr;
@ -182,14 +182,9 @@ TypeDeclaration
'=' type(&tp) '=' type(&tp)
{ if (df->df_type) free_type(df->df_type); { if (df->df_type) free_type(df->df_type);
df->df_type = tp; 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 && if (df->df_kind == D_HTYPE &&
tp->tp_fund != T_POINTER) { 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; else tp = df->df_type;
} }
| %if ( nd = new_node(), nd->nd_token = dot, | %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) df->df_kind == D_MODULE)
type(&tp) type(&tp)
| |

13
lang/m2/comp/def.H
View file

@ -4,11 +4,11 @@
struct module { struct module {
arith mo_priority; /* priority of a 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 */ struct node *mo_body; /* body of this module */
int mo_number; /* number of this module */ int mo_number; /* number of this module */
#define mod_priority df_value.df_module.mo_priority #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_body df_value.df_module.mo_body
#define mod_number df_value.df_module.mo_number #define mod_number df_value.df_module.mo_number
}; };
@ -51,11 +51,11 @@ struct field {
}; };
struct dfproc { struct dfproc {
struct scope *pr_scope; /* scope of procedure */ struct scopelist *pr_vis; /* scope of procedure */
short pr_level; /* depth level of this procedure */ short pr_level; /* depth level of this procedure */
arith pr_nbpar; /* number of bytes parameters */ arith pr_nbpar; /* number of bytes parameters */
struct node *pr_body; /* body of this procedure */ 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_level df_value.df_proc.pr_level
#define prc_nbpar df_value.df_proc.pr_nbpar #define prc_nbpar df_value.df_proc.pr_nbpar
#define prc_body df_value.df_proc.pr_body #define prc_body df_value.df_proc.pr_body
@ -67,11 +67,12 @@ struct import {
}; };
struct dforward { struct dforward {
struct scope *fo_scope; struct scopelist *fo_vis;
struct node *fo_node; struct node *fo_node;
char *fo_name; char *fo_name;
#define for_node df_value.df_forward.fo_node #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 #define for_name df_value.df_forward.fo_name
}; };

190
lang/m2/comp/def.c
View file

@ -35,11 +35,10 @@ MkDef(id, scope, kind)
register struct def *df; register struct def *df;
df = new_def(); df = new_def();
df->df_flags = 0; clear((char *) df, sizeof (*df));
df->df_idf = id; df->df_idf = id;
df->df_scope = scope; df->df_scope = scope;
df->df_kind = kind; df->df_kind = kind;
df->df_type = 0;
df->next = id->id_def; df->next = id->id_def;
id->id_def = df; id->id_def = df;
@ -66,8 +65,7 @@ define(id, scope, kind)
if ( /* Already in this scope */ if ( /* Already in this scope */
df df
|| /* A closed scope, and id defined in the pervasive scope */ || /* A closed scope, and id defined in the pervasive scope */
( CurrentScope == scope (
&&
scopeclosed(scope) scopeclosed(scope)
&& &&
(df = lookup(id, PervasiveScope))) (df = lookup(id, PervasiveScope)))
@ -79,31 +77,40 @@ define(id, scope, kind)
return df; return df;
} }
break; break;
case D_FORWMODULE: case D_FORWMODULE:
if (kind == D_FORWMODULE) { if (kind == D_FORWMODULE) {
return df; return df;
} }
if (kind == D_MODULE) { if (kind == D_MODULE) {
FreeNode(df->for_node); FreeNode(df->for_node);
df->mod_scope = df->for_scope; df->mod_vis = df->for_vis;
df->df_kind = kind; df->df_kind = kind;
return df; return df;
} }
break; break;
case D_FORWARD: case D_FORWARD:
if (kind != D_FORWARD) { if (kind != D_FORWARD) {
FreeNode(df->for_node); FreeNode(df->for_node);
} }
/* Fall Through */
df->df_kind = kind;
return df;
case D_ERROR: case D_ERROR:
df->df_kind = kind; df->df_kind = kind;
return df; return df;
} }
if (kind != D_ERROR) { if (kind != D_ERROR) {
error("identifier \"%s\" already declared", id->id_text); error("identifier \"%s\" already declared", id->id_text);
} }
return df; return df;
} }
return MkDef(id, scope, kind); return MkDef(id, scope, kind);
} }
@ -129,7 +136,6 @@ lookup(id, scope)
retval = df->imp_def; retval = df->imp_def;
assert(retval != 0); assert(retval != 0);
} }
if (df1) { if (df1) {
df1->next = df->next; df1->next = df->next;
df->next = id->id_def; df->next = id->id_def;
@ -143,8 +149,38 @@ lookup(id, scope)
return 0; 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; register struct node *ids;
struct def *moddef;
{ {
/* From the current scope, the list of identifiers "ids" is /* From the current scope, the list of identifiers "ids" is
exported. Note this fact. If the export is not qualified, make exported. Note this fact. If the export is not qualified, make
@ -152,47 +188,71 @@ Export(ids, qualified)
in this scope as "imported". in this scope as "imported".
*/ */
register struct def *df, *df1; 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); 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", node_error(ids, "Identifier \"%s\" occurs more than once in export list",
df->df_idf->id_text); 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) { if (qualified) {
df->df_flags |= D_QEXPORTED; df->df_flags |= D_QEXPORTED;
} }
else { 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; df->df_flags |= D_EXPORTED;
df1 = lookup(ids->nd_IDF, enclosing(CurrentScope)); df1 = lookup(ids->nd_IDF, enclosing(CurrVis)->sc_scope);
if (! df1 || !(df1->df_kind & (D_PROCHEAD|D_HIDDEN))) { if (df1 && df1->df_kind == D_PROCHEAD) {
df1 = define(ids->nd_IDF, if (df->df_kind == D_PROCEDURE) {
enclosing(CurrentScope), df1->df_kind = D_IMPORT;
df1->imp_def = df;
continue;
}
}
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); D_IMPORT);
}
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;
}
df1->imp_def = df; df1->imp_def = df;
DoImport(df, enclosing(CurrVis)->sc_scope);
} }
ids = ids->next;
} }
FreeNode(nd);
} }
static struct scope * static struct scopelist *
ForwModule(df, idn) ForwModule(df, idn)
register struct def *df; register struct def *df;
struct node *idn; struct node *idn;
@ -200,22 +260,22 @@ ForwModule(df, idn)
/* An import is done from a not yet defined module "idn". /* An import is done from a not yet defined module "idn".
Create a declaration and a scope for this module. 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; df->df_kind = D_FORWMODULE;
open_scope(CLOSEDSCOPE); 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 field is not set right. It must indicate the
enclosing scope, but this must be done AFTER enclosing scope, but this must be done AFTER
closing this one closing this one
*/ */
df->for_scope = scope; df->for_vis = vis;
df->for_node = MkNode(Name, NULLNODE, NULLNODE, &(idn->nd_token)); df->for_node = MkNode(Name, NULLNODE, NULLNODE, &(idn->nd_token));
close_scope(0); close_scope(0);
scope->next = df->df_scope; vis->sc_encl = enclosing(CurrVis);
/* Here ! */ /* Here ! */
return scope; return vis;
} }
static struct def * static struct def *
@ -253,8 +313,7 @@ Import(ids, idn, local)
identifiers defined in this module. identifiers defined in this module.
*/ */
register struct def *df; register struct def *df;
struct scope *scope = enclosing(CurrentScope); struct scopelist *vis = enclosing(CurrVis);
int kind = D_IMPORT;
int forwflag = 0; int forwflag = 0;
#define FROM_MODULE 0 #define FROM_MODULE 0
#define FROM_ENCLOSING 1 #define FROM_ENCLOSING 1
@ -264,7 +323,7 @@ Import(ids, idn, local)
if (idn) { if (idn) {
imp_kind = FROM_MODULE; imp_kind = FROM_MODULE;
if (local) { if (local) {
df = lookfor(idn, scope, 0); df = lookfor(idn, vis, 0);
switch(df->df_kind) { switch(df->df_kind) {
case D_ERROR: case D_ERROR:
/* The module from which the import was done /* 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. accept this, but for the time being I will.
??? ???
*/ */
scope = ForwModule(df, idn); vis = ForwModule(df, idn);
forwflag = 1; forwflag = 1;
break; break;
case D_FORWMODULE: case D_FORWMODULE:
scope = df->for_scope; vis = df->for_vis;
break; break;
case D_MODULE: case D_MODULE:
scope = df->mod_scope; vis = df->mod_vis;
break; break;
default: default:
kind = D_ERROR;
node_error(idn, "identifier \"%s\" does not represent a module", node_error(idn, "identifier \"%s\" does not represent a module",
idn->nd_IDF->id_text); idn->nd_IDF->id_text);
break; break;
} }
} }
else scope = GetDefinitionModule(idn->nd_IDF)->mod_scope; else vis = GetDefinitionModule(idn->nd_IDF)->mod_vis;
FreeNode(idn); FreeNode(idn);
} }
@ -297,9 +355,9 @@ idn->nd_IDF->id_text);
while (ids) { while (ids) {
if (imp_kind == FROM_MODULE) { if (imp_kind == FROM_MODULE) {
if (forwflag) { 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", node_error(ids, "identifier \"%s\" not declared in qualifying module",
ids->nd_IDF->id_text); ids->nd_IDF->id_text);
df = ill_df; df = ill_df;
@ -310,40 +368,20 @@ ids->nd_IDF->id_text);
} }
} }
else { else {
if (local) df = ForwDef(ids, scope); if (local) df = ForwDef(ids, vis->sc_scope);
else df = GetDefinitionModule(ids->nd_IDF); else df = GetDefinitionModule(ids->nd_IDF);
} }
DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text, DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text,
df->df_kind)); df->df_kind));
define(ids->nd_IDF, CurrentScope, kind)->imp_def = df; define(df->df_idf, CurrentScope, D_IMPORT)->imp_def = df;
if (df->df_kind == D_TYPE && DoImport(df, CurrentScope);
df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals
*/
exprt_literals(df->df_type->enm_enums, CurrentScope);
}
ids = ids->next; ids = ids->next;
} }
FreeNode(idn); 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) RemImports(pdf)
struct def **pdf; struct def **pdf;
{ {
@ -417,18 +455,18 @@ DeclProc(type)
df->df_kind = D_PROCEDURE; df->df_kind = D_PROCEDURE;
open_scope(OPENSCOPE); open_scope(OPENSCOPE);
CurrentScope->sc_name = df->for_name; CurrentScope->sc_name = df->for_name;
df->prc_scope = CurrentScope; df->prc_vis = CurrVis;
} }
else { else {
df = define(dot.TOK_IDF, CurrentScope, type); df = define(dot.TOK_IDF, CurrentScope, type);
if (CurrentScope != Defined->mod_scope) { if (CurrVis != Defined->mod_vis) {
sprint(buf, "_%d_%s", ++nmcount, sprint(buf, "_%d_%s", ++nmcount,
df->df_idf->id_text); 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)); df->df_idf->id_text));
open_scope(OPENSCOPE); open_scope(OPENSCOPE);
df->prc_scope = CurrentScope; df->prc_vis = CurrVis;
CurrentScope->sc_name = Malloc((unsigned)(strlen(buf)+1)); CurrentScope->sc_name = Malloc((unsigned)(strlen(buf)+1));
strcpy(CurrentScope->sc_name, buf); strcpy(CurrentScope->sc_name, buf);
C_inp(buf); C_inp(buf);

34
lang/m2/comp/enter.c
View file

@ -103,17 +103,17 @@ EnterVarList(IdList, type, local)
procedure procedure
*/ */
register struct def *df; register struct def *df;
register struct scope *scope; register struct scopelist *sc;
char buf[256]; char buf[256];
extern char *sprint(), *Malloc(), *strcpy(); extern char *sprint(), *Malloc(), *strcpy();
scope = CurrentScope; sc = CurrVis;
if (local) { if (local) {
/* Find the closest enclosing open scope. This /* Find the closest enclosing open scope. This
is the procedure that we are dealing with 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) { while (IdList) {
@ -133,23 +133,25 @@ node_error(IdList->nd_left,"Illegal type for address");
as the variable list exists only local to a as the variable list exists only local to a
procedure 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); type->tp_align);
df->var_off = scope->sc_off; df->var_off = sc->sc_scope->sc_off;
} }
else if (!DefinitionModule && else if (!DefinitionModule &&
CurrentScope != Defined->mod_scope) { CurrVis != Defined->mod_vis) {
/* variable list belongs to an internal global /* variable list belongs to an internal global
module. Align offset and add size module. Align offset and add size
*/ */
scope->sc_off = align(scope->sc_off, type->tp_align); sc->sc_scope->sc_off =
df->var_off = scope->sc_off; align(sc->sc_scope->sc_off, type->tp_align);
scope->sc_off += type->tp_size; df->var_off = sc->sc_scope->sc_off;
sc->sc_scope->sc_off += type->tp_size;
} }
else { else {
/* Global name, possibly external /* 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->df_idf->id_text);
df->var_name = Malloc((unsigned)(strlen(buf)+1)); df->var_name = Malloc((unsigned)(strlen(buf)+1));
strcpy(df->var_name, buf); strcpy(df->var_name, buf);
@ -165,26 +167,26 @@ node_error(IdList->nd_left,"Illegal type for address");
} }
struct def * struct def *
lookfor(id, scope, give_error) lookfor(id, vis, give_error)
struct node *id; struct node *id;
struct scope *scope; struct scopelist *vis;
{ {
/* Look for an identifier in the visibility range started by /* Look for an identifier in the visibility range started by
"scope". "vis".
If it is not defined, maybe give an error message, and If it is not defined, maybe give an error message, and
create a dummy definition. create a dummy definition.
*/ */
struct def *df; struct def *df;
register struct scope *sc = scope; register struct scopelist *sc = vis;
struct def *MkDef(); struct def *MkDef();
while (sc) { while (sc) {
df = lookup(id->nd_IDF, sc); df = lookup(id->nd_IDF, sc->sc_scope);
if (df) return df; if (df) return df;
sc = nextvisible(sc); sc = nextvisible(sc);
} }
if (give_error) id_not_declared(id); 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);
} }

26
lang/m2/comp/expression.g
View file

@ -10,7 +10,6 @@ static char *RcsId = "$Header$";
#include "LLlex.h" #include "LLlex.h"
#include "idf.h" #include "idf.h"
#include "def.h" #include "def.h"
#include "scope.h"
#include "node.h" #include "node.h"
#include "const.h" #include "const.h"
#include "type.h" #include "type.h"
@ -170,6 +169,7 @@ factor(struct node **p;)
{ {
struct def *df; struct def *df;
struct node *nd; struct node *nd;
register struct type *tp;
} : } :
qualident(0, &df, (char *) 0, p) qualident(0, &df, (char *) 0, p)
[ [
@ -189,18 +189,20 @@ factor(struct node **p;)
| %default | %default
number(p) number(p)
| |
STRING { STRING {
*p = MkNode(Value, NULLNODE, NULLNODE, &dot); *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
if (dot.TOK_SLE == 1) { if (dot.TOK_SLE == 1) {
int i; int i;
i = *(dot.TOK_STR) & 0377; tp = charc_type;
(*p)->nd_type = charc_type; i = *(dot.TOK_STR) & 0377;
free(dot.TOK_STR); free(dot.TOK_STR);
dot.TOK_INT = i; free((char *) dot.tk_data.tk_str);
} dot.TOK_INT = i;
else (*p)->nd_type = string_type; }
} else tp = standard_type(T_STRING, 1, dot.TOK_SLE);
(*p)->nd_type = tp;
}
| |
'(' expression(p) ')' '(' expression(p) ')'
| |

50
lang/m2/comp/program.g
View file

@ -52,6 +52,8 @@ ModuleDeclaration
static int modulecount = 0; static int modulecount = 0;
char buf[256]; char buf[256];
struct node *nd; struct node *nd;
struct node *exportlist = 0;
int qualified;
extern char *sprint(), *Malloc(), *strcpy(); extern char *sprint(), *Malloc(), *strcpy();
} : } :
MODULE IDENT { MODULE IDENT {
@ -59,14 +61,14 @@ ModuleDeclaration
df = define(id, CurrentScope, D_MODULE); df = define(id, CurrentScope, D_MODULE);
currentdef = df; currentdef = df;
if (!df->mod_scope) { if (!df->mod_vis) {
open_scope(CLOSEDSCOPE); 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 = 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; df->mod_number = ++modulecount;
sprint(buf, "__%d%s", df->mod_number, id->id_text); sprint(buf, "__%d%s", df->mod_number, id->id_text);
CurrentScope->sc_name = CurrentScope->sc_name =
@ -78,9 +80,13 @@ ModuleDeclaration
priority(&(df->mod_priority))? priority(&(df->mod_priority))?
';' ';'
import(1)* import(1)*
export(0)? export(&qualified, &exportlist, 0)?
block(&nd) block(&nd)
IDENT { InitProc(nd, df); IDENT { InitProc(nd, df);
if (exportlist) {
Export(exportlist, qualified, df);
FreeNode(exportlist);
}
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE); close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF); match_id(id, dot.TOK_IDF);
currentdef = savecurr; 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 EXPORT
[ [
QUALIFIED QUALIFIED
{ QUALflag = 1; } { *QUALflag = 1; }
]? |
IdentList(&ExportList) ';' { *QUALflag = 0; }
]
IdentList(ExportList) ';'
{ {
if (!def) { if (def) {
Export(ExportList, QUALflag); node_warning(*ExportList, "export list in definition module ignored");
} FreeNode(*ExportList);
else {
node_warning(ExportList, "export list in definition module ignored");
FreeNode(ExportList);
} }
} }
; ;
@ -146,6 +149,8 @@ DefinitionModule
{ {
register struct def *df; register struct def *df;
struct idf *id; struct idf *id;
struct node *exportlist;
int dummy;
} : } :
DEFINITION DEFINITION
MODULE IDENT { MODULE IDENT {
@ -153,18 +158,18 @@ DefinitionModule
df = define(id, GlobalScope, D_MODULE); df = define(id, GlobalScope, D_MODULE);
if (!SYSTEMModule) open_scope(CLOSEDSCOPE); if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
if (!Defined) Defined = df; if (!Defined) Defined = df;
df->mod_scope = CurrentScope; df->mod_vis = CurrVis;
df->mod_number = 0; df->mod_number = 0;
CurrentScope->sc_name = id->id_text; CurrentScope->sc_name = id->id_text;
df->df_type = standard_type(T_RECORD, 0, (arith) 0); 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++; DefinitionModule++;
DO_DEBUG(1, debug("Definition module \"%s\" %d", DO_DEBUG(1, debug("Definition module \"%s\" %d",
id->id_text, DefinitionModule)); id->id_text, DefinitionModule));
} }
';' ';'
import(0)* import(0)*
export(1)? export(&dummy, &exportlist, 1)?
/* New Modula-2 does not have export lists in definition modules. /* New Modula-2 does not have export lists in definition modules.
For the time being, we ignore export lists here, and a For the time being, we ignore export lists here, and a
warning is issued. warning is issued.
@ -237,14 +242,15 @@ ProgramModule(int state;)
DEFofIMPL = 1; DEFofIMPL = 1;
df = GetDefinitionModule(id); df = GetDefinitionModule(id);
currentdef = df; currentdef = df;
CurrentScope = df->mod_scope; CurrVis = df->mod_vis;
CurrentScope = CurrVis->sc_scope;
DEFofIMPL = 0; DEFofIMPL = 0;
} }
else { else {
df = define(id, CurrentScope, D_MODULE); df = define(id, CurrentScope, D_MODULE);
Defined = df; Defined = df;
open_scope(CLOSEDSCOPE); open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope; df->mod_vis = CurrVis;
df->mod_number = 0; df->mod_number = 0;
CurrentScope->sc_name = id->id_text; CurrentScope->sc_name = id->id_text;
} }

43
lang/m2/comp/scope.C
View file

@ -16,16 +16,21 @@ static char *RcsId = "$Header$";
#include "debug.h" #include "debug.h"
struct scope *CurrentScope, *PervasiveScope, *GlobalScope; struct scope *PervasiveScope, *GlobalScope;
struct scopelist *CurrVis;
static int scp_level; static int scp_level;
static struct scopelist *PervVis;
/* STATICALLOCDEF "scope" */ /* STATICALLOCDEF "scope" */
/* STATICALLOCDEF "scopelist" */
open_scope(scopetype) open_scope(scopetype)
{ {
/* Open a scope that is either open (automatic imports) or closed. /* Open a scope that is either open (automatic imports) or closed.
*/ */
register struct scope *sc = new_scope(); register struct scope *sc = new_scope();
register struct scopelist *ls = new_scopelist();
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE); assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE; sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
@ -33,26 +38,30 @@ open_scope(scopetype)
sc->sc_forw = 0; sc->sc_forw = 0;
sc->sc_def = 0; sc->sc_def = 0;
sc->sc_off = 0; sc->sc_off = 0;
sc->next = 0; if (scopetype == OPENSCOPE) {
DO_DEBUG(1, debug("Opening a %s scope", ls->next = CurrVis;
scopetype == OPENSCOPE ? "open" : "closed"));
if (CurrentScope != PervasiveScope) {
sc->next = CurrentScope;
} }
CurrentScope = sc; else ls->next = PervVis;
ls->sc_scope = sc;
ls->sc_encl = CurrVis;
CurrVis = ls;
} }
init_scope() init_scope()
{ {
register struct scope *sc = new_scope(); register struct scope *sc = new_scope();
register struct scopelist *ls = new_scopelist();
sc->sc_scopeclosed = 0; sc->sc_scopeclosed = 0;
sc->sc_forw = 0; sc->sc_forw = 0;
sc->sc_def = 0; sc->sc_def = 0;
sc->sc_level = scp_level++; sc->sc_level = scp_level++;
sc->next = 0;
PervasiveScope = sc; PervasiveScope = sc;
CurrentScope = sc; ls->next = 0;
ls->sc_encl = 0;
ls->sc_scope = PervasiveScope;
PervVis = ls;
CurrVis = ls;
} }
struct forwards { struct forwards {
@ -127,15 +136,15 @@ node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
Maybe the definitions are in the Maybe the definitions are in the
enclosing scope? enclosing scope?
*/ */
struct scope *sc; struct scopelist *ls;
sc = enclosing(CurrentScope); ls = nextvisible(CurrVis);
if ((*pdf)->df_kind == D_FORWMODULE) { if ((*pdf)->df_kind == D_FORWMODULE) {
(*pdf)->for_scope->next = sc; (*pdf)->for_vis->next = ls;
} }
(*pdf)->df_nextinscope = sc->sc_def; (*pdf)->df_nextinscope = ls->sc_scope->sc_def;
sc->sc_def = *pdf; ls->sc_scope->sc_def = *pdf;
(*pdf)->df_scope = sc; (*pdf)->df_scope = ls->sc_scope;
*pdf = df1; *pdf = df1;
} }
} }
@ -154,7 +163,7 @@ rem_forwards(fo)
struct def *lookfor(); struct def *lookfor();
while (f = fo) { 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))) { if (!(df->df_kind & (D_TYPE|D_HTYPE|D_ERROR))) {
node_error(&(f->fo_tok), "identifier \"%s\" not a type", node_error(&(f->fo_tok), "identifier \"%s\" not a type",
df->df_idf->id_text); df->df_idf->id_text);
@ -216,7 +225,7 @@ close_scope(flag)
if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def)); if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
if (flag & SC_REVERSE) Reverse(&(sc->sc_def)); if (flag & SC_REVERSE) Reverse(&(sc->sc_def));
} }
CurrentScope = sc->next; CurrVis = enclosing(CurrVis);
scp_level = CurrentScope->sc_level; scp_level = CurrentScope->sc_level;
} }

15
lang/m2/comp/scope.h
View file

@ -25,11 +25,20 @@ struct scope {
int sc_level; /* level of this scope */ int sc_level; /* level of this scope */
}; };
struct scopelist {
struct scopelist *next;
struct scopelist *sc_encl;
struct scope *sc_scope;
};
extern struct scope extern struct scope
*CurrentScope,
*PervasiveScope, *PervasiveScope,
*GlobalScope; *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 scopeclosed(x) ((x)->sc_scopeclosed)
#define nextvisible(x) (scopeclosed(x) ? PervasiveScope : enclosing(x)) #define nextvisible(x) ((x)->next) /* use with scopelists */

1
lang/m2/comp/statement.g
View file

@ -5,6 +5,7 @@ static char *RcsId = "$Header$";
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h> #include <em_label.h>
#include "idf.h" #include "idf.h"
#include "LLlex.h" #include "LLlex.h"
#include "scope.h" #include "scope.h"

3
lang/m2/comp/type.H
View file

@ -97,7 +97,6 @@ extern struct type
*word_type, *word_type,
*address_type, *address_type,
*intorcard_type, *intorcard_type,
*string_type,
*bitset_type, *bitset_type,
*std_type, *std_type,
*error_type; /* All from type.c */ *error_type; /* All from type.c */
@ -130,3 +129,5 @@ struct type
*subr_type(); /* All from type.c */ *subr_type(); /* All from type.c */
#define NULLTYPE ((struct type *) 0) #define NULLTYPE ((struct type *) 0)
#define IsConformantArray(tpx) ((tpx)->tp_fund == T_ARRAY && (tpx)->next == 0)

9
lang/m2/comp/type.c
View file

@ -50,7 +50,6 @@ struct type
*word_type, *word_type,
*address_type, *address_type,
*intorcard_type, *intorcard_type,
*string_type,
*bitset_type, *bitset_type,
*std_type, *std_type,
*error_type; *error_type;
@ -152,8 +151,8 @@ init_types()
char_type = standard_type(T_CHAR, 1, (arith) 1); char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 256; char_type->enm_ncst = 256;
/* character constant, different from char because of compatibility /* character constant type, different from character type because
with ARRAY OF CHAR of compatibility with character array's
*/ */
charc_type = standard_type(T_CHAR, 1, (arith) 1); charc_type = standard_type(T_CHAR, 1, (arith) 1);
charc_type->enm_ncst = 256; charc_type->enm_ncst = 256;
@ -176,10 +175,6 @@ init_types()
real_type = standard_type(T_REAL, float_align, float_size); real_type = standard_type(T_REAL, float_align, float_size);
longreal_type = standard_type(T_REAL, double_align, double_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 /* SYSTEM types
*/ */
word_type = standard_type(T_WORD, word_align, word_size); word_type = standard_type(T_WORD, word_align, word_size);

68
lang/m2/comp/typequiv.c
View file

@ -39,13 +39,9 @@ TstParEquiv(tp1, tp2)
TstTypeEquiv(tp1, tp2) TstTypeEquiv(tp1, tp2)
|| ||
( (
tp1->tp_fund == T_ARRAY IsConformantArray(tp1)
&& &&
tp1->next == 0 IsConformantArray(tp2)
&&
tp2->tp_fund == T_ARRAY
&&
tp2->next == 0
&& &&
TstTypeEquiv(tp1->arr_elem, tp2->arr_elem) TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
); );
@ -61,11 +57,15 @@ TstProcEquiv(tp1, tp2)
*/ */
register struct paramlist *p1, *p2; 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; p1 = tp1->prc_params;
p2 = tp2->prc_params; p2 = tp2->prc_params;
/* Now check the parameters
*/
while (p1 && p2) { while (p1 && p2) {
if (p1->par_var != p2->par_var || if (p1->par_var != p2->par_var ||
!TstParEquiv(p1->par_type, p2->par_type)) return 0; !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; struct type *tp1, *tp2;
{ {
/* Test if two types are assignment compatible. /* Test if two types are assignment compatible.
See Def 9.1.
*/ */
if (TstCompat(tp1, tp2)) return 1; if (TstCompat(tp1, tp2)) return 1;
@ -138,24 +140,39 @@ int TstAssCompat(tp1, tp2)
(tp2->tp_fund & T_INTORCARD)) return 1; (tp2->tp_fund & T_INTORCARD)) return 1;
if (tp1 == char_type && tp2 == charc_type) return 1; if (tp1 == char_type && tp2 == charc_type) return 1;
if (tp1->tp_fund == T_ARRAY &&
(tp2 == charc_type || tp2 == string_type)) { if (tp1->tp_fund == T_ARRAY) {
/* Unfortunately the length of the string is not arith size;
available here, so this must be tested somewhere else (???)
*/ if (! tp1->next) return 0;
size = tp1->arr_ub - tp1->arr_lb + 1;
tp1 = tp1->arr_elem; tp1 = tp1->arr_elem;
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next; 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; return 0;
} }
int TstParCompat(formaltype, actualtype, VARflag) int
TstParCompat(formaltype, actualtype, VARflag)
struct type *formaltype, *actualtype; struct type *formaltype, *actualtype;
{ {
/* Check type compatibility for a parameter in a procedure /* 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 return
@ -163,8 +180,19 @@ int TstParCompat(formaltype, actualtype, VARflag)
|| ||
( !VARflag && TstAssCompat(formaltype, actualtype)) ( !VARflag && TstAssCompat(formaltype, actualtype))
|| ||
( formaltype->tp_fund == T_ARRAY ( formaltype == word_type && actualtype->tp_size == word_size)
&& formaltype->next == 0 ||
&& actualtype->tp_fund == T_ARRAY ( IsConformantArray(formaltype)
&& TstTypeEquiv(formaltype->arr_elem, actualtype->arr_elem)); &&
( 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)
)
)
);
} }

82
lang/m2/comp/walk.c
View file

@ -34,11 +34,11 @@ WalkModule(module)
/* Walk through a module, and all its local definitions. /* Walk through a module, and all its local definitions.
Also generate code for its body. Also generate code for its body.
*/ */
register struct def *df = module->mod_scope->sc_def; register struct def *df = module->mod_vis->sc_scope->sc_def;
struct scope *scope; struct scopelist *vis;
scope = CurrentScope; vis = CurrVis;
CurrentScope = module->mod_scope; CurrVis = module->mod_vis;
if (!prclev && module->mod_number) { if (!prclev && module->mod_number) {
/* This module is a local module, but not within a /* This module is a local module, but not within a
@ -46,13 +46,13 @@ WalkModule(module)
variables. This is done by generating a "bss", variables. This is done by generating a "bss",
with label "_<modulenumber><modulename>". with label "_<modulenumber><modulename>".
*/ */
arith size = align(CurrentScope->sc_off, word_size); arith size = align(CurrentScope->sc_off, word_align);
if (size == 0) size = word_size; if (size == 0) size = word_size;
C_df_dnam(&(CurrentScope->sc_name[1])); C_df_dnam(&(CurrentScope->sc_name[1]));
C_bss_cst(size, (arith) 0, 0); 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. /* This module is the module currently being compiled.
Again, generate code to allocate storage for its Again, generate code to allocate storage for its
variables, which all have an explicit name. variables, which all have an explicit name.
@ -83,9 +83,9 @@ WalkModule(module)
WalkNode(module->mod_body, (label) 0); WalkNode(module->mod_body, (label) 0);
C_df_ilb(return_label); C_df_ilb(return_label);
C_ret((label) 0); 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) WalkProcedure(procedure)
@ -94,11 +94,10 @@ WalkProcedure(procedure)
/* Walk through the definition of a procedure and all its /* Walk through the definition of a procedure and all its
local definitions local definitions
*/ */
struct scope *scope = CurrentScope; struct scopelist *vis = CurrVis;
register struct def *df;
prclev++; prclev++;
CurrentScope = procedure->prc_scope; CurrVis = procedure->prc_vis;
WalkDef(CurrentScope->sc_def); WalkDef(CurrentScope->sc_def);
@ -117,7 +116,7 @@ WalkProcedure(procedure)
if (func_type) C_ret((arith) align(func_type->tp_size, word_align)); if (func_type) C_ret((arith) align(func_type->tp_size, word_align));
else C_ret((arith) 0); else C_ret((arith) 0);
C_end(align(-CurrentScope->sc_off, word_size)); C_end(align(-CurrentScope->sc_off, word_size));
CurrentScope = scope; CurrVis = vis;
prclev--; prclev--;
} }
@ -126,6 +125,7 @@ WalkDef(df)
{ {
/* Walk through a list of definitions /* Walk through a list of definitions
*/ */
while (df) { while (df) {
if (df->df_kind == D_MODULE) { if (df->df_kind == D_MODULE) {
WalkModule(df); WalkModule(df);
@ -142,10 +142,11 @@ MkCalls(df)
{ {
/* Generate calls to initialization routines of modules /* Generate calls to initialization routines of modules
*/ */
while (df) { while (df) {
if (df->df_kind == D_MODULE) { if (df->df_kind == D_MODULE) {
C_lxl((arith) 0); C_lxl((arith) 0);
C_cal(df->mod_scope->sc_name); C_cal(df->mod_vis->sc_scope->sc_name);
} }
df = df->df_nextinscope; df = df->df_nextinscope;
} }
@ -160,7 +161,7 @@ WalkNode(nd, lab)
"lab" represents the label that must be jumped to on "lab" represents the label that must be jumped to on
encountering an EXIT statement. encountering an EXIT statement.
*/ */
while (nd->nd_class == Link) { /* statement list */ while (nd->nd_class == Link) { /* statement list */
WalkStat(nd->nd_left, lab); WalkStat(nd->nd_left, lab);
nd = nd->nd_right; nd = nd->nd_right;
@ -191,8 +192,13 @@ WalkStat(nd, lab)
switch(nd->nd_symb) { switch(nd->nd_symb) {
case BECOMES: case BECOMES:
WalkExpr(nd->nd_right); WalkDesignator(left);
WalkDesignator(nd->nd_left); WalkExpr(right);
if (! TstAssCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in assignment");
break;
}
/* ??? */ /* ??? */
break; break;
@ -217,8 +223,23 @@ WalkStat(nd, lab)
} }
case CASE: 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: case WHILE:
{ label l1, l2; { label l1, l2;
@ -259,11 +280,27 @@ WalkStat(nd, lab)
case FOR: case FOR:
/* ??? */ /* ??? */
WalkNode(right, lab);
break; break;
case WITH: 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: case EXIT:
assert(lab != 0); assert(lab != 0);
@ -274,7 +311,10 @@ WalkStat(nd, lab)
case RETURN: case RETURN:
if (right) { if (right) {
WalkExpr(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"); node_error(right, "type incompatibility in RETURN statement");
} }
} }