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-06-10 13:18:52 +00:00
parent 966213238a
commit ec528b797e
19 changed files with 524 additions and 524 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lang/m2/comp/Makefile
View file

@ -19,7 +19,7 @@ COBJ = LLlex.o LLmessage.o char.o error.o main.o \
symbol2str.o tokenname.o idf.o input.o type.o def.o \
scope.o misc.o enter.o defmodule.o typequiv.o node.o \
cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
code.o tmpvar.o
code.o tmpvar.o lookup.o
OBJ = $(COBJ) $(LOBJ) Lpars.o
GENFILES= tokenfile.c \
program.c declar.c expression.c statement.c \

9
lang/m2/comp/casestat.C
View file

@ -66,7 +66,7 @@ CaseCode(nd, exitlabel)
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
clear((char *) sh, sizeof(*sh));
WalkExpr(pnode->nd_left, NO_LABEL, NO_LABEL);
WalkExpr(pnode->nd_left);
sh->sh_type = pnode->nd_left->nd_type;
sh->sh_break = text_label();
@ -88,8 +88,9 @@ CaseCode(nd, exitlabel)
else {
/* Else part
*/
pnode = 0;
sh->sh_default = text_label();
pnode = 0;
}
}
@ -98,7 +99,7 @@ CaseCode(nd, exitlabel)
tablabel = data_label(); /* the rom must have a label */
C_df_dlb(tablabel);
if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
else C_rom_ilb(sh->sh_break);
if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
/* CSA */
@ -112,7 +113,7 @@ CaseCode(nd, exitlabel)
ce = ce->next;
}
else if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
else C_rom_ilb(sh->sh_break);
}
C_lae_dlb(tablabel, (arith)0); /* perform the switch */
C_csa(word_size);

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

