From da54801353765ed1f83330aa48cbc9091211c96c Mon Sep 17 00:00:00 2001 From: ceriel Date: Wed, 26 Nov 1986 16:40:45 +0000 Subject: [PATCH] newer version --- lang/m2/comp/LLlex.c | 11 ++-- lang/m2/comp/Makefile | 14 ++--- lang/m2/comp/Resolve | 7 ++- lang/m2/comp/chk_expr.c | 12 ++-- lang/m2/comp/code.c | 112 +++++++++++++++++--------------------- lang/m2/comp/declar.g | 24 ++++---- lang/m2/comp/def.H | 24 +++++--- lang/m2/comp/def.c | 20 ++++++- lang/m2/comp/defmodule.c | 7 ++- lang/m2/comp/expression.g | 21 ++++--- lang/m2/comp/main.c | 11 +++- lang/m2/comp/program.g | 25 ++++----- lang/m2/comp/scope.C | 50 +++++------------ lang/m2/comp/scope.h | 1 - lang/m2/comp/tmpvar.C | 16 ++++-- lang/m2/comp/type.H | 1 + lang/m2/comp/type.c | 12 ++-- lang/m2/comp/typequiv.c | 7 ++- lang/m2/comp/walk.c | 94 ++++++++++++++++++++++---------- 19 files changed, 264 insertions(+), 205 deletions(-) diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index c9372ecb7..902ed71b9 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -106,9 +106,8 @@ GetString(upto) } str->s_length = p - str->s_str; while (p - str->s_str < len) *p++ = '\0'; - if (str->s_length == 0) str->s_length = 1; /* ??? string length - at least 1 ??? - */ + if (str->s_length == 0) str->s_length = 1; + /* ??? string length at least 1 ??? */ return str; } @@ -239,12 +238,10 @@ again1: goto again; case STGARB: - if (040 < ch && ch < 0177) { + if ((unsigned) ch - 040 < 0137) { lexerror("garbage char %c", ch); } - else { - lexerror("garbage char \\%03o", ch); - } + else lexerror("garbage char \\%03o", ch); goto again; case STSIMP: diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index aff09b741..d434e74ef 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -5,11 +5,11 @@ PKGDIR = $(EMDIR)/modules/pkg LIBDIR = $(EMDIR)/modules/lib OBJECTCODE = $(LIBDIR)/libemk.a LLGEN = $(EMDIR)/bin/LLgen +CURRDIR = . INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR) GFILES = tokenfile.g program.g declar.g expression.g statement.g -CC = cc LLGENOPTIONS = PROFILE = CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC= @@ -50,14 +50,14 @@ GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES) #EXCLEXCLEXCLEXCL all: Cfiles - sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make ../comp/main ; else sh Resolve ../comp/main ; fi' + sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make $(CURRDIR)/main ; else sh Resolve main ; fi' @rm -f nmclash.o a.out install: all - cp main $(EMDIR)/lib/em_m2 + cp $(CURRDIR)/main $(EMDIR)/lib/em_m2 clean: - rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes main + rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes $(CURRDIR)/main (cd .. ; rm -rf Xsrc) lint: Cfiles @@ -123,9 +123,9 @@ depend: Xlint: lint $(INCLUDES) $(LINTFLAGS) $(SRC) -../comp/main: $(OBJ) ../comp/Makefile - $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o ../comp/main - size ../comp/main +$(CURRDIR)/main: $(OBJ) + $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main + size $(CURRDIR)/main #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO LLlex.o: LLlex.h Lpars.h class.h const.h debug.h debugcst.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h warning.h diff --git a/lang/m2/comp/Resolve b/lang/m2/comp/Resolve index eeb0a7b86..e107d789d 100755 --- a/lang/m2/comp/Resolve +++ b/lang/m2/comp/Resolve @@ -8,8 +8,11 @@ case $# in exit 1 ;; esac +currdir=`pwd` case $1 in -../comp/main|Xlint) +main) target=$currdir/$1 + ;; +Xlint) target=$1 ;; *) echo "$0: $1: Illegal argument" 1>&2 exit 1 @@ -48,4 +51,4 @@ $i: clashes $PW/$i cid -Fclashes < $PW/$i > $i EOF done -make $1 +make CURRDIR=$currdir $target diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 7d27a38b3..0e2b0ccc4 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -438,6 +438,7 @@ getarg(argp, bases, designator, edf) } left = arg->nd_left; + *argp = arg; if (designator ? !ChkVariable(left) : !ChkExpression(left)) { return 0; @@ -454,7 +455,6 @@ getarg(argp, bases, designator, edf) } } - *argp = arg; return left; } @@ -470,6 +470,8 @@ getname(argp, kinds, bases, edf) register struct node *arg = *argp; register struct node *left; + *argp = arg->nd_right; + if (!arg->nd_right) { Xerror(arg, "too few arguments supplied", edf); return 0; @@ -496,7 +498,6 @@ getname(argp, kinds, bases, edf) } } - *argp = arg; return left; } @@ -539,7 +540,7 @@ ChkProcCall(expp) if (left->nd_symb == STRING) { TryToString(left, TypeOfParam(param)); } - if (! TstParCompat(RemoveEqual(TypeOfParam(param)), + else if (! TstParCompat(RemoveEqual(TypeOfParam(param)), left->nd_type, IsVarParam(param), left)) { @@ -552,6 +553,9 @@ ChkProcCall(expp) if (expp->nd_right) { Xerror(expp->nd_right, "too many parameters supplied", edf); + while (expp->nd_right) { + getarg(&expp, 0, 0, edf); + } return 0; } @@ -581,7 +585,7 @@ ChkCall(expp) return ChkCast(expp, left); } - if (IsProcCall(left)) { + if (IsProcCall(left) || left->nd_type == error_type) { /* A procedure call. It may also be a call to a standard procedure */ diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index 1fbea8be3..a91f0c989 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -86,7 +86,6 @@ CodePadString(nd, sz) C_loi(sizearg); } - CodeExpr(nd, ds, true_label, false_label) register struct node *nd; register struct desig *ds; @@ -365,27 +364,37 @@ CodeParameters(param, arg) left = arg->nd_left; left_type = left->nd_type; if (IsConformantArray(tp)) { + register struct type *elem = tp->arr_elem; + C_loc(tp->arr_elsize); if (IsConformantArray(left_type)) { DoHIGH(left); - if (tp->arr_elem->tp_size != - left_type->arr_elem->tp_size) { + if (elem->tp_size != left_type->arr_elem->tp_size) { /* This can only happen if the formal type is - ARRAY OF WORD + ARRAY OF (WORD|BYTE) */ - 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); + C_mli(word_size); + if (elem == word_type) { + C_loc(word_size - 1); + C_adi(word_size); + C_loc(word_size); + C_dvi(word_size); + } + else { + assert(elem == byte_type); + } } } else if (left->nd_symb == STRING) { - C_loc(left->nd_SLE); + C_loc(left->nd_SLE - 1); } - else if (tp->arr_elem == word_type) { + else if (elem == word_type) { C_loc((left_type->tp_size+word_size-1) / word_size - 1); } + else if (elem == byte_type) { + C_loc(left_type->tp_size - 1); + } else { arith lb, ub; getbounds(IndexType(left_type), &lb, &ub); @@ -395,20 +404,30 @@ CodeParameters(param, arg) if (left->nd_symb == STRING) { CodeString(left); } - else CodeDAddress(left); - } - else if (IsVarParam(param)) { - CodeDAddress(left); - } - else { - if (left_type->tp_fund == T_STRING) { - CodePadString(left, tp->tp_size); - } - else { + else if (left->nd_class == Call) { + /* ouch! forgot about this one! */ + arith tmp, TmpSpace(); + CodePExpr(left); - RangeCheck(left_type, tp); + tmp = TmpSpace(left->nd_type->tp_size, left->nd_type->tp_align); + C_lal(tmp); + C_sti(WA(left->nd_type->tp_size)); + C_lal(tmp); } + else CodeDAddress(left); + return; } + if (IsVarParam(param)) { + CodeDAddress(left); + return; + } + if (left_type->tp_fund == T_STRING) { + CodePadString(left, tp->tp_size); + return; + } + CodePExpr(left); + RangeCheck(tp, left_type); + CodeCoercion(left_type, tp); } CodeStd(nd) @@ -538,33 +557,6 @@ CodeStd(nd) } } -CodeAssign(nd, dss, dst) - register struct node *nd; - struct desig *dst, *dss; -{ - /* Generate code for an assignment. Testing of type - compatibility and the like is already done. - */ - register struct type *tp = nd->nd_right->nd_type; - arith size = nd->nd_left->nd_type->tp_size; - - if (dss->dsg_kind == DSG_LOADED) { - if (tp->tp_fund == T_STRING) { - CodeAddress(dst); - C_loc(tp->tp_size); - C_loc(size); - C_cal("_StringAssign"); - C_asp((int_size << 1) + (pointer_size << 1)); - return; - } - CodeStore(dst, size); - return; - } - CodeAddress(dss); - CodeAddress(dst); - C_blm(size); -} - RangeCheck(tpl, tpr) register struct type *tpl, *tpr; { @@ -800,32 +792,30 @@ CodeOper(expr, true_label, false_label) case OR: case AND: case '&': { - label l_true, l_false, l_maybe = ++text_label, l_end; + label l_maybe = ++text_label, l_end; struct desig Des; + int genlabels = 0; if (true_label == 0) { - l_true = ++text_label; - l_false = ++text_label; + genlabels = 1; + true_label = ++text_label; + false_label = ++text_label; l_end = ++text_label; } - else { - l_true = true_label; - l_false = false_label; - } Des = InitDesig; if (expr->nd_symb == OR) { - CodeExpr(leftop, &Des, l_true, l_maybe); + CodeExpr(leftop, &Des, true_label, l_maybe); } - else CodeExpr(leftop, &Des, l_maybe, l_false); + else CodeExpr(leftop, &Des, l_maybe, false_label); C_df_ilb(l_maybe); Des = InitDesig; - CodeExpr(rightop, &Des, l_true, l_false); - if (true_label == 0) { - C_df_ilb(l_true); + CodeExpr(rightop, &Des, true_label, false_label); + if (genlabels) { + C_df_ilb(true_label); C_loc((arith)1); C_bra(l_end); - C_df_ilb(l_false); + C_df_ilb(false_label); C_loc((arith)0); C_df_ilb(l_end); } diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index 00624af52..0f309aec4 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -102,10 +102,11 @@ FormalType(struct type **ptp;) } : ARRAY OF qualtype(ptp) { register struct type *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); + tp->tp_align = tp->arr_elem->tp_align; } | qualtype(ptp) @@ -160,16 +161,18 @@ enumeration(struct type **ptp;) struct node *EnumList; } : '(' IdentList(&EnumList) ')' - { - *ptp = standard_type(T_ENUMERATION, int_align, int_size); - EnterEnumList(EnumList, *ptp); - if (ufit((*ptp)->enm_ncst-1, 1)) { - (*ptp)->tp_size = 1; - (*ptp)->tp_align = 1; + { register struct type *tp = + standard_type(T_ENUMERATION, int_align, int_size); + + *ptp = tp; + EnterEnumList(EnumList, tp); + if (ufit(tp->enm_ncst-1, 1)) { + tp->tp_size = 1; + tp->tp_align = 1; } - else if (ufit((*ptp)->enm_ncst-1, short_size)) { - (*ptp)->tp_size = short_size; - (*ptp)->tp_align = short_align; + else if (ufit(tp->enm_ncst-1, short_size)) { + tp->tp_size = short_size; + tp->tp_align = short_align; } } ; @@ -234,7 +237,6 @@ RecordType(struct type **ptp;) { open_scope(OPENSCOPE); /* scope for fields of record */ scope = CurrentScope; close_scope(0); - size = 0; } FieldListSequence(scope, &size, &xalign) { *ptp = standard_type(T_RECORD, xalign, WA(size)); diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index dee4b94b1..a1725310c 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -63,13 +63,20 @@ struct dforward { #define for_name df_value.df_forward.fo_name }; +struct forwtype { + struct node *f_node; + struct type *f_type; +#define df_forw_type df_value.df_fortype.f_type +#define df_forw_node df_value.df_fortype.f_node +}; + struct def { /* list of definitions for a name */ struct def *next; /* next definition in definitions chain */ struct def *df_nextinscope; /* link all definitions in a scope */ struct idf *df_idf; /* link back to the name */ struct scope *df_scope; /* scope in which this definition resides */ - short df_kind; /* the kind of this definition: */ + unsigned short df_kind; /* the kind of this definition: */ #define D_MODULE 0x0001 /* a module */ #define D_PROCEDURE 0x0002 /* procedure of function */ #define D_VARIABLE 0x0004 /* a variable */ @@ -82,20 +89,22 @@ struct def { /* list of definitions for a name */ #define D_HIDDEN 0x0200 /* a hidden type */ #define D_FORWARD 0x0400 /* not yet defined */ #define D_FORWMODULE 0x0800 /* module must be declared later */ -#define D_ERROR 0x1000 /* a compiler generated definition for an +#define D_FORWTYPE 0x1000 /* forward type */ +#define D_FTYPE 0x2000 /* resolved forward type */ +#define D_ERROR 0x4000 /* a compiler generated definition for an undefined variable */ #define D_VALUE (D_PROCEDURE|D_VARIABLE|D_FIELD|D_ENUM|D_CONST|D_PROCHEAD) -#define D_ISTYPE (D_HIDDEN|D_TYPE) +#define D_ISTYPE (D_HIDDEN|D_TYPE|D_FTYPE) #define is_type(dfx) ((dfx)->df_kind & D_ISTYPE) char df_flags; #define D_NOREG 0x01 /* set if it may not reside in a register */ #define D_USED 0x02 /* set if used (future use ???) */ #define D_DEFINED 0x04 /* set if it is assigned a value (future use ???) */ -#define D_VARPAR 0x10 /* set if it is a VAR parameter */ -#define D_VALPAR 0x20 /* set if it is a value parameter */ -#define D_EXPORTED 0x40 /* set if exported */ -#define D_QEXPORTED 0x80 /* set if qualified exported */ +#define D_VARPAR 0x08 /* set if it is a VAR parameter */ +#define D_VALPAR 0x10 /* set if it is a value parameter */ +#define D_EXPORTED 0x20 /* set if exported */ +#define D_QEXPORTED 0x40 /* set if qualified exported */ struct type *df_type; union { struct module df_module; @@ -106,6 +115,7 @@ struct def { /* list of definitions for a name */ struct import df_import; struct dfproc df_proc; struct dforward df_forward; + struct forwtype df_fortype; int df_stdname; /* define for standard name */ } df_value; }; diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c index 36c8906a0..e32e54848 100644 --- a/lang/m2/comp/def.c +++ b/lang/m2/comp/def.c @@ -21,6 +21,8 @@ struct def *h_def; /* pointer to free list of def structures */ int cnt_def; /* count number of allocated ones */ #endif +extern int (*c_inp)(); + STATIC DefInFront(df) register struct def *df; @@ -129,6 +131,18 @@ define(id, scope, kind) } break; + case D_FORWTYPE: + if (kind == D_FORWTYPE) return df; + if (kind == D_TYPE) { + df->df_kind = D_FTYPE; + FreeNode(df->df_forw_node); + } + else { + error("identifier \"%s\" must be a type", + id->id_text); + } + return df; + case D_FORWARD: /* A forward reference, for which we may now have found a definition. @@ -247,7 +261,7 @@ DeclProc(type, id) df = define(id, CurrentScope, type); sprint(buf,"_%d_%s",++nmcount,id->id_text); name = Salloc(buf, (unsigned)(strlen(buf)+1)); - C_inp(buf); + (*c_inp)(buf); } open_scope(OPENSCOPE); scope = CurrentScope; @@ -311,13 +325,13 @@ DefineLocalModule(id) /* Create a type for it */ - df->df_type = standard_type(T_RECORD, 0, (arith) 0); + df->df_type = standard_type(T_RECORD, 1, (arith) 0); df->df_type->rec_scope = sc; /* Generate code that indicates that the initialization procedure for this module is local. */ - C_inp(buf); + (*c_inp)(buf); return df; } diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c index b381d68b6..e1a861608 100644 --- a/lang/m2/comp/defmodule.c +++ b/lang/m2/comp/defmodule.c @@ -36,7 +36,7 @@ GetFile(name) buf[10] = '\0'; /* maximum length */ strcat(buf, ".def"); if (! InsertFile(buf, DEFPATH, &(FileName))) { - error("could'nt find a DEFINITION MODULE for \"%s\"", name); + error("could not find a DEFINITION MODULE for \"%s\"", name); return 0; } LineNumber = 1; @@ -56,6 +56,7 @@ GetDefinitionModule(id, incr) struct def *df; static int level; struct scopelist *vis; + int didread = 0; level += incr; df = lookup(id, GlobalScope, 1); @@ -68,6 +69,7 @@ GetDefinitionModule(id, incr) else { open_scope(CLOSEDSCOPE); if (!is_anon_idf(id) && GetFile(id->id_text)) { + didread = 1; DefModule(); if (level == 1) { /* The module is directly imported by @@ -93,6 +95,9 @@ GetDefinitionModule(id, incr) } df = lookup(id, GlobalScope, 1); if (! df) { + if (didread) { + error("did not read a DEFINITION MODULE for \"%s\"", id->id_text); + } df = MkDef(id, GlobalScope, D_ERROR); df->df_type = error_type; df->mod_vis = vis; diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 787669bda..542d18e8e 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -50,7 +50,7 @@ ExpList(struct node **pnd;) register struct node *nd; } : expression(pnd) { *pnd = nd = MkNode(Link,*pnd,NULLNODE,&dot); - (*pnd)->nd_symb = ','; + nd->nd_symb = ','; } [ ',' { nd->nd_right = MkLeaf(Link, &dot); @@ -60,20 +60,26 @@ ExpList(struct node **pnd;) ]* ; -ConstExpression(struct node **pnd;): +ConstExpression(struct node **pnd;) +{ + register struct node *nd; +}: expression(pnd) /* * Changed rule in new Modula-2. * Check that the expression is a constant expression and evaluate! */ - { DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n")); - DO_DEBUG(options['X'], PrNode(*pnd, 0)); - if (ChkExpression(*pnd) && - ((*pnd)->nd_class != Set && (*pnd)->nd_class != Value)) { + { nd = *pnd; + DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n")); + DO_DEBUG(options['X'], PrNode(nd, 0)); + + if (ChkExpression(nd) && + ((nd)->nd_class != Set && (nd)->nd_class != Value)) { error("constant expression expected"); } + DO_DEBUG(options['X'], print("RESULTS IN\n")); - DO_DEBUG(options['X'], PrNode(*pnd, 0)); + DO_DEBUG(options['X'], PrNode(nd, 0)); } ; @@ -102,6 +108,7 @@ SimpleExpression(struct node **pnd;) [ '+' | '-' ] { *pnd = MkLeaf(Uoper, &dot); pnd = &((*pnd)->nd_right); + /* priority of unary operator ??? */ } ]? term(pnd) diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index 9468c4665..10c44f0e1 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -29,6 +29,9 @@ struct def *Defined; extern int err_occurred; extern int fp_used; /* set if floating point used */ +extern C_inp(), C_exp(); +int (*c_inp)() = C_inp; + main(argc, argv) register char **argv; { @@ -49,6 +52,7 @@ main(argc, argv) fprint(STDERR, "%s: Use a file argument\n", ProgName); return 1; } + if (options['x']) c_inp = C_exp; return !Compile(Nargv[1], Nargv[2]); } @@ -197,6 +201,7 @@ do_SYSTEM() */ open_scope(CLOSEDSCOPE); (void) Enter("WORD", D_TYPE, word_type, 0); + (void) Enter("BYTE", D_TYPE, byte_type, 0); (void) Enter("ADDRESS", D_TYPE, address_type, 0); (void) Enter("ADR", D_PROCEDURE, std_type, S_ADR); (void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE); @@ -215,14 +220,14 @@ Info() { extern int cnt_def, cnt_node, cnt_paramlist, cnt_type, cnt_switch_hdr, cnt_case_entry, - cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar; + cnt_scope, cnt_scopelist, cnt_tmpvar; print("\ %6d def\n%6d node\n%6d paramlist\n%6d type\n%6d switch_hdr\n\ -%6d case_entry\n%6d scope\n%6d scopelist\n%6d forwards\n%6d tmpvar\n", +%6d case_entry\n%6d scope\n%6d scopelist\n%6d tmpvar\n", cnt_def, cnt_node, cnt_paramlist, cnt_type, cnt_switch_hdr, cnt_case_entry, -cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar); +cnt_scope, cnt_scopelist, cnt_tmpvar); print("\nNumber of lines read: %d\n", cntlines); } #endif diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g index 100c55dfb..b45e5f9c4 100644 --- a/lang/m2/comp/program.g +++ b/lang/m2/comp/program.g @@ -59,10 +59,12 @@ ModuleDeclaration priority(arith *pprio;) { - struct node *nd; + register struct node *nd; + struct node *nd1; /* &nd is illegal */ } : - '[' ConstExpression(&nd) ']' - { if (!(nd->nd_type->tp_fund & T_CARDINAL)) { + '[' ConstExpression(&nd1) ']' + { nd = nd1; + if (!(nd->nd_type->tp_fund & T_CARDINAL)) { node_error(nd, "illegal priority"); } *pprio = nd->nd_INT; @@ -70,9 +72,7 @@ priority(arith *pprio;) } ; -export(int *QUALflag; struct node **ExportList;) -{ -} : +export(int *QUALflag; struct node **ExportList;): EXPORT [ QUALIFIED @@ -86,7 +86,7 @@ export(int *QUALflag; struct node **ExportList;) import(int local;) { struct node *ImportList; - struct node *FromId = 0; + register struct node *FromId = 0; register struct def *df; extern struct def *GetDefinitionModule(); } : @@ -121,7 +121,7 @@ DefinitionModule if (!Defined) Defined = df; CurrentScope->sc_name = df->df_idf->id_text; df->mod_vis = CurrVis; - df->df_type = standard_type(T_RECORD, 0, (arith) 0); + df->df_type = standard_type(T_RECORD, 1, (arith) 0); df->df_type->rec_scope = df->mod_vis->sc_scope; DefinitionModule++; } @@ -210,12 +210,9 @@ ProgramModule ; Module: - { open_scope(CLOSEDSCOPE); - warning(W_ORDINARY, "Compiling a definition module"); - } - DefinitionModule - { close_scope(SC_CHKFORW); } -| + DEFINITION + { fatal("Compiling a definition module"); } +| %default [ IMPLEMENTATION { state = IMPLEMENTATION; } | diff --git a/lang/m2/comp/scope.C b/lang/m2/comp/scope.C index d2a26c55e..a81557f43 100644 --- a/lang/m2/comp/scope.C +++ b/lang/m2/comp/scope.C @@ -50,7 +50,6 @@ InitScope() register struct scopelist *ls = new_scopelist(); sc->sc_scopeclosed = 0; - sc->sc_forw = 0; sc->sc_def = 0; sc->sc_level = proclevel; PervasiveScope = sc; @@ -61,14 +60,6 @@ InitScope() CurrVis = ls; } -struct forwards { - struct forwards *next; - struct node *fo_tok; - struct type *fo_ptyp; -}; - -/* STATICALLOCDEF "forwards" 5 */ - Forward(tk, ptp) struct node *tk; struct type *ptp; @@ -78,13 +69,10 @@ Forward(tk, ptp) may have forward references that must howewer be declared in the same scope. */ - register struct forwards *f = new_forwards(); - register struct scope *sc = CurrentScope; + register struct def *df = define(tk->nd_IDF, CurrentScope, D_FORWTYPE); - f->fo_tok = tk; - f->fo_ptyp = ptp; - f->next = sc->sc_forw; - sc->sc_forw = f; + df->df_forw_type = ptp; + df->df_forw_node = tk; } STATIC @@ -117,7 +105,15 @@ chk_forw(pdf) register struct def *df; while (df = *pdf) { - if (df->df_kind & (D_FORWARD|D_FORWMODULE)) { + if (df->df_kind == D_FORWTYPE) { +node_error(df->df_forw_node, "type \"%s\" not declared", df->df_idf->id_text); + FreeNode(df->df_forw_node); + } + else if (df->df_kind == D_FTYPE) { + df->df_kind = D_TYPE; + df->df_forw_type->next = df->df_type; + } + else if (df->df_kind & (D_FORWARD|D_FORWMODULE)) { /* These definitions must be found in the enclosing closed scope, which of course may be the scope that is now closed! @@ -126,7 +122,7 @@ chk_forw(pdf) /* Indeed, the scope was a closed scope, so give error message */ -node_error(df->for_node, "identifier \"%s\" has not been declared", +node_error(df->for_node, "identifier \"%s\" not declared", df->df_idf->id_text); FreeNode(df->for_node); } @@ -153,25 +149,6 @@ df->df_idf->id_text); } } -STATIC -rem_forwards(fo) - register struct forwards *fo; -{ - /* When closing a scope, all forward references must be resolved - */ - register struct def *df; - - if (fo->next) rem_forwards(fo->next); - df = lookfor(fo->fo_tok, CurrVis, 0); - if (! is_type(df)) { - node_error(fo->fo_tok, - "identifier \"%s\" does not represent a type", - df->df_idf->id_text); - } - fo->fo_ptyp->next = df->df_type; - free_forwards(fo); -} - Reverse(pdf) struct def **pdf; { @@ -210,7 +187,6 @@ close_scope(flag) assert(sc != 0); if (flag) { - if (sc->sc_forw) rem_forwards(sc->sc_forw); DO_DEBUG(options['S'], PrScopeDef(sc->sc_def)); if (flag & SC_CHKPROC) chk_proc(sc->sc_def); if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def)); diff --git a/lang/m2/comp/scope.h b/lang/m2/comp/scope.h index 770919c1a..8e105b723 100644 --- a/lang/m2/comp/scope.h +++ b/lang/m2/comp/scope.h @@ -15,7 +15,6 @@ struct scope { struct scope *next; - struct forwards *sc_forw; char *sc_name; /* name of this scope */ struct def *sc_def; /* list of definitions in this scope */ arith sc_off; /* offsets of variables in this scope */ diff --git a/lang/m2/comp/tmpvar.C b/lang/m2/comp/tmpvar.C index 7e0cea211..294ef0775 100644 --- a/lang/m2/comp/tmpvar.C +++ b/lang/m2/comp/tmpvar.C @@ -40,6 +40,16 @@ TmpOpen(sc) struct scope *sc; ProcScope = sc; } +arith +TmpSpace(sz, al) + arith sz; +{ + register struct scope *sc = ProcScope; + + sc->sc_off = - WA(align(sz - sc->sc_off, al)); + return sc->sc_off; +} + arith NewInt() { @@ -47,8 +57,7 @@ NewInt() register struct tmpvar *tmp; if (!TmpInts) { - offset = - WA(align(int_size - ProcScope->sc_off, int_align)); - ProcScope->sc_off = offset; + offset = TmpSpace(int_size, int_align); if (! options['n']) C_ms_reg(offset, int_size, reg_any, 0); } else { @@ -67,8 +76,7 @@ NewPtr() register struct tmpvar *tmp; if (!TmpPtrs) { - offset = - WA(align(pointer_size - ProcScope->sc_off, pointer_align)); - ProcScope->sc_off = offset; + offset = TmpSpace(pointer_size, pointer_align); if (! options['n']) C_ms_reg(offset, pointer_size, reg_pointer, 0); } else { diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index d8a345a7c..b22559c3c 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -95,6 +95,7 @@ extern struct type *real_type, *longreal_type, *word_type, + *byte_type, *address_type, *intorcard_type, *bitset_type, diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index e76565805..134cbec6a 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -48,6 +48,7 @@ struct type *real_type, *longreal_type, *word_type, + *byte_type, *address_type, *intorcard_type, *bitset_type, @@ -123,7 +124,7 @@ standard_type(fund, align, size) register struct type *tp = new_type(); tp->tp_fund = fund; - tp->tp_align = align; + tp->tp_align = align ? align : 1; tp->tp_size = size; return tp; @@ -179,6 +180,7 @@ InitTypes() /* SYSTEM types */ word_type = standard_type(T_WORD, word_align, word_size); + byte_type = standard_type(T_WORD, 1, (arith) 1); address_type = construct_type(T_POINTER, word_type); /* create BITSET type @@ -407,11 +409,11 @@ ArrayElSize(tp) if (tp->tp_fund == T_ARRAY) ArraySizes(tp); algn = align(tp->tp_size, tp->tp_align); - if (algn && word_size % algn != 0) { + if (word_size % algn != 0) { /* algn is not a dividor of the word size, so make sure it is a multiple */ - algn = WA(algn); + return WA(algn); } return algn; } @@ -432,13 +434,13 @@ ArraySizes(tp) */ if (! bounded(index_type)) { error("illegal index type"); - tp->tp_size = 0; + tp->tp_size = tp->arr_elsize; return; } getbounds(index_type, &lo, &hi); - tp->tp_size = WA((hi - lo + 1) * tp->arr_elsize); + tp->tp_size = (hi - lo + 1) * tp->arr_elsize; /* generate descriptor and remember label. */ diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 9735e0cb8..ffd5aa42b 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -177,7 +177,7 @@ TstParCompat(formaltype, actualtype, VARflag, nd) /* Check type compatibility for a parameter in a procedure call. Assignment compatibility may do if the parameter is a value parameter. - Otherwise, a conformant array may do, or an ARRAY OF WORD + Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE) may do too. Or: a WORD may do. */ @@ -201,10 +201,15 @@ TstParCompat(formaltype, actualtype, VARflag, nd) ) ) ) + || + ( formaltype == byte_type + && actualtype->tp_size == (arith) 1 + ) || ( IsConformantArray(formaltype) && ( formaltype->arr_elem == word_type + || formaltype->arr_elem == byte_type || ( actualtype->tp_fund == T_ARRAY && TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem) diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index 5eb55204a..e513174bf 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -44,13 +44,15 @@ DoProfil() static label filename_label = 0; if (! options['L']) { - if (!filename_label) { - filename_label = ++data_label; - C_df_dlb(filename_label); + register label fn_label = filename_label; + + if (!fn_label) { + filename_label = fn_label = ++data_label; + C_df_dlb(fn_label); C_rom_scon(FileName, (arith) (strlen(FileName) + 1)); } - C_fil_dlb(filename_label, (arith) 0); + C_fil_dlb(fn_label, (arith) 0); } } @@ -126,7 +128,7 @@ WalkProcedure(procedure) local definitions, checking and generating code. */ struct scopelist *savevis = CurrVis; - register struct scope *sc; + register struct scope *sc = procedure->prc_vis->sc_scope; register struct type *tp; register struct paramlist *param; label func_res_label = 0; @@ -136,7 +138,6 @@ WalkProcedure(procedure) proclevel++; CurrVis = procedure->prc_vis; - sc = CurrentScope; /* Generate code for all local modules and procedures */ @@ -390,7 +391,7 @@ WalkCall(nd) } WalkStat(nd, exit_label) - struct node *nd; + register struct node *nd; label exit_label; { /* Walk through a statement, generating code for it. @@ -468,10 +469,11 @@ WalkStat(nd, exit_label) { arith tmp = 0; register struct node *fnd; + int good_forvar; label l1 = ++text_label; label l2 = ++text_label; - if (! DoForInit(nd, left)) break; + good_forvar = DoForInit(nd, left); fnd = left->nd_right; if (fnd->nd_class != Value) { /* Upperbound not constant. @@ -489,15 +491,19 @@ WalkStat(nd, exit_label) C_bgt(l2); } else C_blt(l2); - RangeCheck(nd->nd_type, int_type); - CodeDStore(nd); + if (good_forvar) { + RangeCheck(nd->nd_type, int_type); + CodeDStore(nd); + } WalkNode(right, exit_label); - CodePExpr(nd); - C_loc(left->nd_INT); - C_adi(int_size); - C_bra(l1); - C_df_ilb(l2); - C_asp(int_size); + if (good_forvar) { + CodePExpr(nd); + C_loc(left->nd_INT); + C_adi(int_size); + C_bra(l1); + C_df_ilb(l2); + C_asp(int_size); + } if (tmp) FreeInt(tmp); } break; @@ -545,14 +551,23 @@ WalkStat(nd, exit_label) case RETURN: if (right) { - if (! WalkExpr(right)) break; + if (! ChkExpression(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"); + break; } + if (right->nd_type->tp_fund == T_STRING) { + arith strsize = WA(right->nd_type->tp_size); + + C_zer(WA(func_type->tp_size) - strsize); + CodePExpr(right); + C_loi(strsize); + } + else CodePExpr(right); } C_bra(RETURN_LABEL); break; @@ -644,12 +659,12 @@ DoForInit(nd, left) if (df->df_kind == D_FIELD) { node_error(nd, "FOR-loop variable may not be a field of a record"); - return 0; + return 1; } if (!df->var_name && df->var_off >= 0) { node_error(nd, "FOR-loop variable may not be a parameter"); - return 0; + return 1; } if (df->df_scope != CurrentScope) { @@ -659,7 +674,7 @@ DoForInit(nd, left) if (!sc) { node_error(nd, "FOR-loop variable may not be imported"); - return 0; + return 1; } if (sc->sc_scope == df->df_scope) break; sc = nextvisible(sc); @@ -669,7 +684,7 @@ DoForInit(nd, left) if (df->df_type->tp_size > word_size || !(df->df_type->tp_fund & T_DISCRETE)) { node_error(nd, "illegal type of FOR loop variable"); - return 0; + return 1; } if (!TstCompat(df->df_type, left->nd_left->nd_type) || @@ -677,7 +692,7 @@ DoForInit(nd, left) if (!TstAssCompat(df->df_type, left->nd_left->nd_type) || !TstAssCompat(df->df_type, left->nd_right->nd_type)) { node_error(nd, "type incompatibility in FOR statement"); - return 0; + return 1; } node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement"); } @@ -695,29 +710,48 @@ DoAssign(nd, left, right) DAMN THE BOOK! */ struct desig dsl, dsr; + register struct type *rtp, *ltp; if (! (ChkExpression(right) & ChkVariable(left))) return; + rtp = right->nd_type; + ltp = left->nd_type; - if (right->nd_symb == STRING) TryToString(right, left->nd_type); + if (right->nd_symb == STRING) TryToString(right, ltp); dsr = InitDesig; - if (! TstAssCompat(left->nd_type, right->nd_type)) { + if (! TstAssCompat(ltp, rtp)) { node_error(nd, "type incompatibility in assignment"); return; } CodeExpr(right, &dsr, NO_LABEL, NO_LABEL); - if (complex(right->nd_type)) { - CodeAddress(&dsr); - } + if (complex(rtp)) CodeAddress(&dsr); else { - CodeValue(&dsr, right->nd_type->tp_size); - RangeCheck(left->nd_type, right->nd_type); + CodeValue(&dsr, rtp->tp_size); + RangeCheck(ltp, rtp); + CodeCoercion(rtp, ltp); } dsl = InitDesig; CodeDesig(left, &dsl); - CodeAssign(nd, &dsr, &dsl); + /* Generate code for an assignment. Testing of type + compatibility and the like is already done. + */ + + if (dsr.dsg_kind == DSG_LOADED) { + if (rtp->tp_fund == T_STRING) { + CodeAddress(&dsl); + C_loc(rtp->tp_size); + C_loc(ltp->tp_size); + C_cal("_StringAssign"); + C_asp((int_size << 1) + (pointer_size << 1)); + return; + } + CodeStore(&dsl, ltp->tp_size); + return; + } + CodeAddress(&dsl); + C_blm(ltp->tp_size); } RegisterMessages(df)