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-20 14:36:49 +00:00
parent a9dfdc494b
commit 9932033365
16 changed files with 337 additions and 196 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
lang/m2/comp/Makefile
View file

@ -11,7 +11,7 @@ LSRC = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
GEN = /usr/em/util/LLgen/src/LLgen
GENOPTIONS = -d
PROFILE = -p
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
LFLAGS = $(PROFILE)
@ -22,10 +22,17 @@ COBJ = LLlex.o LLmessage.o char.o error.o main.o \
cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
code.o tmpvar.o lookup.o
OBJ = $(COBJ) $(LOBJ) Lpars.o
GENFILES= tokenfile.c \
program.c declar.c expression.c statement.c \
tokenfile.g symbol2str.c char.c Lpars.c Lpars.h
# Keep the next three entries up to date!
GENCFILES= tokenfile.c \
program.c declar.c expression.c statement.c \
symbol2str.c char.c Lpars.c casestat.c tmpvar.c scope.c
GENGFILES= tokenfile.g
GENHFILES= errout.h\
idfsize.h numsize.h strsize.h target_sizes.h debug.h\
inputtype.h maxset.h ndir.h density.h
#
GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
all:
make hfiles
make LLfiles
@ -44,7 +51,7 @@ main: $(OBJ) Makefile
size main
clean:
rm -f $(OBJ) $(GENFILES) LLfiles
rm -f $(OBJ) $(GENFILES) LLfiles hfiles
lint: LLfiles hfiles
lint $(INCLUDES) $(LINTFLAGS) `sources $(OBJ)`
@ -101,7 +108,7 @@ node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
chk_expr.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
options.o: idfsize.h main.h ndir.h type.h
walk.o: LLlex.h Lpars.h chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h
walk.o: LLlex.h Lpars.h chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h walk.h
casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h
desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h
code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h

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

@ -16,6 +16,7 @@ static char *RcsId = "$Header$";
#include "LLlex.h"
#include "node.h"
#include "desig.h"
#include "walk.h"
#include "density.h"
@ -48,8 +49,6 @@ struct case_entry {
*/
#define compact(nr, low, up) (nr != 0 && (up - low) / nr <= DENSITY)
extern label text_label(), data_label();
CaseCode(nd, exitlabel)
struct node *nd;
label exitlabel;
@ -68,7 +67,7 @@ CaseCode(nd, exitlabel)
clear((char *) sh, sizeof(*sh));
WalkExpr(pnode->nd_left);
sh->sh_type = pnode->nd_left->nd_type;
sh->sh_break = text_label();
sh->sh_break = ++text_label;
/* Now, create case label list
*/
@ -76,7 +75,7 @@ CaseCode(nd, exitlabel)
pnode = pnode->nd_right;
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
pnode->nd_lab = text_label();
pnode->nd_lab = ++text_label;
if (! AddCases(sh,
pnode->nd_left->nd_left,
pnode->nd_lab)) {
@ -89,17 +88,17 @@ CaseCode(nd, exitlabel)
/* Else part
*/
sh->sh_default = text_label();
sh->sh_default = ++text_label;
pnode = 0;
}
}
/* Now generate code for the switch itself
*/
tablabel = data_label(); /* the rom must have a label */
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_ilb(sh->sh_break);
else C_rom_ucon("0", pointer_size);
if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
/* CSA */
@ -113,7 +112,7 @@ CaseCode(nd, exitlabel)
ce = ce->next;
}
else if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ilb(sh->sh_break);
else C_rom_ucon("0", pointer_size);
}
C_lae_dlb(tablabel, (arith)0); /* perform the switch */
C_csa(word_size);

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

