diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index 733ba3b37..c9372ecb7 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -76,10 +76,12 @@ GetString(upto) /* Read a Modula-2 string, delimited by the character "upto". */ register int ch; - register struct string *str = (struct string *) Malloc(sizeof(struct string)); + register struct string *str = (struct string *) + Malloc((unsigned) sizeof(struct string)); register char *p; + register int len; - str->s_length = ISTRSIZE; + len = ISTRSIZE; str->s_str = p = Malloc((unsigned int) ISTRSIZE); while (LoadChar(ch), ch != upto) { if (class(ch) == STNL) { @@ -95,15 +97,18 @@ GetString(upto) break; } *p++ = ch; - if (p - str->s_str == str->s_length) { + if (p - str->s_str == len) { str->s_str = Srealloc(str->s_str, - (unsigned int) str->s_length + RSTRSIZE); - p = str->s_str + str->s_length; - str->s_length += RSTRSIZE; + (unsigned int) len + RSTRSIZE); + p = str->s_str + len; + len += RSTRSIZE; } } - *p = '\0'; 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 ??? + */ return str; } @@ -172,7 +177,7 @@ linedirective() { * Remember the file name */ if (!eofseen && strcmp(FileName,buf)) { - FileName = Salloc(buf,strlen(buf) + 1); + FileName = Salloc(buf,(unsigned) strlen(buf) + 1); } } if (eofseen) { diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index f9746fd19..aff09b741 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -64,8 +64,8 @@ lint: Cfiles sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi' @rm -f nmclash.o a.out -clashes: $(SRC) $(HFILES) - sh -c 'if test -f clashes ; then cclash -l7 clashes $? > Xclashes ; mv Xclashes clashes ; else cclash -l7 $? > clashes ; fi' +longnames: $(SRC) $(HFILES) + sh -c 'if test -f longnames ; then prid -l7 longnames $? > Xlongnames ; mv Xlongnames longnames ; else prid -l7 $? > longnames ; fi' # entry points not to be used directly diff --git a/lang/m2/comp/Parameters b/lang/m2/comp/Parameters index 9aa80fbe2..fecdc8a73 100644 --- a/lang/m2/comp/Parameters +++ b/lang/m2/comp/Parameters @@ -1,6 +1,6 @@ !File: errout.h #define ERROUT STDERR /* file pointer for writing messages */ -#define MAXERR_LINE 5 /* maximum number of error messages given +#define MAXERR_LINE 100 /* maximum number of error messages given on the same input line. */ diff --git a/lang/m2/comp/Resolve b/lang/m2/comp/Resolve index b8712499d..eeb0a7b86 100755 --- a/lang/m2/comp/Resolve +++ b/lang/m2/comp/Resolve @@ -20,10 +20,10 @@ then : else mkdir ../Xsrc fi -make clashes +make longnames : remove code generating routines from the clashes list as they are defines. : code generating routine names start with C_ -sed '/^C_/d' < clashes > tmp$$ +sed '/^C_/d' < longnames > tmp$$ cclash -c -l7 tmp$$ > ../Xsrc/Xclashes rm -f tmp$$ PW=`pwd` diff --git a/lang/m2/comp/Version.c b/lang/m2/comp/Version.c index 44e57907d..521e211af 100644 --- a/lang/m2/comp/Version.c +++ b/lang/m2/comp/Version.c @@ -1 +1 @@ -char Version[] = "Version 0.7"; +char Version[] = "ACK Modula-2 compiler Version 0.8"; diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index c01ae1a5d..fb1dd1904 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -25,6 +25,20 @@ extern char *symbol2str(); +STATIC +Xerror(nd, mess, edf) + struct node *nd; + char *mess; + struct def *edf; +{ + if (edf) { + if (edf->df_kind != D_ERROR) { + node_error(nd, "\"%s\": %s", edf->df_idf->id_text, mess); + } + } + else node_error(nd, "%s", mess); +} + int ChkVariable(expp) register struct node *expp; @@ -37,7 +51,7 @@ ChkVariable(expp) if (expp->nd_class == Def && !(expp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) { - node_error(expp, "variable expected"); + Xerror(expp, "variable expected", expp->nd_def); return 0; } @@ -63,7 +77,7 @@ ChkArrow(expp) tp = expp->nd_right->nd_type; if (tp->tp_fund != T_POINTER) { - node_error(expp, "illegal operand for unary operator \"^\""); + node_error(expp, "\"^\": illegal operand"); return 0; } @@ -82,22 +96,18 @@ ChkArr(expp) */ register struct type *tpl, *tpr; + int retval; assert(expp->nd_class == Arrsel); assert(expp->nd_symb == '['); expp->nd_type = error_type; - if ( - !ChkVariable(expp->nd_left) - || - !ChkExpression(expp->nd_right) - || - expp->nd_left->nd_type == error_type - ) return 0; + retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right); 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"); @@ -116,7 +126,7 @@ ChkArr(expp) } expp->nd_type = RemoveEqual(tpl->arr_elem); - return 1; + return retval; } #ifdef DEBUG @@ -168,11 +178,11 @@ ChkLinkOrName(expp) !(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD)) ) ) { - node_error(left, "illegal selection"); + Xerror(left, "illegal selection", left->nd_def); return 0; } - if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope))) { + if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, 1))) { id_not_declared(expp); return 0; } @@ -184,9 +194,7 @@ ChkLinkOrName(expp) /* Fields of a record are always D_QEXPORTED, so ... */ -node_error(expp, "identifier \"%s\" not exported from qualifying module", -df->df_idf->id_text); - return 0; +Xerror(expp, "not exported from qualifying module", df); } } @@ -202,7 +210,6 @@ df->df_idf->id_text); assert(expp->nd_class == Def); df = expp->nd_def; - if (df->df_kind == D_ERROR) return 0; if (df->df_kind & (D_ENUM | D_CONST)) { /* Replace an enum-literal or a CONST identifier by its value. @@ -220,8 +227,7 @@ df->df_idf->id_text); expp->nd_lineno = ln; } } - - return 1; + return df->df_kind != D_ERROR; } STATIC int @@ -238,7 +244,7 @@ ChkExLinkOrName(expp) df = expp->nd_def; if (!(df->df_kind & D_VALUE)) { - node_error(expp, "value expected"); + Xerror(expp, "value expected", df); } if (df->df_kind == D_PROCEDURE) { @@ -352,19 +358,18 @@ ChkSet(expp) /* A type was given. Check it out */ if (! ChkDesignator(nd)) return 0; - assert(nd->nd_class == Def); df = nd->nd_def; if (!is_type(df) || - (df->df_type->tp_fund != T_SET)) { + (df->df_type->tp_fund != T_SET)) { if (df->df_kind != D_ERROR) { -node_error(expp, "type specifier does not represent a set type"); + Xerror(expp, "not a set type", df); } return 0; } tp = df->df_type; - FreeNode(expp->nd_left); + FreeNode(nd); expp->nd_left = 0; } else tp = bitset_type; @@ -412,8 +417,9 @@ node_error(expp, "type specifier does not represent a set type"); } STATIC struct node * -getarg(argp, bases, designator) +getarg(argp, bases, designator, edf) struct node **argp; + struct def *edf; { /* This routine is used to fetch the next argument from an argument list. The argument list is indicated by "argp". @@ -427,7 +433,7 @@ getarg(argp, bases, designator) register struct node *left; if (! arg) { - node_error(*argp, "too few arguments supplied"); + Xerror(*argp, "too few arguments supplied", edf); return 0; } @@ -443,7 +449,7 @@ getarg(argp, bases, designator) if (bases) { if (!(BaseType(left->nd_type)->tp_fund & bases)) { - node_error(arg, "unexpected type"); + Xerror(arg, "unexpected parameter type", edf); return 0; } } @@ -453,8 +459,9 @@ getarg(argp, bases, designator) } STATIC struct node * -getname(argp, kinds) +getname(argp, kinds, bases, edf) struct node **argp; + struct def *edf; { /* Get the next argument from argument list "argp". The argument must indicate a definition, and the @@ -464,7 +471,7 @@ getname(argp, kinds) register struct node *left; if (!arg->nd_right) { - node_error(arg, "too few arguments supplied"); + Xerror(arg, "too few arguments supplied", edf); return 0; } @@ -473,15 +480,22 @@ getname(argp, kinds) if (! ChkDesignator(left)) return 0; if (left->nd_class != Def && left->nd_class != LinkDef) { - node_error(arg, "identifier expected"); + Xerror(arg, "identifier expected", edf); return 0; } if (!(left->nd_def->df_kind & kinds)) { - node_error(arg, "unexpected type"); + 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; + } + } + *argp = arg; return left; } @@ -493,16 +507,25 @@ ChkProcCall(expp) /* Check a procedure call */ register struct node *left; - struct node *arg; + 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) { + edf = left->nd_def; + } expp->nd_type = RemoveEqual(ResultType(left->nd_type)); /* Check parameter list */ for (param = ParamList(left->nd_type); param; param = param->next) { - if (!(left = getarg(&expp, 0, IsVarParam(param)))) return 0; + if (!(left = getarg(&expp, 0, IsVarParam(param), edf))) { + return 0; + } + cnt++; if (left->nd_symb == STRING) { TryToString(left, TypeOfParam(param)); } @@ -510,17 +533,19 @@ ChkProcCall(expp) left->nd_type, IsVarParam(param), left)) { -node_error(left, "type incompatibility in parameter"); - return 0; + sprint(ebuf, "type incompatibility in parameter %d", + cnt); + Xerror(left, ebuf, edf); + retval = 0; } } if (expp->nd_right) { - node_error(expp->nd_right, "too many parameters supplied"); + Xerror(expp->nd_right, "too many parameters supplied", edf); return 0; } - return 1; + return retval; } int @@ -659,11 +684,12 @@ ChkBinOper(expp) register struct node *left, *right; struct type *tpl, *tpr; int allowed; + int retval; left = expp->nd_left; right = expp->nd_right; - if (!ChkExpression(left) || !ChkExpression(right)) return 0; + retval = ChkExpression(left) & ChkExpression(right); tpl = BaseType(left->nd_type); tpr = BaseType(right->nd_type); @@ -695,24 +721,27 @@ ChkBinOper(expp) if (!TstAssCompat(tpl, ElementType(tpr))) { /* Assignment compatible ??? I don't know! Should we be allowed to check - if a CARDINAL is a member of a BITSET??? + if a INTEGER is a member of a BITSET??? */ -node_error(expp, "incompatible types for operator \"IN\""); + node_error(expp, "\"IN\": incompatible types"); return 0; } if (left->nd_class == Value && right->nd_class == Set) { cstset(expp); } - return 1; + return retval; } + if (!retval) return 0; + allowed = AllowedTypes(expp->nd_symb); if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) { if (!((T_CARDINAL & allowed) && ChkAddress(tpl, tpr))) { -node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb)); + node_error(expp, "\"%s\": illegal operand type(s)", + symbol2str(expp->nd_symb)); return 0; } if (expp->nd_type->tp_fund & T_CARDINAL) { @@ -721,16 +750,15 @@ node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_ } if (Boolean(expp->nd_symb) && tpl != bool_type) { -node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb)); - + node_error(expp, "\"%s\": illegal operand type(s)", + symbol2str(expp->nd_symb)); return 0; } /* Operands must be compatible (distilled from Def 8.2) */ if (!TstCompat(tpl, tpr)) { - node_error(expp, "incompatible types for operator \"%s\"", - symbol2str(expp->nd_symb)); + node_error(expp, "\"%s\": incompatible types", symbol2str(expp->nd_symb)); return 0; } @@ -810,14 +838,14 @@ ChkUnOper(expp) default: crash("ChkUnOper"); } - node_error(expp, "illegal operand for unary operator \"%s\"", - symbol2str(expp->nd_symb)); + node_error(expp, "\"%s\": illegal operand", symbol2str(expp->nd_symb)); return 0; } STATIC struct node * -getvariable(argp) +getvariable(argp, edf) struct node **argp; + struct def *edf; { /* Get the next argument from argument list "argp". It must obey the rules of "ChkVariable". @@ -826,7 +854,7 @@ getvariable(argp) arg = arg->nd_right; if (!arg) { - node_error(arg, "too few parameters supplied"); + Xerror(arg, "too few parameters supplied", edf); return 0; } @@ -844,14 +872,16 @@ ChkStandard(expp, left) /* Check a call of a standard procedure or function */ struct node *arg = expp; + register struct def *edf; int std; assert(left->nd_class == Def); std = left->nd_def->df_value.df_stdname; + edf = left->nd_def; switch(std) { case S_ABS: - if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0; + if (!(left = getarg(&arg, T_NUMERIC, 0, edf))) return 0; expp->nd_type = left->nd_type; if (left->nd_class == Value && expp->nd_type->tp_fund != T_REAL) { @@ -861,28 +891,31 @@ ChkStandard(expp, left) case S_CAP: expp->nd_type = char_type; - if (!(left = getarg(&arg, T_CHAR, 0))) return 0; + if (!(left = getarg(&arg, T_CHAR, 0, edf))) return 0; if (left->nd_class == Value) cstcall(expp, S_CAP); break; case S_CHR: expp->nd_type = char_type; - if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0; + if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; if (left->nd_class == Value) cstcall(expp, S_CHR); break; case S_FLOAT: expp->nd_type = real_type; - if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0; + if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; break; case S_HIGH: - if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0))) return 0; + if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0, edf))) { + return 0; + } if (IsConformantArray(left->nd_type)) { - /* A conformant array has no explicit index type - ??? So, what can we use as index-type ??? + /* A conformant array has no explicit index type, + but it is a subrange with lower bound 0, so + it is of type CARDINAL !!! */ - expp->nd_type = intorcard_type; + expp->nd_type = card_type; break; } if (left->nd_type->tp_fund == T_ARRAY) { @@ -890,14 +923,17 @@ ChkStandard(expp, left) cstcall(expp, S_MAX); break; } - if (left->nd_type->tp_fund == T_CHAR) { - if (left->nd_symb != STRING) { - node_error(left,"HIGH: array parameter expected"); - return 0; - } + if (left->nd_symb != STRING) { + Xerror(left,"array parameter expected", edf); + return 0; } - expp->nd_type = intorcard_type; + expp->nd_type = card_type; expp->nd_class = Value; + /* Notice that we could disallow HIGH("") here by checking + that left->nd_type->tp_fund != T_CHAR || left->nd_INT != 0. + ??? For the time being, we don't. !!! + Maybe the empty string should not be allowed at all. + */ expp->nd_INT = left->nd_type->tp_fund == T_CHAR ? 0 : left->nd_SLE - 1; expp->nd_symb = INTEGER; @@ -905,9 +941,7 @@ ChkStandard(expp, left) case S_MAX: case S_MIN: - if (!(left = getname(&arg, D_ISTYPE))) return 0; - if (!(left->nd_type->tp_fund & (T_DISCRETE))) { -node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN"); + if (!(left = getname(&arg, D_ISTYPE, T_DISCRETE, edf))) { return 0; } expp->nd_type = left->nd_type; @@ -915,17 +949,13 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN"); break; case S_ODD: - if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0; + if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; expp->nd_type = bool_type; if (left->nd_class == Value) cstcall(expp, S_ODD); break; case S_ORD: - if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0; - if (left->nd_type->tp_size > word_size) { - node_error(left, "illegal type in argument of ORD"); - return 0; - } + if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0; expp->nd_type = card_type; if (left->nd_class == Value) cstcall(expp, S_ORD); break; @@ -937,12 +967,12 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN"); if (!warning_given) { warning_given = 1; - node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are old-fashioned"); + node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete"); } } - if (! (left = getvariable(&arg))) return 0; + if (! (left = getvariable(&arg, edf))) return 0; if (! (left->nd_type->tp_fund == T_POINTER)) { - node_error(left, "pointer variable expected"); + Xerror(left, "pointer variable expected", edf); return 0; } if (left->nd_class == Def) { @@ -974,23 +1004,19 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN"); case S_TSIZE: /* ??? */ case S_SIZE: expp->nd_type = intorcard_type; - if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE)) return 0; + if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE, 0, edf)) { + return 0; + } cstcall(expp, S_SIZE); break; case S_TRUNC: expp->nd_type = card_type; - if (!(left = getarg(&arg, T_REAL, 0))) return 0; + if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0; break; case S_VAL: - { - struct type *tp; - - if (!(left = getname(&arg, D_ISTYPE))) return 0; - tp = left->nd_def->df_type; - if (!(tp->tp_fund & T_DISCRETE)) { - node_error(arg, "unexpected type"); + if (!(left = getname(&arg, D_ISTYPE, T_DISCRETE, edf))) { return 0; } expp->nd_type = left->nd_def->df_type; @@ -998,26 +1024,25 @@ node_error(left, "illegal type in %s", std == S_MAX ? "MAX" : "MIN"); arg->nd_right = 0; FreeNode(arg); arg = expp; - if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0; + if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0; if (left->nd_class == Value) cstcall(expp, S_VAL); break; - } case S_ADR: expp->nd_type = address_type; - if (!(left = getarg(&arg, 0, 1))) return 0; + if (!(left = getarg(&arg, 0, 1, edf))) return 0; break; case S_DEC: case S_INC: expp->nd_type = 0; - if (! (left = getvariable(&arg))) return 0; + if (! (left = getvariable(&arg, edf))) return 0; if (! (left->nd_type->tp_fund & T_DISCRETE)) { -node_error(left,"illegal type in argument of %s",std == S_INC ? "INC" : "DEC"); + Xerror(left,"illegal parameter type", edf); return 0; } if (arg->nd_right) { - if (! getarg(&arg, T_INTORCARD, 0)) return 0; + if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0; } break; @@ -1031,18 +1056,18 @@ node_error(left,"illegal type in argument of %s",std == S_INC ? "INC" : "DEC"); struct type *tp; expp->nd_type = 0; - if (!(left = getvariable(&arg))) return 0; + if (!(left = getvariable(&arg, edf))) return 0; tp = left->nd_type; if (tp->tp_fund != T_SET) { -node_error(arg, "%s expects a SET parameter", std == S_EXCL ? "EXCL" : "INCL"); + Xerror(arg, "SET parameter expected", edf); return 0; } - if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0; + if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0; if (!TstAssCompat(ElementType(tp), left->nd_type)) { /* What type of compatibility do we want here? apparently assignment compatibility! ??? ??? */ - node_error(arg, "unexpected type"); + Xerror(arg, "unexpected parameter type", edf); return 0; } break; @@ -1053,7 +1078,7 @@ node_error(arg, "%s expects a SET parameter", std == S_EXCL ? "EXCL" : "INCL"); } if (arg->nd_right) { - node_error(arg->nd_right, "too many parameters supplied"); + Xerror(arg->nd_right, "too many parameters supplied", edf); return 0; } @@ -1074,7 +1099,7 @@ ChkCast(expp, left) register struct node *arg = expp->nd_right; if ((! arg) || arg->nd_right) { -node_error(expp, "only one parameter expected in type cast"); + Xerror(expp, "too many parameters in type cast", left->nd_def); return 0; } @@ -1084,7 +1109,7 @@ node_error(expp, "only one parameter expected in type cast"); if (arg->nd_type->tp_size != left->nd_type->tp_size && (arg->nd_type->tp_size > word_size || left->nd_type->tp_size > word_size)) { - node_error(expp, "unequal sizes in type cast"); + Xerror(expp, "unequal sizes in type cast", left->nd_def); } if (arg->nd_class == Value) { @@ -1132,8 +1157,7 @@ no_desig(expp) } STATIC int -done_before(expp) - struct node *expp; +done_before() { return 1; } diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index d5d419ee3..1fbea8be3 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -65,6 +65,7 @@ CodeString(nd) } } +STATIC CodePadString(nd, sz) register struct node *nd; arith sz; @@ -96,7 +97,7 @@ CodeExpr(nd, ds, true_label, false_label) if (tp->tp_fund == T_REAL) fp_used = 1; switch(nd->nd_class) { case Def: - if (nd->nd_def->df_kind == D_PROCEDURE) { + if (nd->nd_def->df_kind & (D_PROCEDURE|D_PROCHEAD)) { C_lpi(NameOfProc(nd->nd_def)); ds->dsg_kind = DSG_LOADED; break; @@ -380,7 +381,7 @@ CodeParameters(param, arg) } } else if (left->nd_symb == STRING) { - C_loc(left->nd_SLE - 1); + C_loc(left->nd_SLE); } else if (tp->arr_elem == word_type) { C_loc((left_type->tp_size+word_size-1) / word_size - 1); @@ -403,8 +404,10 @@ CodeParameters(param, arg) if (left_type->tp_fund == T_STRING) { CodePadString(left, tp->tp_size); } - else CodePExpr(left); - RangeCheck(left_type, tp); + else { + CodePExpr(left); + RangeCheck(left_type, tp); + } } } @@ -413,7 +416,7 @@ CodeStd(nd) { register struct node *arg = nd->nd_right; register struct node *left = 0; - register struct type *tp = 0; + register struct type *tp; int std = nd->nd_left->nd_def->df_value.df_stdname; if (arg) { @@ -426,15 +429,11 @@ CodeStd(nd) case S_ABS: CodePExpr(left); if (tp->tp_fund == T_INTEGER) { - if (tp->tp_size == int_size) { - C_cal("_absi"); - } + if (tp->tp_size == int_size) C_cal("_absi"); else C_cal("_absl"); } else if (tp->tp_fund == T_REAL) { - if (tp->tp_size == float_size) { - C_cal("_absf"); - } + if (tp->tp_size == float_size) C_cal("_absf"); else C_cal("_absd"); } C_asp(tp->tp_size); diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c index aeb9bb8d1..5f743b42d 100644 --- a/lang/m2/comp/cstoper.c +++ b/lang/m2/comp/cstoper.c @@ -72,7 +72,7 @@ cstbin(expp) */ register arith o1 = expp->nd_left->nd_INT; register arith o2 = expp->nd_right->nd_INT; - register int uns = expp->nd_type != int_type; + register int uns = expp->nd_left->nd_type != int_type; assert(expp->nd_class == Oper); assert(expp->nd_left->nd_class == Value); diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index 8a277ed8c..00624af52 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -50,13 +50,14 @@ ProcedureHeading(struct def **pdf; int type;) ; block(struct node **pnd;) : - declaration* - [ { return_occurred = 0; } + [ %persistent + declaration + ]* + { return_occurred = 0; *pnd = 0; } + [ %persistent BEGIN StatementSequence(pnd) - | - { *pnd = 0; } - ] + ]? END ; @@ -72,7 +73,7 @@ declaration: ModuleDeclaration ';' ; -FormalParameters(struct paramlist *ppr; arith *parmaddr; struct type **ptp;): +FormalParameters(struct paramlist **ppr; arith *parmaddr; struct type **ptp;): '(' [ FPSection(ppr, parmaddr) @@ -160,10 +161,15 @@ enumeration(struct type **ptp;) } : '(' IdentList(&EnumList) ')' { - *ptp = standard_type(T_ENUMERATION, 1, (arith) 1); + *ptp = standard_type(T_ENUMERATION, int_align, int_size); EnterEnumList(EnumList, *ptp); - if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */ - error("too many enumeration literals"); + if (ufit((*ptp)->enm_ncst-1, 1)) { + (*ptp)->tp_size = 1; + (*ptp)->tp_align = 1; + } + else if (ufit((*ptp)->enm_ncst-1, short_size)) { + (*ptp)->tp_size = short_size; + (*ptp)->tp_align = short_align; } } ; @@ -263,7 +269,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;) /* Also accept old fashioned Modula-2 syntax, but give a warning. Sorry for the complicated code. */ - [ qualident(0, (struct def **) 0, (char *) 0, &nd1) + [ qualident(&nd1) { nd = nd1; } [ ':' qualtype(&tp) /* This is correct, in both kinds of Modula-2, if @@ -387,7 +393,7 @@ PointerType(struct type **ptp;) } : POINTER TO { *ptp = construct_type(T_POINTER, NULLTYPE); } - [ %if ( lookup(dot.TOK_IDF, CurrentScope) + [ %if ( lookup(dot.TOK_IDF, CurrentScope, 1) /* Either a Module or a Type, but in both cases defined in this scope, so this is the correct identification */ @@ -422,17 +428,33 @@ PointerType(struct type **ptp;) qualtype(struct type **ptp;) { - struct def *df = 0; + register struct node *nd; + struct node *nd1; /* because &nd is illegal */ } : - qualident(D_ISTYPE, &df, "type", (struct node **) 0) - { if (df && !(*ptp = df->df_type)) { - error("type \"%s\" not declared", - df->df_idf->id_text); - *ptp = error_type; - } + qualident(&nd1) + { nd = nd1; + *ptp = error_type; + if (ChkDesignator(nd)) { + if (nd->nd_class != Def) { + node_error(nd, "type expected"); } -; + else { + register struct def *df = nd->nd_def; + if (df->df_kind&(D_ISTYPE|D_FORWARD|D_ERROR)) { + if (! df->df_type) { +node_error(nd,"type \"%s\" not (yet) declared", df->df_idf->id_text); + } + else *ptp = df->df_type; + } + else { +node_error(nd,"identifier \"%s\" is not a type", df->df_idf->id_text); + } + } + } + FreeNode(nd); + } +; ProcedureType(struct type **ptp;) { diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index 226395c3a..dee4b94b1 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -90,9 +90,8 @@ struct def { /* list of definitions for a name */ #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 */ -#define D_DEFINED 0x04 /* set if it is assigned a value */ -#define D_REFERRED 0x08 /* set if it is referred to */ +#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 */ diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c index c57f91548..36c8906a0 100644 --- a/lang/m2/comp/def.c +++ b/lang/m2/comp/def.c @@ -91,14 +91,14 @@ define(id, scope, kind) */ register struct def *df; - df = lookup(id, scope); + df = lookup(id, scope, 1); if ( /* Already in this scope */ df || /* A closed scope, and id defined in the pervasive scope */ ( scopeclosed(scope) && - (df = lookup(id, PervasiveScope))) + (df = lookup(id, PervasiveScope, 1))) ) { switch(df->df_kind) { case D_HIDDEN: @@ -234,7 +234,7 @@ DeclProc(type, id) else { char *name; - df = lookup(id, CurrentScope); + df = lookup(id, CurrentScope, 1); if (df && df->df_kind == D_PROCHEAD) { /* C_exp already generated when we saw the definition in the definition module diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c index aaf49e9df..b381d68b6 100644 --- a/lang/m2/comp/defmodule.c +++ b/lang/m2/comp/defmodule.c @@ -16,6 +16,7 @@ #include "main.h" #include "node.h" #include "type.h" +#include "misc.h" #ifdef DEBUG long sys_filesize(); @@ -57,7 +58,7 @@ GetDefinitionModule(id, incr) struct scopelist *vis; level += incr; - df = lookup(id, GlobalScope); + df = lookup(id, GlobalScope, 1); if (!df) { /* Read definition module. Make an exception for SYSTEM. */ @@ -66,7 +67,7 @@ GetDefinitionModule(id, incr) } else { open_scope(CLOSEDSCOPE); - if (GetFile(id->id_text)) { + if (!is_anon_idf(id) && GetFile(id->id_text)) { DefModule(); if (level == 1) { /* The module is directly imported by @@ -90,14 +91,17 @@ GetDefinitionModule(id, incr) vis = CurrVis; close_scope(SC_CHKFORW); } - df = lookup(id, GlobalScope); + df = lookup(id, GlobalScope, 1); if (! df) { df = MkDef(id, GlobalScope, D_ERROR); df->df_type = error_type; - df->mod_vis = CurrVis; - return df; + df->mod_vis = vis; } } + else if (df == Defined) { + error("cannot import from currently defined module"); + df->df_kind = D_ERROR; + } assert(df); level -= incr; return df; diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c index b8736335c..66d7ab4ec 100644 --- a/lang/m2/comp/desig.c +++ b/lang/m2/comp/desig.c @@ -219,7 +219,6 @@ CodeVarDesig(df, ds) */ assert(ds->dsg_kind == DSG_INIT); - SetUsed(df); if (df->var_addrgiven) { /* the programmer specified an address in the declaration of the variable. Generate code to push the address. @@ -293,7 +292,6 @@ CodeDesig(nd, ds) case Def: df = nd->nd_def; - SetUsed(df); switch(df->df_kind) { case D_FIELD: CodeFieldDesig(df, ds); diff --git a/lang/m2/comp/enter.c b/lang/m2/comp/enter.c index b5c0aa027..04a948e14 100644 --- a/lang/m2/comp/enter.c +++ b/lang/m2/comp/enter.c @@ -273,7 +273,7 @@ ForwDef(ids, scope) */ register struct def *df; - if (!(df = lookup(ids->nd_IDF, scope))) { + if (!(df = lookup(ids->nd_IDF, scope, 1))) { df = define(ids->nd_IDF, scope, D_FORWARD); df->for_node = MkLeaf(Name, &(ids->nd_token)); } @@ -292,9 +292,7 @@ EnterExportList(Idlist, qualified) register struct def *df, *df1; for (;idlist; idlist = idlist->next) { - extern struct def *NoImportlookup(); - - df = NoImportlookup(idlist->nd_IDF, CurrentScope); + df = lookup(idlist->nd_IDF, CurrentScope, 0); if (!df) { /* undefined item in export list @@ -332,7 +330,7 @@ EnterExportList(Idlist, qualified) scope imports it. */ df1 = lookup(idlist->nd_IDF, - enclosing(CurrVis)->sc_scope); + enclosing(CurrVis)->sc_scope, 1); if (df1) { /* It was already defined in the enclosing scope. There are two legal possibilities, @@ -402,7 +400,7 @@ EnterFromImportList(Idlist, FromDef, FromId) for (; idlist; idlist = idlist->next) { if (forwflag) df = ForwDef(idlist, vis->sc_scope); - else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope))) { + else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 1))) { not_declared("identifier", idlist, " in qualifying module"); df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR); } @@ -434,7 +432,7 @@ EnterImportList(Idlist, local) for (; idlist; idlist = idlist->next) { DoImport(local ? ForwDef(idlist, sc) : - GetDefinitionModule(idlist->nd_IDF) , + GetDefinitionModule(idlist->nd_IDF, 1) , CurrentScope); } FreeNode(Idlist); diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 0baa3356e..787669bda 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -31,39 +31,13 @@ number(struct node **p;) : } ; -qualident(int types; - struct def **pdf; - char *str; - struct node **p; - ) +qualident(struct node **p;) { - struct node *nd; } : - IDENT { nd = MkLeaf(Name, &dot); } + IDENT { *p = MkLeaf(Name, &dot); } [ - selector(&nd) + selector(p) ]* - { if (types && ChkDesignator(nd)) { - if (nd->nd_class != Def) { - node_error(nd, "%s expected", str); - } - else { - register struct def *df = nd->nd_def; - - if ( !((types|D_ERROR) & df->df_kind)) { - if (df->df_kind == D_FORWARD) { - not_declared(str, nd, ""); - } - else { -node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str); - } - } - if (pdf) *pdf = df; - } - } - if (!p) FreeNode(nd); - else *p = nd; - } ; selector(struct node **pnd;): @@ -167,7 +141,7 @@ factor(register struct node **p;) { struct node *nd; } : - qualident(0, (struct def **) 0, (char *) 0, p) + qualident(p) [ designator_tail(p)? [ @@ -231,7 +205,7 @@ element(struct node *nd;) designator(struct node **pnd;) : - qualident(0, (struct def **) 0, (char *) 0, pnd) + qualident(pnd) designator_tail(pnd)? ; diff --git a/lang/m2/comp/lookup.c b/lang/m2/comp/lookup.c index 599cf77fc..c4c297a09 100644 --- a/lang/m2/comp/lookup.c +++ b/lang/m2/comp/lookup.c @@ -15,7 +15,7 @@ #include "misc.h" struct def * -lookup(id, scope) +lookup(id, scope, import) register struct idf *id; struct scope *scope; { @@ -43,7 +43,7 @@ lookup(id, scope) df->next = id->id_def; id->id_def = df; } - if (df->df_kind == D_IMPORT) { + if (import && df->df_kind == D_IMPORT) { assert(df->imp_def != 0); return df->imp_def; } @@ -51,38 +51,6 @@ lookup(id, scope) return df; } -struct def * -NoImportlookup(id, scope) - register struct idf *id; - struct scope *scope; -{ - /* Look up a definition of an identifier in scope "scope". - Make the "def" list self-organizing. - Don't check if the definition is imported! - */ - register struct def *df, *df1; - - /* Look in the chain of definitions of this "id" for one with scope - "scope". - */ - for (df = id->id_def, df1 = 0; - df && df->df_scope != scope; - df1 = df, df = df->next) { /* nothing */ } - - if (df) { - /* Found it - */ - if (df1) { - /* Put the definition in front - */ - df1->next = df->next; - df->next = id->id_def; - id->id_def = df; - } - } - return df; -} - struct def * lookfor(id, vis, give_error) register struct node *id; @@ -96,7 +64,7 @@ lookfor(id, vis, give_error) register struct scopelist *sc = vis; while (sc) { - df = lookup(id->nd_IDF, sc->sc_scope); + df = lookup(id->nd_IDF, sc->sc_scope, 1); if (df) return df; sc = nextvisible(sc); } diff --git a/lang/m2/comp/options.c b/lang/m2/comp/options.c index 782c67a53..8bdea33c4 100644 --- a/lang/m2/comp/options.c +++ b/lang/m2/comp/options.c @@ -10,6 +10,13 @@ #include "main.h" #include "warning.h" +#define MINIDFSIZE 14 + +#if MINIDFSIZE < 14 +You fouled up! MINIDFSIZE has to be at least 14 or the compiler will not +recognize some keywords! +#endif + extern int idfsize; static int ndirs; int warning_classes; @@ -72,8 +79,14 @@ DoOption(text) idfsize = txt2int(&t); if (*t || idfsize <= 0) fatal("malformed -M option"); - if (idfsize > IDFSIZE) - fatal("maximum identifier length is %d", IDFSIZE); + if (idfsize > IDFSIZE) { + idfsize = IDFSIZE; + warning(W_ORDINARY,"maximum identifier length is %d", IDFSIZE); + } + if (idfsize < MINIDFSIZE) { + warning(W_ORDINARY, "minimum identifier length is %d", MINIDFSIZE); + idfsize = MINIDFSIZE; + } } break; @@ -113,6 +126,10 @@ DoOption(text) if (size != (arith)0) int_size = size; if (align != 0) int_align = align; break; + case 's': /* short (subranges) */ + if (size != 0) short_size = size; + if (align != 0) short_align = align; + break; case 'l': /* longint */ if (size != (arith)0) long_size = size; if (align != 0) long_align = align; diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g index afaeb7220..100c55dfb 100644 --- a/lang/m2/comp/program.g +++ b/lang/m2/comp/program.g @@ -133,7 +133,7 @@ DefinitionModule modules. Issue a warning. */ { -node_warning(exportlist, W_ORDINARY, "export list in definition module ignored"); +node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignored"); FreeNode(exportlist); } | @@ -183,7 +183,7 @@ definition ProgramModule { - struct def *GetDefinitionModule(); + extern struct def *GetDefinitionModule(); register struct def *df; } : MODULE @@ -210,7 +210,9 @@ ProgramModule ; Module: - { open_scope(CLOSEDSCOPE); } + { open_scope(CLOSEDSCOPE); + warning(W_ORDINARY, "Compiling a definition module"); + } DefinitionModule { close_scope(SC_CHKFORW); } | diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index 0e612f20e..d8a345a7c 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -103,6 +103,7 @@ extern struct type extern int word_align, + short_align, int_align, long_align, float_align, @@ -113,6 +114,7 @@ extern int extern arith word_size, dword_size, + short_size, int_size, long_size, float_size, @@ -149,3 +151,8 @@ struct type #define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \ (tpx)) #define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED) + +extern long full_mask[]; + +#define fit(n, i) (((n) + (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 13fac5323..e76565805 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -21,6 +21,7 @@ int word_align = AL_WORD, + short_align = AL_SHORT, int_align = AL_INT, long_align = AL_LONG, float_align = AL_FLOAT, @@ -32,6 +33,7 @@ arith word_size = SZ_WORD, dword_size = 2 * SZ_WORD, int_size = SZ_INT, + short_size = SZ_SHORT, long_size = SZ_LONG, float_size = SZ_FLOAT, double_size = SZ_DOUBLE, @@ -280,6 +282,27 @@ subr_type(lb, ub) res->sub_ub = ub->nd_INT; res->tp_size = tp->tp_size; res->tp_align = tp->tp_align; + if (tp == card_type) { + if (ufit(res->sub_ub, 1)) { + res->tp_size = 1; + res->tp_align = 1; + } + else if (ufit(res->sub_ub, 2)) { + res->tp_size = short_size; + res->tp_align = short_align; + } + } + else if (tp == int_type) { + if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) { + res->tp_size = 1; + res->tp_align = 1; + } + else if (fit(res->sub_lb, short_size) && + fit(res->sub_ub, short_size)) { + res->tp_size = short_size; + res->tp_align = short_align; + } + } return res; } diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index 1672cf58b..5eb55204a 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -636,9 +636,9 @@ DoForInit(nd, left) nd->nd_class = Name; nd->nd_symb = IDENT; - if (! ChkVariable(nd) || - ! WalkExpr(left->nd_left) || - ! ChkExpression(left->nd_right)) return 0; + if (!( ChkVariable(nd) & + WalkExpr(left->nd_left) & + ChkExpression(left->nd_right))) return 0; df = nd->nd_def; if (df->df_kind == D_FIELD) { @@ -696,17 +696,17 @@ DoAssign(nd, left, right) */ struct desig dsl, dsr; - if (! ChkExpression(right) || ! ChkVariable(left)) return; + if (! (ChkExpression(right) & ChkVariable(left))) return; if (right->nd_symb == STRING) TryToString(right, left->nd_type); dsr = InitDesig; - CodeExpr(right, &dsr, NO_LABEL, NO_LABEL); if (! TstAssCompat(left->nd_type, right->nd_type)) { node_error(nd, "type incompatibility in assignment"); return; } + CodeExpr(right, &dsr, NO_LABEL, NO_LABEL); if (complex(right->nd_type)) { CodeAddress(&dsr); }