From: ceriel Date: Thu, 25 Sep 1986 19:39:06 +0000 (+0000) Subject: many bug fixes X-Git-Tag: release-5-5~5217 X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=c3d4d40d1bc6e908cdcb89e3059d6b25a141d7a8;p=ack.git many bug fixes --- diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index 20d08b3bd..d97afee18 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -25,10 +25,10 @@ static char *RcsId = "$Header$"; long str2long(); -struct token dot, aside; -struct type *toktype; -struct string string; -int idfsize = IDFSIZE; +struct token dot, + aside; +struct type *toktype; +int idfsize = IDFSIZE; #ifdef DEBUG extern int cntlines; #endif @@ -40,10 +40,9 @@ SkipComment() Note that comments may be nested (par. 3.5). */ register int ch; - register int NestLevel = 0; - LoadChar(ch); for (;;) { + LoadChar(ch); if (class(ch) == STNL) { LineNumber++; #ifdef DEBUG @@ -52,32 +51,26 @@ SkipComment() } else if (ch == '(') { LoadChar(ch); - if (ch == '*') ++NestLevel; - else continue; + if (ch == '*') SkipComment(); } else if (ch == '*') { LoadChar(ch); - if (ch == ')') { - if (NestLevel-- == 0) return; - } - else continue; + if (ch == ')') break; } - LoadChar(ch); } } -STATIC +STATIC struct string * GetString(upto) { /* Read a Modula-2 string, delimited by the character "upto". */ register int ch; - register struct string *str = &string; + register struct string *str = (struct string *) Malloc(sizeof(struct string)); register char *p; str->s_str = p = Malloc((unsigned int) (str->s_length = ISTRSIZE)); - LoadChar(ch); - while (ch != upto) { + while (LoadChar(ch), ch != upto) { if (class(ch) == STNL) { lexerror("newline in string"); LineNumber++; @@ -86,7 +79,7 @@ GetString(upto) #endif break; } - if (ch == EOI) { + if (ch == EOI) { lexerror("end-of-file in string"); break; } @@ -97,10 +90,10 @@ GetString(upto) p = str->s_str + str->s_length; str->s_length += RSTRSIZE; } - LoadChar(ch); } *p = '\0'; str->s_length = p - str->s_str; + return str; } int @@ -131,15 +124,15 @@ again: switch (class(ch)) { - case STSKIP: - goto again; - case STNL: LineNumber++; #ifdef DEBUG cntlines++; #endif tk->tk_lineno++; + /* Fall Through */ + + case STSKIP: goto again; case STGARB: @@ -172,15 +165,13 @@ again: if (nch == '.') { return tk->tk_symb = UPTO; } - PushBack(nch); - return tk->tk_symb = ch; + break; case ':': if (nch == '=') { return tk->tk_symb = BECOMES; } - PushBack(nch); - return tk->tk_symb = ch; + break; case '<': if (nch == '=') { @@ -190,50 +181,52 @@ again: lexwarning("'<>' is old-fashioned; use '#'"); return tk->tk_symb = '#'; } - PushBack(nch); - return tk->tk_symb = ch; + break; case '>': if (nch == '=') { return tk->tk_symb = GREATEREQUAL; } - PushBack(nch); - return tk->tk_symb = ch; + break; default : crash("(LLlex, STCOMP)"); } + PushBack(nch); + return tk->tk_symb = ch; case STIDF: { - register char *tg = &buf[0]; + register char *tag = &buf[0]; register struct idf *id; do { - if (tg - buf < idfsize) *tg++ = ch; + if (tag - buf < idfsize) *tag++ = ch; LoadChar(ch); } while(in_idf(ch)); if (ch != EOI) PushBack(ch); - *tg++ = '\0'; + *tag++ = '\0'; tk->TOK_IDF = id = str2idf(buf, 1); return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT; } - case STSTR: - GetString(ch); - if (string.s_length == 1) { - tk->TOK_INT = *(string.s_str) & 0377; + case STSTR: { + register struct string *str = GetString(ch); + + if (str->s_length == 1) { + tk->TOK_INT = *(str->s_str) & 0377; toktype = char_type; + free(str->s_str); + free((char *) str); } else { - tk->tk_data.tk_str = (struct string *) - Malloc(sizeof (struct string)); - *(tk->tk_data.tk_str) = string; - toktype = standard_type(T_STRING, 1, string.s_length); + tk->tk_data.tk_str = str; + toktype = standard_type(T_STRING, 1, str->s_length); } return tk->tk_symb = STRING; + } case STNUM: { @@ -241,172 +234,157 @@ again: is that we don't know the base in advance so we have to read the number with the help of a rather complex finite automaton. - Excuses for the very ugly code! */ + enum statetp {Oct,Hex,Dec,OctEndOrHex,End,OptReal,Real}; + register enum statetp state; + register int base; register char *np = &buf[1]; /* allow a '-' to be added */ buf[0] = '-'; *np++ = ch; - + state = is_oct(ch) ? Oct : Dec; LoadChar(ch); - while (is_oct(ch)) { - if (np < &buf[NUMSIZE]) { - *np++ = ch; - } - LoadChar(ch); - } - switch (ch) { - case 'H': -Shex: *np++ = '\0'; - tk->TOK_INT = str2long(&buf[1], 16); - if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) { - toktype = intorcard_type; - } - else toktype = card_type; - return tk->tk_symb = INTEGER; - - case '8': - case '9': - do { - if (np < &buf[NUMSIZE]) { - *np++ = ch; + for (;;) { + switch(state) { + case Oct: + while (is_oct(ch)) { + if (np < &buf[NUMSIZE]) *np++ = ch; + LoadChar(ch); + } + if (ch == 'B' || ch == 'C') { + base = 8; + state = OctEndOrHex; + break; + } + /* Fall Through */ + case Dec: + base = 10; + while (is_dig(ch)) { + if (np < &buf[NUMSIZE]) { + *np++ = ch; + } + LoadChar(ch); + } + if (is_hex(ch)) state = Hex; + else if (ch == '.') state = OptReal; + else { + state = End; + if (ch == 'H') base = 16; + else PushBack(ch); } + break; + + case Hex: + while (is_hex(ch)) { + if (np < &buf[NUMSIZE]) *np++ = ch; + LoadChar(ch); + } + base = 16; + state = End; + if (ch != 'H') { + lexerror("H expected after hex number"); + PushBack(ch); + } + break; + + case OctEndOrHex: + if (np < &buf[NUMSIZE]) *np++ = ch; LoadChar(ch); - } while (is_dig(ch)); - - if (is_hex(ch)) - goto S2; - if (ch == 'H') - goto Shex; - if (ch == '.') - goto Sreal; - PushBack(ch); - goto Sdec; - - case 'B': - case 'C': - if (np < &buf[NUMSIZE]) { - *np++ = ch; - } - LoadChar(ch); - if (ch == 'H') - goto Shex; - if (is_hex(ch)) - goto S2; - PushBack(ch); - ch = *--np; - *np++ = '\0'; - tk->TOK_INT = str2long(&buf[1], 8); - if (ch == 'C') { - toktype = char_type; - if (tk->TOK_INT < 0 || tk->TOK_INT > 255) { + if (ch == 'H') { + base = 16; + state = End; + break; + } + if (is_hex(ch)) { + state = Hex; + break; + } + PushBack(ch); + ch = *--np; + *np++ = '\0'; + base = 8; + /* Fall through */ + + case End: + *np++ = '\0'; + tk->TOK_INT = str2long(&buf[1], base); + if (ch == 'C' && base == 8) { + toktype = char_type; + if (tk->TOK_INT<0 || tk->TOK_INT>255) { lexwarning("Character constant out of range"); + } } - } - else if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) { - toktype = intorcard_type; - } - else toktype = card_type; - return tk->tk_symb = INTEGER; - - case 'A': - case 'D': - case 'E': - case 'F': -S2: - do { - if (np < &buf[NUMSIZE]) { - *np++ = ch; + else if (tk->TOK_INT>=0 && + tk->TOK_INT<=max_int) { + toktype = intorcard_type; } + else toktype = card_type; + return tk->tk_symb = INTEGER; + + case OptReal: + /* The '.' could be the first of the '..' + token. At this point, we need a + look-ahead of two characters. + */ LoadChar(ch); - } while (is_hex(ch)); - if (ch != 'H') { - lexerror("H expected after hex number"); - PushBack(ch); + if (ch == '.') { + /* Indeed the '..' token + */ + PushBack(ch); + PushBack(ch); + state = End; + base = 10; + break; + } + state = Real; + break; } - goto Shex; + if (state == Real) break; + } - case '.': -Sreal: - /* This '.' could be the first of the '..' - token. At this point, we need a look-ahead - of two characters. + /* a real real constant */ + if (np < &buf[NUMSIZE]) *np++ = '.'; + + while (is_dig(ch)) { + /* Fractional part */ + if (np < &buf[NUMSIZE]) *np++ = ch; LoadChar(ch); - if (ch == '.') { - /* Indeed the '..' token - */ - PushBack(ch); - PushBack(ch); - goto Sdec; - } + } - /* a real constant */ - if (np < &buf[NUMSIZE]) { - *np++ = '.'; + if (ch == 'E') { + /* Scale factor + */ + if (np < &buf[NUMSIZE]) *np++ = 'E'; + LoadChar(ch); + if (ch == '+' || ch == '-') { + /* Signed scalefactor + */ + if (np < &buf[NUMSIZE]) *np++ = ch; + LoadChar(ch); } - if (is_dig(ch)) { - /* Fractional part - */ do { - if (np < &buf[NUMSIZE]) { - *np++ = ch; - } + if (np < &buf[NUMSIZE]) *np++ = ch; LoadChar(ch); } while (is_dig(ch)); } - - if (ch == 'E') { - /* Scale factor - */ - if (np < &buf[NUMSIZE]) { - *np++ = 'E'; - } - LoadChar(ch); - if (ch == '+' || ch == '-') { - /* Signed scalefactor - */ - if (np < &buf[NUMSIZE]) { - *np++ = ch; - } - LoadChar(ch); - } - if (is_dig(ch)) { - do { - if (np < &buf[NUMSIZE]) { - *np++ = ch; - } - LoadChar(ch); - } while (is_dig(ch)); - } - else { - lexerror("bad scale factor"); - } + else { + lexerror("bad scale factor"); } + } - PushBack(ch); + PushBack(ch); - if (np == &buf[NUMSIZE + 1]) { - tk->TOK_REL = Salloc("0.0", 5); - lexerror("floating constant too long"); - } - else tk->TOK_REL = Salloc(buf, np - buf) + 1; - toktype = real_type; - return tk->tk_symb = REAL; - - default: - PushBack(ch); -Sdec: - *np++ = '\0'; - tk->TOK_INT = str2long(&buf[1], 10); - if (tk->TOK_INT < 0 || tk->TOK_INT > max_int) { - toktype = card_type; - } - else toktype = intorcard_type; - return tk->tk_symb = INTEGER; + if (np >= &buf[NUMSIZE]) { + tk->TOK_REL = Salloc("0.0", 5); + lexerror("floating constant too long"); } + else tk->TOK_REL = Salloc(buf, np - buf) + 1; + toktype = real_type; + return tk->tk_symb = REAL; + /*NOTREACHED*/ } diff --git a/lang/m2/comp/LLlex.h b/lang/m2/comp/LLlex.h index 8ba0bd944..16495e10b 100644 --- a/lang/m2/comp/LLlex.h +++ b/lang/m2/comp/LLlex.h @@ -2,13 +2,17 @@ /* $Header$ */ +/* Structure to store a string constant +*/ struct string { - arith s_length; /* length of a string */ - char *s_str; /* the string itself */ + arith s_length; /* length of a string */ + char *s_str; /* the string itself */ }; +/* Token structure. Keep it small, as it is part of a parse-tree node +*/ struct token { - short tk_symb; /* token itself */ + short tk_symb; /* token itself */ unsigned short tk_lineno; /* linenumber on which it occurred */ union { struct idf *tk_idf; /* IDENT */ diff --git a/lang/m2/comp/LLmessage.c b/lang/m2/comp/LLmessage.c index ffb3d80b6..3fabfbc6c 100644 --- a/lang/m2/comp/LLmessage.c +++ b/lang/m2/comp/LLmessage.c @@ -20,12 +20,11 @@ static char *RcsId = "$Header$"; extern char *symbol2str(); extern struct idf *gen_anon_idf(); -int err_occurred = 0; +extern int err_occurred; LLmessage(tk) int tk; { - ++err_occurred; if (tk) { /* if (tk != 0), it represents the token to be inserted. otherwize, the current token is deleted diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index 25407363f..02c58fe24 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -11,7 +11,7 @@ INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR) LSRC = tokenfile.g program.g declar.g expression.g statement.g CC = cc LLGENOPTIONS = -PROFILE = +PROFILE = CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC= LINTFLAGS = -DSTATIC= -DNORCSID LFLAGS = $(PROFILE) @@ -52,13 +52,13 @@ lint: Cfiles @rm -f nmclash.o a.out mkdep: mkdep.o - $(CC) -o mkdep mkdep.o + $(CC) $(LFLAGS) -o mkdep mkdep.o cclash: cclash.o - $(CC) -o cclash cclash.o + $(CC) $(LFLAGS) -o cclash cclash.o cid: cid.o - $(CC) -o cid cid.o + $(CC) $(LFLAGS) -o cid cid.o # entry points not to be used directly diff --git a/lang/m2/comp/Resolve b/lang/m2/comp/Resolve new file mode 100755 index 000000000..cabad11d5 --- /dev/null +++ b/lang/m2/comp/Resolve @@ -0,0 +1,43 @@ +case $# in +1) + ;; +*) echo "$0: one argument expected" 1>&2 + exit 1 + ;; +esac +case $1 in +main) + ;; +Xlint) + ;; +*) echo "$0: $1: Illegal argument" 1>&2 + exit 1 + ;; +esac +if test -d ../Xsrc +then + : +else mkdir ../Xsrc +fi +make cclash +make cid +./cclash -c -l7 `cat Cfiles` > clashes +sed '/^C_/d' < clashes > ../Xsrc/Xclashes +cd ../Xsrc +if cmp -s Xclashes clashes +then + : +else + mv Xclashes clashes +fi +rm -f Makefile +for i in `cat ../src/Cfiles` +do + cat >> Makefile < $i + +EOF +done +make `cat ../src/Cfiles` +make -f ../src/Makefile $1 diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index ae2571ebe..981b98069 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -64,7 +64,7 @@ ChkArrow(expp) return 0; } - expp->nd_type = PointedtoType(tp); + expp->nd_type = RemoveEqual(PointedtoType(tp)); return 1; } @@ -106,7 +106,7 @@ ChkArr(expp) return 0; } - expp->nd_type = tpl->arr_elem; + expp->nd_type = RemoveEqual(tpl->arr_elem); return 1; } @@ -137,7 +137,7 @@ ChkLinkOrName(expp) if (expp->nd_class == Name) { expp->nd_def = lookfor(expp, CurrVis, 1); expp->nd_class = Def; - expp->nd_type = expp->nd_def->df_type; + expp->nd_type = RemoveEqual(expp->nd_def->df_type); } else if (expp->nd_class == Link) { register struct node *left = expp->nd_left; @@ -161,7 +161,7 @@ ChkLinkOrName(expp) } else { expp->nd_def = df; - expp->nd_type = df->df_type; + 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, @@ -418,19 +418,17 @@ getarg(argp, bases, designator) variable. */ struct type *tp; - register struct node *arg = *argp; + register struct node *arg = (*argp)->nd_right; register struct node *left; - if (! arg->nd_right) { - node_error(arg, "too few arguments supplied"); + if (! arg) { + node_error(*argp, "too few arguments supplied"); return 0; } - arg = arg->nd_right; left = arg->nd_left; - if ((!designator && !ChkExpression(left)) || - (designator && !ChkVariable(left))) { + if (designator ? !ChkVariable(left) : !ChkExpression(left)) { return 0; } @@ -438,11 +436,12 @@ getarg(argp, bases, designator) left->nd_def->df_flags |= D_NOREG; } - tp = BaseType(left->nd_type); - - if (bases && !(tp->tp_fund & bases)) { - node_error(arg, "unexpected type"); - return 0; + if (bases) { + tp = BaseType(left->nd_type); + if (!(tp->tp_fund & bases)) { + node_error(arg, "unexpected type"); + return 0; + } } *argp = arg; @@ -489,14 +488,14 @@ ChkProcCall(expp) left = expp->nd_left; arg = expp; - expp->nd_type = ResultType(left->nd_type); + expp->nd_type = RemoveEqual(ResultType(left->nd_type)); for (param = ParamList(left->nd_type); param; param = param->next) { if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0; if (left->nd_symb == STRING) { TryToString(left, TypeOfParam(param)); } - if (! TstParCompat(TypeOfParam(param), + if (! TstParCompat(RemoveEqual(TypeOfParam(param)), left->nd_type, IsVarParam(param), left)) { @@ -689,15 +688,29 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R } allowed = AllowedTypes(expp->nd_symb); - if (!(tpl->tp_fund & allowed) || - (tpl != bool_type && Boolean(expp->nd_symb))) { - if (!(tpl->tp_fund == T_POINTER && - (T_CARDINAL & allowed) && - ChkAddress(tpl, tpr))) { + + /* Check that the application of the operator is allowed on the type + of the operands. + There are two tricky parts: + - Boolean operators are only allowed on boolean operands, but + the "allowed-mask" of "AllowedTypes" can only indicate + an enumeration type. + - All operations that are allowed on CARDINALS are also allowed + on ADDRESS. + */ + if (Boolean(expp->nd_symb) && tpl != bool_type) { +node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb)); + + return 0; + } + if (!(tpl->tp_fund & allowed)) { + if (!(tpl->tp_fund == T_POINTER && + (T_CARDINAL & allowed) && + ChkAddress(tpl, tpr))) { node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb)); return 0; } - expp->nd_type = card_type; + if (expp->nd_type == card_type) expp->nd_type = address_type; } if (tpl->tp_fund == T_SET) { @@ -1058,6 +1071,9 @@ TryToString(nd, tp) { /* Try a coercion from character constant to string. */ + + assert(nd->nd_symb == STRING); + if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) { int ch = nd->nd_INT; diff --git a/lang/m2/comp/class.h b/lang/m2/comp/class.h index 72341981c..5fb0f3d2e 100644 --- a/lang/m2/comp/class.h +++ b/lang/m2/comp/class.h @@ -29,10 +29,10 @@ class. This is implemented as a collection of tables to speed up the decision whether a character has a special meaning. */ -#define in_idf(ch) (inidf[ch]) -#define is_oct(ch) (isoct[ch]) -#define is_dig(ch) (isdig[ch]) -#define is_hex(ch) (ishex[ch]) +#define in_idf(ch) ((unsigned)ch < 0177 && inidf[ch]) +#define is_oct(ch) ((unsigned)ch < 0177 && isoct[ch]) +#define is_dig(ch) ((unsigned)ch < 0177 && isdig[ch]) +#define is_hex(ch) ((unsigned)ch < 0177 && ishex[ch]) extern char tkclass[]; extern char inidf[], isoct[], isdig[], ishex[]; diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index acfeda5ef..d70f2f3e3 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -55,7 +55,7 @@ CodeString(nd) { label lab; - if (nd->nd_type == char_type) { + if (nd->nd_type->tp_fund != T_STRING) { C_loc(nd->nd_INT); } else { @@ -237,6 +237,7 @@ CodeCoercion(t1, t2) case T_CHAR: case T_CARDINAL: case T_POINTER: + case T_EQUAL: case T_INTORCARD: if (t2->tp_size > word_size) { C_loc(word_size); @@ -353,7 +354,7 @@ CodeParameters(param, arg) register struct type *tp; register struct node *left; register struct type *left_type; - + assert(param != 0 && arg != 0); if (param->next) { @@ -406,7 +407,7 @@ CodeParameters(param, arg) CodePadString(left, tp->tp_size); } else CodePExpr(left); - CheckAssign(left_type, tp); + RangeCheck(left_type, tp); } } @@ -451,7 +452,7 @@ CodeStd(nd) case S_CHR: CodePExpr(left); - CheckAssign(char_type, tp); + RangeCheck(char_type, tp); break; case S_FLOAT: @@ -489,7 +490,7 @@ CodeStd(nd) case S_VAL: CodePExpr(left); - CheckAssign(nd->nd_type, tp); + RangeCheck(nd->nd_type, tp); break; case S_ADR: @@ -510,7 +511,7 @@ CodeStd(nd) if (tp->tp_fund == T_INTEGER) C_adi(word_size); else C_adu(word_size); } - CheckAssign(tp, int_type); + RangeCheck(tp, int_type); } else { CodeCoercion(int_type, tp); @@ -576,7 +577,7 @@ CodeAssign(nd, dss, dst) C_blm(nd->nd_left->nd_type->tp_size); } -CheckAssign(tpl, tpr) +RangeCheck(tpl, tpr) register struct type *tpl, *tpr; { /* Generate a range check if neccessary @@ -634,6 +635,7 @@ CodeOper(expr, true_label, false_label) C_adf(tp->tp_size); break; case T_POINTER: + case T_EQUAL: case T_CARDINAL: case T_INTORCARD: C_adu(tp->tp_size); @@ -655,6 +657,7 @@ CodeOper(expr, true_label, false_label) C_sbf(tp->tp_size); break; case T_POINTER: + case T_EQUAL: case T_CARDINAL: case T_INTORCARD: C_sbu(tp->tp_size); @@ -674,6 +677,7 @@ CodeOper(expr, true_label, false_label) C_mli(tp->tp_size); break; case T_POINTER: + case T_EQUAL: case T_CARDINAL: case T_INTORCARD: C_mlu(tp->tp_size); @@ -708,6 +712,7 @@ CodeOper(expr, true_label, false_label) C_dvi(tp->tp_size); break; case T_POINTER: + case T_EQUAL: case T_CARDINAL: case T_INTORCARD: C_dvu(tp->tp_size); @@ -723,6 +728,7 @@ CodeOper(expr, true_label, false_label) C_rmi(tp->tp_size); break; case T_POINTER: + case T_EQUAL: case T_CARDINAL: case T_INTORCARD: C_rmu(tp->tp_size); @@ -744,8 +750,9 @@ CodeOper(expr, true_label, false_label) case T_INTEGER: C_cmi(tp->tp_size); break; - case T_HIDDEN: case T_POINTER: + case T_EQUAL: + case T_HIDDEN: case T_CARDINAL: case T_INTORCARD: C_cmu(tp->tp_size); diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index a9fdac975..167bcf997 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -31,7 +31,7 @@ int return_occurred; /* set if a return occurred in a ProcedureDeclaration { register struct def *df; - struct def *df1; + struct def *df1; /* only exists because &df is illegal */ } : { ++proclevel; return_occurred = 0; @@ -53,9 +53,10 @@ error("function procedure %s does not return a value", df->df_idf->id_text); ProcedureHeading(struct def **pdf; int type;) { struct paramlist *params = 0; - struct type *tp = 0; + register struct type *tp; + struct type *tp1 = 0; register struct def *df; - arith NBytesParams; + arith NBytesParams; /* parameter offset counter */ } : PROCEDURE IDENT { df = DeclProc(type); @@ -64,8 +65,8 @@ ProcedureHeading(struct def **pdf; int type;) } else NBytesParams = 0; } - FormalParameters(¶ms, &tp, &NBytesParams)? - { tp = construct_type(T_PROCEDURE, tp); + FormalParameters(¶ms, &tp1, &NBytesParams)? + { tp = construct_type(T_PROCEDURE, tp1); tp->prc_params = params; tp->prc_nbpar = NBytesParams; if (df->df_type) { @@ -151,7 +152,7 @@ TypeDeclaration struct def *df; struct type *tp; }: - IDENT { df = define(dot.TOK_IDF,CurrentScope,D_TYPE); } + IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); } '=' type(&tp) { DeclareType(df, tp); } ; @@ -398,9 +399,7 @@ node_error(nd1,"type incompatibility in case label"); } ; -SetType(struct type **ptp;) -{ -} : +SetType(struct type **ptp;) : SET OF SimpleType(ptp) { *ptp = set_type(*ptp); } ; @@ -411,7 +410,6 @@ SetType(struct type **ptp;) */ PointerType(struct type **ptp;) { - register struct def *df; register struct node *nd; } : POINTER TO @@ -422,10 +420,9 @@ PointerType(struct type **ptp;) */ qualtype(&((*ptp)->next)) | %if ( nd = new_node(), nd->nd_token = dot, - df = lookfor(nd, CurrVis, 0), - df->df_kind == D_MODULE) + lookfor(nd, CurrVis, 0)->df_kind == D_MODULE) + { if (dot.tk_symb == IDENT) free_node(nd); } type(&((*ptp)->next)) - { free_node(nd); } | IDENT { Forward(nd, (*ptp)); } ] @@ -436,11 +433,10 @@ qualtype(struct type **ptp;) struct def *df; } : qualident(D_ISTYPE, &df, "type", (struct node **) 0) - { if (!df->df_type) { + { if (!(*ptp = df->df_type)) { error("type \"%s\" not declared", df->df_idf->id_text); *ptp = error_type; } - else *ptp = df->df_type; } ; diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index 774fd798a..56431ae62 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -113,6 +113,8 @@ struct def { /* list of definitions for a name */ } df_value; }; +#define SetUsed(df) ((df)->df_flags |= D_USED) + /* ALLOCDEF "def" */ extern struct def diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c index 8c189150c..04b43ebe6 100644 --- a/lang/m2/comp/def.c +++ b/lang/m2/comp/def.c @@ -60,6 +60,7 @@ InitDef() struct idf *gen_anon_idf(); ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR); + ill_df->df_type = error_type; } struct def * @@ -204,7 +205,6 @@ DeclProc(type) sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text); df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1)); if (CurrVis == Defined->mod_vis) C_exp(df->for_name); - open_scope(OPENSCOPE); } else { df = lookup(dot.TOK_IDF, CurrentScope); diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c index f33a589d4..c9fca7264 100644 --- a/lang/m2/comp/desig.c +++ b/lang/m2/comp/desig.c @@ -166,18 +166,17 @@ CodeFieldDesig(df, ds) in "ds". "df" indicates the definition of the field. */ - register struct withdesig *wds; if (ds->dsg_kind == DSG_INIT) { /* In a WITH statement. We must find the designator in the WITH statement, and act as if the field is a selection of this designator. So, first find the right WITH statement, which is the - first one of the proper record type. - Notice that the proper record type is recognized by its - scope indication. + first one of the proper record type, which is + recognized by its scope indication. */ - wds = WithDesigs; + register struct withdesig *wds = WithDesigs; + assert(wds != 0); while (wds->w_scope != df->df_scope) { @@ -225,7 +224,7 @@ CodeVarDesig(df, ds) */ assert(ds->dsg_kind == DSG_INIT); - df->df_flags |= D_USED; + SetUsed(df); if (df->var_addrgiven) { /* the programmer specified an address in the declaration of the variable. Generate code to push the address. @@ -258,7 +257,9 @@ CodeVarDesig(df, ds) C_lxa((arith) (proclevel - sc->sc_level)); if ((df->df_flags & D_VARPAR) || IsConformantArray(df->df_type)) { - /* var parameter + /* var parameter or conformant array. + For conformant array's, the address is + passed. */ C_adp(df->var_off); C_loi(pointer_size); @@ -297,7 +298,7 @@ CodeDesig(nd, ds) case Def: df = nd->nd_def; - df->df_flags |= D_USED; + 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 2c9f87432..237ee29bb 100644 --- a/lang/m2/comp/enter.c +++ b/lang/m2/comp/enter.c @@ -172,6 +172,7 @@ EnterParamList(ppr, Idlist, type, VARp, off) static struct paramlist *last; if (! idlist) { + /* Can only happen when a procedure type is defined */ dummy = Idlist = idlist = MkLeaf(Name, &dot); } for ( ; idlist; idlist = idlist->next) { @@ -182,7 +183,7 @@ EnterParamList(ppr, Idlist, type, VARp, off) } else last->next = pr; last = pr; - if (idlist != dummy) { + if (!DefinitionModule && idlist != dummy) { df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE); df->var_off = *off; } @@ -222,22 +223,20 @@ DoImport(df, scope) if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) { /* Also import all enumeration literals */ - df = df->df_type->enm_enums; - while (df) { + for (df = df->df_type->enm_enums; df; df = df->enm_next) { define(df->df_idf, scope, D_IMPORT)->imp_def = df; - df = df->enm_next; } } else if (df->df_kind == D_MODULE) { /* Also import all definitions that are exported from this module */ - df = df->mod_vis->sc_scope->sc_def; - while (df) { + for (df = df->mod_vis->sc_scope->sc_def; + df; + df = df->df_nextinscope) { if (df->df_flags & D_EXPORTED) { define(df->df_idf,scope,D_IMPORT)->imp_def = df; } - df = df->df_nextinscope; } } } @@ -337,18 +336,22 @@ idlist->nd_IDF->id_text); scope. There are two legal possibilities, which are examined below. */ - if ((df1->df_kind == D_PROCHEAD && - df->df_kind == D_PROCEDURE) || - (df1->df_kind == D_HIDDEN && - df->df_kind == D_TYPE)) { - if (df->df_kind == D_TYPE && - df->df_type->tp_fund != T_POINTER) { -node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_text); - } + if (df1->df_kind == D_PROCHEAD && + df->df_kind == D_PROCEDURE) { df1->df_kind = D_IMPORT; df1->imp_def = df; continue; } + if (df1->df_kind == D_HIDDEN && + df->df_kind == D_TYPE) { + if (df->df_type->tp_fund != T_POINTER) { +node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_text); + } + assert(df1->df_type->next == NULLTYPE); + df1->df_kind = D_TYPE; + df1->df_type->next = df->df_type; + continue; + } } DoImport(df, enclosing(CurrVis)->sc_scope); diff --git a/lang/m2/comp/lookup.c b/lang/m2/comp/lookup.c index d8b89ef6c..a2785916d 100644 --- a/lang/m2/comp/lookup.c +++ b/lang/m2/comp/lookup.c @@ -15,6 +15,7 @@ static char *RcsId = "$Header$"; #include "scope.h" #include "LLlex.h" #include "node.h" +#include "type.h" struct def * lookup(id, scope) @@ -73,5 +74,7 @@ lookfor(id, vis, give_error) if (give_error) id_not_declared(id); - return MkDef(id->nd_IDF, vis->sc_scope, D_ERROR); + df = MkDef(id->nd_IDF, vis->sc_scope, D_ERROR); + df->df_type = error_type; + return df; } diff --git a/lang/m2/comp/options.c b/lang/m2/comp/options.c index 25f16c90e..69931fe3a 100644 --- a/lang/m2/comp/options.c +++ b/lang/m2/comp/options.c @@ -24,10 +24,14 @@ DoOption(text) default: options[text[-1]]++; /* flags, debug options etc. */ break; + /* recognized flags: + -L: don't generate fil/lin + -p: generate procentry/procexit + -w: no warnings + -n: no register messages + and many more if DEBUG + */ - case 'L' : /* don't generate fil/lin */ - options['L'] = 1; - break; case 'M': /* maximum identifier length */ idfsize = txt2int(&text); @@ -37,10 +41,6 @@ DoOption(text) fatal("maximum identifier length is %d", IDFSIZE); break; - case 'p' : /* generate profiling code procentry/procexit ???? */ - options['p'] = 1; - break; - case 'I' : if (++ndirs >= NDIRS) { fatal("Too many -I options"); @@ -99,14 +99,6 @@ DoOption(text) } break; } - - case 'n': - options['n'] = 1; /* use no registers */ - break; - - case 'w': - options['w'] = 1; /* no warnings will be given */ - break; } } diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g index 0573fde3c..993d53c35 100644 --- a/lang/m2/comp/program.g +++ b/lang/m2/comp/program.g @@ -193,7 +193,6 @@ definition VAR [ VariableDeclaration Semicolon ]* | ProcedureHeading(&dummy, D_PROCHEAD) - { close_scope(0); } Semicolon ; diff --git a/lang/m2/comp/scope.C b/lang/m2/comp/scope.C index 9962b67c5..23959a2f3 100644 --- a/lang/m2/comp/scope.C +++ b/lang/m2/comp/scope.C @@ -90,19 +90,6 @@ Forward(tk, ptp) CurrentScope->sc_forw = f; } -ChForward(was, becomes) - struct type *was, *becomes; -{ - /* The declaration of a hidden type had a forward reference. - In this case, the "forwards" list must be adapted. - */ - register struct forwards *f = CurrentScope->sc_forw; - - while (f && f->fo_ptyp != was) f = f->next; - assert(f != 0); - f->fo_ptyp = becomes; -} - STATIC chk_proc(df) register struct def *df; @@ -114,7 +101,7 @@ chk_proc(df) if (df->df_kind == D_PROCHEAD) { /* A not defined procedure */ -node_error(df->for_node, "procedure \"%s\" not defined", df->df_idf->id_text); +error("procedure \"%s\" not defined", df->df_idf->id_text); FreeNode(df->for_node); } df = df->df_nextinscope; diff --git a/lang/m2/comp/statement.g b/lang/m2/comp/statement.g index 6c45f898a..c04b36bd3 100644 --- a/lang/m2/comp/statement.g +++ b/lang/m2/comp/statement.g @@ -85,7 +85,7 @@ StatementSequence(register struct node **pnd;) struct node *nd; } : statement(pnd) - [ + [ %persistent ';' statement(&nd) { if (nd) { *pnd = MkNode(Link, *pnd, nd, &dot); diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index c20e7a152..68dc16661 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -52,14 +52,14 @@ struct proc { struct type { struct type *next; /* used with ARRAY, PROCEDURE, POINTER, SET, - SUBRANGE + SUBRANGE, EQUAL */ int tp_fund; /* fundamental type or constructor */ #define T_RECORD 0x0001 #define T_ENUMERATION 0x0002 #define T_INTEGER 0x0004 #define T_CARDINAL 0x0008 -/* #define T_LONGINT 0x0010 */ +#define T_EQUAL 0x0010 #define T_REAL 0x0020 #define T_HIDDEN 0x0040 #define T_POINTER 0x0080 @@ -129,7 +129,8 @@ struct type *construct_type(), *standard_type(), *set_type(), - *subr_type(); /* All from type.c */ + *subr_type(), + *RemoveEqual(); /* All from type.c */ #define NULLTYPE ((struct type *) 0) @@ -147,6 +148,6 @@ struct type (tpx)->next) #define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER),\ (tpx)->next) -#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next\ - : (tpx)) +#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \ + (tpx)) #define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED) diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index c04f19312..41727ea76 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -224,6 +224,8 @@ chk_basesubrange(tp, base) /* A subrange had a specified base. Check that the bases conform. */ + assert(tp->tp_fund == T_SUBRANGE); + if (base->tp_fund == T_SUBRANGE) { /* Check that the bounds of "tp" fall within the range of "base". @@ -231,22 +233,22 @@ chk_basesubrange(tp, base) if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) { error("Base type has insufficient range"); } - base = BaseType(base); + base = base->next; } if (base->tp_fund & (T_ENUMERATION|T_CHAR)) { - if (BaseType(tp) != base) { + if (tp->next != base) { error("Specified base does not conform"); } } else if (base != card_type && base != int_type) { error("Illegal base for a subrange"); } - else if (base == int_type && BaseType(tp) == card_type && + else if (base == int_type && tp->next == card_type && (tp->sub_ub > max_int || tp->sub_ub < 0)) { error("Upperbound to large for type INTEGER"); } - else if (base != BaseType(tp) && base != int_type) { + else if (base != tp->next && base != int_type) { error("Specified base does not conform"); } @@ -462,24 +464,31 @@ DeclareType(df, tp) */ if (df->df_type && df->df_type->tp_fund == T_HIDDEN) { - if (tp->tp_fund != T_POINTER) { + if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) { error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text); } - /* Careful now ... we might have declarations - referring to the hidden type. - */ - *(df->df_type) = *tp; - if (! tp->next) { - /* It also contains a forward reference, - so update the forwardlist - */ - ChForward(tp, df->df_type); + df->df_type->next = tp; + df->df_type->tp_fund = T_EQUAL; + while (tp != df->df_type && tp->tp_fund == T_EQUAL) { + tp = tp->next; + } + if (tp == df->df_type) { + /* Circular definition! */ +error("opaque type \"%s\" has a circular definition", df->df_idf->id_text); } - free_type(tp); } else df->df_type = tp; } +struct type * +RemoveEqual(tpx) + register struct type *tpx; +{ + + if (tpx) while (tpx->tp_fund == T_EQUAL) tpx = tpx->next; + return tpx; +} + int gcd(m, n) register int m, n; @@ -532,6 +541,10 @@ DumpType(tp) print("CARDINAL"); break; case T_REAL: print("REAL"); break; + case T_HIDDEN: + print("HIDDEN"); break; + case T_EQUAL: + print("EQUAL"); break; case T_POINTER: print("POINTER"); break; case T_CHAR: diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index c63249387..098744dfe 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -38,6 +38,9 @@ static struct type *func_type; struct withdesig *WithDesigs; struct node *Modules; +#define NO_EXIT_LABEL ((label) 0) +#define RETURN_LABEL ((label) 1) + STATIC DoProfil() { @@ -59,6 +62,7 @@ WalkModule(module) { /* Walk through a module, and all its local definitions. Also generate code for its body. + This code is collected in an initialization routine. */ register struct scope *sc; struct scopelist *savevis = CurrVis; @@ -75,7 +79,7 @@ WalkModule(module) this module. */ sc->sc_off = 0; /* no locals (yet) */ - text_label = 1; + text_label = 1; /* label at end of initialization routine */ TmpOpen(sc); /* Initialize for temporaries */ C_pro_narg(sc->sc_name); DoProfil(); @@ -93,10 +97,12 @@ WalkModule(module) */ C_df_dlb(l1); C_bss_cst(word_size, (arith) 0, 1); + /* if this one is set to non-zero, the initialization + was already done. + */ C_loe_dlb(l1, (arith) 0); - C_zne((label) 1); - C_loc((arith) 1); - C_ste_dlb(l1, (arith) 0); + C_zne(RETURN_LABEL); + C_ine_dlb(l1, (arith) 0); /* Prevent this module from calling its own initialization routine */ @@ -111,8 +117,8 @@ WalkModule(module) MkCalls(sc->sc_def); proclevel++; DO_DEBUG(options['X'], PrNode(module->mod_body, 0)); - WalkNode(module->mod_body, (label) 0); - C_df_ilb((label) 1); + WalkNode(module->mod_body, NO_EXIT_LABEL); + C_df_ilb(RETURN_LABEL); C_ret((arith) 0); C_end(-sc->sc_off); proclevel--; @@ -132,8 +138,9 @@ WalkProcedure(procedure) register struct type *tp; register struct paramlist *param; label func_res_label = 0; - arith tmpvar1 = 0; + arith StackAdjustment = 0; arith retsav = 0; + arith func_res_size = 0; proclevel++; CurrVis = procedure->prc_vis; @@ -152,11 +159,19 @@ WalkProcedure(procedure) func_type = tp = ResultType(procedure->df_type); if (tp && IsConstructed(tp)) { + /* The result type of this procedure is constructed. + The actual procedure will return a pointer to a global + data area in which the function result is stored. + Notice that this does make the code non-reentrant. + Here, we create the data area for the function result. + */ func_res_label = ++data_label; C_df_dlb(func_res_label); C_bss_cst(tp->tp_size, (arith) 0, 0); } + if (tp) func_res_size = WA(tp->tp_size); + /* Generate calls to initialization routines of modules defined within this procedure */ @@ -192,22 +207,25 @@ WalkProcedure(procedure) */ arith tmpvar = NewInt(); - if (! tmpvar1) { + if (! StackAdjustment) { + /* First time we get here + */ if (tp && !func_res_label) { /* Some local space, only needed if the value itself is returned */ - sc->sc_off -= WA(tp->tp_size); + sc->sc_off -= func_res_size; retsav = sc->sc_off; } - tmpvar1 = NewInt(); + StackAdjustment = NewInt(); C_loc((arith) 0); - C_stl(tmpvar1); + C_stl(StackAdjustment); } - /* First compute the size */ + /* First compute the size of the array */ C_lol(param->par_def->var_off + pointer_size + word_size); + /* upper - lower */ C_inc(); /* gives number of elements */ C_loc(tp->arr_elem->tp_size); C_cal("_wa"); @@ -219,15 +237,22 @@ WalkProcedure(procedure) /* size in bytes */ C_stl(tmpvar); C_lol(tmpvar); - C_dup(word_size); - C_lol(tmpvar1); + C_lol(tmpvar); + C_lol(StackAdjustment); C_adi(word_size); - C_stl(tmpvar1); /* remember all stack adjustments */ + C_stl(StackAdjustment); + /* remember stack adjustments */ C_ngi(word_size); + /* Assumption: stack grows + downwards!! ??? + */ C_ass(word_size); /* adjusted stack pointer */ C_lor((arith) 1); - /* destination address */ + /* destination address (sp), + also assumes stack grows + downwards ??? + */ C_lal(param->par_def->var_off); C_loi(pointer_size); /* push source address */ @@ -237,7 +262,9 @@ WalkProcedure(procedure) C_bls(word_size); /* copy */ C_lor((arith) 1); - /* push new address of array */ + /* push new address of array + ... downwards ... ??? + */ C_lal(param->par_def->var_off); C_sti(pointer_size); FreeInt(tmpvar); @@ -245,41 +272,50 @@ WalkProcedure(procedure) } } - text_label = 1; + text_label = 1; /* label at end of procedure */ DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0)); - WalkNode(procedure->prc_body, (label) 0); - C_df_ilb((label) 1); + WalkNode(procedure->prc_body, NO_EXIT_LABEL); + C_df_ilb(RETURN_LABEL); /* label at end */ tp = func_type; if (func_res_label) { + /* Fill the data area reserved for the function result + with the result + */ C_lae_dlb(func_res_label, (arith) 0); C_sti(tp->tp_size); - if (tmpvar1) { - C_lol(tmpvar1); + if (StackAdjustment) { + /* Remove copies of conformant arrays + */ + C_lol(StackAdjustment); C_ass(word_size); } C_lae_dlb(func_res_label, (arith) 0); C_ret(pointer_size); } else if (tp) { - if (tmpvar1) { + 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 + */ C_lal(retsav); - C_sti(WA(tp->tp_size)); - C_lol(tmpvar1); + C_sti(func_res_size); + C_lol(StackAdjustment); C_ass(word_size); C_lal(retsav); - C_loi(WA(tp->tp_size)); + C_loi(func_res_size); } - C_ret(WA(tp->tp_size)); + C_ret(func_res_size); } else { - if (tmpvar1) { - C_lol(tmpvar1); + if (StackAdjustment) { + C_lol(StackAdjustment); C_ass(word_size); } C_ret((arith) 0); } - if (tmpvar1) FreeInt(tmpvar1); + if (StackAdjustment) FreeInt(StackAdjustment); if (! options['n']) RegisterMessages(sc->sc_def); C_end(-sc->sc_off); TmpClose(); @@ -293,20 +329,26 @@ WalkDef(df) /* Walk through a list of definitions */ - while (df) { - if (df->df_kind == D_MODULE) { + for ( ; df; df = df->df_nextinscope) { + switch(df->df_kind) { + case D_MODULE: WalkModule(df); - } - else if (df->df_kind == D_PROCEDURE) { + break; + case D_PROCEDURE: WalkProcedure(df); + break; + case D_VARIABLE: + if (!proclevel) { + C_df_dnam(df->var_name); + C_bss_cst( + WA(df->df_type->tp_size), + (arith) 0, 0); + } + break; + default: + /* nothing */ + ; } - else if (!proclevel && df->df_kind == D_VARIABLE) { - C_df_dnam(df->var_name); - C_bss_cst( - WA(df->df_type->tp_size), - (arith) 0, 0); - } - df = df->df_nextinscope; } } @@ -316,31 +358,28 @@ MkCalls(df) /* Generate calls to initialization routines of modules */ - while (df) { + for ( ; df; df = df->df_nextinscope) { if (df->df_kind == D_MODULE) { C_lxl((arith) 0); C_cal(df->mod_vis->sc_scope->sc_name); C_asp(pointer_size); } - df = df->df_nextinscope; } } -WalkLink(nd, lab) +WalkLink(nd, exit_label) register struct node *nd; - label lab; + label exit_label; { /* Walk node "nd", which is a link. - "lab" represents the label that must be jumped to on - encountering an EXIT statement. */ while (nd && nd->nd_class == Link) { /* statement list */ - WalkNode(nd->nd_left, lab); + WalkNode(nd->nd_left, exit_label); nd = nd->nd_right; } - WalkNode(nd, lab); + WalkNode(nd, exit_label); } WalkCall(nd) @@ -358,13 +397,11 @@ WalkCall(nd) } } -WalkStat(nd, lab) +WalkStat(nd, exit_label) struct node *nd; - label lab; + label exit_label; { /* Walk through a statement, generating code for it. - "lab" represents the label that must be jumped to on - encountering an EXIT statement. */ register struct node *left = nd->nd_left; register struct node *right = nd->nd_right; @@ -386,12 +423,12 @@ WalkStat(nd, lab) ExpectBool(left, l3, l1); assert(right->nd_symb == THEN); C_df_ilb(l3); - WalkNode(right->nd_left, lab); + WalkNode(right->nd_left, exit_label); if (right->nd_right) { /* ELSE part */ C_bra(l2); C_df_ilb(l1); - WalkNode(right->nd_right, lab); + WalkNode(right->nd_right, exit_label); C_df_ilb(l2); } else C_df_ilb(l1); @@ -399,7 +436,7 @@ WalkStat(nd, lab) } case CASE: - CaseCode(nd, lab); + CaseCode(nd, exit_label); break; case WHILE: @@ -411,7 +448,7 @@ WalkStat(nd, lab) C_df_ilb(l1); ExpectBool(left, l3, l2); C_df_ilb(l3); - WalkNode(right, lab); + WalkNode(right, exit_label); C_bra(l1); C_df_ilb(l2); break; @@ -423,7 +460,7 @@ WalkStat(nd, lab) l1 = ++text_label; l2 = ++text_label; C_df_ilb(l1); - WalkNode(left, lab); + WalkNode(left, exit_label); ExpectBool(right, l2, l1); C_df_ilb(l2); break; @@ -457,9 +494,9 @@ WalkStat(nd, lab) } C_bra(l1); C_df_ilb(l2); - CheckAssign(nd->nd_type, int_type); + RangeCheck(nd->nd_type, int_type); CodeDStore(nd); - WalkNode(right, lab); + WalkNode(right, exit_label); CodePExpr(nd); C_loc(left->nd_INT); C_adi(int_size); @@ -493,8 +530,7 @@ WalkStat(nd, lab) wds.w_scope = left->nd_type->rec_scope; CodeAddress(&ds); ds.dsg_kind = DSG_FIXED; - /* Create a designator structure for the - temporary. + /* Create a designator structure for the temporary. */ ds.dsg_offset = tmp = NewPtr(); ds.dsg_name = 0; @@ -505,7 +541,7 @@ WalkStat(nd, lab) link.sc_scope = wds.w_scope; link.next = CurrVis; CurrVis = &link; - WalkNode(right, lab); + WalkNode(right, exit_label); CurrVis = link.next; WithDesigs = wds.w_next; FreePtr(tmp); @@ -513,9 +549,9 @@ WalkStat(nd, lab) } case EXIT: - assert(lab != 0); + assert(exit_label != 0); - C_bra(lab); + C_bra(exit_label); break; case RETURN: @@ -529,7 +565,7 @@ WalkStat(nd, lab) node_error(right, "type incompatibility in RETURN statement"); } } - C_bra((label) 1); + C_bra(RETURN_LABEL); break; default: @@ -576,7 +612,7 @@ ExpectBool(nd, true_label, false_label) int WalkExpr(nd) - struct node *nd; + register struct node *nd; { /* Check an expression and generate code for it */ @@ -664,12 +700,15 @@ DoAssign(nd, left, right) struct node *nd; register struct node *left, *right; { - /* May we do it in this order (expression first) ??? */ + /* May we do it in this order (expression first) ??? + The reference manual sais nothing about it, but the book does: + it sais that the left hand side is evaluated first. + */ struct desig dsl, dsr; if (! ChkExpression(right)) return; if (! ChkVariable(left)) return; - TryToString(right, left->nd_type); + if (right->nd_symb == STRING) TryToString(right, left->nd_type); dsr = InitDesig; CodeExpr(right, &dsr, NO_LABEL, NO_LABEL); @@ -683,7 +722,7 @@ DoAssign(nd, left, right) } else { CodeValue(&dsr, right->nd_type->tp_size); - CheckAssign(left->nd_type, right->nd_type); + RangeCheck(left->nd_type, right->nd_type); } dsl = InitDesig; CodeDesig(left, &dsl); @@ -702,12 +741,11 @@ RegisterMessages(df) */ tp = BaseType(df->df_type); if ((df->df_flags & D_VARPAR) || - tp->tp_fund == T_POINTER) { + (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) { C_ms_reg(df->var_off, pointer_size, reg_pointer, 0); } - else if ((tp->tp_fund & T_NUMERIC) && - tp->tp_size <= dword_size) { + else if (tp->tp_fund & T_NUMERIC) { C_ms_reg(df->var_off, tp->tp_size, tp->tp_fund == T_REAL ?