@ -36,22 +36,17 @@ chk_expr(expp)
*/
switch(expp->nd_class) {
case Oper:
if (expp->nd_symb == '[') {
return chk_designator(expp, DESIGNATOR|VARIABLE, D_NOREG|D_USED);
}
case Arrsel:
return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
return chk_expr(expp->nd_left) &&
chk_expr(expp->nd_right) &&
chk_oper(expp);
case Oper:
return chk_oper(expp);
case Arrow:
return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
case Uoper:
if (expp->nd_symb == '^') {
return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
}
return chk_expr(expp->nd_right) &&
chk_uoper(expp);
return chk_uoper(expp);
case Value:
switch(expp->nd_symb) {
@ -547,7 +542,7 @@ df->df_idf->id_text);
return 0;
}
if (expp->nd_class == Oper) {
if (expp->nd_class == Arrsel) {
struct type *tpl, *tpr;
assert(expp->nd_symb == '[');
@ -582,7 +577,7 @@ df->df_idf->id_text);
return 1;
}
if (expp->nd_class == Uoper) {
if (expp->nd_class == Arrow) {
assert(expp->nd_symb == '^');
if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE, dflags)) {
@ -665,12 +660,18 @@ chk_oper(expp)
{
/* Check a binary operation.
*/
register struct node *left = expp->nd_left;
register struct node *right = expp->nd_right;
struct type *tpl = left->nd_type;
struct type *tpr = right->nd_type;
register struct node *left, *right;
struct type *tpl, *tpr;
int allowed;
left = expp->nd_left;
right = expp->nd_right;
if (!chk_expr(left) || !chk_expr(right)) return 0;
tpl = left->nd_type;
tpr = right->nd_type;
if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;
@ -763,8 +764,11 @@ chk_uoper(expp)
/* Check an unary operation.
*/
register struct node *right = expp->nd_right;
register struct type *tpr = right->nd_type;
register struct type *tpr;
if (! chk_expr(right)) return 0;
tpr = right->nd_type;
if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;
expp->nd_type = tpr;
@ -839,7 +843,7 @@ getvariable(argp)
left = arg->nd_left;
if (! chk_designator(left, DESIGNATOR, D_REFERRED)) return 0;
if (left->nd_class == Oper || left->nd_class == Uoper) {
if (left->nd_class == Arrsel || left->nd_class == Arrow) {
*argp = arg;
return left;
}

48
lang/m2/comp/code.c
View file

@ -60,7 +60,7 @@ CodeString(nd)
}
else {
C_df_dlb(lab = data_label());
C_rom_scon(nd->nd_STR, align(nd->nd_SLE + 1, (int) word_size));
C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
C_lae_dlb(lab, (arith) 0);
}
}
@ -72,7 +72,7 @@ CodePadString(nd, sz)
/* Generate code to push the string indicated by "nd".
Make it null-padded to "sz" bytes
*/
register arith sizearg = align(nd->nd_type->tp_size, word_align);
register arith sizearg = WA(nd->nd_type->tp_size);
assert(nd->nd_type->tp_fund == T_STRING);
@ -114,25 +114,21 @@ CodeExpr(nd, ds, true_label, false_label)
/* Fall through */
case Link:
case Arrsel:
case Arrow:
CodeDesig(nd, ds);
break;
case Oper:
if (nd->nd_symb == '[') {
CodeDesig(nd, ds);
break;
}
CodeOper(nd, true_label, false_label);
if (true_label == 0) ds->dsg_kind = DSG_LOADED;
else ds->dsg_kind = DSG_INIT;
true_label = 0;
else {
ds->dsg_kind = DSG_INIT;
true_label = 0;
}
break;
case Uoper:
if (nd->nd_symb == '^') {
CodeDesig(nd, ds);
break;
}
CodePExpr(nd->nd_right);
CodeUoper(nd);
ds->dsg_kind = DSG_LOADED;
@ -298,7 +294,6 @@ CodeCall(nd)
register struct node *arg = nd;
register struct paramlist *param;
struct type *tp;
arith pushed = 0;
if (left->nd_type == std_type) {
CodeStd(nd);
@ -332,27 +327,28 @@ CodeCall(nd)
else if (tp->arr_elem == word_type) {
C_loc(left->nd_type->tp_size / word_size - 1);
}
else C_loc(left->nd_type->tp_size /
tp->arr_elsize - 1);
else {
tp = left->nd_type->next;
if (tp->tp_fund == T_SUBRANGE) {
C_loc(tp->sub_ub - tp->sub_lb);
}
else C_loc((arith) (tp->enm_ncst - 1));
}
C_loc((arith) 0);
if (left->nd_symb == STRING) {
CodeString(left);
}
else CodeDAddress(left);
pushed += pointer_size + 3 * word_size;
}
else if (IsVarParam(param)) {
CodeDAddress(left);
pushed += pointer_size;
}
else {
if (left->nd_type->tp_fund == T_STRING) {
CodePadString(left,
align(tp->tp_size, word_align));
CodePadString(left, tp->tp_size);
}
else CodePExpr(left);
CheckAssign(left->nd_type, tp);
pushed += align(tp->tp_size, word_align);
}
}
@ -361,7 +357,6 @@ CodeCall(nd)
if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
if (left->nd_def->df_scope->sc_level > 0) {
C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level);
pushed += pointer_size;
}
C_cal(NameOfProc(left->nd_def));
}
@ -372,9 +367,9 @@ CodeCall(nd)
CodePExpr(left);
C_cai();
}
if (pushed) C_asp(pushed);
if (left->nd_type->prc_nbpar) C_asp(left->nd_type->prc_nbpar);
if (left->nd_type->next) {
C_lfr(align(left->nd_type->next->tp_size, word_align));
C_lfr(WA(left->nd_type->next->tp_size));
}
}
@ -526,7 +521,6 @@ CodeAssign(nd, dss, dst)
compatibility and the like is already done.
*/
register struct type *tp = nd->nd_right->nd_type;
extern arith align();
if (dss->dsg_kind == DSG_LOADED) {
if (tp->tp_fund == T_STRING) {
@ -787,6 +781,10 @@ CodeOper(expr, true_label, false_label)
Operands(rightop, leftop);
CodeCoercion(leftop->nd_type, word_type);
C_inn(rightop->nd_type->tp_size);
if (true_label != 0) {
C_zne(true_label);
C_bra(false_label);
}
break;
case AND:
case '&':
@ -1032,7 +1030,7 @@ DoHIGH(nd)
highoff = df->var_off + pointer_size + word_size;
if (df->df_scope->sc_level < proclevel) {
C_lxa(proclevel - df->df_scope->sc_level);
C_lxa((arith) (proclevel - df->df_scope->sc_level));
C_lof(highoff);
}
else C_lol(highoff);

3
lang/m2/comp/cstoper.c
View file

@ -430,8 +430,7 @@ cstcall(expp, call)
CutSize(expp);
break;
case S_SIZE:
expp->nd_INT = align(expr->nd_type->tp_size, (int) word_size) /
word_size;
expp->nd_INT = WA(expr->nd_type->tp_size) / word_size;
break;
case S_VAL:
expp->nd_INT = expr->nd_INT;

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

@ -139,10 +139,7 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
VAR { VARp = D_VARPAR; }
]?
IdentList(&FPList) ':' FormalType(&tp)
{
ParamList(ppr, FPList, tp, VARp, parmaddr);
FreeNode(FPList);
}
{ EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
;
FormalType(struct type **ptp;)
@ -235,11 +232,8 @@ enumeration(struct type **ptp;)
'(' IdentList(&EnumList) ')'
{
*ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
EnterIdList(EnumList, D_ENUM, 0, tp,
CurrentScope, (arith *) 0);
FreeNode(EnumList);
if (tp->enm_ncst > 256) {
/* ??? is this reasonable ??? */
EnterEnumList(EnumList, tp);
if (tp->enm_ncst > 256) { /* ??? is this reasonable ??? */
error("Too many enumeration literals");
}
}
@ -311,7 +305,7 @@ RecordType(struct type **ptp;)
}
FieldListSequence(scope, &count, &xalign)
{
*ptp = standard_type(T_RECORD, xalign, count);
*ptp = standard_type(T_RECORD, xalign, WA(count));
(*ptp)->rec_scope = scope;
}
END
@ -336,9 +330,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
[
IdentList(&FldList) ':' type(&tp)
{ *palign = lcm(*palign, tp->tp_align);
EnterIdList(FldList, D_FIELD, D_QEXPORTED,
tp, scope, cnt);
FreeNode(FldList);
EnterFieldList(FldList, tp, scope, cnt);
}
|
CASE
@ -575,9 +567,7 @@ VariableDeclaration
{ nd = nd->nd_right; }
]*
':' type(&tp)
{ EnterVarList(VarList, tp, proclevel > 0);
FreeNode(VarList);
}
{ EnterVarList(VarList, tp, proclevel > 0); }
;
IdentAddr(struct node **pnd;) :

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

@ -141,276 +141,6 @@ error("identifier \"%s\" already declared", id->id_text);
return MkDef(id, scope, kind);
}
struct def *
lookup(id, scope)
register struct idf *id;
struct scope *scope;
{
/* Look up a definition of an identifier in scope "scope".
Make the "def" list self-organizing.
Return a pointer to its "def" structure if it exists,
otherwise return 0.
*/
register struct def *df, *df1;
struct def *retval;
df1 = 0;
df = id->id_def;
while (df) {
if (df->df_scope == scope) {
retval = df;
if (df->df_kind == D_IMPORT) {
retval = df->imp_def;
assert(retval != 0);
}
if (df1) {
/* Put the definition now found in front
*/
df1->next = df->next;
df->next = id->id_def;
id->id_def = df;
}
return retval;
}
df1 = df;
df = df->next;
}
return 0;
}
DoImport(df, scope)
register struct def *df;
struct scope *scope;
{
/* Definition "df" is imported to scope "scope".
Handle the case that it is an enumeration type or a module.
*/
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals
*/
df = df->df_type->enm_enums;
while (df) {
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
df = df->enm_next;
}
}
else if (df->df_kind == D_MODULE) {
/* Also import all definitions that are exported from this
module
*/
df = df->mod_vis->sc_scope->sc_def;
while (df) {
if (df->df_flags & D_EXPORTED) {
define(df->df_idf,scope,D_IMPORT)->imp_def = df;
}
df = df->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
all the "ids" visible in the enclosing scope by defining them
in this scope as "imported".
*/
register struct def *df, *df1;
register struct def *impmod;
for (;ids; ids = ids->next) {
df = lookup(ids->nd_IDF, CurrentScope);
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);
}
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
*/
df->df_flags |= D_EXPORTED;
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;
}
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_TYPE;
df1->df_kind = D_IMPORT;
df1->imp_def = df;
continue;
}
}
DoImport(df, enclosing(CurrVis)->sc_scope);
}
}
}
static struct scopelist *
ForwModule(df, idn)
register struct def *df;
struct node *idn;
{
/* An import is done from a not yet defined module "idn".
Create a declaration and a scope for this module.
*/
struct scopelist *vis;
df->df_scope = enclosing(CurrVis)->sc_scope;
df->df_kind = D_FORWMODULE;
open_scope(CLOSEDSCOPE);
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_vis = vis;
df->for_node = MkLeaf(Name, &(idn->nd_token));
close_scope(0);
vis->sc_encl = enclosing(CurrVis);
/* Here ! */
return vis;
}
static struct def *
ForwDef(ids, scope)
register struct node *ids;
struct scope *scope;
{
/* Enter a forward definition of "ids" in scope "scope",
if it is not already defined.
*/
register struct def *df;
if (!(df = lookup(ids->nd_IDF, scope))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
df->for_node = MkLeaf(Name, &(ids->nd_token));
}
return df;
}
Import(ids, idn, local)
register struct node *ids;
struct node *idn;
{
/* "ids" is a list of imported identifiers.
If "idn" is a null-pointer, the identifiers are imported from
the enclosing scope. Otherwise they are imported from the module
indicated by "idn", which must be visible in the enclosing
scope. An exception must be made for imports of the
Compilation Unit.
This case is indicated by the value 0 of the flag "local".
In this case, if "idn" is a null pointer, the "ids" identifiers
are all module identifiers. Their Definition Modules must be
read. Otherwise "idn" is a module identifier whose Definition
Module must be read. "ids" then represents a list of
identifiers defined in this module.
*/
register struct def *df;
struct scopelist *vis = enclosing(CurrVis);
int forwflag = 0;
#define FROM_MODULE 0
#define FROM_ENCLOSING 1
int imp_kind = FROM_ENCLOSING;
struct def *lookfor(), *GetDefinitionModule();
if (idn) {
imp_kind = FROM_MODULE;
if (local) {
df = lookfor(idn, vis, 0);
switch(df->df_kind) {
case D_ERROR:
/* The module from which the import was done
is not yet declared. I'm not sure if I must
accept this, but for the time being I will.
???
*/
vis = ForwModule(df, idn);
forwflag = 1;
break;
case D_FORWMODULE:
vis = df->for_vis;
break;
case D_MODULE:
vis = df->mod_vis;
break;
default:
node_error(idn, "identifier \"%s\" does not represent a module",
idn->nd_IDF->id_text);
break;
}
}
else vis = GetDefinitionModule(idn->nd_IDF)->mod_vis;
FreeNode(idn);
}
idn = ids;
while (ids) {
if (imp_kind == FROM_MODULE) {
if (forwflag) {
df = ForwDef(ids, vis->sc_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 = define(ids->nd_IDF,vis->sc_scope,D_ERROR);
}
else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
node_error(ids,"identifier \"%s\" not exported from qualifying module",
ids->nd_IDF->id_text);
df->df_flags |= D_QEXPORTED;
}
}
else {
if (local) df = ForwDef(ids, vis->sc_scope);
else df = GetDefinitionModule(ids->nd_IDF);
}
DoImport(df, CurrentScope);
ids = ids->next;
}
FreeNode(idn);
}
RemoveImports(pdf)
struct def **pdf;
{

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

@ -319,7 +319,7 @@ CodeDesig(nd, ds)
CodeFieldDesig(nd->nd_def, ds);
break;
case Oper:
case Arrsel:
assert(nd->nd_symb == '[');
CodeDesig(nd->nd_left, ds);
@ -347,7 +347,7 @@ CodeDesig(nd, ds)
ds->dsg_kind = DSG_INDEXED;
break;
case Uoper:
case Arrow:
assert(nd->nd_symb == '^');
CodeDesig(nd->nd_right, ds);

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

@ -1,4 +1,4 @@
/* H I G H L E V E L S Y M B O L E N T R Y A N D L O O K U P */
/* H I G H L E V E L S Y M B O L E N T R Y */
#ifndef NORCSID
static char *RcsId = "$Header$";
@ -28,86 +28,65 @@ Enter(name, kind, type, pnam)
"type" in the Current Scope. If it is a standard name, also
put its number in the definition structure.
*/
struct idf *id;
struct def *df;
register struct def *df;
id = str2idf(name, 0);
if (!id) fatal("Out of core");
df = define(id, CurrentScope, kind);
df = define(str2idf(name, 0), CurrentScope, kind);
df->df_type = type;
if (type = std_type) {
df->df_value.df_stdname = pnam;
}
if (pnam) df->df_value.df_stdname = pnam;
return df;
}
EnterIdList(idlist, kind, flags, type, scope, addr)
register struct node *idlist;
struct type *type;
EnterEnumList(Idlist, type)
struct node *Idlist;
register struct type *type;
{
/* Put a list of enumeration literals in the symbol table.
They all have type "type".
Also assign numbers to them, and link them together.
We must link them together because an enumeration type may
be exported, in which case its literals must also be exported.
Thus, we need an easy way to get to them.
*/
register struct def *df;
register struct node *idlist = Idlist;
type->enm_ncst = 0;
for (; idlist; idlist = idlist->next) {
df = define(idlist->nd_IDF, CurrentScope, D_ENUM);
df->df_type = type;
df->enm_val = (type->enm_ncst)++;
df->enm_next = type->enm_enums;
type->enm_enums = df;
}
FreeNode(Idlist);
}
EnterFieldList(Idlist, type, scope, addr)
struct node *Idlist;
register struct type *type;
struct scope *scope;
arith *addr;
{
/* Put a list of identifiers in the symbol table.
They all have kind "kind", and type "type", and are put
in scope "scope". "flags" initializes the "df_flags" field
of the definition structure.
Also assign numbers to enumeration literals, and link
them together.
/* Put a list of fields in the symbol table.
They all have type "type", and are put in scope "scope".
Mark them as QUALIFIED EXPORT, because that's exactly what
fields are, you can get to them by qualifying them.
*/
register struct def *df;
struct def *first = 0, *last = 0;
int assval = 0;
arith off;
register struct node *idlist = Idlist;
while (idlist) {
df = define(idlist->nd_IDF, scope, kind);
for (; idlist; idlist = idlist->next) {
df = define(idlist->nd_IDF, scope, D_FIELD);
df->df_type = type;
df->df_flags |= flags;
if (addr) {
int xalign = type->tp_align;
if (xalign < word_align && kind != D_FIELD) {
/* variables are at least word aligned
*/
xalign = word_align;
}
if (*addr >= 0) {
off = align(*addr, xalign);
*addr = off + type->tp_size;
}
else {
off = -align(-*addr-type->tp_size, xalign);
*addr = off;
}
if (kind == D_VARIABLE) {
df->var_off = off;
}
else {
assert(kind == D_FIELD);
df->fld_off = off;
}
}
if (kind == D_ENUM) {
if (!first) first = df;
df->enm_val = assval++;
if (last) last->enm_next = df;
last = df;
}
idlist = idlist->next;
}
if (last) {
/* Also meaning : kind == D_ENUM */
assert(kind == D_ENUM);
last->enm_next = 0;
type->enm_enums = first;
type->enm_ncst = assval;
df->df_flags |= D_QEXPORTED;
df->fld_off = align(*addr, type->tp_align);
*addr = df->fld_off + type->tp_size;
}
FreeNode(Idlist);
}
EnterVarList(IdList, type, local)
register struct node *IdList;
EnterVarList(Idlist, type, local)
struct node *Idlist;
struct type *type;
{
/* Enter a list of identifiers representing variables into the
@ -116,6 +95,7 @@ EnterVarList(IdList, type, local)
procedure.
*/
register struct def *df;
register struct node *idlist = Idlist;
register struct scopelist *sc;
char buf[256];
extern char *sprint();
@ -129,17 +109,17 @@ EnterVarList(IdList, type, local)
while (sc->sc_scope->sc_scopeclosed) sc = enclosing(sc);
}
while (IdList) {
df = define(IdList->nd_IDF, CurrentScope, D_VARIABLE);
for (; idlist; idlist = idlist->nd_right) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->df_type = type;
if (IdList->nd_left) {
if (idlist->nd_left) {
/* An address was supplied
*/
df->var_addrgiven = 1;
if (IdList->nd_left->nd_type != card_type) {
node_error(IdList->nd_left,"Illegal type for address");
if (idlist->nd_left->nd_type != card_type) {
node_error(idlist->nd_left,"Illegal type for address");
}
df->var_off = IdList->nd_left->nd_INT;
df->var_off = idlist->nd_left->nd_INT;
}
else if (local) {
/* subtract aligned size of variable to the offset,
@ -147,8 +127,8 @@ node_error(IdList->nd_left,"Illegal type for address");
procedure
*/
sc->sc_scope->sc_off =
-align(type->tp_size - sc->sc_scope->sc_off,
type->tp_align);
-WA(align(type->tp_size - sc->sc_scope->sc_off,
type->tp_align));
df->var_off = sc->sc_scope->sc_off;
}
else {
@ -165,32 +145,279 @@ node_error(IdList->nd_left,"Illegal type for address");
C_ina_dnam(df->var_name);
}
}
IdList = IdList->nd_right;
}
FreeNode(Idlist);
}
struct def *
lookfor(id, vis, give_error)
struct node *id;
struct scopelist *vis;
EnterParamList(ppr, Idlist, type, VARp, off)
struct node *Idlist;
struct paramlist **ppr;
struct type *type;
int VARp;
arith *off;
{
/* Look for an identifier in the visibility range started by
"vis".
If it is not defined, maybe give an error message, and
create a dummy definition.
/* Create (part of) a parameterlist of a procedure.
"ids" indicates the list of identifiers, "tp" their type, and
"VARp" indicates D_VARPAR or D_VALPAR.
*/
struct def *df;
register struct scopelist *sc = vis;
struct def *MkDef();
register struct paramlist *pr;
register struct def *df;
register struct node *idlist = Idlist;
while (sc) {
df = lookup(id->nd_IDF, sc->sc_scope);
if (df) return df;
sc = nextvisible(sc);
for ( ; idlist; idlist = idlist->next) {
pr = new_paramlist();
pr->next = *ppr;
*ppr = pr;
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
pr->par_def = df;
df->df_type = type;
df->var_off = *off;
df->df_flags = VARp;
if (IsConformantArray(type)) {
/* we need room for the base address and a descriptor
*/
*off += pointer_size + 3 * word_size;
}
else if (VARp == D_VARPAR) {
*off += pointer_size;
}
else {
*off += WA(type->tp_size);
}
}
FreeNode(Idlist);
}
static
DoImport(df, scope)
register struct def *df;
struct scope *scope;
{
/* Definition "df" is imported to scope "scope".
Handle the case that it is an enumeration type or a module.
*/
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals
*/
df = df->df_type->enm_enums;
while (df) {
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
df = df->enm_next;
}
}
else if (df->df_kind == D_MODULE) {
/* Also import all definitions that are exported from this
module
*/
df = df->mod_vis->sc_scope->sc_def;
while (df) {
if (df->df_flags & D_EXPORTED) {
define(df->df_idf,scope,D_IMPORT)->imp_def = df;
}
df = df->df_nextinscope;
}
}
}
static struct scopelist *
ForwModule(df, idn)
register struct def *df;
struct node *idn;
{
/* An import is done from a not yet defined module "idn".
Create a declaration and a scope for this module.
*/
struct scopelist *vis;
df->df_scope = enclosing(CurrVis)->sc_scope;
df->df_kind = D_FORWMODULE;
open_scope(CLOSEDSCOPE);
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_vis = vis;
df->for_node = MkLeaf(Name, &(idn->nd_token));
close_scope(0);
vis->sc_encl = enclosing(CurrVis);
/* Here ! */
return vis;
}
static struct def *
ForwDef(ids, scope)
register struct node *ids;
struct scope *scope;
{
/* Enter a forward definition of "ids" in scope "scope",
if it is not already defined.
*/
register struct def *df;
if (!(df = lookup(ids->nd_IDF, scope))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
df->for_node = MkLeaf(Name, &(ids->nd_token));
}
return df;
}
EnterExportList(Idlist, qualified)
struct node *Idlist;
{
/* From the current scope, the list of identifiers "ids" is
exported. Note this fact. If the export is not qualified, make
all the "ids" visible in the enclosing scope by defining them
in this scope as "imported".
*/
register struct node *idlist = Idlist;
register struct def *df, *df1;
register struct def *impmod;
for (;idlist; idlist = idlist->next) {
df = lookup(idlist->nd_IDF, CurrentScope);
if (!df) {
/* undefined item in export list
*/
node_error(idlist, "identifier \"%s\" not defined", idlist->nd_IDF->id_text);
continue;
}
if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
node_error(idlist, "identifier \"%s\" occurs more than once in export list",
idlist->nd_IDF->id_text);
}
df->df_flags |= qualified;
if (qualified == D_EXPORTED) {
/* Export, but not qualified.
Find all imports of the module in which this export
occurs, and export the current definition to it
*/
impmod = CurrentScope->sc_definedby->df_idf->id_def;
while (impmod) {
if (impmod->df_kind == D_IMPORT &&
impmod->imp_def == CurrentScope->sc_definedby) {
DoImport(df, impmod->df_scope);
}
impmod = impmod->next;
}
/* Also handle the definition as if the enclosing
scope imports it.
*/
df1 = lookup(idlist->nd_IDF,
enclosing(CurrVis)->sc_scope);
if (df1) {
/* It was already defined in the enclosing
scope. There are two legal possibilities,
which are examined below.
*/
if ((df1->df_kind == D_PROCHEAD &&
df->df_kind == D_PROCEDURE) ||
(df1->df_kind == D_HIDDEN &&
df->df_kind == D_TYPE)) {
if (df->df_kind == D_TYPE &&
df->df_type->tp_fund != T_POINTER) {
node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
df1->df_kind = D_IMPORT;
df1->imp_def = df;
continue;
}
}
DoImport(df, enclosing(CurrVis)->sc_scope);
}
}
FreeNode(Idlist);
}
EnterFromImportList(Idlist, Fromid, local)
struct node *Idlist;
register struct node *Fromid;
{
/* Import the list Idlist from the module indicated by Fromid.
An exception must be made for imports of the Compilation Unit,
because in this case the definition module for Fromid must
be read.
This case is indicated by the value 0 of the flag "local".
*/
register struct node *idlist = Idlist;
register struct def *df;
struct scopelist *vis = enclosing(CurrVis);
int forwflag = 0;
extern struct def *lookfor(), *GetDefinitionModule();
if (local) {
df = lookfor(Fromid, vis, 0);
switch(df->df_kind) {
case D_ERROR:
/* The module from which the import was done
is not yet declared. I'm not sure if I must
accept this, but for the time being I will.
???
*/
vis = ForwModule(df, Fromid);
forwflag = 1;
break;
case D_FORWMODULE:
vis = df->for_vis;
break;
case D_MODULE:
vis = df->mod_vis;
break;
default:
node_error(Fromid, "identifier \"%s\" does not represent a module",
Fromid->nd_IDF->id_text);
break;
}
}
else vis = GetDefinitionModule(Fromid->nd_IDF)->mod_vis;
FreeNode(Fromid);
for (; idlist; idlist = idlist->next) {
if (forwflag) {
df = ForwDef(idlist, vis->sc_scope);
}
else if (!(df = lookup(idlist->nd_IDF, vis->sc_scope))) {
node_error(idlist, "identifier \"%s\" not declared in qualifying module",
idlist->nd_IDF->id_text);
df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
}
else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
node_error(idlist,"identifier \"%s\" not exported from qualifying module",
idlist->nd_IDF->id_text);
df->df_flags |= D_QEXPORTED;
}
DoImport(df, CurrentScope);
}
if (give_error) id_not_declared(id);
return MkDef(id->nd_IDF, vis->sc_scope, D_ERROR);
FreeNode(Idlist);
}
EnterImportList(Idlist, local)
struct node *Idlist;
{
/* Import "Idlist" from the enclosing scope.
An exception must be made for imports of the compilation unit.
In this case, definition modules must be read for "Idlist".
This case is indicated by the value 0 of the "local" flag.
*/
register struct node *idlist = Idlist;
register struct def *df;
struct scopelist *vis = enclosing(CurrVis);
extern struct def *lookfor(), *GetDefinitionModule();
for (; idlist; idlist = idlist->next) {
if (local) df = ForwDef(idlist, vis->sc_scope);
else df = GetDefinitionModule(idlist->nd_IDF);
DoImport(df, CurrentScope);
}
FreeNode(Idlist);
}

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

