# 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
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
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)
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: ../src/def.H ../src/make.allocd
+ ../src/make.allocd < ../src/def.H > def.h
+
+type.h: ../src/type.H ../src/make.allocd
+ ../src/make.allocd < ../src/type.H > type.h
-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
+node.h: ../src/node.H ../src/make.allocd
+ ../src/make.allocd < ../src/node.H > node.h
-char.c: char.tab tab
- ./tab -fchar.tab >char.c
+scope.c: ../src/scope.C ../src/make.allocd
+ ../src/make.allocd < ../src/scope.C > scope.c
-tab:
- $(CC) tab.c -o tab
+tmpvar.c: ../src/tmpvar.C ../src/make.allocd
+ ../src/make.allocd < ../src/tmpvar.C > tmpvar.c
-depend:
+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
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
!File: idfsize.h
-#define IDFSIZE 30 /* maximum significant length of an identifier */
+#define IDFSIZE 128 /* maximum significant length of an identifier */
!File: numsize.h
{
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;
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) {
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;
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) {
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;
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) {
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);
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(df));
+ break;
}
- C_cal(NameOfProc(left->nd_def));
- }
- 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();
}
{
register struct type *tp;
register struct node *left;
+ register struct type *left_type;
assert(param != 0 && arg != 0);
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);
}
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);
}
}
}
else C_cal("_absd");
}
+ C_asp(tp->tp_size);
C_lfr(tp->tp_size);
break;
break;
case S_ODD:
+ CodePExpr(left);
if (tp->tp_size == word_size) {
C_loc((arith) 1);
C_and(word_size);
}
}
-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:
}
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:
}
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:
}
break;
case '/':
- Operands(leftop, rightop);
+ Operands(leftop, rightop, tp);
switch (tp->tp_fund) {
case T_REAL:
C_dvf(tp->tp_size);
}
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:
}
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:
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:
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);
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:
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) {
}
break;
case AND:
- case '&':
+ case '&': {
+ label l_true, l_false, l_maybe = ++text_label, l_end;
+ struct desig Des;
+
if (true_label == 0) {
- 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;
- CodeExpr(leftop, &Des, l_maybe, l_false);
- C_df_ilb(l_maybe);
- Des = InitDesig;
- CodeExpr(rightop, &Des, l_true, l_false);
+ 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);
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:
+ }
+ case OR: {
+ label l_true, l_false, l_maybe = ++text_label, l_end;
+ struct desig Des;
+
if (true_label == 0) {
- 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;
- CodeExpr(leftop, &Des, l_true, l_maybe);
- C_df_ilb(l_maybe);
- Des = InitDesig;
- CodeExpr(rightop, &Des, l_true, l_false);
+ 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);
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));
}
}
case '-':
switch(tp->tp_fund) {
case T_INTEGER:
+ case T_INTORCARD:
C_ngi(tp->tp_size);
break;
case T_REAL:
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);
}
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);
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))));
FormalParameters(struct paramlist **pr;
struct type **ptp;
arith *parmaddr;)
-{
- struct def *df;
-} :
+:
'('
[
FPSection(pr, 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);
- 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;
+ 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);
}
+|
+ 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)
|
register struct node *q;
} :
IDENT { *p = q = MkLeaf(Value, &dot); }
- [
+ [ %persistent
',' IDENT
{ q->next = MkLeaf(Value, &dot);
q = q->next;
*/
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))
+ type(&((*ptp)->next))
+ { free_node(nd); }
|
- IDENT { Forward(&dot, (*ptp)); }
+ IDENT { Forward(nd, (*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); }
]*
]?
')'
} :
IdentAddr(&VarList)
{ nd = VarList; }
- [
+ [ %persistent
',' IdentAddr(&(nd->nd_right))
{ nd = nd->nd_right; }
]*
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];
/* 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.
}
df = lookup(id, GlobalScope);
}
- assert(df != 0 && df->df_kind == D_MODULE);
+ assert(df && df->df_kind == D_MODULE);
level--;
return df;
}
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;
}
else last->next = pr;
last = pr;
- df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
+ 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
*/
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) {
- 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;
- }
+ 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(FromDef, FromDef->df_idf);
+ forwflag = 1;
+ break;
+ case D_FORWMODULE:
+ vis = FromDef->for_vis;
+ break;
+ case D_MODULE:
+ vis = FromDef->mod_vis;
+ break;
+ default:
+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) {
#include "def.h"
#include "type.h"
#include "node.h"
+#include "f_info.h"
}
/*
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) ';'
/*
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);
}
;
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
*/
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;
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",
- df->df_idf->id_text);
- }
- f->fo_ptyp->next = df->df_type;
- fo = f->next;
- free_forwards(f);
+ 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);
+ }
+ 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)
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;
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
*/
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;
p2 = p2->next;
}
+ /* Here, at least one of the parameterlists is exhausted.
+ Check that they are both.
+ */
return p1 == p2;
}
||
( 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
)
)
( tp2 == address_type
&&
( tp1 == card_type
- || tp1 == intorcard_type
|| tp1->tp_fund == T_POINTER
)
)
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.
)
)
||
- ( 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;
-}
register struct type *tp;
register struct paramlist *param;
label func_res_label = 0;
+ arith tmpvar1 = 0;
+ arith retsav = 0;
proclevel++;
CurrVis = procedure->prc_vis;
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
*/
/* 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;
if (! IsVarParam(param)) {
tp = TypeOfParam(param);
- if (!IsConformantArray(tp) && tp->tp_size < word_size) {
- C_lol(param->par_def->var_off);
+ 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(tp->tp_size);
+ 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);
- 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);
+ 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);
}
- else C_ret(WA(tp->tp_size));
+ C_lae_dlb(func_res_label, (arith) 0);
+ C_ret(pointer_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();
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;
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).
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:
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;
/* 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)
public / ack.git / commitdiff