d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases 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 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;
}

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

@ -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 */
};

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.
*/
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;
}

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

@ -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)
|

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

@ -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
};

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

@ -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),
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 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);
}
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;
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);

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

@ -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);
}

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

@ -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) ')'
|

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

@ -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;
}

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

@ -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;
}

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

@ -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 */

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

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

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

@ -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)

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

@ -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);

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

@ -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)
)
)
);
}

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

@ -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 "_<modulenumber><modulename>".
*/
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");
}
}