@ -258,16 +258,16 @@ designator_tail(struct node **pnd;):
;
visible_designator_tail(struct node **pnd;):
'[' { *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
'[' { *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot); }
expression(&((*pnd)->nd_right))
[
','
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot);
{ *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot);
(*pnd)->nd_symb = '[';
}
expression(&((*pnd)->nd_right))
]*
']'
|
'^' { *pnd = MkNode(Uoper, NULLNODE, *pnd, &dot); }
'^' { *pnd = MkNode(Arrow, NULLNODE, *pnd, &dot); }
;

74
lang/m2/comp/lookup.c Normal file
View file

@ -0,0 +1,74 @@
/* L O O K U P R O U T I N E S */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "def.h"
#include "idf.h"
#include "scope.h"
#include "LLlex.h"
#include "node.h"
extern struct def *MkDef();
struct def *
lookup(id, scope)
register struct idf *id;
struct scope *scope;
{
/* Look up a definition of an identifier in scope "scope".
Make the "def" list self-organizing.
Return a pointer to its "def" structure if it exists,
otherwise return 0.
*/
register struct def *df;
struct def *df1;
for (df = id->id_def, df1 = 0; df; df1 = df, df = df->next) {
if (df->df_scope == scope) {
if (df1) {
/* Put the definition in front
*/
df1->next = df->next;
df->next = id->id_def;
id->id_def = df;
}
if (df->df_kind == D_IMPORT) {
assert(df->imp_def != 0);
return df->imp_def;
}
return df;
}
}
return 0;
}
struct def *
lookfor(id, vis, give_error)
register struct node *id;
struct scopelist *vis;
{
/* Look for an identifier in the visibility range started by "vis".
If it is not defined create a dummy definition and,
if "give_error" is set, give an error message.
*/
struct def *df;
register struct scopelist *sc = vis;
while (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, vis->sc_scope, D_ERROR);
}