@ -31,7 +31,7 @@ STATIC int
chk_arr(expp)
struct node *expp;
{
return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
return chk_designator(expp, VARIABLE, D_USED);
}
STATIC int
@ -54,7 +54,7 @@ STATIC int
chk_linkorname(expp)
register struct node *expp;
{
if (chk_designator(expp, VALUE|DESIGNATOR, D_USED)) {
if (chk_designator(expp, VALUE, D_USED)) {
if (expp->nd_class == Def &&
expp->nd_def->df_kind == D_PROCEDURE) {
/* Check that this procedure is one that we
@ -269,7 +269,7 @@ getarg(argp, bases, designator)
if ((!designator && !chk_expr(left)) ||
(designator &&
!chk_designator(left, DESIGNATOR|VARIABLE, D_USED|D_NOREG))) {
!chk_designator(left, VARIABLE, D_USED|D_NOREG))) {
return 0;
}
@ -299,7 +299,10 @@ getname(argp, kinds)
arg = arg->nd_right;
if (! chk_designator(arg->nd_left, 0, D_REFERRED)) return 0;
if (arg->nd_left->nd_class != Def);
if (arg->nd_left->nd_class != Def && arg->nd_left->nd_class != LinkDef) {
node_error(arg, "identifier expected");
return 0;
}
if (!(arg->nd_left->nd_def->df_kind & kinds)) {
node_error(arg, "unexpected type");
@ -324,7 +327,7 @@ chk_proccall(expp)
arg = expp;
expp->nd_type = left->nd_type->next;
for (param = left->nd_type->prc_params; param; param = param->next) {
for (param = ParamList(left->nd_type); param; param = param->next) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
@ -430,8 +433,6 @@ chk_designator(expp, flag, dflags)
be something that can be assigned to.
It may also contain the flag VALUE, indicating that a
value is expected. In this case, VARIABLE may not be set.
It also contains the flag DESIGNATOR, indicating that '['
and '^' are allowed for this designator.
Also contained may be the flag HASSELECTORS, indicating that
the result must have selectors.
"dflags" contains some flags that must be set at the definition
@ -440,6 +441,11 @@ chk_designator(expp, flag, dflags)
register struct def *df;
register struct type *tp;
if (expp->nd_class == Def || expp->nd_class == LinkDef) {
expp->nd_def->df_flags |= dflags;
return 1;
}
expp->nd_type = error_type;
if (expp->nd_class == Name) {
@ -453,7 +459,7 @@ chk_designator(expp, flag, dflags)
assert(expp->nd_symb == '.');
if (! chk_designator(left,
(flag&DESIGNATOR)|HASSELECTORS,
HASSELECTORS,
dflags)) return 0;
tp = left->nd_type;
@ -466,6 +472,7 @@ chk_designator(expp, flag, dflags)
else {
expp->nd_def = df;
expp->nd_type = df->df_type;
expp->nd_class = LinkDef;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
/* Fields of a record are always D_QEXPORTED,
so ...
@ -513,18 +520,13 @@ df->df_idf->id_text);
return 1;
}
if (! (flag & DESIGNATOR)) {
node_error(expp, "identifier expected");
return 0;
}
if (expp->nd_class == Arrsel) {
struct type *tpl, *tpr;
assert(expp->nd_symb == '[');
if (
!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE, dflags)
!chk_designator(expp->nd_left, VARIABLE, dflags)
||
!chk_expr(expp->nd_right)
||
@ -556,7 +558,7 @@ df->df_idf->id_text);
if (expp->nd_class == Arrow) {
assert(expp->nd_symb == '^');
if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE, dflags)) {
if (! chk_designator(expp->nd_right, VARIABLE, dflags)) {
return 0;
}
@ -795,7 +797,7 @@ chk_uoper(expp)
break;
default:
assert(0);
crash("chk_uoper");
}
node_error(expp, "illegal operand for unary operator \"%s\"",
symbol2str(expp->nd_symb));
@ -818,14 +820,14 @@ getvariable(argp)
left = arg->nd_left;
if (! chk_designator(left, DESIGNATOR, D_REFERRED)) return 0;
if (! chk_designator(left, 0, D_REFERRED)) return 0;
if (left->nd_class == Arrsel || left->nd_class == Arrow) {
*argp = arg;
return left;
}
df = 0;
if (left->nd_class == Link || left->nd_class == Def) {
if (left->nd_class == LinkDef || left->nd_class == Def) {
df = left->nd_def;
}
@ -917,6 +919,47 @@ DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
if (left->nd_class == Value) cstcall(expp, S_ORD);
break;
case S_NEW:
case S_DISPOSE:
{
static int warning_given = 0;
if (!warning_given) {
warning_given = 1;
node_warning(expp, "NEW and DISPOSE are old-fashioned");
}
}
if (! (left = getvariable(&arg))) return 0;
if (! (left->nd_type->tp_fund == T_POINTER)) {
node_error(left, "pointer variable expected");
return 0;
}
if (left->nd_class == Def) {
left->nd_def->df_flags |= D_NOREG;
}
/* Now, make it look like a call to ALLOCATE or DEALLOCATE */
{
struct token dt;
struct node *nd;
dt.TOK_INT = left->nd_type->next->tp_size;
dt.tk_symb = INTEGER;
dt.tk_lineno = left->nd_lineno;
nd = MkLeaf(Value, &dt);
nd->nd_type = card_type;
dt.tk_symb = ',';
arg->nd_right = MkNode(Link, nd, NULLNODE, &dt);
/* Ignore other arguments to NEW and/or DISPOSE ??? */
FreeNode(expp->nd_left);
dt.tk_symb = IDENT;
dt.tk_lineno = expp->nd_left->nd_lineno;
dt.TOK_IDF = str2idf(std == S_NEW ?
"ALLOCATE" : "DEALLOCATE", 0);
expp->nd_left = MkLeaf(Name, &dt);
}
return chk_call(expp);
case S_TSIZE: /* ??? */
case S_SIZE:
expp->nd_type = intorcard_type;
@ -1080,5 +1123,6 @@ int (*ChkTable[])() = {
chk_set,
NodeCrash,
NodeCrash,
chk_linkorname
chk_linkorname,
NodeCrash
};

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

@ -21,9 +21,8 @@ static char *RcsId = "$Header$";
#include "node.h"
#include "Lpars.h"
#include "standards.h"
#include "walk.h"
extern label data_label();
extern label text_label();
extern char *long2str();
extern char *symbol2str();
extern int proclevel;
@ -43,7 +42,7 @@ CodeConst(cst, size)
C_ldc(cst);
}
else {
C_df_dlb(dlab = data_label());
C_df_dlb(dlab = ++data_label);
C_rom_icon(long2str((long) cst), size);
C_lae_dlb(dlab, (arith) 0);
C_loi(size);
@ -59,7 +58,7 @@ CodeString(nd)
C_loc(nd->nd_INT);
}
else {
C_df_dlb(lab = data_label());
C_df_dlb(lab = ++data_label);
C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
C_lae_dlb(lab, (arith) 0);
}
@ -88,7 +87,7 @@ CodePadString(nd, sz)
CodeReal(nd)
register struct node *nd;
{
label lab = data_label();
label lab = ++data_label;
C_df_dlb(lab);
C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
@ -114,6 +113,7 @@ CodeExpr(nd, ds, true_label, false_label)
/* Fall through */
case Link:
case LinkDef:
case Arrsel:
case Arrow:
CodeDesig(nd, ds);
@ -290,6 +290,7 @@ CodeCall(nd)
and result is already done.
*/
register struct node *left = nd->nd_left;
register struct type *result_tp;
if (left->nd_type == std_type) {
CodeStd(nd);
@ -308,7 +309,7 @@ CodeCall(nd)
assert(IsProcCall(left));
if (nd->nd_right) {
CodeParameters(left->nd_type->prc_params, nd->nd_right);
CodeParameters(ParamList(left->nd_type), nd->nd_right);
}
if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
@ -325,8 +326,12 @@ CodeCall(nd)
C_cai();
}
if (left->nd_type->prc_nbpar) C_asp(left->nd_type->prc_nbpar);
if (left->nd_type->next) {
C_lfr(WA(left->nd_type->next->tp_size));
if (result_tp = ResultType(left->nd_type)) {
if (IsConstructed(result_tp)) {
C_lfr(pointer_size);
C_loi(result_tp->tp_size);
}
else C_lfr(WA(result_tp->tp_size));
}
}
@ -765,6 +770,7 @@ CodeOper(expr, true_label, false_label)
C_com(tp->tp_size);
C_and(tp->tp_size);
C_ior(tp->tp_size);
C_zer(tp->tp_size);
}
C_cms(tp->tp_size);
break;
@ -795,10 +801,10 @@ CodeOper(expr, true_label, false_label)
case AND:
case '&':
if (true_label == 0) {
label l_true = text_label();
label l_false = text_label();
label l_maybe = text_label();
label l_end = text_label();
label l_true = ++text_label;
label l_false = ++text_label;
label l_maybe = ++text_label;
label l_end = ++text_label;
struct desig Des;
Des = InitDesig;
@ -814,7 +820,7 @@ CodeOper(expr, true_label, false_label)
C_df_ilb(l_end);
}
else {
label l_maybe = text_label();
label l_maybe = ++text_label;
struct desig Des;
Des = InitDesig;
@ -826,10 +832,10 @@ CodeOper(expr, true_label, false_label)
break;
case OR:
if (true_label == 0) {
label l_true = text_label();
label l_false = text_label();
label l_maybe = text_label();
label l_end = text_label();
label l_true = ++text_label;
label l_false = ++text_label;
label l_maybe = ++text_label;
label l_end = ++text_label;
struct desig Des;
Des = InitDesig;
@ -845,7 +851,7 @@ CodeOper(expr, true_label, false_label)
C_df_ilb(l_end);
}
else {
label l_maybe = text_label();
label l_maybe = ++text_label;
struct desig Des;
Des = InitDesig;
@ -1026,13 +1032,10 @@ CodeDStore(nd)
DoHIGH(nd)
struct node *nd;
{
register struct def *df;
arith highoff;
register struct def *df = nd->nd_def;
register arith highoff;
assert(nd->nd_class == Def);
df = nd->nd_def;
assert(df->df_kind == D_VARIABLE);
highoff = df->var_off + pointer_size + word_size;

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

@ -21,23 +21,31 @@ static char *RcsId = "$Header$";
#include "misc.h"
#include "main.h"
int proclevel = 0; /* nesting level of procedures */
int proclevel = 0; /* nesting level of procedures */
int return_occurred; /* set if a return occurred in a
procedure or function
*/
}
ProcedureDeclaration
{
struct def *df;
register struct def *df;
struct def *df1;
} :
{ proclevel++; }
ProcedureHeading(&df, D_PROCEDURE)
ProcedureHeading(&df1, D_PROCEDURE)
{
CurrentScope->sc_definedby = df;
CurrentScope->sc_definedby = df = df1;
df->prc_vis = CurrVis;
return_occurred = 0;
}
';' block(&(df->prc_body)) IDENT
{
match_id(dot.TOK_IDF, df->df_idf);
close_scope(SC_CHKFORW|SC_REVERSE);
if (! return_occurred && ResultType(df->df_type)) {
error("function procedure does not return a value", df->df_idf->id_text);
}
proclevel--;
}
;

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

@ -311,7 +311,7 @@ CodeDesig(nd, ds)
}
break;
case Link:
case LinkDef:
assert(nd->nd_symb == '.');
CodeDesig(nd->nd_left, ds);

41
lang/m2/comp/lookup.c
View file

@ -26,26 +26,31 @@ lookup(id, scope)
Return a pointer to its "def" structure if it exists,
otherwise return 0.
*/
register struct def *df;
struct def *df1;
register struct def *df, *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;
/* Look in the chain of definitions of this "id" for one with scope
"scope".
*/
for (df = id->id_def, df1 = 0;
df && df->df_scope != scope;
df1 = df, df = df->next) { /* nothing */ }
if (df) {
/* Found it
*/
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 0;
return df;
}
struct def *
@ -57,7 +62,7 @@ lookfor(id, vis, give_error)
If it is not defined create a dummy definition and,
if "give_error" is set, give an error message.
*/
struct def *df;
register struct def *df;
register struct scopelist *sc = vis;
while (sc) {

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

@ -159,6 +159,8 @@ AddStandards()
(void) Enter("DEC", D_PROCEDURE, std_type, S_DEC);
(void) Enter("INC", D_PROCEDURE, std_type, S_INC);
(void) Enter("VAL", D_PROCEDURE, std_type, S_VAL);
(void) Enter("NEW", D_PROCEDURE, std_type, S_NEW);
(void) Enter("DISPOSE", D_PROCEDURE, std_type, S_DISPOSE);
(void) Enter("TRUNC", D_PROCEDURE, std_type, S_TRUNC);
(void) Enter("SIZE", D_PROCEDURE, std_type, S_SIZE);
(void) Enter("ORD", D_PROCEDURE, std_type, S_ORD);

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

@ -19,6 +19,7 @@ struct node {
#define Def 9 /* an identified name */
#define Stat 10 /* a statement */
#define Link 11
#define LinkDef 12
/* do NOT change the order or the numbers!!! */
struct type *nd_type; /* type of this node */
struct token nd_token;
@ -40,10 +41,9 @@ extern struct node *MkNode(), *MkLeaf();
#define NULLNODE ((struct node *) 0)
#define DESIGNATOR 1
#define HASSELECTORS 2
#define VARIABLE 4
#define VALUE 8
#define HASSELECTORS 002
#define VARIABLE 004
#define VALUE 010
#define IsCast(lnd) ((lnd)->nd_class == Def && is_type((lnd)->nd_def))
#define IsCast(lnd) (((lnd)->nd_class == Def || (lnd)->nd_class == LinkDef) && is_type((lnd)->nd_def))
#define IsProcCall(lnd) ((lnd)->nd_type->tp_fund == T_PROCEDURE)

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

@ -19,6 +19,8 @@
#define S_SIZE 15
#define S_TRUNC 16
#define S_VAL 17
#define S_NEW 18
#define S_DISPOSE 19
/* Standard procedures and functions defined in the SYSTEM module ... */

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

@ -229,9 +229,12 @@ ReturnStatement(struct node **pnd;)
{
register struct def *df = CurrentScope->sc_definedby;
register struct node *nd;
extern int return_occurred;
} :
RETURN { *pnd = nd = MkLeaf(Stat, &dot); }
RETURN { *pnd = nd = MkLeaf(Stat, &dot);
return_occurred = 1;
}
[
expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) {

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

@ -74,7 +74,7 @@ struct type {
#define T_NUMERIC (T_INTORCARD|T_REAL)
#define T_INDEX (T_ENUMERATION|T_CHAR|T_SUBRANGE)
#define T_DISCRETE (T_INDEX|T_INTORCARD)
#define T_PRCRESULT (T_DISCRETE|T_REAL|T_POINTER|T_WORD)
#define T_CONSTRUCTED (T_ARRAY|T_SET|T_RECORD)
int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */
union {
@ -136,6 +136,8 @@ struct type
#define IsConformantArray(tpx) ((tpx)->tp_fund==T_ARRAY && (tpx)->next==0)
#define bounded(tpx) ((tpx)->tp_fund & T_INDEX)
#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))
#define ResultType(tpx) (assert((tpx)->tp_fund == T_PROCEDURE), (tpx)->next)
#define ParamList(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
(tpx)->prc_params)
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED)

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

@ -20,6 +20,7 @@ static char *RcsId = "$Header$";
#include "node.h"
#include "const.h"
#include "scope.h"
#include "walk.h"
int
word_align = AL_WORD,
@ -64,8 +65,6 @@ struct type *h_type;
int cnt_type;
#endif
extern label data_label();
struct type *
create_type(fund)
int fund;
@ -93,10 +92,6 @@ construct_type(fund, tp)
switch (fund) {
case T_PROCEDURE:
if (tp && !returntype(tp)) {
error("illegal procedure result type");
}
/* Fall through */
case T_POINTER:
case T_HIDDEN:
dtp->tp_align = pointer_align;
@ -315,11 +310,11 @@ genrck(tp)
if (tp->tp_fund == T_SUBRANGE) {
if (!(ol = tp->sub_rck)) {
tp->sub_rck = l = data_label();
tp->sub_rck = l = ++data_label;
}
}
else if (!(ol = tp->enm_rck)) {
tp->enm_rck = l = data_label();
tp->enm_rck = l = ++data_label;
}
if (!ol) {
ol = l;
@ -423,7 +418,7 @@ ArraySizes(tp)
/* generate descriptor and remember label.
*/
tp->arr_descr = data_label();
tp->arr_descr = ++data_label;
C_df_dlb(tp->arr_descr);
C_rom_cst(lo);
C_rom_cst(hi - lo);
@ -441,7 +436,7 @@ FreeType(tp)
assert(tp->tp_fund == T_PROCEDURE);
pr = tp->prc_params;
pr = ParamList(tp);
while (pr) {
pr1 = pr;
pr = pr->next;
@ -516,7 +511,7 @@ DumpType(tp)
break;
case T_PROCEDURE:
{
register struct paramlist *par = tp->prc_params;
register struct paramlist *par = ParamList(tp);
print("PROCEDURE");
if (par) {
@ -541,7 +536,7 @@ DumpType(tp)
case T_INTORCARD:
print("INTORCARD"); break;
default:
assert(0);
crash("DumpType");
}
print(";");
}

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

@ -7,8 +7,11 @@ static char *RcsId = "$Header$";
/* Routines for testing type equivalence, type compatibility, and
assignment compatibility
*/
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "type.h"
#include "def.h"
@ -66,8 +69,8 @@ TstProcEquiv(tp1, tp2)
*/
if (! TstTypeEquiv(tp1->next, tp2->next)) return 0;
p1 = tp1->prc_params;
p2 = tp2->prc_params;
p1 = ParamList(tp1);
p2 = ParamList(tp2);
/* Now check the parameters
*/
@ -180,6 +183,10 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
TstTypeEquiv(formaltype, actualtype)
||
( !VARflag && TstAssCompat(formaltype, actualtype))
||
( formaltype == address_type
&& actualtype->tp_fund == T_POINTER
)
||
( formaltype == word_type
&&

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

@ -26,31 +26,18 @@ static char *RcsId = "$Header$";
#include "f_info.h"
#include "idf.h"
#include "chk_expr.h"
#include "walk.h"
extern arith NewPtr();
extern arith NewInt();
extern int proclevel;
static label instructionlabel;
static char return_expr_occurred;
label text_label;
label data_label;
static struct type *func_type;
struct withdesig *WithDesigs;
struct node *Modules;
struct scope *ProcScope;
label
text_label()
{
return instructionlabel++;
}
label
data_label()
{
static label datalabel = 0;
return ++datalabel;
}
STATIC
DoProfil()
{
@ -58,7 +45,7 @@ DoProfil()
if (! options['L']) {
if (!filename_label) {
filename_label = data_label();
filename_label = ++data_label;
C_df_dlb(filename_label);
C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
}
@ -73,7 +60,6 @@ WalkModule(module)
/* Walk through a module, and all its local definitions.
Also generate code for its body.
*/
register struct def *df = module->mod_vis->sc_scope->sc_def;
register struct scope *sc;
struct scopelist *vis;
@ -81,20 +67,10 @@ WalkModule(module)
CurrVis = module->mod_vis;
sc = CurrentScope;
if (!proclevel) {
/* This module is a glocal module.
Generate code to allocate storage for its variables.
They all have an explicit name.
if (!proclevel && module == Defined) {
/* This module is a global module. Export the name of its
initialization routine
*/
while (df) {
if (df->df_kind == D_VARIABLE) {
C_df_dnam(df->var_name);
C_bss_cst(
WA(df->df_type->tp_size),
(arith) 0, 0);
}
df = df->df_nextinscope;
}
if (state == PROGRAM) C_exp("main");
else C_exp(sc->sc_name);
}
@ -108,12 +84,11 @@ WalkModule(module)
this module.
*/
sc->sc_off = 0;
instructionlabel = 2;
func_type = 0;
text_label = 1;
ProcScope = CurrentScope;
C_pro_narg(state == PROGRAM ? "main" : sc->sc_name);
C_pro_narg(state==PROGRAM && module==Defined ? "main" : sc->sc_name);
DoProfil();
if (CurrVis == Defined->mod_vis) {
if (module == Defined) {
/* Body of implementation or program module.
Call initialization routines of imported modules.
Also prevent recursive calls of this one.
@ -121,7 +96,7 @@ WalkModule(module)
struct node *nd;
if (state == IMPLEMENTATION) {
label l1 = data_label();
label l1 = ++data_label;
/* we don't actually prevent recursive calls,
but do nothing if called recursively
*/
@ -157,44 +132,73 @@ WalkProcedure(procedure)
/* Walk through the definition of a procedure and all its
local definitions
*/
struct scopelist *vis = CurrVis;
struct scopelist *savevis = CurrVis;
register struct scope *sc;
register struct type *tp;
register struct paramlist *param;
label func_res_label = 0;
proclevel++;
CurrVis = procedure->prc_vis;
ProcScope = sc = CurrentScope;
/* Generate code for all local modules and procedures
*/
WalkDef(sc->sc_def);
/* Generate code for this procedure
*/
C_pro_narg(sc->sc_name);
DoProfil();
/* generate calls to initialization routines of modules defined within
/* Generate calls to initialization routines of modules defined within
this procedure
*/
MkCalls(sc->sc_def);
return_expr_occurred = 0;
instructionlabel = 2;
func_type = tp = procedure->df_type->next;
if (! returntype(tp)) {
node_error(procedure->prc_body, "illegal result type");
}
WalkNode(procedure->prc_body, (label) 0);
C_df_ilb((label) 1);
if (tp) {
if (! return_expr_occurred) {
node_error(procedure->prc_body,"function procedure does not return a value");
/* Make sure that arguments of size < word_size are on a
fixed place.
*/
for (param = ParamList(procedure->df_type);
param;
param = param->next) {
if (! IsVarParam(param)) {
tp = TypeOfParam(param);
if (!IsConformantArray(tp) && tp->tp_size < word_size) {
C_lol(param->par_def->var_off);
C_lal(param->par_def->var_off);
C_sti(tp->tp_size);
}
}
C_ret(WA(tp->tp_size));
}
else C_ret((arith) 0);
text_label = 1;
func_type = tp = ResultType(procedure->df_type);
if (IsConstructed(tp)) {
func_res_label = ++data_label;
C_df_dlb(func_res_label);
C_bss_cst(tp->tp_size, (arith) 0, 0);
}
WalkNode(procedure->prc_body, (label) 0);
C_ret((arith) 0);
if (tp) {
C_df_ilb((label) 1);
if (func_res_label) {
C_lae_dlb(func_res_label, (arith) 0);
C_sti(tp->tp_size);
C_lae_dlb(func_res_label, (arith) 0);
C_ret(pointer_size);
}
else C_ret(WA(tp->tp_size));
}
RegisterMessages(sc->sc_def);
C_end(-sc->sc_off);
TmpClose();
CurrVis = vis;
CurrVis = savevis;
proclevel--;
}
@ -211,6 +215,12 @@ WalkDef(df)
else if (df->df_kind == D_PROCEDURE) {
WalkProcedure(df);
}
else if (!proclevel && df->df_kind == D_VARIABLE) {
C_df_dnam(df->var_name);
C_bss_cst(
WA(df->df_type->tp_size),
(arith) 0, 0);
}
df = df->df_nextinscope;
}
}
@ -231,22 +241,36 @@ MkCalls(df)
}
}
WalkNode(nd, lab)
WalkLink(nd, lab)
register struct node *nd;
label lab;
{
/* Node "nd" represents either a statement or a statement list.
Walk through it.
/* Walk node "nd", which is a link.
"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);
while (nd && nd->nd_class == Link) { /* statement list */
WalkNode(nd->nd_left, lab);
nd = nd->nd_right;
}
WalkStat(nd, lab);
WalkNode(nd, lab);
}
WalkCall(nd)
register struct node *nd;
{
assert(nd->nd_class == Call);
if (! options['L']) C_lin((arith) nd->nd_lineno);
if (chk_call(nd)) {
if (nd->nd_type != 0) {
node_error(nd, "procedure call expected");
return;
}
CodeCall(nd);
}
}
WalkStat(nd, lab)
@ -260,27 +284,9 @@ WalkStat(nd, lab)
register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right;
if (!nd) {
/* Empty statement
*/
return;
}
if (! options['L']) C_lin((arith) nd->nd_lineno);
if (nd->nd_class == Call) {
if (chk_call(nd)) {
if (nd->nd_type != 0) {
node_error(nd, "procedure call expected");
return;
}
CodeCall(nd);
}
return;
}
assert(nd->nd_class == Stat);
if (! options['L']) C_lin((arith) nd->nd_lineno);
switch(nd->nd_symb) {
case BECOMES:
DoAssign(nd, left, right);
@ -289,9 +295,9 @@ WalkStat(nd, lab)
case IF:
{ label l1, l2, l3;
l1 = instructionlabel++;
l2 = instructionlabel++;
l3 = instructionlabel++;
l1 = ++text_label;
l2 = ++text_label;
l3 = ++text_label;
ExpectBool(left, l3, l1);
assert(right->nd_symb == THEN);
C_df_ilb(l3);
@ -314,9 +320,9 @@ WalkStat(nd, lab)
case WHILE:
{ label l1, l2, l3;
l1 = instructionlabel++;
l2 = instructionlabel++;
l3 = instructionlabel++;
l1 = ++text_label;
l2 = ++text_label;
l3 = ++text_label;
C_df_ilb(l1);
ExpectBool(left, l3, l2);
C_df_ilb(l3);
@ -329,8 +335,8 @@ WalkStat(nd, lab)
case REPEAT:
{ label l1, l2;
l1 = instructionlabel++;
l2 = instructionlabel++;
l1 = ++text_label;
l2 = ++text_label;
C_df_ilb(l1);
WalkNode(left, lab);
ExpectBool(right, l2, l1);
@ -341,8 +347,8 @@ WalkStat(nd, lab)
case LOOP:
{ label l1, l2;
l1 = instructionlabel++;
l2 = instructionlabel++;
l1 = ++text_label;
l2 = ++text_label;
C_df_ilb(l1);
WalkNode(right, l2);
C_bra(l1);
@ -354,8 +360,8 @@ WalkStat(nd, lab)
{
arith tmp = 0;
struct node *fnd;
label l1 = instructionlabel++;
label l2 = instructionlabel++;
label l1 = ++text_label;
label l2 = ++text_label;
if (! DoForInit(nd, left)) break;
fnd = left->nd_right;
@ -432,14 +438,16 @@ WalkStat(nd, lab)
case RETURN:
if (right) {
WalkExpr(right);
/* Assignment compatibility? Yes, see Rep. 9.11
/* The type of the return-expression must be
assignment compatible with the result type of the
function procedure (See Rep. 9.11).
*/
if (!TstAssCompat(func_type, right->nd_type)) {
node_error(right, "type incompatibility in RETURN statement");
}
return_expr_occurred = 1;
C_bra((label) 1);
}
C_bra((label) 1);
else C_ret((arith) 0);
break;
default:
@ -447,6 +455,24 @@ node_error(right, "type incompatibility in RETURN statement");
}
}
extern int NodeCrash();
int (*WalkTable[])() = {
NodeCrash,
NodeCrash,
NodeCrash,
NodeCrash,
NodeCrash,
WalkCall,
NodeCrash,
NodeCrash,
NodeCrash,
NodeCrash,
WalkStat,
WalkLink,
NodeCrash
};
ExpectBool(nd, true_label, false_label)
register struct node *nd;
label true_label, false_label;
@ -488,7 +514,7 @@ WalkDesignator(nd, ds)
DO_DEBUG(1, (DumpTree(nd), print("\n")));
if (! chk_designator(nd, DESIGNATOR|VARIABLE, D_DEFINED)) return;
if (! chk_designator(nd, VARIABLE, D_DEFINED)) return;
*ds = InitDesig;
CodeDesig(nd, ds);
@ -497,6 +523,7 @@ WalkDesignator(nd, ds)
DoForInit(nd, left)
register struct node *nd, *left;
{
register struct def *df;
nd->nd_left = nd->nd_right = 0;
nd->nd_class = Name;
@ -506,6 +533,30 @@ DoForInit(nd, left)
! chk_expr(left->nd_left) ||
! chk_expr(left->nd_right)) return 0;
df = nd->nd_def;
if (df->df_kind == D_FIELD) {
node_error(nd, "FOR-loop variable may not be a field of a record");
return 0;
}
if (!df->var_name && df->var_off >= 0) {
node_error(nd, "FOR-loop variable may not be a parameter");
return 0;
}
if (df->df_scope != CurrentScope) {
register struct scopelist *sc = CurrVis;
while (sc && sc->sc_scope != df->df_scope) {
sc = nextvisible(sc);
}
if (!sc) {
node_error(nd, "FOR-loop variable may not be imported");
return 0;
}
}
if (nd->nd_type->tp_size > word_size ||
!(nd->nd_type->tp_fund & T_DISCRETE)) {
node_error(nd, "illegal type of FOR loop variable");
@ -536,7 +587,7 @@ DoAssign(nd, left, right)
struct desig dsl, dsr;
if (!chk_expr(right)) return;
if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
if (! chk_designator(left, VARIABLE, D_DEFINED)) return;
TryToString(right, left->nd_type);
dsr = InitDesig;
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);

13
lang/m2/comp/walk.h Normal file
View file

@ -0,0 +1,13 @@
/* P A R S E T R E E W A L K E R */
/* $Header$ */
/* Definition of WalkNode macro
*/
extern int (*WalkTable[])();
#define WalkNode(xnd, xlab) ((xnd) && (*WalkTable[(xnd)->nd_class])((xnd), (xlab)))
extern label text_label;
extern label data_label;