From 4173e3c48727d96ad696341ff29b8171d0fdf100 Mon Sep 17 00:00:00 2001 From: ceriel Date: Fri, 25 Apr 1986 10:14:08 +0000 Subject: [PATCH] newer version --- lang/m2/comp/LLlex.c | 13 ++++- lang/m2/comp/Makefile | 4 +- lang/m2/comp/Parameters | 4 ++ lang/m2/comp/chk_expr.c | 117 ++++++++++++++++++++++++++------------ lang/m2/comp/declar.g | 11 +++- lang/m2/comp/defmodule.c | 1 - lang/m2/comp/expression.g | 4 +- lang/m2/comp/main.c | 24 ++------ lang/m2/comp/main.h | 9 +-- lang/m2/comp/node.H | 5 +- lang/m2/comp/options.c | 12 +++- lang/m2/comp/type.c | 67 ++++++++++++++++++++++ lang/m2/comp/typequiv.c | 18 ++++++ lang/m2/comp/walk.c | 19 ++++++- 14 files changed, 235 insertions(+), 73 deletions(-) diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index a252b606d..a1ccd14a4 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -248,8 +248,11 @@ again: switch (ch) { case 'H': Shex: *np++ = '\0'; - numtype = card_type; tk->TOK_INT = str2long(&buf[1], 16); + if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) { + numtype = intorcard_type; + } + else numtype = card_type; return tk->tk_symb = INTEGER; case '8': @@ -283,11 +286,17 @@ Shex: *np++ = '\0'; PushBack(ch); ch = *--np; *np++ = '\0'; + tk->TOK_INT = str2long(&buf[1], 8); if (ch == 'C') { numtype = 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) { + numtype = intorcard_type; } else numtype = card_type; - tk->TOK_INT = str2long(&buf[1], 8); return tk->tk_symb = INTEGER; case 'A': diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index 708158581..7d893277b 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -82,7 +82,7 @@ LLlex.o: LLlex.h Lpars.h class.h const.h f_info.h idf.h idfsize.h input.h inputt LLmessage.o: LLlex.h Lpars.h idf.h char.o: class.h error.o: LLlex.h debug.h errout.h f_info.h input.h inputtype.h main.h node.h -main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h node.h scope.h standards.h tokenname.h type.h +main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h ndirs.h node.h scope.h standards.h tokenname.h type.h symbol2str.o: Lpars.h tokenname.o: Lpars.h idf.h tokenname.h idf.o: idf.h @@ -97,7 +97,7 @@ typequiv.o: def.h type.h node.o: LLlex.h debug.h def.h node.h type.h cstoper.o: LLlex.h Lpars.h idf.h node.h standards.h target_sizes.h type.h chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h -options.o: idfsize.h type.h +options.o: idfsize.h main.h ndir.h type.h walk.o: LLlex.h Lpars.h debug.h def.h main.h node.h scope.h type.h tokenfile.o: Lpars.h program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h diff --git a/lang/m2/comp/Parameters b/lang/m2/comp/Parameters index fcdfc05c9..7604bdf98 100644 --- a/lang/m2/comp/Parameters +++ b/lang/m2/comp/Parameters @@ -63,4 +63,8 @@ extern char options[]; but what is a reasonable choice ??? */ +!File: ndir.h +#define NDIRS 16 /* maximum number of directories searched */ + + diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 81fc53c89..938fc6f0e 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -35,7 +35,7 @@ chk_expr(expp) switch(expp->nd_class) { case Oper: if (expp->nd_symb == '[') { - return chk_designator(expp, DESIGNATOR); + return chk_designator(expp, DESIGNATOR|VARIABLE); } return chk_expr(expp->nd_left) && @@ -44,7 +44,7 @@ chk_expr(expp) case Uoper: if (expp->nd_symb == '^') { - return chk_designator(expp, DESIGNATOR); + return chk_designator(expp, DESIGNATOR|VARIABLE); } return chk_expr(expp->nd_right) && @@ -66,13 +66,13 @@ chk_expr(expp) return chk_set(expp); case Name: - return chk_designator(expp, DESIGNATOR); + return chk_designator(expp, VALUE); case Call: return chk_call(expp); case Link: - return chk_designator(expp, DESIGNATOR); + return chk_designator(expp, DESIGNATOR|VALUE); default: assert(0); @@ -99,7 +99,7 @@ chk_set(expp) if (nd = expp->nd_left) { /* A type was given. Check it out */ - if (! chk_designator(nd, QUALONLY)) return 0; + if (! chk_designator(nd, 0)) return 0; assert(nd->nd_class == Def); df = nd->nd_def; @@ -270,12 +270,15 @@ getname(argp, kinds) return 0; } argp = argp->nd_right; - if (! chk_designator(argp->nd_left, QUALONLY)) return 0; + if (! chk_designator(argp->nd_left, 0)) return 0; + assert(argp->nd_left->nd_class == Def); + if (!(argp->nd_left->nd_def->df_kind & kinds)) { node_error(argp, "unexpected type"); return 0; } + return argp; } @@ -294,9 +297,8 @@ chk_call(expp) */ expp->nd_type = error_type; left = expp->nd_left; - if (! chk_designator(left, DESIGNATOR)) return 0; + if (! chk_designator(left, 0)) return 0; - if (left->nd_type == error_type) return 0; if (left->nd_class == Def && (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) { /* It was a type cast. This is of course not portable. @@ -310,7 +312,7 @@ node_error(expp, "only one parameter expected in type cast"); arg = arg->nd_left; if (! chk_expr(arg)) return 0; if (arg->nd_type->tp_size != left->nd_type->tp_size) { -node_error(expp, "size of type in type cast does not match size of operand"); +node_error(expp, "unequal sizes in type cast"); } arg->nd_type = left->nd_type; FreeNode(expp->nd_left); @@ -352,30 +354,59 @@ chk_proccall(expp) register struct node *arg; register struct paramlist *param; - expp->nd_type = left->nd_type->next; - param = left->nd_type->prc_params; arg = expp; + arg->nd_type = left->nd_type->next; + param = left->nd_type->prc_params; while (param) { - arg = getarg(arg, 0); - if (!arg) return 0; - if (param->par_var && - ! TstCompat(param->par_type, arg->nd_left->nd_type)) { -node_error(arg->nd_left, "type incompatibility in var parameter"); - return 0; - } - else - if (!param->par_var && - !TstAssCompat(param->par_type, arg->nd_left->nd_type)) { -node_error(arg->nd_left, "type incompatibility in value parameter"); + if (!(arg = getarg(arg, 0))) return 0; + + if (! TstParCompat(param->par_type, + arg->nd_left->nd_type, + param->par_var)) { +node_error(arg->nd_left, "type incompatibility in parameter"); return 0; } + param = param->next; } + if (arg->nd_right) { node_error(arg->nd_right, "too many parameters supplied"); return 0; } + + return 1; +} + +static int +FlagCheck(expp, df, flag) + struct node *expp; + struct def *df; +{ + /* See the routine "chk_designator" for an explanation of + "flag". Here, a definition "df" is checked against it. + */ + + if ((flag & VARIABLE) && + !(df->df_kind & (D_FIELD|D_VARIABLE))) { + node_error(expp, "variable expected"); + return 0; + } + + if ((flag & HASSELECTORS) && + ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_MODULE)) || + df->df_type->tp_fund != T_RECORD)) { + node_error(expp, "illegal selection"); + return 0; + } + + if ((flag & VALUE) && + ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_CONST|D_ENUM)))) { + node_error(expp, "value expected"); + return 0; + } + return 1; } @@ -384,7 +415,15 @@ chk_designator(expp, flag) register struct node *expp; { /* Find the name indicated by "expp", starting from the current - scope. + scope. "flag" indicates the kind of designator we expect: + It contains the flags VARIABLE, indicating that the result must + be something that can be assigned to. + It may also contain the flag VALUE, indicating that a + value is expected. In this case, VARIABLE may not be set. + It also contains the flag DESIGNATOR, indicating that '[' + and '^' are allowed for this designator. + Also contained may be the flag HASSELECTORS, indicating that + the result must have selectors. */ register struct def *df; register struct type *tp; @@ -403,21 +442,20 @@ chk_designator(expp, flag) assert(expp->nd_symb == '.'); assert(expp->nd_right->nd_class == Name); - if (! chk_designator(expp->nd_left, flag)) return 0; + if (! chk_designator(expp->nd_left, + (flag|HASSELECTORS)&DESIGNATOR)) return 0; + tp = expp->nd_left->nd_type; - if (tp == error_type) return 0; - else if (tp->tp_fund != T_RECORD) { - /* This is also true for modules */ - node_error(expp,"illegal selection"); - return 0; - } - else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope); + + assert(tp->tp_fund == T_RECORD); + + df = lookup(expp->nd_right->nd_IDF, tp->rec_scope); if (!df) { id_not_declared(expp->nd_right); return 0; } - else if (df != ill_df) { + else { expp->nd_type = df->df_type; if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) { node_error(expp->nd_right, @@ -434,12 +472,16 @@ df->df_idf->id_text); FreeNode(expp->nd_right); expp->nd_left = expp->nd_right = 0; } - else return 1; + else { + return FlagCheck(expp->nd_right, df, flag); + } } if (expp->nd_class == Def) { df = expp->nd_def; + if (! FlagCheck(expp, df, flag)) return 0; + if (df->df_kind & (D_ENUM | D_CONST)) { if (df->df_kind == D_ENUM) { expp->nd_class = Value; @@ -455,7 +497,7 @@ df->df_idf->id_text); return 1; } - if (flag == QUALONLY) { + if (! (flag & DESIGNATOR)) { node_error(expp, "identifier expected"); return 0; } @@ -466,7 +508,7 @@ df->df_idf->id_text); assert(expp->nd_symb == '['); if ( - !chk_designator(expp->nd_left, DESIGNATOR) + !chk_designator(expp->nd_left, DESIGNATOR|VARIABLE) || !chk_expr(expp->nd_right) || @@ -498,7 +540,10 @@ df->df_idf->id_text); if (expp->nd_class == Uoper) { assert(expp->nd_symb == '^'); - if (! chk_designator(expp->nd_right, DESIGNATOR)) return 0; + if (! chk_designator(expp->nd_right, DESIGNATOR|VARIABLE)) { + return 0; + } + if (expp->nd_right->nd_type->tp_fund != T_POINTER) { node_error(expp, "illegal operand for unary operator \"%s\"", symbol2str(expp->nd_symb)); diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index baca3d8f8..ad2bcd17c 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -17,6 +17,8 @@ static char *RcsId = "$Header$"; #include "misc.h" #include "main.h" +#include "debug.h" + int proclevel = 0; /* nesting level of procedures */ extern char *sprint(); extern struct def *currentdef; @@ -68,6 +70,10 @@ error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text); } df->df_type = tp; *pdf = df; + + DO_DEBUG(1, type == D_PROCEDURE && + (print("proc %s:", df->df_idf->id_text), + DumpType(tp), print("\n"))); } ; @@ -107,9 +113,8 @@ FormalParameters(int doparams; '(' [ FPSection(doparams, pr, parmaddr) - { pr1 = *pr; } [ - { for (; pr1->next; pr1 = pr1->next) ; } + { for (pr1 = *pr; pr1->next; pr1 = pr1->next) ; } ';' FPSection(doparams, &(pr1->next), parmaddr) ]* ]? @@ -366,7 +371,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;) { warning("Old fashioned Modula-2 syntax!"); id = gen_anon_idf(); df = ill_df; - if (chk_designator(nd, QUALONLY) && + if (chk_designator(nd, 0) && (nd->nd_class != Def || !(nd->nd_def->df_kind & (D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN)))) { diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c index 808ff8454..faf3b629c 100644 --- a/lang/m2/comp/defmodule.c +++ b/lang/m2/comp/defmodule.c @@ -26,7 +26,6 @@ GetFile(name) /* Try to find a file with basename "name" and extension ".def", in the directories mentioned in "DEFPATH". */ - extern char *DEFPATH[]; char buf[256]; char *strcpy(), *strcat(); diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 4348fceba..a3b122ec7 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -43,7 +43,7 @@ qualident(int types; struct def **pdf; char *str; struct node **p;) { if (types) { df = ill_df; - if (chk_designator(nd, QUALONLY)) { + if (chk_designator(nd, 0)) { if (nd->nd_class != Def) { node_error(nd, "%s expected", str); } @@ -83,7 +83,7 @@ ExpList(struct node **pnd;) ',' { *nd = MkNode(Link, NULLNODE, NULLNODE, &dot); } expression(&(*nd)->nd_left) - { nd = &((*pnd)->nd_right); } + { nd = &((*nd)->nd_right); } ]* ; diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index 0c4532727..afd2b1350 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -19,14 +19,14 @@ static char *RcsId = "$Header$"; #include "node.h" #include "debug.h" +#include "ndir.h" char options[128]; int DefinitionModule; int SYSTEMModule = 0; char *ProgName; extern int err_occurred; -char *DEFPATH[128]; -char *getenv(); +char *DEFPATH[NDIRS+1]; struct def *Defined; main(argc, argv) @@ -67,7 +67,8 @@ Compile(src, dst) } LineNumber = 1; FileName = src; - init_DEFPATH(); + DEFPATH[0] = ""; + DEFPATH[NDIRS] = 0; init_idf(); init_cst(); reserve(tkidf); @@ -181,23 +182,6 @@ add_standards() df->enm_next = 0; } -init_DEFPATH() -{ - register char *p = getenv("M2path"); - register int i = 0; - - if (p) { - while (*p) { - DEFPATH[i++] = p; - while (*p && *p != ':') p++; - if (*p) *p++ = '\0'; - } - } - else DEFPATH[i++] = ""; - - DEFPATH[i] = 0; -} - do_SYSTEM() { /* Simulate the reading of the SYSTEM definition module diff --git a/lang/m2/comp/main.h b/lang/m2/comp/main.h index 04ca4ed65..35a0f9ad1 100644 --- a/lang/m2/comp/main.h +++ b/lang/m2/comp/main.h @@ -2,17 +2,18 @@ /* $Header$ */ -extern char options[]; /* Indicating which options were given */ +extern char options[]; /* indicating which options were given */ extern int DefinitionModule; - /* Flag indicating that we are reading a definition + /* flag indicating that we are reading a definition module */ -extern int SYSTEMModule;/* Flag indicating that we are handling the SYSTEM +extern int SYSTEMModule;/* flag indicating that we are handling the SYSTEM module */ extern struct def *Defined; - /* Definition structure of module defined in this + /* definition structure of module defined in this compilation */ +extern char *DEFPATH[]; /* search path for DEFINITION MODULE's */ diff --git a/lang/m2/comp/node.H b/lang/m2/comp/node.H index f74fd3ab7..f4a30952f 100644 --- a/lang/m2/comp/node.H +++ b/lang/m2/comp/node.H @@ -36,5 +36,8 @@ struct node { extern struct node *MkNode(); #define NULLNODE ((struct node *) 0) -#define QUALONLY 0 + #define DESIGNATOR 1 +#define HASSELECTORS 2 +#define VARIABLE 4 +#define VALUE 8 diff --git a/lang/m2/comp/options.c b/lang/m2/comp/options.c index f8bc48818..f372a6286 100644 --- a/lang/m2/comp/options.c +++ b/lang/m2/comp/options.c @@ -6,12 +6,15 @@ static char *RcsId = "$Header$"; #include #include "idfsize.h" +#include "ndir.h" #include "type.h" +#include "main.h" -extern char options[]; extern int idfsize; +static int ndirs; + do_option(text) char *text; { @@ -37,6 +40,13 @@ do_option(text) options['p'] = 1; break; + case 'I' : + if (++ndirs >= NDIRS) { + fatal("Too many -I options"); + } + DEFPATH[ndirs] = text; + break; + case 'V' : /* set object sizes and alignment requirements */ { arith size; diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index 2d5b140a0..41d1e255b 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -436,3 +436,70 @@ lcm(m, n) */ return m * (n / gcd(m, n)); } + +#ifdef DEBUG +DumpType(tp) + register struct type *tp; +{ + print(" a:%d; s:%ld;", tp->tp_align, (long) tp->tp_size); + if (tp->next && tp->tp_fund != T_POINTER) { + /* Avoid printing recursive types! + */ + print(" n:("); + DumpType(tp->next); + print(")"); + } + + print(" f:"); + switch(tp->tp_fund) { + case T_RECORD: + print("RECORD"); break; + case T_ENUMERATION: + print("ENUMERATION; n:%d", tp->enm_ncst); break; + case T_INTEGER: + print("INTEGER"); break; + case T_CARDINAL: + print("CARDINAL"); break; + case T_REAL: + print("REAL"); break; + case T_POINTER: + print("POINTER"); break; + case T_CHAR: + print("CHAR"); break; + case T_WORD: + print("WORD"); break; + case T_SET: + print("SET"); break; + case T_SUBRANGE: + print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub); + break; + case T_PROCEDURE: + { + register struct paramlist *par = tp->prc_params; + + print("PROCEDURE"); + if (par) { + print("; p:"); + while(par) { + if (par->par_var) print("VAR "); + DumpType(par->par_type); + par = par->next; + } + } + break; + } + case T_ARRAY: + print("ARRAY %ld-%ld", (long) tp->arr_lb, (long) tp->arr_ub); + print("; el:"); + DumpType(tp->arr_elem); + break; + case T_STRING: + print("STRING"); break; + case T_INTORCARD: + print("INTORCARD"); break; + default: + assert(0); + } + print(";"); +} +#endif diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 2a7c1a81b..80c23318e 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -150,3 +150,21 @@ int TstAssCompat(tp1, tp2) return 0; } + +int TstParCompat(formaltype, actualtype, VARflag) + struct type *formaltype, *actualtype; +{ + /* Check type compatibility for a parameter in a procedure + call + */ + + return + TstCompat(formaltype, actualtype) + || + ( !VARflag && TstAssCompat(formaltype, actualtype)) + || + ( formaltype->tp_fund == T_ARRAY + && formaltype->next == 0 + && actualtype->tp_fund == T_ARRAY + && TstTypeEquiv(formaltype->arr_elem, actualtype->arr_elem)); +} diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index c8fffc568..9e7c2e73a 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -181,7 +181,9 @@ WalkStat(nd, lab) register struct node *right = nd->nd_right; if (nd->nd_class == Call) { - /* ??? */ + if (chk_call(nd)) { + /* ??? */ + } return; } @@ -189,6 +191,8 @@ WalkStat(nd, lab) switch(nd->nd_symb) { case BECOMES: + WalkExpr(nd->nd_right); + WalkDesignator(nd->nd_left); /* ??? */ break; @@ -309,6 +313,19 @@ WalkExpr(nd) } } +WalkDesignator(nd) + struct node *nd; +{ + /* Check designator and generate code for it + */ + + DO_DEBUG(1, (DumpTree(nd), print("\n"))); + + if (chk_designator(nd, DESIGNATOR|VARIABLE)) { + /* ??? */ + } +} + #ifdef DEBUG DumpTree(nd) struct node *nd;