10
lang/m2/comp/main.c
View file

@ -146,7 +146,7 @@ LexScan()
AddStandards()
{
register struct def *df;
struct def *Enter();
extern struct def *Enter();
static struct node nilnode = { 0, 0, Value, 0, { INTEGER, 0}};
(void) Enter("ABS", D_PROCEDURE, std_type, S_ABS);
@ -184,11 +184,11 @@ AddStandards()
construct_type(T_PROCEDURE, NULLTYPE),
0);
df = Enter("BITSET", D_TYPE, bitset_type, 0);
df = Enter("FALSE", D_ENUM, bool_type, 0);
df->enm_val = 0;
df->enm_next = Enter("TRUE", D_ENUM, bool_type, 0);
df = df->enm_next;
df = Enter("TRUE", D_ENUM, bool_type, 0);
df->enm_val = 1;
df->enm_next = Enter("FALSE", D_ENUM, bool_type, 0);
df = df->enm_next;
df->enm_val = 0;
df->enm_next = 0;
}

16
lang/m2/comp/node.H
View file

@ -7,15 +7,17 @@ struct node {
#define nd_left next
struct node *nd_right;
int nd_class; /* kind of node */
#define Value 1 /* constant */
#define Value 0 /* constant */
#define Arrsel 1 /* array selection */
#define Oper 2 /* binary operator */
#define Uoper 3 /* unary operator */
#define Call 4 /* cast or procedure - or function call */
#define Name 5 /* an identifier */
#define Set 6 /* a set constant */
#define Xset 7 /* a set */
#define Def 8 /* an identified name */
#define Stat 9 /* a statement */
#define Arrow 4 /* ^ construction */
#define Call 5 /* cast or procedure - or function call */
#define Name 6 /* an identifier */
#define Set 7 /* a set constant */
#define Xset 8 /* a set */
#define Def 9 /* an identified name */
#define Stat 10 /* a statement */
#define Link 11
struct type *nd_type; /* type of this node */
struct token nd_token;

2
lang/m2/comp/options.c
View file

@ -22,7 +22,7 @@ DoOption(text)
switch(*text++) {
default:
options[text[-1]] = 1; /* flags, debug options etc. */
options[text[-1]]++; /* flags, debug options etc. */
break;
case 'L' : /* don't generate fil/lin */

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

@ -76,12 +76,11 @@ ModuleDeclaration
priority(&(df->mod_priority))?
';'
import(1)*
export(&qualified, &exportlist, 0)?
export(&qualified, &exportlist)?
block(&nd)
IDENT { InitProc(nd, df);
if (exportlist) {
Export(exportlist, qualified, df);
FreeNode(exportlist);
EnterExportList(exportlist, qualified);
}
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
@ -101,23 +100,17 @@ priority(arith *pprio;)
}
;
export(int *QUALflag; struct node **ExportList; int def;)
export(int *QUALflag; struct node **ExportList;)
{
} :
EXPORT
[
QUALIFIED
{ *QUALflag = 1; }
{ *QUALflag = D_QEXPORTED; }
|
{ *QUALflag = 0; }
{ *QUALflag = D_EXPORTED; }
]
IdentList(ExportList) ';'
{
if (def) {
node_warning(*ExportList, "export list in definition module ignored");
FreeNode(*ExportList);
}
}
;
import(int local;)
@ -135,8 +128,8 @@ import(int local;)
If the FROM clause is present, the identifier in it is a module
name, otherwise the names in the import list are module names.
*/
{
Import(ImportList, id, local);
{ if (id) EnterFromImportList(ImportList, id, local);
else EnterImportList(ImportList, local);
}
;
@ -144,7 +137,7 @@ DefinitionModule
{
register struct def *df;
struct idf *id;
struct node *exportlist;
struct node *exportlist = 0;
int dummy;
} :
DEFINITION
@ -163,11 +156,16 @@ DefinitionModule
}
';'
import(0)*
export(&dummy, &exportlist, 1)?
export(&dummy, &exportlist)?
/* 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.
*/
{ if (exportlist) {
node_warning(exportlist, "export list in definition module ignored");
FreeNode(exportlist);
}
}
definition* END IDENT
{
df = CurrentScope->sc_def;

16
lang/m2/comp/tmpvar.C
View file

@ -6,6 +6,9 @@ static char *RcsId = "$Header$";
/* Code for the allocation and de-allocation of temporary variables,
allowing re-use.
The routines use "ProcScope" instead of "CurrentScope", because
"CurrentScope" also reflects WITH statements, and these scopes do not
have local variabes.
*/
#include "debug.h"
@ -29,8 +32,9 @@ struct tmpvar {
static struct tmpvar *TmpInts, /* for integer temporaries */
*TmpPtrs; /* for pointer temporaries */
extern arith align();
extern struct scope *ProcScope; /* scope of procedure in which the
temporaries are allocated
*/
arith
NewInt()
@ -39,8 +43,8 @@ NewInt()
register struct tmpvar *tmp;
if (!TmpInts) {
offset = - align(int_size - CurrentScope->sc_off, int_align);
CurrentScope->sc_off = offset;
offset = - WA(align(int_size - ProcScope->sc_off, int_align));
ProcScope->sc_off = offset;
C_ms_reg(offset, int_size, reg_any, 0);
}
else {
@ -59,8 +63,8 @@ NewPtr()
register struct tmpvar *tmp;
if (!TmpPtrs) {
offset = - align(pointer_size - CurrentScope->sc_off, pointer_align);
CurrentScope->sc_off = offset;
offset = - WA(align(pointer_size - ProcScope->sc_off, pointer_align));
ProcScope->sc_off = offset;
C_ms_reg(offset, pointer_size, reg_pointer, 0);
}
else {

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

@ -138,3 +138,4 @@ struct type
#define complex(tpx) ((tpx)->tp_fund & (T_RECORD|T_ARRAY))
#define returntype(tpx) (((tpx)->tp_fund & T_PRCRESULT) ||\
((tpx)->tp_fund == T_SET && (tpx)->tp_size <= dword_size))
#define WA(sz) (align(sz, (int) word_size))

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

@ -221,43 +221,6 @@ InitTypes()
error_type = standard_type(T_CHAR, 1, (arith) 1);
}
ParamList(ppr, ids, tp, VARp, off)
register struct node *ids;
struct paramlist **ppr;
struct type *tp;
int VARp;
arith *off;
{
/* Create (part of) a parameterlist of a procedure.
"ids" indicates the list of identifiers, "tp" their type, and
"VARp" indicates D_VARPAR or D_VALPAR.
*/
register struct paramlist *pr;
register struct def *df;
for ( ; ids; ids = ids->next) {
pr = new_paramlist();
pr->next = *ppr;
*ppr = pr;
df = define(ids->nd_IDF, CurrentScope, D_VARIABLE);
pr->par_def = df;
df->df_type = tp;
df->var_off = align(*off, word_align);
df->df_flags = VARp;
if (IsConformantArray(tp)) {
/* we need room for the base address and a descriptor
*/
*off = df->var_off + pointer_size + 3 * word_size;
}
else if (VARp == D_VARPAR) {
*off = df->var_off + pointer_size;
}
else {
*off = df->var_off + tp->tp_size;
}
}
}
chk_basesubrange(tp, base)
register struct type *tp, *base;
{
@ -417,7 +380,7 @@ set_type(tp)
}
tp = construct_type(T_SET, tp);
tp->tp_size = align(((ub - lb) + 7)/8, word_align);
tp->tp_size = WA(((ub - lb) + 7)/8);
return tp;
}
@ -433,8 +396,11 @@ ArrayElSize(tp)
if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
algn = align(tp->tp_size, tp->tp_align);
if (!(algn % word_size == 0 || word_size % algn == 0)) {
algn = align(algn, (int) word_size);
if (word_size % algn != 0) {
/* algn is not a dividor of the word size, so make sure it
is a multiple
*/
algn = WA(algn);
}
return algn;
}
@ -481,8 +447,9 @@ ArraySizes(tp)
default:
crash("Funny index type");
}
C_rom_cst(tp->arr_elsize);
tp->tp_size = WA(tp->tp_size);
/* ??? overflow checking ???
*/

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

@ -33,6 +33,7 @@ static char return_expr_occurred;
static struct type *func_type;
struct withdesig *WithDesigs;
struct node *Modules;
struct scope *ProcScope;
label
text_label()
@ -87,7 +88,7 @@ WalkModule(module)
if (df->df_kind == D_VARIABLE) {
C_df_dnam(df->var_name);
C_bss_cst(
align(df->df_type->tp_size, word_align),
WA(df->df_type->tp_size),
(arith) 0, 0);
}
df = df->df_nextinscope;
@ -107,6 +108,7 @@ WalkModule(module)
sc->sc_off = 0;
instructionlabel = 2;
func_type = 0;
ProcScope = CurrentScope;
C_pro_narg(state == PROGRAM ? "main" : sc->sc_name);
DoProfil();
if (CurrVis == Defined->mod_vis) {
@ -161,7 +163,7 @@ WalkProcedure(procedure)
proclevel++;
CurrVis = procedure->prc_vis;
sc = CurrentScope;
ProcScope = sc = CurrentScope;
WalkDef(sc->sc_def);
@ -185,7 +187,7 @@ WalkProcedure(procedure)
if (! return_expr_occurred) {
node_error(procedure->prc_body,"function procedure does not return a value");
}
C_ret(align(res_type->tp_size, word_align));
C_ret(WA(res_type->tp_size));
}
else C_ret((arith) 0);
C_end(-sc->sc_off);
@ -341,7 +343,7 @@ WalkStat(nd, lab)
l1 = instructionlabel++;
l2 = instructionlabel++;
C_df_ilb(l1);
WalkNode(left, l2);
WalkNode(right, l2);
C_bra(l1);
C_df_ilb(l2);
break;
@ -425,7 +427,7 @@ WalkStat(nd, lab)
case RETURN:
if (right) {
WalkExpr(right, NO_LABEL, NO_LABEL);
WalkExpr(right);
/* Assignment compatibility? Yes, see Rep. 9.11
*/
if (!TstAssCompat(func_type, right->nd_type)) {
@ -449,16 +451,18 @@ ExpectBool(nd, true_label, false_label)
generate code to evaluate the expression.
*/
WalkExpr(nd, true_label, false_label);
if (!chk_expr(nd)) return;
if (nd->nd_type != bool_type && nd->nd_type != error_type) {
node_error(nd, "boolean expression expected");
}
Desig = InitDesig;
CodeExpr(nd, &Desig, true_label, false_label);
}
WalkExpr(nd, true_label, false_label)
WalkExpr(nd)
struct node *nd;
label true_label, false_label;
{
/* Check an expression and generate code for it
*/
@ -467,8 +471,7 @@ WalkExpr(nd, true_label, false_label)
if (! chk_expr(nd)) return;
Desig = InitDesig;
CodeExpr(nd, &Desig, true_label, false_label);
CodePExpr(nd);
}
WalkDesignator(nd)
@ -568,6 +571,8 @@ DumpTree(nd)
switch(nd->nd_class) {
case Def: s = "Def"; break;
case Oper: s = "Oper"; break;
case Arrsel: s = "Arrsel"; break;
case Arrow: s = "Arrow"; break;
case Uoper: s = "Uoper"; break;
case Name: s = "Name"; break;
case Set: s = "Set"; break;