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

newer version with bug fixes

Browse source
This commit is contained in:
ceriel 1986-08-26 14:33:24 +00:00
parent e1c67b1fba
commit a0db745586
14 changed files with 452 additions and 320 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

103
lang/m2/comp/Makefile
View file

@ -1,16 +1,16 @@
# make modula-2 "compiler"
# $Header$
EMDIR = /usr/em
EMDIR = /usr/ceriel/em
MHDIR = $(EMDIR)/modules/h
PKGDIR = $(EMDIR)/modules/pkg
LIBDIR = $(EMDIR)/modules/lib
LLGEN = $(EMDIR)/util/LLgen/src/LLgen
LLGEN = $(EMDIR)/bin/LLgen
INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
LSRC = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
LLGENOPTIONS = -d
LLGENOPTIONS =
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
@ -23,7 +23,7 @@ COBJ = LLlex.o LLmessage.o char.o error.o main.o \
code.o tmpvar.o lookup.o
OBJ = $(COBJ) $(LOBJ) Lpars.o
# Keep the next three entries up to date!
# Keep the next 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
@ -32,12 +32,42 @@ GENHFILES= errout.h\
idfsize.h numsize.h strsize.h target_sizes.h debug.h\
inputtype.h maxset.h ndir.h density.h\
def.h type.h Lpars.h node.h
HFILES= LLlex.h\
chk_expr.h class.h const.h desig.h f_info.h idf.h\
input.h main.h misc.h scope.h standards.h tokenname.h\
walk.h $(GENHFILES)
#
GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
all:
make hfiles
make LLfiles
make main
all: Cfiles
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make main ; else sh Resolve main ; fi'
@rm -f nmclash.o a.out
clean:
rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab cclash.o cid.o cclash cid
(cd .. ; rm -rf Xsrc)
lint: Cfiles
sh -c `if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
@rm -f nmclash.o a.out
mkdep: mkdep.o
$(CC) -o mkdep mkdep.o
cclash: cclash.o
$(CC) -o cclash cclash.o
cid: cid.o
$(CC) -o cid cid.o
# entry points not to be used directly
Xlint:
lint $(INCLUDES) $(LINTFLAGS) `./sources $(OBJ)`
Cfiles: hfiles LLfiles $(GENHFILES) $(GENCFILES)
./sources $(OBJ) > Cfiles
sh -c 'for i in $(HFILES) ; do echo $$i ; done >> Cfiles'
LLfiles: $(LSRC)
$(LLGEN) $(LLGENOPTIONS) $(LSRC)
@ -47,47 +77,48 @@ hfiles: Parameters make.hfiles
make.hfiles Parameters
touch hfiles
main: $(OBJ) Makefile
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libeme.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o main
size main
clean:
rm -f $(OBJ) $(GENFILES) LLfiles hfiles
lint: LLfiles hfiles
lint $(INCLUDES) $(LINTFLAGS) `sources $(OBJ)`
main: $(OBJ) ../src/Makefile
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../src/main
size ../src/main
tokenfile.g: tokenname.c make.tokfile
make.tokfile <tokenname.c >tokenfile.g
symbol2str.c: tokenname.c make.tokcase
make.tokcase <tokenname.c >symbol2str.c
symbol2str.c: ../src/tokenname.c ../src/make.tokcase
../src/make.tokcase <../src/tokenname.c >symbol2str.c
def.h: def.H make.allocd
type.h: type.H make.allocd
node.h: node.H make.allocd
scope.c: scope.C make.allocd
tmpvar.c: tmpvar.C make.allocd
casestat.c: casestat.C make.allocd
def.h: ../src/def.H ../src/make.allocd
../src/make.allocd < ../src/def.H > def.h
char.c: char.tab tab
./tab -fchar.tab >char.c
type.h: ../src/type.H ../src/make.allocd
../src/make.allocd < ../src/type.H > type.h
tab:
$(CC) tab.c -o tab
node.h: ../src/node.H ../src/make.allocd
../src/make.allocd < ../src/node.H > node.h
depend:
scope.c: ../src/scope.C ../src/make.allocd
../src/make.allocd < ../src/scope.C > scope.c
tmpvar.c: ../src/tmpvar.C ../src/make.allocd
../src/make.allocd < ../src/tmpvar.C > tmpvar.c
casestat.c: ../src/casestat.C ../src/make.allocd
../src/make.allocd < ../src/casestat.C > casestat.c
char.c: ../src/char.tab ../src/tab
../src/tab -fchar.tab >char.c
../src/tab:
$(CC) ../src/tab.c -o ../src/tab
depend: mkdep
sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
/user1/erikb/bin/mkdep `sources $(OBJ)` |\
./mkdep `./sources $(OBJ)` |\
sed 's/\.c:/\.o:/' >> Makefile.new
mv Makefile Makefile.old
mv Makefile.new Makefile
.SUFFIXES: .H .h .C
.H.h .C.c :
make.allocd < $< > $@
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
LLlex.o: LLlex.h Lpars.h class.h const.h debug.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h
LLmessage.o: LLlex.h Lpars.h idf.h
@ -116,7 +147,7 @@ code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h
tmpvar.o: debug.h def.h main.h scope.h type.h
lookup.o: LLlex.h debug.h def.h idf.h node.h scope.h
tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
program.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h chk_expr.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h
expression.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h type.h
statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h

2
lang/m2/comp/Parameters
View file

@ -5,7 +5,7 @@
!File: idfsize.h
#define IDFSIZE 30 /* maximum significant length of an identifier */
#define IDFSIZE 128 /* maximum significant length of an identifier */
!File: numsize.h

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

@ -132,6 +132,8 @@ ChkLinkOrName(expp)
{
register struct def *df;
expp->nd_type = error_type;
if (expp->nd_class == Name) {
expp->nd_def = lookfor(expp, CurrVis, 1);
expp->nd_class = Def;
@ -183,7 +185,7 @@ df->df_idf->id_text);
assert(expp->nd_class == Def);
df = expp->nd_def;
if (df == ill_df) return 0;
if (df->df_kind == D_ERROR) return 0;
if (df->df_kind & (D_ENUM | D_CONST)) {
if (df->df_kind == D_ENUM) {
@ -855,7 +857,7 @@ ChkStandard(expp, left)
case S_MIN:
if (!(left = getname(&arg, D_ISTYPE))) return 0;
if (!(left->nd_type->tp_fund & (T_DISCRETE))) {
node_error(left, "illegal type in MIN or MAX");
node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN");
return 0;
}
expp->nd_type = left->nd_type;
@ -961,7 +963,7 @@ ChkStandard(expp, left)
expp->nd_type = 0;
if (! (left = getvariable(&arg))) return 0;
if (! (left->nd_type->tp_fund & T_DISCRETE)) {
node_error(left, "illegal type in argument of INC or DEC");
node_error(left,"illegal type in argument of %s",std == S_INC ? "INC" : "DEC");
return 0;
}
if (arg->nd_right) {
@ -982,7 +984,7 @@ node_error(left, "illegal type in argument of INC or DEC");
if (!(left = getvariable(&arg))) return 0;
tp = left->nd_type;
if (tp->tp_fund != T_SET) {
node_error(arg, "EXCL and INCL expect a SET parameter");
node_error(arg, "%s expects a SET parameter", std == S_EXCL ? "EXCL" : "INCL");
return 0;
}
if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;

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

@ -201,7 +201,6 @@ CodeCoercion(t1, t2)
if ((fund2 = t2->tp_fund) == T_WORD) fund2 = T_INTEGER;
switch(fund1) {
case T_INTEGER:
case T_INTORCARD:
switch(fund2) {
case T_INTEGER:
if (t2->tp_size != t1->tp_size) {
@ -232,11 +231,13 @@ CodeCoercion(t1, t2)
case T_CHAR:
case T_ENUMERATION:
case T_CARDINAL:
case T_INTORCARD:
switch(fund2) {
case T_ENUMERATION:
case T_CHAR:
case T_CARDINAL:
case T_POINTER:
case T_INTORCARD:
if (t2->tp_size > word_size) {
C_loc(word_size);
C_loc(t2->tp_size);
@ -313,16 +314,25 @@ CodeCall(nd)
CodeParameters(ParamList(left->nd_type), nd->nd_right);
}
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);
switch(left->nd_class) {
case Def: {
register struct def *df = left->nd_def;
if (df->df_kind == D_PROCEDURE) {
arith level = df->df_scope->sc_level;
if (level > 0) {
C_lxl((arith) proclevel - level);
}
C_cal(NameOfProc(left->nd_def));
C_cal(NameOfProc(df));
break;
}
else if (left->nd_class == Def && left->nd_def->df_kind == D_PROCHEAD) {
C_cal(left->nd_def->for_name);
}
else {
else if (df->df_kind == D_PROCHEAD) {
C_cal(df->for_name);
break;
}}
/* Fall through */
default:
CodePExpr(left);
C_cai();
}
@ -342,6 +352,7 @@ CodeParameters(param, arg)
{
register struct type *tp;
register struct node *left;
register struct type *left_type;
assert(param != 0 && arg != 0);
@ -351,25 +362,31 @@ CodeParameters(param, arg)
tp = TypeOfParam(param);
left = arg->nd_left;
left_type = left->nd_type;
if (IsConformantArray(tp)) {
C_loc(tp->arr_elsize);
if (IsConformantArray(left->nd_type)) {
if (IsConformantArray(left_type)) {
DoHIGH(left);
if (tp->arr_elem->tp_size != left->nd_type->arr_elem->tp_size) {
if (tp->arr_elem->tp_size !=
left_type->arr_elem->tp_size) {
/* This can only happen if the formal type is
ARRAY OF WORD
*/
/* ??? */
assert(tp->arr_elem == word_type);
C_loc(left_type->arr_elem->tp_size);
C_cal("_wa");
C_asp(dword_size);
C_lfr(word_size);
}
}
else if (left->nd_symb == STRING) {
C_loc(left->nd_SLE);
}
else if (tp->arr_elem == word_type) {
C_loc(left->nd_type->tp_size / word_size - 1);
C_loc((left_type->tp_size+word_size-1) / word_size - 1);
}
else {
tp = IndexType(left->nd_type);
tp = IndexType(left_type);
if (tp->tp_fund == T_SUBRANGE) {
C_loc(tp->sub_ub - tp->sub_lb);
}
@ -385,11 +402,11 @@ CodeParameters(param, arg)
CodeDAddress(left);
}
else {
if (left->nd_type->tp_fund == T_STRING) {
if (left_type->tp_fund == T_STRING) {
CodePadString(left, tp->tp_size);
}
else CodePExpr(left);
CheckAssign(left->nd_type, tp);
CheckAssign(left_type, tp);
}
}
@ -422,6 +439,7 @@ CodeStd(nd)
}
else C_cal("_absd");
}
C_asp(tp->tp_size);
C_lfr(tp->tp_size);
break;
@ -447,6 +465,7 @@ CodeStd(nd)
break;
case S_ODD:
CodePExpr(left);
if (tp->tp_size == word_size) {
C_loc((arith) 1);
C_and(word_size);
@ -584,45 +603,39 @@ CheckAssign(tpl, tpr)
}
}
Operands(leftop, rightop)
Operands(leftop, rightop, tp)
register struct node *leftop, *rightop;
struct type *tp;
{
CodePExpr(leftop);
if (rightop->nd_type->tp_fund == T_POINTER &&
leftop->nd_type->tp_size != pointer_size) {
CodeCoercion(leftop->nd_type, rightop->nd_type);
leftop->nd_type = rightop->nd_type;
}
CodeCoercion(leftop->nd_type, tp);
CodePExpr(rightop);
CodeCoercion(rightop->nd_type, tp);
}
CodeOper(expr, true_label, false_label)
struct node *expr; /* the expression tree itself */
register struct node *expr; /* the expression tree itself */
label true_label;
label false_label; /* labels to jump to in logical expr's */
{
register int oper = expr->nd_symb;
register struct node *leftop = expr->nd_left;
register struct node *rightop = expr->nd_right;
register struct type *tp = expr->nd_type;
switch (oper) {
switch (expr->nd_symb) {
case '+':
Operands(leftop, rightop);
Operands(leftop, rightop, tp);
switch (tp->tp_fund) {
case T_INTEGER:
C_adi(tp->tp_size);
break;
case T_POINTER:
C_ads(rightop->nd_type->tp_size);
break;
case T_REAL:
C_adf(tp->tp_size);
break;
case T_POINTER:
case T_CARDINAL:
case T_INTORCARD:
C_adu(tp->tp_size);
break;
case T_SET:
@ -633,24 +646,17 @@ CodeOper(expr, true_label, false_label)
}
break;
case '-':
Operands(leftop, rightop);
Operands(leftop, rightop, tp);
switch (tp->tp_fund) {
case T_INTEGER:
C_sbi(tp->tp_size);
break;
case T_POINTER:
if (rightop->nd_type->tp_fund == T_POINTER) {
C_sbs(pointer_size);
}
else {
C_ngi(rightop->nd_type->tp_size);
C_ads(rightop->nd_type->tp_size);
}
break;
case T_REAL:
C_sbf(tp->tp_size);
break;
case T_POINTER:
case T_CARDINAL:
case T_INTORCARD:
C_sbu(tp->tp_size);
break;
case T_SET:
@ -662,15 +668,14 @@ CodeOper(expr, true_label, false_label)
}
break;
case '*':
Operands(leftop, rightop);
Operands(leftop, rightop, tp);
switch (tp->tp_fund) {
case T_INTEGER:
C_mli(tp->tp_size);
break;
case T_POINTER:
CodeCoercion(rightop->nd_type, tp);
/* Fall through */
case T_CARDINAL:
case T_INTORCARD:
C_mlu(tp->tp_size);
break;
case T_REAL:
@ -684,7 +689,7 @@ CodeOper(expr, true_label, false_label)
}
break;
case '/':
Operands(leftop, rightop);
Operands(leftop, rightop, tp);
switch (tp->tp_fund) {
case T_REAL:
C_dvf(tp->tp_size);
@ -697,15 +702,14 @@ CodeOper(expr, true_label, false_label)
}
break;
case DIV:
Operands(leftop, rightop);
Operands(leftop, rightop, tp);
switch(tp->tp_fund) {
case T_INTEGER:
C_dvi(tp->tp_size);
break;
case T_POINTER:
CodeCoercion(rightop->nd_type, tp);
/* Fall through */
case T_CARDINAL:
case T_INTORCARD:
C_dvu(tp->tp_size);
break;
default:
@ -713,15 +717,14 @@ CodeOper(expr, true_label, false_label)
}
break;
case MOD:
Operands(leftop, rightop);
Operands(leftop, rightop, tp);
switch(tp->tp_fund) {
case T_INTEGER:
C_rmi(tp->tp_size);
break;
case T_POINTER:
CodeCoercion(rightop->nd_type, tp);
/* Fall through */
case T_CARDINAL:
case T_INTORCARD:
C_rmu(tp->tp_size);
break;
default:
@ -734,18 +737,17 @@ CodeOper(expr, true_label, false_label)
case GREATEREQUAL:
case '=':
case '#':
Operands(leftop, rightop);
CodeCoercion(rightop->nd_type, leftop->nd_type);
tp = BaseType(leftop->nd_type); /* Not the result type! */
tp = BaseType(leftop->nd_type);
if (tp == intorcard_type) tp = BaseType(rightop->nd_type);
Operands(leftop, rightop, tp);
switch (tp->tp_fund) {
case T_INTEGER:
C_cmi(tp->tp_size);
break;
case T_HIDDEN:
case T_POINTER:
C_cmp();
break;
case T_CARDINAL:
case T_INTORCARD:
C_cmu(tp->tp_size);
break;
case T_ENUMERATION:
@ -756,19 +758,18 @@ CodeOper(expr, true_label, false_label)
C_cmf(tp->tp_size);
break;
case T_SET:
if (oper == GREATEREQUAL) {
if (expr->nd_symb == GREATEREQUAL) {
/* A >= B is the same as A equals A + B
*/
C_dup(2*tp->tp_size);
C_asp(tp->tp_size);
C_zer(tp->tp_size);
C_ior(tp->tp_size);
}
else if (oper == LESSEQUAL) {
else if (expr->nd_symb == LESSEQUAL) {
/* A <= B is the same as A - B = {}
*/
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);
@ -777,11 +778,11 @@ CodeOper(expr, true_label, false_label)
crash("bad type COMPARE");
}
if (true_label != 0) {
compare(oper, true_label);
compare(expr->nd_symb, true_label);
C_bra(false_label);
}
else {
truthvalue(oper);
truthvalue(expr->nd_symb);
}
break;
case IN:
@ -789,7 +790,8 @@ CodeOper(expr, true_label, false_label)
INN instruction expects the bit number on top of the
stack
*/
Operands(rightop, leftop);
CodePExpr(rightop);
CodePExpr(leftop);
CodeCoercion(leftop->nd_type, word_type);
C_inn(rightop->nd_type->tp_size);
if (true_label != 0) {
@ -798,19 +800,26 @@ CodeOper(expr, true_label, false_label)
}
break;
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;
case '&': {
label l_true, l_false, l_maybe = ++text_label, l_end;
struct desig Des;
if (true_label == 0) {
l_true = ++text_label;
l_false = ++text_label;
l_end = ++text_label;
}
else {
l_true = true_label;
l_false = false_label;
}
Des = InitDesig;
CodeExpr(leftop, &Des, l_maybe, l_false);
C_df_ilb(l_maybe);
Des = InitDesig;
CodeExpr(rightop, &Des, l_true, l_false);
if (true_label == 0) {
C_df_ilb(l_true);
C_loc((arith)1);
C_bra(l_end);
@ -818,30 +827,27 @@ CodeOper(expr, true_label, false_label)
C_loc((arith)0);
C_df_ilb(l_end);
}
else {
label l_maybe = ++text_label;
struct desig Des;
Des = InitDesig;
CodeExpr(leftop, &Des, l_maybe, false_label);
Des = InitDesig;
C_df_ilb(l_maybe);
CodeExpr(rightop, &Des, 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;
}
case OR: {
label l_true, l_false, l_maybe = ++text_label, l_end;
struct desig Des;
if (true_label == 0) {
l_true = ++text_label;
l_false = ++text_label;
l_end = ++text_label;
}
else {
l_true = true_label;
l_false = false_label;
}
Des = InitDesig;
CodeExpr(leftop, &Des, l_true, l_maybe);
C_df_ilb(l_maybe);
Des = InitDesig;
CodeExpr(rightop, &Des, l_true, l_false);
if (true_label == 0) {
C_df_ilb(l_false);
C_loc((arith)0);
C_bra(l_end);
@ -849,19 +855,10 @@ CodeOper(expr, true_label, false_label)
C_loc((arith)1);
C_df_ilb(l_end);
}
else {
label l_maybe = ++text_label;
struct desig Des;
Des = InitDesig;
CodeExpr(leftop, &Des, true_label, l_maybe);
C_df_ilb(l_maybe);
Des = InitDesig;
CodeExpr(rightop, &Des, true_label, false_label);
}
break;
}
default:
crash("(CodeOper) Bad operator %s\n", symbol2str(oper));
crash("(CodeOper) Bad operator %s\n",symbol2str(expr->nd_symb));
}
}
@ -936,6 +933,7 @@ CodeUoper(nd)
case '-':
switch(tp->tp_fund) {
case T_INTEGER:
case T_INTORCARD:
C_ngi(tp->tp_size);
break;
case T_REAL:
@ -977,7 +975,7 @@ CodeEl(nd, tp)
C_loc(eltype->sub_ub);
}
else C_loc((arith) (eltype->enm_ncst - 1));
Operands(nd->nd_left, nd->nd_right);
Operands(nd->nd_left, nd->nd_right, word_type);
C_cal("_LtoUset"); /* library routine to fill set */
C_asp(4 * word_size);
}
@ -1032,13 +1030,20 @@ CodeDStore(nd)
DoHIGH(nd)
struct node *nd;
{
/* Get the high index of a conformant array, indicated by "nd".
The high index is the second field in the descriptor of
the array, so it is easily found.
*/
register struct def *df = nd->nd_def;
register arith highoff;
assert(nd->nd_class == Def);
assert(df->df_kind == D_VARIABLE);
assert(IsConformantArray(df->df_type));
highoff = df->var_off + pointer_size + word_size;
highoff = df->var_off /* base address and descriptor */
+ pointer_size /* skip base address */
+ word_size; /* skip first field of descriptor */
if (df->df_scope->sc_level < proclevel) {
C_lxa((arith) (proclevel - df->df_scope->sc_level));
C_lof(highoff);

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

@ -248,6 +248,7 @@ cstset(expp)
assert(expp->nd_left->nd_class == Value);
i = expp->nd_left->nd_INT;
expp->nd_class = Value;
expp->nd_INT = (i >= 0 && set2 != 0 &&
i < setsize * wrd_bits &&
(set2[i / wrd_bits] & (1 << (i % wrd_bits))));

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

@ -108,9 +108,7 @@ declaration:
FormalParameters(struct paramlist **pr;
struct type **ptp;
arith *parmaddr;)
{
struct def *df;
} :
:
'('
[
FPSection(pr, parmaddr)
@ -128,74 +126,38 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
struct node *FPList;
struct type *tp;
int VARp;
struct paramlist *p = 0;
} :
var(&VARp) IdentList(&FPList) ':' FormalType(&p, 0)
{ EnterParamList(ppr, FPList, p->par_def->df_type,
VARp, parmaddr);
free_def(p->par_def);
free_paramlist(p);
}
var(&VARp) IdentList(&FPList) ':' FormalType(&tp)
{ EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
;
FormalType(struct paramlist **ppr; int VARp;)
FormalType(struct type **ptp;)
{
register struct def *df;
int ARRAYflag;
register struct type *tp;
struct type *tp1;
register struct paramlist *p = new_paramlist();
extern arith ArrayElSize();
} :
[ ARRAY OF { ARRAYflag = 1; }
| { ARRAYflag = 0; }
]
qualtype(&tp1)
{ if (ARRAYflag) {
tp = construct_type(T_ARRAY, NULLTYPE);
tp->arr_elem = tp1;
tp->arr_elsize = ArrayElSize(tp1);
ARRAY OF qualtype(ptp)
{ tp = construct_type(T_ARRAY, NULLTYPE);
tp->arr_elem = *ptp; *ptp = tp;
tp->arr_elsize = ArrayElSize(tp->arr_elem);
tp->tp_align = lcm(word_align, pointer_align);
}
else tp = tp1;
p->next = *ppr;
*ppr = p;
p->par_def = df = new_def();
df->df_type = tp;
df->df_flags = VARp;
}
|
qualtype(ptp)
;
TypeDeclaration
{
register struct def *df;
struct def *df;
struct type *tp;
}:
IDENT { df = define(dot.TOK_IDF,CurrentScope,D_TYPE); }
'=' type(&tp)
{ if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
if (tp->tp_fund != T_POINTER) {
error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
/* Careful now ... we might have declarations
referring to the hidden type.
*/
*(df->df_type) = *tp;
if (! tp->next) {
/* It also contains a forward
reference, so update the forward-
list
*/
ChForward(tp, df->df_type);
}
free_type(tp);
}
else df->df_type = tp;
}
{ DeclareType(df, tp); }
;
type(struct type **ptp;):
SimpleType(ptp)
%default SimpleType(ptp)
|
ArrayType(ptp)
|
@ -247,7 +209,7 @@ IdentList(struct node **p;)
register struct node *q;
} :
IDENT { *p = q = MkLeaf(Value, &dot); }
[
[ %persistent
',' IDENT
{ q->next = MkLeaf(Value, &dot);
q = q->next;
@ -460,11 +422,12 @@ PointerType(struct type **ptp;)
*/
qualtype(&((*ptp)->next))
| %if ( nd = new_node(), nd->nd_token = dot,
df = lookfor(nd, CurrVis, 0), free_node(nd),
df = lookfor(nd, CurrVis, 0),
df->df_kind == D_MODULE)
type(&((*ptp)->next))
{ free_node(nd); }
|
IDENT { Forward(&dot, (*ptp)); }
IDENT { Forward(nd, (*ptp)); }
]
;
@ -486,24 +449,28 @@ ProcedureType(struct type **ptp;)
{
struct paramlist *pr = 0;
register struct type *tp;
arith nbytes = 0;
} :
{ *ptp = 0; }
PROCEDURE FormalTypeList(&pr, ptp)?
PROCEDURE FormalTypeList(&pr, ptp, &nbytes)?
{ *ptp = tp = construct_type(T_PROCEDURE, *ptp);
tp->prc_params = pr;
tp->prc_nbpar = nbytes;
}
;
FormalTypeList(struct paramlist **ppr; struct type **ptp;)
FormalTypeList(struct paramlist **ppr; struct type **ptp; arith *parmaddr;)
{
struct def *df;
int VARp;
struct type *tp;
} :
'(' { *ppr = 0; }
[
var(&VARp) FormalType(ppr, VARp)
var(&VARp) FormalType(&tp)
{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
[
',' var(&VARp) FormalType(ppr, VARp)
',' var(&VARp) FormalType(&tp)
{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
]*
]?
')'
@ -535,7 +502,7 @@ VariableDeclaration
} :
IdentAddr(&VarList)
{ nd = VarList; }
[
[ %persistent
',' IdentAddr(&(nd->nd_right))
{ nd = nd->nd_right; }
]*

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

@ -290,7 +290,6 @@ DefineLocalModule(id)
a name to be used for code generation.
*/
register struct def *df = define(id, CurrentScope, D_MODULE);
register struct type *tp;
register struct scope *sc;
static int modulecount = 0;
char buf[256];
@ -316,8 +315,8 @@ DefineLocalModule(id)
/* Create a type for it
*/
df->df_type = tp = standard_type(T_RECORD, 0, (arith) 0);
tp->rec_scope = sc;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = sc;
/* Generate code that indicates that the initialization procedure
for this module is local.

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

@ -74,7 +74,7 @@ GetDefinitionModule(id)
}
df = lookup(id, GlobalScope);
}
assert(df != 0 && df->df_kind == D_MODULE);
assert(df && df->df_kind == D_MODULE);
level--;
return df;
}

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

@ -168,8 +168,12 @@ EnterParamList(ppr, Idlist, type, VARp, off)
register struct paramlist *pr;
register struct def *df;
register struct node *idlist = Idlist;
struct node *dummy = 0;
static struct paramlist *last;
if (! idlist) {
dummy = Idlist = idlist = MkLeaf(Name, &dot);
}
for ( ; idlist; idlist = idlist->next) {
pr = new_paramlist();
pr->next = 0;
@ -178,11 +182,17 @@ EnterParamList(ppr, Idlist, type, VARp, off)
}
else last->next = pr;
last = pr;
if (idlist != dummy) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->var_off = *off;
}
else {
df = new_def();
}
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
*/
@ -347,49 +357,38 @@ node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_te
FreeNode(Idlist);
}
EnterFromImportList(Idlist, Fromid, local)
EnterFromImportList(Idlist, FromDef)
struct node *Idlist;
register struct node *Fromid;
register struct def *FromDef;
{
/* 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".
/* Import the list Idlist from the module indicated by Fromdef.
*/
register struct node *idlist = Idlist;
register struct scopelist *vis;
register struct def *df;
struct scopelist *vis = enclosing(CurrVis);
int forwflag = 0;
extern struct def *GetDefinitionModule();
if (local) {
df = lookfor(Fromid, vis, 0);
switch(df->df_kind) {
switch(FromDef->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);
vis = ForwModule(FromDef, FromDef->df_idf);
forwflag = 1;
break;
case D_FORWMODULE:
vis = df->for_vis;
vis = FromDef->for_vis;
break;
case D_MODULE:
vis = df->mod_vis;
vis = FromDef->mod_vis;
break;
default:
node_error(Fromid, "identifier \"%s\" does not represent a module",
Fromid->nd_IDF->id_text);
error("identifier \"%s\" does not represent a module",
FromDef->df_idf->id_text);
break;
}
}
else vis = GetDefinitionModule(Fromid->nd_IDF)->mod_vis;
FreeNode(Fromid);
for (; idlist; idlist = idlist->next) {
if (forwflag) {

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

@ -18,6 +18,7 @@ static char *RcsId = "$Header$";
#include "def.h"
#include "type.h"
#include "node.h"
#include "f_info.h"
}
/*
@ -91,12 +92,22 @@ export(int *QUALflag; struct node **ExportList;)
import(int local;)
{
struct node *ImportList;
register struct node *id;
register struct def *df;
int fromid;
extern struct def *GetDefinitionModule();
} :
[ FROM
IDENT { id = MkLeaf(Value, &dot); }
IDENT { fromid = 1;
if (local) {
struct node *nd = MkLeaf(Name, &dot);
df = lookfor(nd,enclosing(CurrVis),0);
FreeNode(nd);
}
else df = GetDefinitionModule(dot.TOK_IDF);
}
|
{ id = 0; }
{ fromid = 0; }
]
IMPORT IdentList(&ImportList) ';'
/*
@ -105,7 +116,7 @@ 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.
*/
{ if (id) EnterFromImportList(ImportList, id, local);
{ if (fromid) EnterFromImportList(ImportList, df);
else EnterImportList(ImportList, local);
}
;

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

@ -67,14 +67,14 @@ InitScope()
struct forwards {
struct forwards *next;
struct node fo_tok;
struct node *fo_tok;
struct type *fo_ptyp;
};
/* STATICALLOCDEF "forwards" */
Forward(tk, ptp)
struct token *tk;
struct node *tk;
struct type *ptp;
{
/* Enter a forward reference into a list belonging to the
@ -84,7 +84,7 @@ Forward(tk, ptp)
*/
register struct forwards *f = new_forwards();
f->fo_tok.nd_token = *tk;
f->fo_tok = tk;
f->fo_ptyp = ptp;
f->next = CurrentScope->sc_forw;
CurrentScope->sc_forw = f;
@ -168,23 +168,24 @@ node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
STATIC
rem_forwards(fo)
struct forwards *fo;
register struct forwards *fo;
{
/* When closing a scope, all forward references must be resolved
*/
register struct forwards *f;
register struct def *df;
while (f = fo) {
df = lookfor(&(f->fo_tok), CurrVis, 1);
if (!(df->df_kind & (D_TYPE|D_ERROR))) {
node_error(&(f->fo_tok), "identifier \"%s\" not a type",
if (fo->next) rem_forwards(fo->next);
df = lookfor(fo->fo_tok, CurrVis, 0);
if (df->df_kind == D_ERROR) {
node_error(fo->fo_tok, "identifier \"%s\" not declared",
df->df_idf->id_text);
}
f->fo_ptyp->next = df->df_type;
fo = f->next;
free_forwards(f);
else if (df->df_kind != D_TYPE) {
node_error(fo->fo_tok, "identifier \"%s\" not a type",
df->df_idf->id_text);
}
fo->fo_ptyp->next = df->df_type;
free_forwards(fo);
}
Reverse(pdf)

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

@ -104,10 +104,11 @@ construct_type(fund, tp)
break;
case T_ARRAY:
dtp->tp_align = tp->tp_align;
if (tp) dtp->tp_align = tp->tp_align;
break;
case T_SUBRANGE:
assert(tp != 0);
dtp->tp_align = tp->tp_align;
dtp->tp_size = tp->tp_size;
break;
@ -386,7 +387,7 @@ ArrayElSize(tp)
if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
algn = align(tp->tp_size, tp->tp_align);
if (word_size % algn != 0) {
if (algn && word_size % algn != 0) {
/* algn is not a dividor of the word size, so make sure it
is a multiple
*/
@ -449,6 +450,36 @@ FreeType(tp)
free_type(tp);
}
DeclareType(df, tp)
register struct def *df;
register struct type *tp;
{
/* A type with type-description "tp" is declared and must
be bound to definition "df".
This routine also handles the case that the type-field of
"df" is already bound. In that case, it is either an opaque
type, or an error message was given when "df" was created.
*/
if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
if (tp->tp_fund != T_POINTER) {
error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
/* Careful now ... we might have declarations
referring to the hidden type.
*/
*(df->df_type) = *tp;
if (! tp->next) {
/* It also contains a forward reference,
so update the forwardlist
*/
ChForward(tp, df->df_type);
}
free_type(tp);
}
else df->df_type = tp;
}
int
gcd(m, n)
register int m, n;

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

@ -81,6 +81,9 @@ TstProcEquiv(tp1, tp2)
p2 = p2->next;
}
/* Here, at least one of the parameterlists is exhausted.
Check that they are both.
*/
return p1 == p2;
}
@ -101,18 +104,17 @@ TstCompat(tp1, tp2)
||
( tp1 == intorcard_type
&&
(tp2 == int_type || tp2 == card_type)
(tp2 == int_type || tp2 == card_type || tp2 == address_type)
)
||
( tp2 == intorcard_type
&&
(tp1 == int_type || tp1 == card_type)
(tp1 == int_type || tp1 == card_type || tp1 == address_type)
)
||
( tp1 == address_type
&&
( tp2 == card_type
|| tp2 == intorcard_type
|| tp2->tp_fund == T_POINTER
)
)
@ -120,7 +122,6 @@ TstCompat(tp1, tp2)
( tp2 == address_type
&&
( tp1 == card_type
|| tp1 == intorcard_type
|| tp1->tp_fund == T_POINTER
)
)
@ -173,7 +174,7 @@ TstAssCompat(tp1, tp2)
int
TstParCompat(formaltype, actualtype, VARflag, nd)
struct type *formaltype, *actualtype;
register struct type *formaltype, *actualtype;
struct node *nd;
{
/* Check type compatibility for a parameter in a procedure call.
@ -218,19 +219,12 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
)
)
||
( VARflag && OldCompat(formaltype, actualtype, nd))
( VARflag
&& ( TstCompat(formaltype, actualtype)
&&
(node_warning(nd, "oldfashioned! types of formal and actual must be identical"),
1)
)
)
;
}
int
OldCompat(ft, at, nd)
struct type *ft, *at;
struct node *nd;
{
if (TstCompat(ft, at)) {
node_warning(nd, "oldfashioned! types of formal and actual must be identical");
return 1;
}
return 0;
}

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

@ -132,6 +132,8 @@ WalkProcedure(procedure)
register struct type *tp;
register struct paramlist *param;
label func_res_label = 0;
arith tmpvar1 = 0;
arith retsav = 0;
proclevel++;
CurrVis = procedure->prc_vis;
@ -147,6 +149,14 @@ WalkProcedure(procedure)
DoProfil();
TmpOpen(sc);
func_type = tp = ResultType(procedure->df_type);
if (tp && IsConstructed(tp)) {
func_res_label = ++data_label;
C_df_dlb(func_res_label);
C_bss_cst(tp->tp_size, (arith) 0, 0);
}
/* Generate calls to initialization routines of modules defined within
this procedure
*/
@ -154,6 +164,7 @@ WalkProcedure(procedure)
/* Make sure that arguments of size < word_size are on a
fixed place.
Also make copies of conformant arrays when neccessary.
*/
for (param = ParamList(procedure->df_type);
param;
@ -161,37 +172,114 @@ WalkProcedure(procedure)
if (! IsVarParam(param)) {
tp = TypeOfParam(param);
if (!IsConformantArray(tp) && tp->tp_size < word_size) {
if (! IsConformantArray(tp)) {
if (tp->tp_size < word_size) {
C_lol(param->par_def->var_off);
C_lal(param->par_def->var_off);
C_sti(tp->tp_size);
}
}
else {
/* Here, we have to make a copy of the
array. We must also remember how much
room is reserved for copies, because
we have to adjust the stack pointer before
a RET is done. This is even more complicated
when the procedure returns a value.
Then, the value must be saved (in retval),
the stack adjusted, the return value pushed
again, and then RET
*/
arith tmpvar = NewInt();
if (! tmpvar1) {
if (tp && !func_res_label) {
/* Some local space, only
needed if the value itself
is returned
*/
sc->sc_off -= WA(tp->tp_size);
retsav = sc->sc_off;
}
tmpvar1 = NewInt();
C_loc((arith) 0);
C_stl(tmpvar1);
}
/* First compute the size */
C_lol(param->par_def->var_off +
pointer_size + word_size);
C_inc(); /* gives number of elements */
C_loc(tp->arr_elem->tp_size);
C_cal("_wa");
C_asp(dword_size);
C_lfr(word_size);
/* size in words */
C_loc(word_size);
C_mli(word_size);
/* size in bytes */
C_stl(tmpvar);
C_lol(tmpvar);
C_dup(word_size);
C_lol(tmpvar1);
C_adi(word_size);
C_stl(tmpvar1); /* remember all stack adjustments */
C_ngi(word_size);
C_ass(word_size);
/* adjusted stack pointer */
C_lor((arith) 1);
/* destination address */
C_lal(param->par_def->var_off);
C_loi(pointer_size);
/* push source address */
C_exg(pointer_size);
/* exchange them */
C_lol(tmpvar); /* push size */
C_bls(word_size);
/* copy */
C_lor((arith) 1);
/* push new address of array */
C_lal(param->par_def->var_off);
C_sti(pointer_size);
FreeInt(tmpvar);
}
}
}
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);
}
DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
WalkNode(procedure->prc_body, (label) 0);
C_ret((arith) 0);
if (tp) {
C_df_ilb((label) 1);
tp = func_type;
if (func_res_label) {
C_lae_dlb(func_res_label, (arith) 0);
C_sti(tp->tp_size);
if (tmpvar1) {
C_lol(tmpvar1);
C_ass(word_size);
}
C_lae_dlb(func_res_label, (arith) 0);
C_ret(pointer_size);
}
else C_ret(WA(tp->tp_size));
else if (tp) {
if (tmpvar1) {
C_lal(retsav);
C_sti(WA(tp->tp_size));
C_lol(tmpvar1);
C_ass(word_size);
C_lal(retsav);
C_loi(WA(tp->tp_size));
}
C_ret(WA(tp->tp_size));
}
else {
if (tmpvar1) {
C_lol(tmpvar1);
C_ass(word_size);
}
C_ret((arith) 0);
}
if (tmpvar1) FreeInt(tmpvar1);
if (! options['n']) RegisterMessages(sc->sc_def);
C_end(-sc->sc_off);
TmpClose();
@ -394,7 +482,7 @@ WalkStat(nd, lab)
struct desig ds;
arith tmp = 0;
WalkDesignator(left, &ds);
if (! WalkDesignator(left, &ds)) break;
if (left->nd_type->tp_fund != T_RECORD) {
node_error(left, "record variable expected");
break;
@ -432,7 +520,7 @@ WalkStat(nd, lab)
case RETURN:
if (right) {
WalkExpr(right);
if (! WalkExpr(right)) break;
/* The type of the return-expression must be
assignment compatible with the result type of the
function procedure (See Rep. 9.11).
@ -440,9 +528,8 @@ WalkStat(nd, lab)
if (!TstAssCompat(func_type, right->nd_type)) {
node_error(right, "type incompatibility in RETURN statement");
}
C_bra((label) 1);
}
else C_ret((arith) 0);
C_bra((label) 1);
break;
default:
@ -487,17 +574,20 @@ ExpectBool(nd, true_label, false_label)
CodeExpr(nd, &ds, true_label, false_label);
}
int
WalkExpr(nd)
struct node *nd;
{
/* Check an expression and generate code for it
*/
if (! ChkExpression(nd)) return;
if (! ChkExpression(nd)) return 0;
CodePExpr(nd);
return 1;
}
int
WalkDesignator(nd, ds)
struct node *nd;
struct desig *ds;
@ -505,10 +595,11 @@ WalkDesignator(nd, ds)
/* Check designator and generate code for it
*/
if (! ChkVariable(nd)) return;
if (! ChkVariable(nd)) return 0;
*ds = InitDesig;
CodeDesig(nd, ds);
return 1;
}
DoForInit(nd, left)