diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index eced01075..c8107c2ab 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -19,6 +19,7 @@ #include #include +#include "LLlex.h" #include "input.h" #include "f_info.h" #include "Lpars.h" @@ -26,7 +27,6 @@ #include "idf.h" #include "def.h" #include "type.h" -#include "LLlex.h" #include "const.h" #include "warning.h" @@ -278,6 +278,8 @@ again: else if (nch == EOI) eofseen = 1; else PushBack(); } + if (ch == '&') return tk->tk_symb = AND; + if (ch == '~') return tk->tk_symb = NOT; return tk->tk_symb = ch; case STCOMP: @@ -301,7 +303,6 @@ again: return tk->tk_symb = LESSEQUAL; } if (nch == '>') { - lexwarning(W_STRICT, "'<>' is old-fashioned; use '#'"); return tk->tk_symb = '#'; } break; diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index 13df19bf3..e739f717f 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -40,14 +40,14 @@ OBJ = $(COBJ) $(LOBJ) Lpars.o GENH= errout.h\ idfsize.h numsize.h strsize.h target_sizes.h \ inputtype.h maxset.h density.h\ - def.h debugcst.h type.h Lpars.h node.h + def.h debugcst.h type.h Lpars.h node.h desig.h HFILES= LLlex.h\ - chk_expr.h class.h const.h debug.h desig.h f_info.h idf.h\ + chk_expr.h class.h const.h debug.h f_info.h idf.h\ input.h main.h misc.h scope.h standards.h tokenname.h\ walk.h warning.h SYSTEM.h $(GENH) # GENFILES = $(GENGFILES) $(GENC) $(GENH) -NEXTFILES = def.H type.H node.H scope.C tmpvar.C casestat.C +NEXTFILES = def.H type.H node.H desig.H scope.C tmpvar.C casestat.C #EXCLEXCLEXCLEXCL @@ -113,6 +113,7 @@ symbol2str.c: tokenname.c make.tokcase def.h: make.allocd type.h: make.allocd node.h: make.allocd +desig.h: make.allocd scope.c: make.allocd tmpvar.c: make.allocd casestat.c: make.allocd diff --git a/lang/m2/comp/casestat.C b/lang/m2/comp/casestat.C index d57fe3223..d3a36a489 100644 --- a/lang/m2/comp/casestat.C +++ b/lang/m2/comp/casestat.C @@ -30,6 +30,7 @@ #include "node.h" #include "desig.h" #include "walk.h" +#include "chk_expr.h" #include "density.h" @@ -81,14 +82,16 @@ CaseCode(nd, exitlabel) assert(pnode->nd_class == Stat && pnode->nd_symb == CASE); - WalkExpr(pnode->nd_left); /* evaluate case expression */ + if (ChkExpression(pnode->nd_left)) { + MkCoercion(&(pnode->nd_left),BaseType(pnode->nd_left->nd_type)); + CodePExpr(pnode->nd_left); + } sh->sh_type = pnode->nd_left->nd_type; sh->sh_break = ++text_label; /* Now, create case label list */ - while (pnode->nd_right) { - pnode = pnode->nd_right; + while (pnode = pnode->nd_right) { if (pnode->nd_class == Link && pnode->nd_symb == '|') { if (pnode->nd_left) { /* non-empty case @@ -168,8 +171,7 @@ CaseCode(nd, exitlabel) /* Now generate code for the cases */ pnode = nd; - while (pnode->nd_right) { - pnode = pnode->nd_right; + while (pnode = pnode->nd_right) { if (pnode->nd_class == Link && pnode->nd_symb == '|') { if (pnode->nd_left) { C_df_ilb(pnode->nd_lab); @@ -252,8 +254,7 @@ AddOneCase(sh, node, lbl) ce->ce_label = lbl; ce->ce_value = node->nd_INT; - if (! TstCompat(sh->sh_type, node->nd_type)) { - node_error(node, "type incompatibility in case"); + if (! ChkCompat(&node, sh->sh_type, "case")) { free_case_entry(ce); return 0; } diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 0f4787243..bdaf1b146 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -22,8 +22,8 @@ #include "Lpars.h" #include "idf.h" #include "type.h" -#include "def.h" #include "LLlex.h" +#include "def.h" #include "node.h" #include "scope.h" #include "const.h" @@ -35,7 +35,7 @@ extern char *symbol2str(); extern char *sprint(); -STATIC +STATIC int Xerror(nd, mess, edf) struct node *nd; char *mess; @@ -45,9 +45,86 @@ Xerror(nd, mess, edf) if (edf->df_kind != D_ERROR) { node_error(nd,"\"%s\": %s", edf->df_idf->id_text, mess); } - return; } - node_error(nd, "%s", mess); + else node_error(nd, "%s", mess); + return 0; +} + +MkCoercion(pnd, tp) + struct node **pnd; + register struct type *tp; +{ + register struct node *nd = *pnd; + register struct type *nd_tp = nd->nd_type; + extern int pass_1; + int w = 0; + + if (nd_tp == tp) return; + if (nd_tp->tp_fund == T_STRING) return; + nd_tp = BaseType(nd_tp); + if (nd->nd_class == Value) { + switch(tp->tp_fund) { + case T_REAL: + if (nd_tp->tp_fund == T_REAL) { + break; + } + goto Out; + case T_SUBRANGE: + if (! chk_bounds(tp->sub_lb, nd->nd_INT, + BaseType(tp)->tp_fund) || + ! chk_bounds(nd->nd_INT, tp->sub_ub, + BaseType(tp)->tp_fund)) { + node_warning(nd, + W_ORDINARY, + "might cause range bound error"); + w = 1; + } + break; + case T_ENUMERATION: + case T_CHAR: + if (nd->nd_INT < 0 || nd->nd_INT >= tp->enm_ncst) { + node_warning(nd, + W_ORDINARY, + "might cause range bound error"); + w = 1; + } + break; + case T_INTORCARD: + case T_CARDINAL: + case T_POINTER: + if ((nd_tp->tp_fund == T_INTEGER && + nd->nd_INT < 0) || + (nd->nd_INT & ~full_mask[(int)(tp->tp_size)])) { + node_warning(nd, + W_ORDINARY, + "might cause conversion error"); + w = 1; + } + break; + case T_INTEGER: { + long i = ~int_mask[(int)(tp->tp_size)]; + long j = nd->nd_INT & i; + + if ((nd_tp->tp_fund == T_INTEGER && + j != i && j != 0) || + (nd_tp->tp_fund != T_INTEGER && j)) { + node_warning(nd, + W_ORDINARY, + "might cause conversion error"); + w = 1; + } + } + break; + } + if (!w || pass_1) { + nd->nd_type = tp; + return; + } + } +Out: + *pnd = nd = MkNode(Uoper, NULLNODE, nd, &(nd->nd_token)); + nd->nd_symb = COERCION; + nd->nd_type = tp; } int @@ -58,15 +135,10 @@ ChkVariable(expp) assigned to. */ - if (! ChkDesignator(expp)) return 0; - - if ((expp->nd_class == Def || expp->nd_class == LinkDef) && - !(expp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) { - Xerror(expp, "variable expected", expp->nd_def); - return 0; - } - - return 1; + return ChkDesignator(expp) && + ( expp->nd_class != Def || + ( expp->nd_def->df_kind & (D_FIELD|D_VARIABLE)) || + Xerror(expp, "variable expected", expp->nd_def)); } STATIC int @@ -106,37 +178,33 @@ ChkArr(expp) assignment compatible with the array-index. */ - register struct type *tpl, *tpr; - int retval; + register struct type *tpl; assert(expp->nd_class == Arrsel); assert(expp->nd_symb == '['); expp->nd_type = error_type; - retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right); + if (! (ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right))) { + return 0; + } tpl = expp->nd_left->nd_type; - tpr = expp->nd_right->nd_type; - if (tpl == error_type || tpr == error_type) return 0; if (tpl->tp_fund != T_ARRAY) { node_error(expp, "not indexing an ARRAY type"); return 0; } + expp->nd_type = RemoveEqual(tpl->arr_elem); /* Type of the index must be assignment compatible with the index type of the array (Def 8.1). However, the index type of a conformant array is not specified. In our implementation it is CARDINAL. */ - if (!TstAssCompat(IndexType(tpl), tpr)) { - node_error(expp, "incompatible index type"); - return 0; - } - - expp->nd_type = RemoveEqual(tpl->arr_elem); - return retval; + return ChkAssCompat(&(expp->nd_right), + BaseType(IndexType(tpl)), + "index type"); } #ifdef DEBUG @@ -183,13 +251,12 @@ ChkLinkOrName(expp) if (! ChkDesignator(left)) return 0; - if ((left->nd_class==Def || left->nd_class==LinkDef) && + if (left->nd_class==Def && (left->nd_type->tp_fund != T_RECORD || !(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD)) ) ) { - Xerror(left, "illegal selection", left->nd_def); - return 0; + return Xerror(left, "illegal selection", left->nd_def); } if (left->nd_type->tp_fund != T_RECORD) { node_error(left, "illegal selection"); @@ -200,25 +267,22 @@ ChkLinkOrName(expp) id_not_declared(expp); return 0; } - else { - expp->nd_def = df; - expp->nd_type = RemoveEqual(df->df_type); - expp->nd_class = LinkDef; - if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) { - /* Fields of a record are always D_QEXPORTED, - so ... - */ + expp->nd_def = df; + expp->nd_type = RemoveEqual(df->df_type); + expp->nd_class = Def; + if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) { + /* Fields of a record are always D_QEXPORTED, + so ... + */ Xerror(expp, "not exported from qualifying module", df); - } } - if ((left->nd_class == Def || left->nd_class == LinkDef) && - left->nd_def->df_kind == D_MODULE) { - expp->nd_class = Def; - FreeNode(left); - expp->nd_left = 0; + if (!(left->nd_class == Def && + left->nd_def->df_kind == D_MODULE)) { + return 1; } - else return 1; + FreeNode(left); + expp->nd_left = 0; } assert(expp->nd_class == Def); @@ -242,8 +306,11 @@ ChkExLinkOrName(expp) if (df->df_kind & (D_ENUM | D_CONST)) { /* Replace an enum-literal or a CONST identifier by its value. */ + if (df->df_type->tp_fund == T_SET) { + expp->nd_class = Set; + } + else expp->nd_class = Value; if (df->df_kind == D_ENUM) { - expp->nd_class = Value; expp->nd_INT = df->enm_val; expp->nd_symb = INTEGER; } @@ -251,7 +318,7 @@ ChkExLinkOrName(expp) unsigned int ln = expp->nd_lineno; assert(df->df_kind == D_CONST); - *expp = *(df->con_const); + expp->nd_token = df->con_const; expp->nd_lineno = ln; } } @@ -278,32 +345,24 @@ node_error(expp, "standard or local procedures may not be assigned"); STATIC int ChkEl(expr, tp) - register struct node *expr; + register struct node **expr; struct type *tp; { - if (!ChkExpression(expr)) return 0; - if (!TstCompat(tp, expr->nd_type)) { - node_error(expr, "set element has incompatible type"); - return 0; - } - - return 1; + return ChkExpression(*expr) && ChkCompat(expr, tp, "set element"); } STATIC int ChkElement(expp, tp, set) struct node **expp; struct type *tp; - arith **set; + arith *set; { /* Check elements of a set. This routine may call itself recursively. Also try to compute the set! */ register struct node *expr = *expp; - register struct node *left = expr->nd_left; - register struct node *right = expr->nd_right; register unsigned int i; arith lo, hi, low, high; @@ -311,22 +370,25 @@ ChkElement(expp, tp, set) /* { ... , expr1 .. expr2, ... } First check expr1 and expr2, and try to compute them. */ - if (! (ChkEl(left, tp) & ChkEl(right, tp))) { + if (! (ChkEl(&(expr->nd_left), tp) & + ChkEl(&(expr->nd_right), tp))) { return 0; } - if (!(left->nd_class == Value && right->nd_class == Value)) { + if (!(expr->nd_left->nd_class == Value && + expr->nd_right->nd_class == Value)) { return 1; } /* We have a constant range. Put all elements in the set */ - low = left->nd_INT; - high = right->nd_INT; + low = expr->nd_left->nd_INT; + high = expr->nd_right->nd_INT; } else { - if (! ChkEl(expr, tp)) return 0; + if (! ChkEl(expp, tp)) return 0; + expr = *expp; if (expr->nd_class != Value) { return 1; } @@ -344,7 +406,7 @@ ChkElement(expp, tp, set) } for (i=(unsigned)low; i<= (unsigned)high; i++) { - (*set)[i/wrd_bits] |= (1<<(i%wrd_bits)); + set[i/wrd_bits] |= (1<<(i%wrd_bits)); } FreeNode(expr); *expp = 0; @@ -374,7 +436,7 @@ ChkSet(expp) /* A type was given. Check it out */ if (! ChkDesignator(nd)) return 0; - assert(nd->nd_class == Def || nd->nd_class == LinkDef); + assert(nd->nd_class == Def); df = nd->nd_def; if (!is_type(df) || @@ -406,7 +468,7 @@ ChkSet(expp) assert(nd->nd_class == Link && nd->nd_symb == ','); if (!ChkElement(&(nd->nd_left), ElementType(tp), - &(expp->nd_set))) { + expp->nd_set)) { retval = 0; } if (nd->nd_left) expp->nd_class = Xset; @@ -420,6 +482,21 @@ ChkSet(expp) return retval; } +STATIC struct node * +nextarg(argp, edf) + struct node **argp; + struct def *edf; +{ + register struct node *arg = (*argp)->nd_right; + + if (! arg) { + return (struct node *)Xerror(*argp, "too few arguments supplied", edf); + } + + *argp = arg; + return arg->nd_left; +} + STATIC struct node * getarg(argp, bases, designator, edf) struct node **argp; @@ -433,29 +510,23 @@ getarg(argp, bases, designator, edf) that it must be a designator and may not be a register variable. */ - register struct node *arg = (*argp)->nd_right; - register struct node *left; + register struct node *left = nextarg(argp, edf); - if (! arg) { - Xerror(*argp, "too few arguments supplied", edf); + if (!left || (designator ? !ChkVariable(left) : !ChkExpression(left))) { return 0; } - left = arg->nd_left; - *argp = arg; - - if (designator ? !ChkVariable(left) : !ChkExpression(left)) { - return 0; - } - - if (designator && (left->nd_class==Def || left->nd_class==LinkDef)) { + if (designator && left->nd_class==Def) { left->nd_def->df_flags |= D_NOREG; } if (bases) { - if (!(BaseType(left->nd_type)->tp_fund & bases)) { - Xerror(arg, "unexpected parameter type", edf); - return 0; + struct type *tp = BaseType(left->nd_type); + + MkCoercion(&((*argp)->nd_left), tp); + left = (*argp)->nd_left; + if (!(tp->tp_fund & bases)) { + return (struct node *)Xerror(left, "unexpected parameter type", edf); } } @@ -471,35 +542,17 @@ getname(argp, kinds, bases, edf) The argument must indicate a definition, and the definition kind must be one of "kinds". */ - register struct node *arg = *argp; - register struct node *left; + register struct node *left = nextarg(argp, edf); - *argp = arg->nd_right; + if (!left || ! ChkDesignator(left)) return 0; - if (!arg->nd_right) { - Xerror(arg, "too few arguments supplied", edf); - return 0; + if (left->nd_class != Def) { + return (struct node *)Xerror(left, "identifier expected", edf); } - arg = arg->nd_right; - left = arg->nd_left; - if (! ChkDesignator(left)) return 0; - - if (left->nd_class != Def && left->nd_class != LinkDef) { - Xerror(arg, "identifier expected", edf); - return 0; - } - - if (!(left->nd_def->df_kind & kinds)) { - Xerror(arg, "unexpected parameter type", edf); - return 0; - } - - if (bases) { - if (!(left->nd_type->tp_fund & bases)) { - Xerror(arg, "unexpected parameter type", edf); - return 0; - } + if (!(left->nd_def->df_kind & kinds) || + (bases && !(left->nd_type->tp_fund & bases))) { + return (struct node *)Xerror(left, "unexpected parameter type", edf); } return left; @@ -514,12 +567,11 @@ ChkProcCall(expp) register struct node *left; struct def *edf = 0; register struct paramlist *param; - char ebuf[256]; int retval = 1; int cnt = 0; left = expp->nd_left; - if (left->nd_class == Def || left->nd_class == LinkDef) { + if (left->nd_class == Def) { edf = left->nd_def; } if (left->nd_type == error_type) { @@ -544,13 +596,11 @@ ChkProcCall(expp) if (left->nd_symb == STRING) { TryToString(left, TypeOfParam(param)); } - if (! TstParCompat(RemoveEqual(TypeOfParam(param)), - left->nd_type, + if (! TstParCompat(cnt, + RemoveEqual(TypeOfParam(param)), IsVarParam(param), - left)) { - sprint(ebuf, "type incompatibility in parameter %d", - cnt); - Xerror(left, ebuf, edf); + &(expp->nd_left), + edf)) { retval = 0; } } @@ -591,19 +641,18 @@ ChkCall(expp) Of course this does not have to be a call at all, it may also be a cast or a standard procedure call. */ - register struct node *left; + register struct node *left = expp->nd_left; STATIC int ChkStandard(); STATIC int ChkCast(); /* First, get the name of the function or procedure */ expp->nd_type = error_type; - left = expp->nd_left; if (ChkDesignator(left)) { if (IsCast(left)) { /* It was a type cast. */ - return ChkCast(expp, left); + return ChkCast(expp); } if (IsProcCall(left) || left->nd_type == error_type) { @@ -613,7 +662,7 @@ ChkCall(expp) if (left->nd_type == std_type) { /* A standard procedure */ - return ChkStandard(expp, left); + return ChkStandard(expp); } /* Here, we have found a real procedure call. The left hand side may also represent a procedure @@ -650,7 +699,7 @@ ResultOfOperation(operator, tp) STATIC int Boolean(operator) { - return operator == OR || operator == AND || operator == '&'; + return operator == OR || operator == AND; } STATIC int @@ -672,7 +721,6 @@ AllowedTypes(operator) return T_INTORCARD; case OR: case AND: - case '&': return T_ENUMERATION; case '=': case '#': @@ -756,15 +804,16 @@ ChkBinOper(expp) node_error(expp, "\"IN\": right operand must be a set"); return 0; } - if (!TstAssCompat(tpl, ElementType(tpr))) { + if (!TstAssCompat(ElementType(tpr), tpl)) { /* Assignment compatible ??? I don't know! Should we be allowed to check if a INTEGER is a member of a BITSET??? */ - - node_error(expp, "\"IN\": incompatible types"); + node_error(left, "type incompatibility in IN"); return 0; } + MkCoercion(&(expp->nd_left), word_type); + left = expp->nd_left; if (left->nd_class == Value && right->nd_class == Set) { cstset(expp); } @@ -795,11 +844,15 @@ ChkBinOper(expp) /* Operands must be compatible (distilled from Def 8.2) */ - if (!TstCompat(tpl, tpr)) { - node_error(expp, "\"%s\": incompatible types", symbol2str(expp->nd_symb)); + if (!TstCompat(tpr, tpl)) { + node_error(expp,"\"%s\": incompatible types", + symbol2str(expp->nd_symb)); return 0; } + MkCoercion(&(expp->nd_left), tpl); + MkCoercion(&(expp->nd_right), tpr); + if (tpl->tp_fund == T_SET) { if (left->nd_class == Set && right->nd_class == Set) { cstset(expp); @@ -823,8 +876,10 @@ ChkUnOper(expp) register struct type *tpr; if (! ChkExpression(right)) return 0; - expp->nd_type = tpr = BaseType(right->nd_type); + MkCoercion(&(expp->nd_right), tpr); + right = expp->nd_right; + if (tpr == address_type) tpr = card_type; switch(expp->nd_symb) { @@ -862,7 +917,6 @@ ChkUnOper(expp) break; case NOT: - case '~': if (tpr == bool_type) { if (right->nd_class == Value) { cstunary(expp); @@ -886,38 +940,31 @@ getvariable(argp, edf) /* Get the next argument from argument list "argp". It must obey the rules of "ChkVariable". */ - register struct node *arg = *argp; + register struct node *left = nextarg(argp, edf); - arg = arg->nd_right; - if (!arg) { - Xerror(arg, "too few parameters supplied", edf); - return 0; - } + if (!left || !ChkVariable(left)) return 0; - *argp = arg; - arg = arg->nd_left; - if (! ChkVariable(arg)) return 0; - - return arg; + return left; } STATIC int -ChkStandard(expp, left) - register struct node *expp, *left; +ChkStandard(expp) + register struct node *expp; { /* Check a call of a standard procedure or function */ struct node *arg = expp; - register struct def *edf; - int std; + register struct node *left = expp->nd_left; + register struct def *edf = left->nd_def; + int free_it = 0; - assert(left->nd_class == Def || left->nd_class == LinkDef); - edf = left->nd_def; - std = edf->df_value.df_stdname; + assert(left->nd_class == Def); - switch(std) { + switch(edf->df_value.df_stdname) { case S_ABS: if (!(left = getarg(&arg, T_NUMERIC, 0, edf))) return 0; + MkCoercion(&(arg->nd_left), BaseType(left->nd_type)); + left = arg->nd_left; expp->nd_type = left->nd_type; if (left->nd_class == Value && expp->nd_type->tp_fund != T_REAL) { @@ -934,47 +981,57 @@ ChkStandard(expp, left) case S_CHR: expp->nd_type = char_type; if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; - if (left->nd_class == Value) cstcall(expp, S_CHR); + MkCoercion(&(arg->nd_left), char_type); + free_it = 1; break; case S_FLOATD: case S_FLOAT: - expp->nd_type = real_type; - if (std == S_FLOATD) expp->nd_type = longreal_type; - if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; + if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0; + if (edf->df_value.df_stdname == S_FLOAT) { + MkCoercion(&(arg->nd_left), card_type); + } + MkCoercion(&(arg->nd_left), + edf->df_value.df_stdname == S_FLOATD ? + longreal_type : + real_type); + free_it = 1; break; + case S_SHORT: case S_LONG: { struct type *tp; + struct type *s1, *s2, *d1, *d2; + + if (edf->df_value.df_stdname == S_SHORT) { + s1 = longint_type; + d1 = int_type; + s2 = longreal_type; + d2 = real_type; + } + else { + d1 = longint_type; + s1 = int_type; + d2 = longreal_type; + s2 = real_type; + } if (!(left = getarg(&arg, 0, 0, edf))) { return 0; } tp = BaseType(left->nd_type); - if (tp == int_type) expp->nd_type = longint_type; - else if (tp == real_type) expp->nd_type = longreal_type; + if (tp == s1) { + MkCoercion(&(arg->nd_left), d1); + } + else if (tp == s2) { + MkCoercion(&(arg->nd_left), d2); + } else { expp->nd_type = error_type; Xerror(left, "unexpected parameter type", edf); + break; } - if (left->nd_class == Value) cstcall(expp, S_LONG); - break; - } - - case S_SHORT: { - struct type *tp; - - if (!(left = getarg(&arg, 0, 0, edf))) { - return 0; - } - tp = BaseType(left->nd_type); - if (tp == longint_type) expp->nd_type = int_type; - else if (tp == longreal_type) expp->nd_type = real_type; - else { - expp->nd_type = error_type; - Xerror(left, "unexpected parameter type", edf); - } - if (left->nd_class == Value) cstcall(expp, S_SHORT); + free_it = 1; break; } @@ -990,8 +1047,7 @@ ChkStandard(expp, left) break; } if (left->nd_symb != STRING) { - Xerror(left,"array parameter expected", edf); - return 0; + return Xerror(left,"array parameter expected", edf); } expp->nd_type = card_type; expp->nd_class = Value; @@ -1011,19 +1067,20 @@ ChkStandard(expp, left) return 0; } expp->nd_type = left->nd_type; - cstcall(expp,std); + cstcall(expp,edf->df_value.df_stdname); break; case S_ODD: - if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; + if (! (left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; + MkCoercion(&(arg->nd_left), BaseType(left->nd_type)); expp->nd_type = bool_type; - if (left->nd_class == Value) cstcall(expp, S_ODD); + if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD); break; case S_ORD: - if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0; - expp->nd_type = card_type; - if (left->nd_class == Value) cstcall(expp, S_ORD); + if (! getarg(&arg, T_DISCRETE, 0, edf)) return 0; + MkCoercion(&(arg->nd_left), card_type); + free_it = 1; break; case S_NEW: @@ -1038,8 +1095,7 @@ ChkStandard(expp, left) } if (! (left = getvariable(&arg, edf))) return 0; if (! (left->nd_type->tp_fund == T_POINTER)) { - Xerror(left, "pointer variable expected", edf); - return 0; + return Xerror(left, "pointer variable expected", edf); } /* Now, make it look like a call to ALLOCATE or DEALLOCATE */ { @@ -1058,7 +1114,7 @@ ChkStandard(expp, left) FreeNode(expp->nd_left); dt.tk_symb = IDENT; dt.tk_lineno = expp->nd_left->nd_lineno; - dt.TOK_IDF = str2idf(std == S_NEW ? + dt.TOK_IDF = str2idf(edf->df_value.df_stdname==S_NEW ? "ALLOCATE" : "DEALLOCATE", 0); expp->nd_left = MkLeaf(Name, &dt); } @@ -1080,8 +1136,12 @@ ChkStandard(expp, left) case S_TRUNCD: case S_TRUNC: expp->nd_type = card_type; - if (std == S_TRUNCD) expp->nd_type = longint_type; - if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0; + if (edf->df_value.df_stdname == S_TRUNCD) { + expp->nd_type = longint_type; + } + if (! getarg(&arg, T_REAL, 0, edf)) return 0; + MkCoercion(&(arg->nd_left), expp->nd_type); + free_it = 1; break; case S_VAL: @@ -1094,12 +1154,13 @@ ChkStandard(expp, left) FreeNode(arg); arg = expp; if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; - if (left->nd_class == Value) cstcall(expp, S_VAL); + MkCoercion(&(arg->nd_left), expp->nd_type); + free_it = 1; break; case S_ADR: expp->nd_type = address_type; - if (!(left = getarg(&arg, 0, 1, edf))) return 0; + if (! getarg(&arg, 0, 1, edf)) return 0; break; case S_DEC: @@ -1107,8 +1168,7 @@ ChkStandard(expp, left) expp->nd_type = 0; if (! (left = getvariable(&arg, edf))) return 0; if (! (left->nd_type->tp_fund & T_DISCRETE)) { - Xerror(left,"illegal parameter type", edf); - return 0; + return Xerror(left,"illegal parameter type", edf); } if (arg->nd_right) { if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0; @@ -1122,23 +1182,26 @@ ChkStandard(expp, left) case S_EXCL: case S_INCL: { - struct type *tp; + register struct type *tp; + struct node *dummy; expp->nd_type = 0; if (!(left = getvariable(&arg, edf))) return 0; tp = left->nd_type; if (tp->tp_fund != T_SET) { - Xerror(arg, "SET parameter expected", edf); - return 0; + return Xerror(arg, "SET parameter expected", edf); } - if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0; - if (!TstAssCompat(ElementType(tp), left->nd_type)) { + if (!(dummy = getarg(&arg, 0, 0, edf))) return 0; + if (!ChkAssCompat(&dummy, ElementType(tp), "EXCL/INCL")) { /* What type of compatibility do we want here? apparently assignment compatibility! ??? ??? + But we don't want the coercion in the tree, because + we don't want a range check here. We want a SET + error. */ - Xerror(arg, "unexpected parameter type", edf); return 0; } + MkCoercion(&(arg->nd_left), word_type); break; } @@ -1147,16 +1210,22 @@ ChkStandard(expp, left) } if (arg->nd_right) { - Xerror(arg->nd_right, "too many parameters supplied", edf); - return 0; + return Xerror(arg->nd_right, "too many parameters supplied", edf); + } + + if (free_it) { + FreeNode(expp->nd_left); + *expp = *(arg->nd_left); + arg->nd_left = 0; + FreeNode(arg); } return 1; } STATIC int -ChkCast(expp, left) - register struct node *expp, *left; +ChkCast(expp) + register struct node *expp; { /* Check a cast and perform it if the argument is constant. If the sizes don't match, only complain if at least one of them @@ -1165,17 +1234,19 @@ ChkCast(expp, left) is no problem as such values take a word on the EM stack anyway. */ - register struct type *lefttype = left->nd_type; + register struct node *left = expp->nd_left; register struct node *arg = expp->nd_right; + register struct type *lefttype = left->nd_type; if ((! arg) || arg->nd_right) { - Xerror(expp, "too many parameters in type cast", left->nd_def); - return 0; + return Xerror(expp, "type cast must have 1 parameter", left->nd_def); } - arg = arg->nd_left; - if (! ChkExpression(arg)) return 0; + if (! ChkExpression(arg->nd_left)) return 0; + MkCoercion(&(arg->nd_left), BaseType(arg->nd_left->nd_type)); + + arg = arg->nd_left; if (arg->nd_type->tp_size != lefttype->tp_size && (arg->nd_type->tp_size > word_size || lefttype->tp_size > word_size)) { @@ -1186,11 +1257,9 @@ ChkCast(expp, left) FreeNode(left); expp->nd_right->nd_left = 0; FreeNode(expp->nd_right); - expp->nd_left = expp->nd_right = 0; *expp = *arg; - expp->nd_type = lefttype; } - else expp->nd_type = lefttype; + expp->nd_type = lefttype; return 1; } @@ -1201,17 +1270,16 @@ TryToString(nd, tp) { /* Try a coercion from character constant to string. */ + static char buf[2]; assert(nd->nd_symb == STRING); if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) { - int ch = nd->nd_INT; - + buf[0] = nd->nd_INT; nd->nd_type = standard_type(T_STRING, 1, (arith) 2); nd->nd_token.tk_data.tk_str = (struct string *) Malloc(sizeof(struct string)); - nd->nd_STR = Salloc("X", 2); - *(nd->nd_STR) = ch; + nd->nd_STR = Salloc(buf, 2); nd->nd_SLE = 1; } } diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index 0e189f261..5a06852cb 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -19,12 +19,13 @@ #include #include #include +#include #include "type.h" +#include "LLlex.h" #include "def.h" #include "scope.h" #include "desig.h" -#include "LLlex.h" #include "node.h" #include "Lpars.h" #include "standards.h" @@ -90,7 +91,6 @@ CodeExpr(nd, ds, true_label, false_label) /* Fall through */ case Link: - case LinkDef: case Arrsel: case Arrow: CodeDesig(nd, ds); @@ -263,10 +263,21 @@ CodeCoercion(t1, t2) C_cfi(); break; case T_CARDINAL: + { + label lb = ++text_label; + + C_dup(t1->tp_size); + C_zrf(t1->tp_size); + C_cmf(t1->tp_size); + C_zge(lb); + C_loc((arith) ECONV); + C_trp(); + C_df_ilb(lb); C_loc(t1->tp_size); C_loc(t2->tp_size); C_cfu(); break; + } default: crash("Funny REAL conversion"); } @@ -400,7 +411,6 @@ CodeParameters(param, arg) case Arrsel: case Arrow: case Def: - case LinkDef: CodeDAddress(left); break; default:{ @@ -425,14 +435,6 @@ CodeParameters(param, arg) return; } CodePExpr(left); - CodeCheckExpr(left_type, tp); -} - -CodeCheckExpr(tp1, tp2) - struct type *tp1, *tp2; -{ - CodeCoercion(tp1, tp2); - RangeCheck(tp2, tp1); } CodePString(nd, tp) @@ -486,11 +488,6 @@ CodeStd(nd) C_and(word_size); break; - case S_CHR: - CodePExpr(left); - RangeCheck(char_type, tp); - break; - case S_HIGH: assert(IsConformantArray(tp)); DoHIGH(left->nd_def); @@ -519,52 +516,15 @@ CodeStd(nd) } break; - case S_ORD: - CodePExpr(left); - break; - - case S_FLOAT: - CodePExpr(left); - RangeCheck(card_type, left->nd_type); - CodeCoercion(tp, nd->nd_type); - break; - - case S_TRUNC: { - label lb = ++text_label; - - CodePExpr(left); - C_dup(tp->tp_size); - C_zrf(tp->tp_size); - C_cmf(tp->tp_size); - C_zge(lb); - C_loc((arith) ECONV); - C_trp(); - C_df_ilb(lb); - CodeCoercion(tp, nd->nd_type); - } - break; - - case S_TRUNCD: - case S_FLOATD: - case S_LONG: - case S_SHORT: - CodePExpr(left); - CodeCoercion(tp, nd->nd_type); - break; - - case S_VAL: - CodePExpr(left); - RangeCheck(nd->nd_type, tp); - break; - case S_ADR: CodeDAddress(left); break; case S_DEC: case S_INC: { - register arith size = tp->tp_size; + register arith size; + size = left->nd_type->tp_size; if (size < word_size) size = word_size; CodePExpr(left); if (arg) { @@ -584,7 +544,7 @@ CodeStd(nd) else C_adu(size); } if (size == word_size) { - RangeCheck(tp, tp->tp_fund == T_INTEGER ? + RangeCheck(left->nd_type, tp->tp_fund == T_INTEGER ? int_type : card_type); } CodeDStore(left); @@ -628,24 +588,24 @@ RangeCheck(tpl, tpr) if (!bounded(tpr)) { /* yes, we need one */ genrck(tpl); + return; } - else { - /* both types are restricted. check the bounds - to see wether we need a range check. - We don't need one if the range of values of the - right hand side is a subset of the range of values - of the left hand side. - */ - getbounds(tpl, &llo, &lhi); - getbounds(tpr, &rlo, &rhi); - if (llo > rlo || lhi < rhi) { - genrck(tpl); - } + /* both types are restricted. check the bounds + to see wether we need a range check. + We don't need one if the range of values of the + right hand side is a subset of the range of values + of the left hand side. + */ + getbounds(tpl, &llo, &lhi); + getbounds(tpr, &rlo, &rhi); + if (llo > rlo || lhi < rhi) { + genrck(tpl); } + return; } - else if (tpl->tp_size <= tpr->tp_size && - ((tpl->tp_fund == T_INTEGER && tpr == card_type) || - (tpr->tp_fund == T_INTEGER && tpl == card_type))) { + if (tpl->tp_size <= tpr->tp_size && + ((tpl->tp_fund == T_INTEGER && tpr == card_type) || + (tpr->tp_fund == T_INTEGER && tpl == card_type))) { label lb = ++text_label; C_dup(word_size); @@ -654,18 +614,14 @@ RangeCheck(tpl, tpr) C_trp(); C_df_ilb(lb); } - } -Operands(leftop, rightop, tp) +Operands(leftop, rightop) register struct node *leftop, *rightop; - struct type *tp; { CodePExpr(leftop); - CodeCoercion(leftop->nd_type, tp); CodePExpr(rightop); - CodeCoercion(rightop->nd_type, tp); } CodeOper(expr, true_label, false_label) @@ -679,7 +635,7 @@ CodeOper(expr, true_label, false_label) switch (expr->nd_symb) { case '+': - Operands(leftop, rightop, tp); + Operands(leftop, rightop); switch (tp->tp_fund) { case T_INTEGER: C_adi(tp->tp_size); @@ -701,7 +657,7 @@ CodeOper(expr, true_label, false_label) } break; case '-': - Operands(leftop, rightop, tp); + Operands(leftop, rightop); switch (tp->tp_fund) { case T_INTEGER: C_sbi(tp->tp_size); @@ -724,7 +680,7 @@ CodeOper(expr, true_label, false_label) } break; case '*': - Operands(leftop, rightop, tp); + Operands(leftop, rightop); switch (tp->tp_fund) { case T_INTEGER: C_mli(tp->tp_size); @@ -746,7 +702,7 @@ CodeOper(expr, true_label, false_label) } break; case '/': - Operands(leftop, rightop, tp); + Operands(leftop, rightop); switch (tp->tp_fund) { case T_REAL: C_dvf(tp->tp_size); @@ -759,7 +715,7 @@ CodeOper(expr, true_label, false_label) } break; case DIV: - Operands(leftop, rightop, tp); + Operands(leftop, rightop); switch(tp->tp_fund) { case T_INTEGER: C_dvi(tp->tp_size); @@ -775,7 +731,7 @@ CodeOper(expr, true_label, false_label) } break; case MOD: - Operands(leftop, rightop, tp); + Operands(leftop, rightop); switch(tp->tp_fund) { case T_INTEGER: C_rmi(tp->tp_size); @@ -796,9 +752,9 @@ CodeOper(expr, true_label, false_label) case GREATEREQUAL: case '=': case '#': + Operands(leftop, rightop); 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); @@ -854,7 +810,6 @@ CodeOper(expr, true_label, false_label) */ CodePExpr(rightop); CodePExpr(leftop); - CodeCoercion(leftop->nd_type, word_type); C_inn(rightop->nd_type->tp_size); if (true_label != NO_LABEL) { C_zne(true_label); @@ -862,10 +817,9 @@ CodeOper(expr, true_label, false_label) } break; case OR: - case AND: - case '&': { + case AND: { label l_maybe = ++text_label, l_end; - struct desig Des; + struct desig *Des = new_desig(); int genlabels = 0; if (true_label == NO_LABEL) { @@ -875,14 +829,14 @@ CodeOper(expr, true_label, false_label) l_end = ++text_label; } - Des = InitDesig; if (expr->nd_symb == OR) { - CodeExpr(leftop, &Des, true_label, l_maybe); + CodeExpr(leftop, Des, true_label, l_maybe); } - else CodeExpr(leftop, &Des, l_maybe, false_label); + else CodeExpr(leftop, Des, l_maybe, false_label); C_df_ilb(l_maybe); - Des = InitDesig; - CodeExpr(rightop, &Des, true_label, false_label); + free_desig(Des); + Des = new_desig(); + CodeExpr(rightop, Des, true_label, false_label); if (genlabels) { C_df_ilb(true_label); C_loc((arith)1); @@ -891,6 +845,7 @@ CodeOper(expr, true_label, false_label) C_loc((arith)0); C_df_ilb(l_end); } + free_desig(Des); break; } default: @@ -962,7 +917,6 @@ CodeUoper(nd) CodePExpr(nd->nd_right); switch(nd->nd_symb) { - case '~': case NOT: C_teq(); break; @@ -979,6 +933,10 @@ CodeUoper(nd) crash("Bad operand to unary -"); } break; + case COERCION: + CodeCoercion(nd->nd_right->nd_type, tp); + RangeCheck(tp, nd->nd_right->nd_type); + break; default: crash("Bad unary operator"); } @@ -1010,7 +968,7 @@ CodeEl(nd, tp) C_loc(eltype->sub_ub); } else C_loc((arith) (eltype->enm_ncst - 1)); - Operands(nd->nd_left, nd->nd_right, word_type); + Operands(nd->nd_left, nd->nd_right); C_cal("_LtoUset"); /* library routine to fill set */ C_asp(4 * word_size); } @@ -1027,11 +985,11 @@ CodePExpr(nd) /* Generate code to push the value of the expression "nd" on the stack. */ - struct desig designator; + register struct desig *designator = new_desig(); - designator = InitDesig; - CodeExpr(nd, &designator, NO_LABEL, NO_LABEL); - CodeValue(&designator, nd->nd_type); + CodeExpr(nd, designator, NO_LABEL, NO_LABEL); + CodeValue(designator, nd->nd_type); + free_desig(designator); } CodeDAddress(nd) @@ -1041,11 +999,11 @@ CodeDAddress(nd) on the stack. */ - struct desig designator; + register struct desig *designator = new_desig(); - designator = InitDesig; - CodeDesig(nd, &designator); - CodeAddress(&designator); + CodeDesig(nd, designator); + CodeAddress(designator); + free_desig(designator); } CodeDStore(nd) @@ -1055,11 +1013,11 @@ CodeDStore(nd) designator "nd". */ - struct desig designator; + register struct desig *designator = new_desig(); - designator = InitDesig; - CodeDesig(nd, &designator); - CodeStore(&designator, nd->nd_type); + CodeDesig(nd, designator); + CodeStore(designator, nd->nd_type); + free_desig(designator); } DoHIGH(df) diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c index e867818cb..55ba64821 100644 --- a/lang/m2/comp/cstoper.c +++ b/lang/m2/comp/cstoper.c @@ -27,6 +27,7 @@ long mach_long_sign; /* sign bit of the machine long */ int mach_long_size; /* size of long on this machine == sizeof(long) */ long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */ +long int_mask[MAXSIZE]; /* int_mask[1] == 0x7F, int_mask[2] == 0x7FFF, .. */ arith max_int; /* maximum integer on target machine */ arith max_unsigned; /* maximum unsigned on target machine */ arith max_longint; /* maximum longint on target machine */ @@ -200,14 +201,7 @@ cstbin(expp) /* Fall through */ case GREATEREQUAL: - if (uns) { - o1 = (o1 & mach_long_sign ? - (o2 & mach_long_sign ? o1 >= o2 : 1) : - (o2 & mach_long_sign ? 0 : o1 >= o2) - ); - } - else - o1 = (o1 >= o2); + o1 = chk_bounds(o2, o1, uns ? T_CARDINAL : T_INTEGER); break; case '=': @@ -251,6 +245,7 @@ cstset(expp) assert(expp->nd_right->nd_class == Set); assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set); + set2 = expp->nd_right->nd_set; setsize = (unsigned) expp->nd_right->nd_type->tp_size / (unsigned) word_size; @@ -390,22 +385,11 @@ cstcall(expp, call) CutSize(expp); break; - case S_LONG: - case S_SHORT: { - struct type *tp = expp->nd_type; - - *expp = *expr; - expp->nd_type = tp; - break; - } case S_CAP: if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') { expr->nd_INT = expr->nd_INT + ('A' - 'a'); } - /* fall through */ - case S_CHR: expp->nd_INT = expr->nd_INT; - CutSize(expp); break; case S_MAX: @@ -443,35 +427,10 @@ cstcall(expp, call) expp->nd_INT = (expr->nd_INT & 1); break; - case S_ORD: - expp->nd_INT = expr->nd_INT; - CutSize(expp); - break; - case S_SIZE: expp->nd_INT = expr->nd_type->tp_size; break; - case S_VAL: - expp->nd_INT = expr->nd_INT; - if ( /* Check overflow of subranges or enumerations */ - ( expp->nd_type->tp_fund == T_SUBRANGE - && - ( expp->nd_INT < expp->nd_type->sub_lb - || expp->nd_INT > expp->nd_type->sub_ub - ) - ) - || - ( expp->nd_type->tp_fund == T_ENUMERATION - && - ( expp->nd_INT < 0 - || expp->nd_INT >= expp->nd_type->enm_ncst - ) - ) - ) node_warning(expp, W_ORDINARY, ovflow); - else CutSize(expp); - break; - default: crash("(cstcall)"); } @@ -501,9 +460,9 @@ CutSize(expr) } else { int nbits = (int) (mach_long_size - size) * 8; - long remainder = o1 & ~full_mask[size]; + long remainder = o1 & ~int_mask[size]; - if (remainder != 0 && remainder != ~full_mask[size]) { + if (remainder != 0 && remainder != ~int_mask[size]) { node_warning(expr, W_ORDINARY, ovflow); o1 <<= nbits; o1 >>= nbits; @@ -522,6 +481,7 @@ InitCst() if (i == MAXSIZE) fatal("array full_mask too small for this machine"); full_mask[i] = bt; + int_mask[i] = bt & ~(1L << ((i << 3) - 1)); } mach_long_size = i; mach_long_sign = 1L << (mach_long_size * 8 - 1); @@ -529,8 +489,8 @@ InitCst() fatal("sizeof (long) insufficient on this machine"); } - max_int = full_mask[int_size] & ~(1L << (int_size * 8 - 1)); + max_int = int_mask[int_size]; max_unsigned = full_mask[int_size]; - max_longint = full_mask[long_size] & ~(1L << (long_size * 8 - 1)); + max_longint = int_mask[long_size]; wrd_bits = 8 * (unsigned) word_size; } diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index 4da0391ad..f926f1e9b 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -387,22 +387,22 @@ CaseLabels(struct type **ptp; register struct node **pnd;) register struct node *nd; }: ConstExpression(pnd) - { nd = *pnd; } + { + if (*ptp != 0) { + ChkCompat(pnd, *ptp, "case label"); + } + nd = *pnd; + } [ UPTO { *pnd = MkNode(Link,nd,NULLNODE,&dot); } ConstExpression(&(*pnd)->nd_right) - { if (!TstCompat(nd->nd_type, - (*pnd)->nd_right->nd_type)) { - node_error((*pnd)->nd_right, - "type incompatibility in case label"); + { if (!ChkCompat(&((*pnd)->nd_right), nd->nd_type, + "case label")) { nd->nd_type = error_type; } } ]? - { if (*ptp != 0 && !TstCompat(*ptp, nd->nd_type)) { - node_error(nd, - "type incompatibility in case label"); - } + { *ptp = nd->nd_type; } ; @@ -486,10 +486,15 @@ ConstantDeclaration { struct idf *id; struct node *nd; + register struct def *df; }: IDENT { id = dot.TOK_IDF; } '=' ConstExpression(&nd) - { define(id,CurrentScope,D_CONST)->con_const = nd; } + { df = define(id,CurrentScope,D_CONST); + df->con_const = nd->nd_token; + df->df_type = nd->nd_type; + FreeNode(nd); + } ; VariableDeclaration @@ -508,10 +513,14 @@ VariableDeclaration { EnterVarList(VarList, tp, proclevel > 0); } ; -IdentAddr(register struct node **pnd;) : - IDENT { *pnd = MkLeaf(Name, &dot); } +IdentAddr(struct node **pnd;) +{ + register struct node *nd; +} : + IDENT { nd = MkLeaf(Name, &dot); } [ '[' - ConstExpression(&((*pnd)->nd_left)) + ConstExpression(&(nd->nd_left)) ']' ]? + { *pnd = nd; } ; diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index 44df7b87b..5cd7a6a0d 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -26,7 +26,7 @@ struct variable { }; struct constant { - struct node *co_const; /* result of a constant expression */ + struct token co_const; /* result of a constant expression */ #define con_const df_value.df_constant.co_const }; diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c index 5151b448d..183b6dadd 100644 --- a/lang/m2/comp/def.c +++ b/lang/m2/comp/def.c @@ -16,17 +16,15 @@ #include #include +#include "LLlex.h" #include "main.h" #include "def.h" #include "type.h" #include "idf.h" #include "scope.h" -#include "LLlex.h" #include "node.h" #include "Lpars.h" -extern int (*c_inp)(); - STATIC DefInFront(df) register struct def *df; @@ -272,7 +270,10 @@ 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); + if (options['x']) { + C_exp(buf); + } + else C_inp(buf); } open_scope(OPENSCOPE); scope = CurrentScope; @@ -342,7 +343,10 @@ DefineLocalModule(id) /* Generate code that indicates that the initialization procedure for this module is local. */ - (*c_inp)(buf); + if (options['x']) { + C_exp(buf); + } + else C_inp(buf); return df; } diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c index bff2bb090..90e11828d 100644 --- a/lang/m2/comp/defmodule.c +++ b/lang/m2/comp/defmodule.c @@ -19,8 +19,8 @@ #include "idf.h" #include "input.h" #include "scope.h" -#include "def.h" #include "LLlex.h" +#include "def.h" #include "Lpars.h" #include "f_info.h" #include "main.h" diff --git a/lang/m2/comp/desig.H b/lang/m2/comp/desig.H new file mode 100644 index 000000000..52b252af4 --- /dev/null +++ b/lang/m2/comp/desig.H @@ -0,0 +1,66 @@ +/* + * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands. + * See the copyright notice in the ACK home directory, in the file "Copyright". + * + * Author: Ceriel J.H. Jacobs + */ + +/* D E S I G N A T O R D E S C R I P T I O N S */ + +/* $Header$ */ + +/* Generating code for designators is not particularly easy, especially if + you don't know wether you want the address or the value. + The next structure is used to generate code for designators. + It contains information on how to find the designator, after generation + of the code that is common to both address and value computations. +*/ + +struct desig { + int dsg_kind; +#define DSG_INIT 0 /* don't know anything yet */ +#define DSG_LOADED 1 /* designator loaded on top of the stack */ +#define DSG_PLOADED 2 /* designator accessible through pointer on + stack, possibly with an offset + */ +#define DSG_FIXED 3 /* designator directly accessible */ +#define DSG_PFIXED 4 /* designator accessible through directly + accessible pointer + */ +#define DSG_INDEXED 5 /* designator accessible through array + operation. Address of array descriptor on + top of the stack, index beneath that, and + base address beneath that + */ + arith dsg_offset; /* contains an offset for PLOADED, + or for FIXED or PFIXED it contains an + offset from dsg_name, if it exists, + or from the current Local Base + */ + char *dsg_name; /* name of global variable, used for + FIXED and PFIXED + */ + struct def *dsg_def; /* def structure associated with this + designator, or 0 + */ +}; + +/* ALLOCDEF "desig" 5 */ + +/* The next structure describes the designator in a with-statement. + We have a linked list of them, as with-statements may be nested. +*/ + +struct withdesig { + struct withdesig *w_next; + struct scope *w_scope; /* scope in which fields of this record + reside + */ + struct desig w_desig; /* a desig structure for this particular + designator + */ +}; + +extern struct withdesig *WithDesigs; + +#define NO_LABEL ((label) 0) diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c index e8a0eeeeb..ff88c6607 100644 --- a/lang/m2/comp/desig.c +++ b/lang/m2/comp/desig.c @@ -22,16 +22,16 @@ #include #include #include +#include #include "type.h" +#include "LLlex.h" #include "def.h" #include "scope.h" #include "desig.h" -#include "LLlex.h" #include "node.h" extern int proclevel; -struct desig InitDesig = {DSG_INIT, 0, 0, 0}; int WordOrDouble(ds, size) @@ -86,9 +86,9 @@ DoStore(ds, size) } STATIC int -properly(ds, size, al) +properly(ds, tp) register struct desig *ds; - arith size; + register struct type *tp; { /* Check if it is allowed to load or store the value indicated by "ds" with LOI/STI. @@ -100,16 +100,17 @@ properly(ds, size, al) with DSG_FIXED. */ - int szmodword = (int) size % (int) word_size; /* 0 if multiple of wordsize */ - int wordmodsz = word_size % size; /* 0 if dividor of wordsize */ + int szmodword = (int) (tp->tp_size) % (int) word_size; + /* 0 if multiple of wordsize */ + int wordmodsz = word_size % tp->tp_size;/* 0 if dividor of wordsize */ if (szmodword && wordmodsz) return 0; - if (al >= word_align) return 1; - if (szmodword && al >= szmodword) return 1; + if (tp->tp_align >= word_align) return 1; + if (szmodword && tp->tp_align >= szmodword) return 1; return ds->dsg_kind == DSG_FIXED && ((! szmodword && (int) (ds->dsg_offset) % word_align == 0) || - (! wordmodsz && ds->dsg_offset % size == 0)); + (! wordmodsz && ds->dsg_offset % tp->tp_size == 0)); } CodeValue(ds, tp) @@ -131,7 +132,7 @@ CodeValue(ds, tp) case DSG_PLOADED: case DSG_PFIXED: sz = WA(tp->tp_size); - if (properly(ds, tp->tp_size, tp->tp_align)) { + if (properly(ds, tp)) { CodeAddress(ds); C_loi(tp->tp_size); break; @@ -162,9 +163,6 @@ CodeValue(ds, tp) } ds->dsg_kind = DSG_LOADED; - if (tp->tp_fund == T_SUBRANGE) { - CodeCoercion(tp, BaseType(tp)); - } } CodeStore(ds, tp) @@ -184,7 +182,7 @@ CodeStore(ds, tp) case DSG_PLOADED: case DSG_PFIXED: CodeAddress(&save); - if (properly(ds, tp->tp_size, tp->tp_align)) { + if (properly(ds, tp)) { C_sti(tp->tp_size); break; } @@ -225,13 +223,10 @@ CodeMove(rhs, left, rtp) register struct node *left; struct type *rtp; { - struct desig dsl; - register struct desig *lhs = &dsl; + register struct desig *lhs = new_desig(); register struct type *tp = left->nd_type; int loadedflag = 0; - dsl = InitDesig; - /* Generate code for an assignment. Testing of type compatibility and the like is already done. Go through some (considerable) trouble to see if a BLM can be @@ -247,10 +242,10 @@ CodeMove(rhs, left, rtp) C_loc(tp->tp_size); C_cal("_StringAssign"); C_asp(word_size << 2); - return; + break; } CodeStore(lhs, tp); - return; + break; case DSG_PLOADED: case DSG_PFIXED: CodeAddress(rhs); @@ -259,11 +254,11 @@ CodeMove(rhs, left, rtp) CodeDesig(left, lhs); CodeAddress(lhs); C_blm(tp->tp_size); - return; + break; } CodeValue(rhs, tp); CodeDStore(left); - return; + break; case DSG_FIXED: CodeDesig(left, lhs); if (lhs->dsg_kind == DSG_FIXED && @@ -313,7 +308,7 @@ CodeMove(rhs, left, rtp) CodeCopy(lhs, rhs, (arith) sz, &size); } } - return; + break; } if (lhs->dsg_kind == DSG_PLOADED || lhs->dsg_kind == DSG_INDEXED) { @@ -326,7 +321,7 @@ CodeMove(rhs, left, rtp) if (loadedflag) C_exg(pointer_size); else CodeAddress(lhs); C_blm(tp->tp_size); - return; + break; } { arith tmp; @@ -343,11 +338,12 @@ CodeMove(rhs, left, rtp) CodeValue(rhs, tp); CodeStore(lhs, tp); if (loadedflag) FreePtr(tmp); - return; + break; } default: crash("CodeMove"); } + free_desig(lhs); } CodeAddress(ds) @@ -529,6 +525,7 @@ CodeDesig(nd, ds) switch(nd->nd_class) { /* Divide */ case Def: df = nd->nd_def; + if (nd->nd_left) CodeDesig(nd->nd_left, ds); switch(df->df_kind) { case D_FIELD: @@ -544,22 +541,12 @@ CodeDesig(nd, ds) } break; - case LinkDef: - assert(nd->nd_symb == '.'); - - CodeDesig(nd->nd_left, ds); - CodeFieldDesig(nd->nd_def, ds); - break; - case Arrsel: assert(nd->nd_symb == '['); CodeDesig(nd->nd_left, ds); CodeAddress(ds); CodePExpr(nd->nd_right); - if (nd->nd_right->nd_type->tp_size > word_size) { - CodeCoercion(nd->nd_right->nd_type, int_type); - } /* Now load address of descriptor */ diff --git a/lang/m2/comp/enter.c b/lang/m2/comp/enter.c index 1f0939722..c2e6950ed 100644 --- a/lang/m2/comp/enter.c +++ b/lang/m2/comp/enter.c @@ -18,10 +18,10 @@ #include #include "idf.h" +#include "LLlex.h" #include "def.h" #include "type.h" #include "scope.h" -#include "LLlex.h" #include "node.h" #include "main.h" #include "misc.h" diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 7a89fde1b..50676b30d 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -146,19 +146,21 @@ AddOperator: term(struct node **pnd;) { + register struct node *nd; }: - factor(pnd) + factor(pnd) { nd = *pnd; } [ /* MulOperator */ - [ '*' | '/' | DIV | MOD | AND | '&' ] - { *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); } - factor(&((*pnd)->nd_right)) + [ '*' | '/' | DIV | MOD | AND ] + { nd = MkNode(Oper, nd, NULLNODE, &dot); } + factor(&(nd->nd_right)) ]* + { *pnd = nd; } ; /* inline in "term" MulOperator: - '*' | '/' | DIV | MOD | AND | '&' + '*' | '/' | DIV | MOD | AND ; */ diff --git a/lang/m2/comp/input.c b/lang/m2/comp/input.c index 7a884d6dc..92183b3fb 100644 --- a/lang/m2/comp/input.c +++ b/lang/m2/comp/input.c @@ -12,11 +12,6 @@ #include "f_info.h" struct f_info file_info; #include "input.h" -#include -#include -#include "def.h" -#include "idf.h" -#include "scope.h" #include diff --git a/lang/m2/comp/lookup.c b/lang/m2/comp/lookup.c index 31b7e0a45..7ef0b2ccc 100644 --- a/lang/m2/comp/lookup.c +++ b/lang/m2/comp/lookup.c @@ -15,10 +15,10 @@ #include #include +#include "LLlex.h" #include "def.h" #include "idf.h" #include "scope.h" -#include "LLlex.h" #include "node.h" #include "type.h" #include "misc.h" @@ -52,9 +52,11 @@ lookup(id, scope, import) df->df_next = id->id_def; id->id_def = df; } - if (import && df->df_kind == D_IMPORT) { - assert(df->imp_def != 0); - return df->imp_def; + if (import) { + while (df->df_kind == D_IMPORT) { + assert(df->imp_def != 0); + df = df->imp_def; + } } } return df; diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index 9f5bc8ed9..78561e14f 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -36,13 +36,11 @@ int DefinitionModule; char *ProgName; char **DEFPATH; int nDEF, mDEF; +int pass_1; 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; { @@ -66,7 +64,6 @@ main(argc, argv) fprint(STDERR, "%s: Use a file argument\n", ProgName); exit(1); } - if (options['x']) c_inp = C_exp; exit(!Compile(Nargv[1], Nargv[2])); } @@ -103,9 +100,11 @@ Compile(src, dst) C_magic(); C_ms_emx(word_size, pointer_size); CheckForLineDirective(); + pass_1 = 1; CompUnit(); C_ms_src((int)LineNumber - 1, FileName); if (!err_occurred) { + pass_1 = 0; C_exp(Defined->mod_vis->sc_scope->sc_name); WalkModule(Defined); if (fp_used) C_ms_flt(); @@ -186,7 +185,7 @@ AddStandards() { register struct def *df; register struct stdproc *p; - static struct node nilnode = { 0, 0, Value, 0, { INTEGER, 0}}; + static struct token nilconst = { INTEGER, 0}; for (p = stdproc; p->st_nam != 0; p++) { Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con); @@ -200,9 +199,7 @@ AddStandards() EnterType("BOOLEAN", bool_type); EnterType("CARDINAL", card_type); df = Enter("NIL", D_CONST, address_type, 0); - df->con_const = &nilnode; - nilnode.nd_INT = 0; - nilnode.nd_type = address_type; + df->con_const = nilconst; EnterType("PROC", construct_type(T_PROCEDURE, NULLTYPE)); EnterType("BITSET", bitset_type); diff --git a/lang/m2/comp/node.c b/lang/m2/comp/node.c index c2a624ec2..dd2bb6ef8 100644 --- a/lang/m2/comp/node.c +++ b/lang/m2/comp/node.c @@ -16,9 +16,9 @@ #include #include +#include "LLlex.h" #include "def.h" #include "type.h" -#include "LLlex.h" #include "node.h" struct node * diff --git a/lang/m2/comp/tmpvar.C b/lang/m2/comp/tmpvar.C index 3595d86fe..88429a5ae 100644 --- a/lang/m2/comp/tmpvar.C +++ b/lang/m2/comp/tmpvar.C @@ -24,6 +24,7 @@ #include #include +#include "LLlex.h" #include "def.h" #include "type.h" #include "scope.h" diff --git a/lang/m2/comp/tokenname.c b/lang/m2/comp/tokenname.c index cbf7c8413..e719acd2f 100644 --- a/lang/m2/comp/tokenname.c +++ b/lang/m2/comp/tokenname.c @@ -85,6 +85,7 @@ struct tokenname tkidf[] = { /* names of the identifier tokens */ #ifdef ___XXX___ struct tokenname tkinternal[] = { /* internal keywords */ {PROGRAM, ""}, + {COERCION, ""}, {0, "0"} }; diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index b5448064a..784f3a5cb 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -179,6 +179,7 @@ struct type #define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED) extern long full_mask[]; +extern long int_mask[]; #define fit(n, i) (((n) + ((arith)0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0) #define ufit(n, i) (((n) & ~full_mask[(i)]) == 0) diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index 810f6369f..91430f91c 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -19,10 +19,10 @@ #include #include +#include "LLlex.h" #include "def.h" #include "type.h" #include "idf.h" -#include "LLlex.h" #include "node.h" #include "const.h" #include "scope.h" @@ -287,7 +287,10 @@ chk_basesubrange(tp, base) /* Check that the bounds of "tp" fall within the range of "base". */ - if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) { + int fund = base->tp_next->tp_fund; + + if (! chk_bounds(base->sub_lb, tp->sub_lb, fund) || + ! chk_bounds(base->sub_ub, tp->sub_ub, fund)) { error("base type has insufficient range"); } base = base->tp_next; @@ -314,6 +317,21 @@ chk_basesubrange(tp, base) tp->tp_align = base->tp_align; } +int +chk_bounds(l1, l2, fund) + arith l1, l2; +{ + /* compare to arith's, but be careful. They might be unsigned + */ + if (fund == T_INTEGER) { + return l2 >= l1; + } + return (l2 & mach_long_sign ? + (l1 & mach_long_sign ? l2 >= l1 : 1) : + (l1 & mach_long_sign ? 0 : l2 >= l1) + ); +} + struct type * subr_type(lb, ub) register struct node *lb; @@ -326,11 +344,6 @@ subr_type(lb, ub) register struct type *tp = BaseType(lb->nd_type); register struct type *res; - if (!TstCompat(lb->nd_type, ub->nd_type)) { - node_error(lb, "types of subrange bounds not equal"); - return error_type; - } - if (tp == intorcard_type) { /* Lower bound >= 0; in this case, the base type is CARDINAL, according to the language definition, par. 6.3 @@ -339,6 +352,10 @@ subr_type(lb, ub) tp = card_type; } + if (!ChkCompat(&ub, tp, "subrange bounds")) { + return error_type; + } + /* Check base type */ if (! (tp->tp_fund & T_DISCRETE)) { @@ -348,7 +365,7 @@ subr_type(lb, ub) /* Check bounds */ - if (lb->nd_INT > ub->nd_INT) { + if (! chk_bounds(lb->nd_INT, ub->nd_INT, tp->tp_fund)) { node_error(lb, "lower bound exceeds upper bound"); } @@ -490,7 +507,7 @@ ArraySizes(tp) */ register struct type *index_type = IndexType(tp); register struct type *elem_type = tp->arr_elem; - arith lo, hi; + arith lo, hi, diff; tp->arr_elsize = ArrayElSize(elem_type); tp->tp_align = elem_type->tp_align; @@ -504,20 +521,21 @@ ArraySizes(tp) } getbounds(index_type, &lo, &hi); + diff = hi - lo; - tp->tp_size = (hi - lo + 1) * tp->arr_elsize; + tp->tp_size = (diff + 1) * tp->arr_elsize; /* generate descriptor and remember label. */ tp->arr_descr = ++data_label; C_df_dlb(tp->arr_descr); C_rom_cst(lo); - C_rom_cst(hi - lo); + C_rom_cst(diff); C_rom_cst(tp->arr_elsize); } FreeType(tp) - struct type *tp; + register struct type *tp; { /* Release type structures indicated by "tp". This procedure is only called for types, constructed with @@ -549,19 +567,20 @@ DeclareType(nd, df, tp) "df" is already bound. In that case, it is either an opaque type, or an error message was given when "df" was created. */ + register struct type *df_tp = df->df_type; - if (df->df_type && df->df_type->tp_fund == T_HIDDEN) { + if (df_tp && df_tp->tp_fund == T_HIDDEN) { if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) { node_error(nd, "opaque type \"%s\" is not a pointer type", df->df_idf->id_text); } - df->df_type->tp_next = tp; - df->df_type->tp_fund = T_EQUAL; - while (tp != df->df_type && tp->tp_fund == T_EQUAL) { + df_tp->tp_next = tp; + df_tp->tp_fund = T_EQUAL; + while (tp != df_tp && tp->tp_fund == T_EQUAL) { tp = tp->tp_next; } - if (tp == df->df_type) { + if (tp == df_tp) { /* Circular definition! */ node_error(nd, "opaque type \"%s\" has a circular definition", @@ -588,7 +607,7 @@ type_or_forward(ptp) in "dot". This routine handles the different cases. */ register struct node *nd; - register struct def *df1; + register struct def *df, *df1; if ((df1 = lookup(dot.TOK_IDF, CurrentScope, 1))) { /* Either a Module or a Type, but in both cases defined @@ -622,21 +641,17 @@ type_or_forward(ptp) may have forward references that must howewer be declared in the same scope. */ - { - register struct def *df = - define(nd->nd_IDF, CurrentScope, D_FORWTYPE); + df = define(nd->nd_IDF, CurrentScope, D_FORWTYPE); - if (df->df_kind == D_TYPE) { - (*ptp)->tp_next = df->df_type; - free_node(nd); - } - else { - nd->nd_type = *ptp; - df->df_forw_node = nd; - if (df1->df_kind == D_TYPE) { - df->df_type = df1->df_type; - } - } + if (df->df_kind == D_TYPE) { + (*ptp)->tp_next = df->df_type; + free_node(nd); + return 0; + } + nd->nd_type = *ptp; + df->df_forw_node = nd; + if (df1->df_kind == D_TYPE) { + df->df_type = df1->df_type; } return 0; } diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 4976ee894..ad86487e2 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -19,8 +19,9 @@ #include #include "type.h" -#include "def.h" #include "LLlex.h" +#include "idf.h" +#include "def.h" #include "node.h" #include "warning.h" @@ -175,9 +176,10 @@ TstAssCompat(tp1, tp2) } int -TstParCompat(formaltype, actualtype, VARflag, nd) - register struct type *formaltype, *actualtype; - struct node *nd; +TstParCompat(parno, formaltype, VARflag, nd, edf) + register struct type *formaltype; + struct node **nd; + struct def *edf; { /* Check type compatibility for a parameter in a procedure call. Assignment compatibility may do if the parameter is @@ -186,11 +188,19 @@ TstParCompat(formaltype, actualtype, VARflag, nd) may do too. Or: a WORD may do. */ + register struct type *actualtype = (*nd)->nd_type; + char ebuf[256]; + char ebuf1[256]; - return + if (edf) { + sprintf(ebuf, "\"%s\", parameter %d: %%s", edf->df_idf->id_text, parno); + } + else sprint(ebuf, "parameter %d: %%s", parno); + + if ( TstTypeEquiv(formaltype, actualtype) || - ( !VARflag && TstAssCompat(formaltype, actualtype)) + ( !VARflag && ChkAssCompat(nd, formaltype, (char *) 0)) || ( formaltype == address_type && actualtype->tp_fund == T_POINTER @@ -225,13 +235,62 @@ TstParCompat(formaltype, actualtype, VARflag, nd) ) ) ) - || - ( VARflag - && ( TstCompat(formaltype, actualtype) - && -(node_warning(nd, W_OLDFASHIONED, "types of formal and actual must be identical"), - 1) - ) - ) - ; + ) + return 1; + if (VARflag && TstCompat(formaltype, actualtype)) { + if (formaltype->tp_size == actualtype->tp_size) { + sprint(ebuf1, ebuf, "identical types required"); + node_warning(*nd, + W_OLDFASHIONED, + ebuf1); + return 1; + } + sprint(ebuf1, ebuf, "equal sized types required"); + node_error(*nd, ebuf1); + return 0; + } + + sprint(ebuf1, ebuf, "type incompatibility"); + node_error(*nd, ebuf1); + return 0; +} + +CompatCheck(nd, tp, message, fc) + struct node **nd; + struct type *tp; + char *message; + int (*fc)(); +{ + if (! (*fc)(tp, (*nd)->nd_type)) { + if (message) { + node_error(*nd, "type incompatibility in %s", message); + } + return 0; + } + MkCoercion(nd, tp); + return 1; +} + +ChkAssCompat(nd, tp, message) + struct node **nd; + struct type *tp; + char *message; +{ + /* Check assignment compatibility of node "nd" with type "tp". + Give an error message when it fails + */ + + return CompatCheck(nd, tp, message, TstAssCompat); +} + +ChkCompat(nd, tp, message) + struct node **nd; + struct type *tp; + char *message; +{ + /* Check compatibility of node "nd" with type "tp". + Give an error message when it fails + */ + + return CompatCheck(nd, tp, message, TstCompat); } diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index 73bf05ea7..a1f4e28de 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -21,12 +21,13 @@ #include #include #include +#include +#include "LLlex.h" #include "def.h" #include "type.h" #include "scope.h" #include "main.h" -#include "LLlex.h" #include "node.h" #include "Lpars.h" #include "desig.h" @@ -40,7 +41,7 @@ extern arith NewPtr(); extern arith NewInt(); extern int proclevel; label text_label; -label data_label; +label data_label = 1; static struct type *func_type; struct withdesig *WithDesigs; struct node *Modules; @@ -55,8 +56,11 @@ DoPriority() /* For the time being (???), handle priorities by calls to the runtime system */ - if (priority) { - C_loc(priority->nd_INT); + + register struct node *p; + + if (p = priority) { + C_loc(p->nd_INT); C_cal("_stackprio"); C_asp(word_size); } @@ -77,13 +81,13 @@ DoProfil() if (! options['L']) { - if (!filename_label) { - filename_label = ++data_label; - C_df_dlb(filename_label); + if (! filename_label) { + filename_label = 1; + C_df_dlb((label) 1); C_rom_scon(FileName, (arith) (strlen(FileName) + 1)); } - C_fil_dlb(filename_label, (arith) 0); + C_fil_dlb((label) 1, (arith) 0); } } @@ -215,14 +219,14 @@ WalkProcedure(procedure) param; param = param->par_next) { if (! IsVarParam(param)) { - register struct type *TpParam = TypeOfParam(param); + tp = TypeOfParam(param); - if (! IsConformantArray(TpParam)) { - if (TpParam->tp_size < word_size && - (int) word_size % (int) TpParam->tp_size == 0) { + if (! IsConformantArray(tp)) { + if (tp->tp_size < word_size && + (int) word_size % (int) tp->tp_size == 0) { C_lol(param->par_def->var_off); C_lal(param->par_def->var_off); - C_sti(TpParam->tp_size); + C_sti(tp->tp_size); } } else { @@ -239,7 +243,7 @@ WalkProcedure(procedure) if (! StackAdjustment) { /* First time we get here */ - if (tp && !func_res_label) { + if (func_type && !func_res_label) { /* Some local space, only needed if the value itself is returned @@ -290,21 +294,20 @@ WalkProcedure(procedure) C_str((arith) 1); } C_lae_dlb(func_res_label, (arith) 0); - EndPriority(); - C_ret(pointer_size); + func_res_size = pointer_size; } else if (StackAdjustment) { /* First save the function result in a safe place. Then remove copies of conformant arrays, and put function result back on the stack */ - if (tp) { + if (func_type) { C_lal(retsav); C_sti(func_res_size); } C_lol(StackAdjustment); C_str((arith) 1); - if (tp) { + if (func_type) { C_lal(retsav); C_loi(func_res_size); } @@ -410,7 +413,7 @@ WalkStat(nd, exit_label) break; case BECOMES: - DoAssign(nd, left, right); + DoAssign(left, right); break; case IF: @@ -478,43 +481,47 @@ WalkStat(nd, exit_label) int good_forvar; label l1 = ++text_label; label l2 = ++text_label; + int uns = 0; good_forvar = DoForInit(nd, left); -#ifdef DEBUG - nd->nd_left = left; - nd->nd_right = right; -#endif fnd = left->nd_right; - if (fnd->nd_class != Value) { - /* Upperbound not constant. - The expression may only be evaluated once, - so generate a temporary for it - */ - CodePExpr(fnd); - tmp = NewInt(); - C_stl(tmp); - } - C_df_ilb(l1); - C_dup(int_size); - if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT); - if (left->nd_INT > 0) { - C_bgt(l2); - } - else C_blt(l2); if (good_forvar) { - RangeCheck(nd->nd_type, int_type); + uns = BaseType(nd->nd_type)->tp_fund != T_INTEGER; + if (fnd->nd_class != Value) { + /* Upperbound not constant. + The expression may only be evaluated + once, so generate a temporary for it + */ + CodePExpr(fnd); + tmp = NewInt(); + C_stl(tmp); + } + C_df_ilb(l1); + C_dup(int_size); + if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT); + if (uns) C_cmu(int_size); + else C_cmi(int_size); + if (left->nd_INT > 0) { + C_zgt(l2); + } + else C_zlt(l2); CodeDStore(nd); } WalkNode(right, exit_label); if (good_forvar) { CodePExpr(nd); C_loc(left->nd_INT); - C_adi(int_size); + if (uns) C_adu(int_size); + else C_adi(int_size); C_bra(l1); C_df_ilb(l2); C_asp(int_size); } if (tmp) FreeInt(tmp); +#ifdef DEBUG + nd->nd_left = left; + nd->nd_right = right; +#endif } break; @@ -566,15 +573,14 @@ WalkStat(nd, exit_label) 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"); + if (!ChkAssCompat(&(nd->nd_right), func_type, "RETURN")) { break; } + right = nd->nd_right; if (right->nd_type->tp_fund == T_STRING) { CodePString(right, func_type); } else CodePExpr(right); - RangeCheck(func_type, right->nd_type); } C_bra(RETURN_LABEL); break; @@ -609,29 +615,16 @@ ExpectBool(nd, true_label, false_label) /* "nd" must indicate a boolean expression. Check this and generate code to evaluate the expression. */ - struct desig ds; + register struct desig *ds = new_desig(); - if (!ChkExpression(nd)) return; + if (ChkExpression(nd)) { + if (nd->nd_type != bool_type && nd->nd_type != error_type) { + node_error(nd, "boolean expression expected"); + } - if (nd->nd_type != bool_type && nd->nd_type != error_type) { - node_error(nd, "boolean expression expected"); + CodeExpr(nd, ds, true_label, false_label); } - - ds = InitDesig; - CodeExpr(nd, &ds, true_label, false_label); -} - -int -WalkExpr(nd) - register struct node *nd; -{ - /* Check an expression and generate code for it - */ - - if (! ChkExpression(nd)) return 0; - - CodePExpr(nd); - return 1; + free_desig(ds); } int @@ -644,7 +637,7 @@ WalkDesignator(nd, ds) if (! ChkVariable(nd)) return 0; - *ds = InitDesig; + clear((char *) ds, sizeof(struct desig)); CodeDesig(nd, ds); return 1; } @@ -653,13 +646,14 @@ DoForInit(nd, left) register struct node *nd, *left; { register struct def *df; + struct type *tpl, *tpr; nd->nd_left = nd->nd_right = 0; nd->nd_class = Name; nd->nd_symb = IDENT; if (!( ChkVariable(nd) & - WalkExpr(left->nd_left) & + ChkExpression(left->nd_left) & ChkExpression(left->nd_right))) return 0; df = nd->nd_def; @@ -694,21 +688,22 @@ DoForInit(nd, left) return 1; } - if (!TstCompat(df->df_type, left->nd_left->nd_type) || - !TstCompat(df->df_type, left->nd_right->nd_type)) { - 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 1; - } + tpl = left->nd_left->nd_type; + tpr = left->nd_right->nd_type; + if (!ChkAssCompat(&(left->nd_left), df->df_type, "FOR statement") || + !ChkAssCompat(&(left->nd_right), df->df_type,"FOR statement")) { + return 1; + } + if (!TstCompat(df->df_type, tpl) || + !TstCompat(df->df_type, tpr)) { node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement"); } + CodePExpr(left->nd_left); return 1; } -DoAssign(nd, left, right) - struct node *nd; +DoAssign(left, right) register struct node *left, *right; { /* May we do it in this order (expression first) ??? @@ -716,32 +711,32 @@ DoAssign(nd, left, right) it sais that the left hand side is evaluated first. DAMN THE BOOK! */ - struct desig dsr; + register struct desig *dsr; register struct type *rtp, *ltp; + struct node *rht = right; if (! (ChkExpression(right) & ChkVariable(left))) return; rtp = right->nd_type; ltp = left->nd_type; if (right->nd_symb == STRING) TryToString(right, ltp); - dsr = InitDesig; - if (! TstAssCompat(ltp, rtp)) { - node_error(nd, "type incompatibility in assignment"); + if (! ChkAssCompat(&rht, ltp, "assignment")) { return; } + dsr = new_desig(); #define StackNeededFor(ds) ((ds)->dsg_kind == DSG_PLOADED \ || (ds)->dsg_kind == DSG_INDEXED) - CodeExpr(right, &dsr, NO_LABEL, NO_LABEL); + CodeExpr(rht, dsr, NO_LABEL, NO_LABEL); if (complex(rtp)) { - if (StackNeededFor(&dsr)) CodeAddress(&dsr); + if (StackNeededFor(dsr)) CodeAddress(dsr); } else { - CodeValue(&dsr, rtp); - CodeCheckExpr(rtp, ltp); + CodeValue(dsr, rtp); } - CodeMove(&dsr, left, rtp); + CodeMove(dsr, left, rtp); + free_desig(dsr); } RegisterMessages(df) diff --git a/lang/m2/comp/walk.h b/lang/m2/comp/walk.h index 877af2723..23f1da4a6 100644 --- a/lang/m2/comp/walk.h +++ b/lang/m2/comp/walk.h @@ -14,7 +14,7 @@ extern int (*WalkTable[])(); -#define WalkNode(xnd, xlab) ((xnd) && (*WalkTable[(xnd)->nd_class])((xnd), (xlab))) +#define WalkNode(xnd, xlab) if (! xnd) ; else (*WalkTable[(xnd)->nd_class])((xnd), (xlab)) extern label text_label; extern label data_label;