From 6715e3b171c4dd68cb8d0de47c5bf20a9fa2d109 Mon Sep 17 00:00:00 2001 From: ceriel Date: Fri, 18 Apr 1986 17:53:47 +0000 Subject: [PATCH] newer version --- lang/m2/comp/LLlex.c | 2 +- lang/m2/comp/Makefile | 5 +- lang/m2/comp/char.tab | 2 +- lang/m2/comp/chk_expr.c | 134 +++++++++++++++++++++++++++++++------- lang/m2/comp/declar.g | 8 +++ lang/m2/comp/def.H | 12 +++- lang/m2/comp/def.c | 40 ++++++++---- lang/m2/comp/enter.c | 15 ++++- lang/m2/comp/error.c | 1 + lang/m2/comp/expression.g | 11 +++- lang/m2/comp/main.c | 25 +++++-- lang/m2/comp/program.g | 17 +++-- lang/m2/comp/scope.C | 4 ++ lang/m2/comp/scope.h | 2 + lang/m2/comp/type.H | 1 + lang/m2/comp/type.c | 3 + lang/m2/comp/typequiv.c | 24 +++++++ 17 files changed, 246 insertions(+), 60 deletions(-) diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index c53e31594..1cf3c3877 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -76,7 +76,7 @@ GetString(upto) register struct string *str = &string; register char *p; - str->s_str = p = Malloc((unsigned) (str->s_length = ISTRSIZE)); + str->s_str = p = Malloc(str->s_length = ISTRSIZE); LoadChar(ch); while (ch != upto) { if (class(ch) == STNL) { diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index 8ce1097fc..c342b5e0f 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -38,7 +38,7 @@ hfiles: Parameters make.hfiles touch hfiles main: $(OBJ) Makefile - $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main + $(CC) $(LFLAGS) $(OBJ) /user1/erikb/em/lib/libem_mes.a /user1/erikb/em/lib/libeme.a $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main size main clean: @@ -91,12 +91,13 @@ type.o: LLlex.h const.h debug.h def.h idf.h node.h target_sizes.h type.h def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h misc.o: LLlex.h f_info.h idf.h misc.h node.h -enter.o: LLlex.h def.h idf.h node.h scope.h type.h +enter.o: LLlex.h def.h idf.h main.h node.h scope.h type.h defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.h 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 tokenfile.o: Lpars.h program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h diff --git a/lang/m2/comp/char.tab b/lang/m2/comp/char.tab index 53b2d69d6..e4f57402f 100644 --- a/lang/m2/comp/char.tab +++ b/lang/m2/comp/char.tab @@ -23,7 +23,7 @@ STEOI:\200 % INIDF % %C -1:a-zA-Z_0-9 +1:a-zA-Z0-9 %Tchar inidf[] = { %F %s, %p diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 95ecf20b1..6c950e5bd 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -8,6 +8,7 @@ static char *RcsId = "$Header$"; #include #include #include + #include "Lpars.h" #include "idf.h" #include "type.h" @@ -17,6 +18,7 @@ static char *RcsId = "$Header$"; #include "scope.h" #include "const.h" #include "standards.h" + #include "debug.h" int @@ -25,7 +27,7 @@ chk_expr(expp) { /* Check the expression indicated by expp for semantic errors, identify identifiers used in it, replace constants by - their value. + their value, and try to evaluate the expression. */ switch(expp->nd_class) { @@ -33,25 +35,32 @@ chk_expr(expp) return chk_expr(expp->nd_left) && chk_expr(expp->nd_right) && chk_oper(expp); + case Uoper: return chk_expr(expp->nd_right) && chk_uoper(expp); + case Value: switch(expp->nd_symb) { case REAL: case STRING: case INTEGER: return 1; + default: assert(0); } break; + case Xset: return chk_set(expp); + case Name: return chk_name(expp); + case Call: return chk_call(expp); + case Link: return chk_name(expp); default: @@ -82,9 +91,9 @@ chk_set(expp) findname(expp->nd_left); assert(expp->nd_left->nd_class == Def); df = expp->nd_left->nd_def; - if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) || + if (!(df->df_kind & (D_TYPE|D_ERROR)) || (df->df_type->tp_fund != T_SET)) { - node_error(expp, "Illegal set type"); + node_error(expp, "illegal set type"); return 0; } tp = df->df_type; @@ -93,7 +102,8 @@ chk_set(expp) /* Now check the elements given, and try to compute a constant set. */ - set = (arith *) Malloc(tp->tp_size * sizeof(arith) / word_size); + set = (arith *) + Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size)); nd = expp->nd_right; while (nd) { assert(nd->nd_class == Link && nd->nd_symb == ','); @@ -102,7 +112,10 @@ chk_set(expp) } expp->nd_type = tp; if (set) { - /* Yes, in was a constant set, and we managed to compute it! + /* Yes, it was a constant set, and we managed to compute it! + Notice that at the moment there is no such thing as + partial evaluation. Either we evaluate the set, or we + don't (at all). Improvement not neccesary. (???) */ expp->nd_class = Set; expp->nd_set = set; @@ -123,6 +136,8 @@ chk_el(expp, tp, set) recursively. Also try to compute the set! */ + register int i; + if (expp->nd_class == Link && expp->nd_symb == UPTO) { /* { ... , expr1 .. expr2, ... } First check expr1 and expr2, and try to compute them. @@ -136,10 +151,9 @@ chk_el(expp, tp, set) /* We have a constant range. Put all elements in the set */ - register int i; if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) { -node_error(expp, "Lower bound exceeds upper bound in range"); +node_error(expp, "lower bound exceeds upper bound in range"); return rem_set(set); } @@ -161,20 +175,21 @@ node_error(expp, "Lower bound exceeds upper bound in range"); return rem_set(set); } if (!TstCompat(tp, expp->nd_type)) { - node_error(expp, "Set element has incompatible type"); + node_error(expp, "set element has incompatible type"); return rem_set(set); } if (expp->nd_class == Value) { + i = expp->nd_INT; if ((tp->tp_fund != T_ENUMERATION && - (expp->nd_INT < tp->sub_lb || expp->nd_INT > tp->sub_ub)) + (i < tp->sub_lb || i > tp->sub_ub)) || (tp->tp_fund == T_ENUMERATION && - (expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst)) + (i < 0 || i > tp->enm_ncst)) ) { - node_error(expp, "Set element out of range"); + node_error(expp, "set element out of range"); return rem_set(set); } - if (*set) (*set)[expp->nd_INT/wrd_bits] |= (1 << (expp->nd_INT%wrd_bits)); + if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits)); } return 1; } @@ -207,8 +222,8 @@ getarg(argp, bases) if (!chk_expr(argp->nd_left)) return 0; tp = argp->nd_left->nd_type; if (tp->tp_fund == T_SUBRANGE) tp = tp->next; - if (!(tp->tp_fund & bases)) { - node_error(argp, "Unexpected type"); + if (bases && !(tp->tp_fund & bases)) { + node_error(argp, "unexpected type"); return 0; } return argp; @@ -226,7 +241,7 @@ getname(argp, kinds) findname(argp->nd_left); assert(argp->nd_left->nd_class == Def); if (!(argp->nd_left->nd_def->df_kind & kinds)) { - node_error(argp, "Unexpected type"); + node_error(argp, "unexpected type"); return 0; } return argp; @@ -243,6 +258,8 @@ chk_call(expp) register struct node *left; register struct node *arg; + /* First, get the name of the function or procedure + */ expp->nd_type = error_type; left = expp->nd_left; findname(left); @@ -250,18 +267,18 @@ chk_call(expp) if (left->nd_type == error_type) return 0; if (left->nd_class == Def && (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) { - /* A type cast. This is of course not portable. + /* It was a type cast. This is of course not portable. No runtime action. Remove it. */ arg = expp->nd_right; if ((! arg) || arg->nd_right) { -node_error(expp, "Only one parameter expected in type cast"); +node_error(expp, "only one parameter expected in type cast"); return 0; } 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, "size of type in type cast does not match size of operand"); return 0; } arg->nd_type = left->nd_type; @@ -285,7 +302,7 @@ node_error(expp, "Size of type in type cast does not match size of operand"); /* A standard procedure */ assert(left->nd_class == Def); -DO_DEBUG(3, debug("Standard name \"%s\", %d", +DO_DEBUG(3, debug("standard name \"%s\", %d", left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); switch(left->nd_def->df_value.df_stdname) { case S_ABS: @@ -297,6 +314,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); cstcall(expp, S_ABS); } break; + case S_CAP: arg = getarg(arg, T_CHAR); expp->nd_type = char_type; @@ -306,6 +324,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); cstcall(expp, S_CAP); } break; + case S_CHR: arg = getarg(arg, T_INTORCARD); expp->nd_type = char_type; @@ -314,11 +333,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); cstcall(expp, S_CHR); } break; + case S_FLOAT: arg = getarg(arg, T_INTORCARD); expp->nd_type = real_type; if (!arg) return 0; break; + case S_HIGH: arg = getarg(arg, T_ARRAY); if (!arg) return 0; @@ -331,6 +352,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); } else cstcall(expp, S_MAX); break; + case S_MAX: case S_MIN: arg = getarg(arg, T_DISCRETE); @@ -338,6 +360,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); expp->nd_type = arg->nd_left->nd_type; cstcall(expp,left->nd_def->df_value.df_stdname); break; + case S_ODD: arg = getarg(arg, T_INTORCARD); if (!arg) return 0; @@ -346,6 +369,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); cstcall(expp, S_ODD); } break; + case S_ORD: arg = getarg(arg, T_DISCRETE); if (!arg) return 0; @@ -354,6 +378,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); cstcall(expp, S_ORD); } break; + case S_TSIZE: /* ??? */ case S_SIZE: arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE); @@ -361,11 +386,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); if (!arg) return 0; cstcall(expp, S_SIZE); break; + case S_TRUNC: arg = getarg(arg, T_REAL); if (!arg) return 0; expp->nd_type = card_type; break; + case S_VAL: { struct type *tp; @@ -388,11 +415,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); } break; } + case S_ADR: arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE); expp->nd_type = address_type; if (!arg) return 0; break; + case S_DEC: case S_INC: expp->nd_type = 0; @@ -403,9 +432,11 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); if (!arg) return 0; } break; + case S_HALT: expp->nd_type = 0; break; + case S_EXCL: case S_INCL: { struct type *tp; @@ -421,11 +452,12 @@ node_error(arg, "EXCL and INCL expect a SET parameter"); arg = getarg(arg, T_DISCRETE); if (!arg) return 0; if (!TstCompat(tp->next, arg->nd_left->nd_type)) { - node_error(arg, "Unexpected type"); + node_error(arg, "unexpected type"); return 0; } break; } + default: assert(0); } @@ -436,14 +468,51 @@ node_error(arg, "EXCL and INCL expect a SET parameter"); } return 1; } - /* Here, we have found a real procedure call + /* Here, we have found a real procedure call. The left hand + side may also represent a procedure variable. */ - return 1; + return chk_proccall(expp); } node_error(expp->nd_left, "procedure, type, or function expected"); return 0; } +chk_proccall(expp) + struct node *expp; +{ + /* Check a procedure call + */ + register struct node *left = expp->nd_left; + register struct node *arg; + register struct paramlist *param; + + expp->nd_type = left->nd_type->next; + param = left->nd_type->prc_params; + arg = expp; + + 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"); + return 0; + } + param = param->next; + } + if (arg->nd_right) { + node_error(arg->nd_right, "too many parameters supplied"); + return 0; + } + return 1; +} + findname(expp) register struct node *expp; { @@ -471,7 +540,7 @@ findname(expp) } else if (tp->tp_fund != T_RECORD) { /* This is also true for modules */ - node_error(expp,"Illegal selection"); + node_error(expp,"illegal selection"); df = ill_df; } else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope); @@ -614,16 +683,19 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R cstbin(expp); } return 1; + case T_SET: if (expp->nd_left->nd_class == Set && expp->nd_right->nd_class == Set) { cstset(expp); } /* Fall through */ + case T_REAL: return 1; } break; + case '/': switch(tpl->tp_fund) { case T_SET: @@ -632,10 +704,12 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R cstset(expp); } /* Fall through */ + case T_REAL: return 1; } break; + case DIV: case MOD: if (tpl->tp_fund & T_INTORCARD) { @@ -646,6 +720,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R return 1; } break; + case OR: case AND: if (tpl == bool_type) { @@ -657,6 +732,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R } errval = 3; break; + case '=': case '#': case GREATEREQUAL: @@ -673,6 +749,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R cstset(expp); } return 1; + case T_INTEGER: case T_CARDINAL: case T_ENUMERATION: /* includes boolean */ @@ -683,24 +760,29 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R cstbin(expp); } return 1; + case T_POINTER: if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) { break; } /* Fall through */ + case T_REAL: return 1; } + default: assert(0); } switch(errval) { case 1: - node_error(expp,"Operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb)); + node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb)); break; + case 3: node_error(expp, "BOOLEAN type(s) expected"); break; + default: assert(0); } @@ -727,6 +809,7 @@ chk_uoper(expp) return 1; } break; + case '-': if (tpr->tp_fund & T_INTORCARD) { if (expp->nd_right->nd_class == Value) { @@ -747,6 +830,7 @@ chk_uoper(expp) return 1; } break; + case NOT: if (tpr == bool_type) { if (expp->nd_right->nd_class == Value) { @@ -755,10 +839,12 @@ chk_uoper(expp) return 1; } break; + case '^': if (tpr->tp_fund != T_POINTER) break; expp->nd_type = tpr->next; return 1; + default: assert(0); } diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index 8e5dbcd5d..173104d27 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -14,16 +14,24 @@ static char *RcsId = "$Header$"; #include "scope.h" #include "node.h" #include "misc.h" +#include "main.h" static int proclevel = 0; /* nesting level of procedures */ +char * sprint(); } ProcedureDeclaration { struct def *df; + char buf[256]; } : ProcedureHeading(&df, D_PROCEDURE) { df->prc_level = proclevel++; + if (DefinitionModule) { + C_exp(sprint(buf, "%s_%s", + df->df_scope->sc_name, + df->df_idf->id_text)); + } } ';' block(&(df->prc_body)) IDENT { match_id(dot.TOK_IDF, df->df_idf); diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index f2705a946..e208653c1 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -14,8 +14,13 @@ struct module { struct variable { arith va_off; /* address or offset of variable */ char va_addrgiven; /* an address was given in the program */ + char va_noreg; /* may not be in a register */ + short va_number; /* number of this variable in definition module + */ #define var_off df_value.df_variable.va_off #define var_addrgiven df_value.df_variable.va_addrgiven +#define var_noreg df_value.df_variable.va_noreg +#define var_number df_value.df_variable.va_number }; struct constant { @@ -43,13 +48,16 @@ struct field { struct dfproc { struct scope *pr_scope; /* scope of procedure */ - int pr_level; /* depth level of this procedure */ - arith pr_nbpar; /* Number of bytes parameters */ + short pr_level; /* depth level of this procedure */ + short pr_number; /* number of this procedure in definition module + */ + arith pr_nbpar; /* number of bytes parameters */ struct node *pr_body; /* body of this procedure */ #define prc_scope df_value.df_proc.pr_scope #define prc_level df_value.df_proc.pr_level #define prc_nbpar df_value.df_proc.pr_nbpar #define prc_body df_value.df_proc.pr_body +#define prc_number df_value.df_proc.pr_number }; struct import { diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c index 4ebdef06f..809bb5ed9 100644 --- a/lang/m2/comp/def.c +++ b/lang/m2/comp/def.c @@ -22,6 +22,32 @@ static struct def illegal_def = struct def *ill_df = &illegal_def; +struct def * +MkDef(id, scope, kind) + struct idf *id; + struct scope *scope; +{ + /* Create a new definition structure in scope "scope", with + id "id" and kind "kind". + */ + register struct def *df; + + df = new_def(); + df->df_flags = 0; + df->df_idf = id; + df->df_scope = scope; + df->df_kind = kind; + df->df_type = 0; + df->next = id->id_def; + id->id_def = df; + + /* enter the definition in the list of definitions in this scope + */ + df->df_nextinscope = scope->sc_def; + scope->sc_def = df; + return df; +} + struct def * define(id, scope, kind) register struct idf *id; @@ -85,19 +111,7 @@ error("identifier \"%s\" already declared", id->id_text); } return df; } - df = new_def(); - df->df_flags = 0; - df->df_idf = id; - df->df_scope = scope; - df->df_kind = kind; - df->df_type = 0; - df->next = id->id_def; - id->id_def = df; - - /* enter the definition in the list of definitions in this scope */ - df->df_nextinscope = scope->sc_def; - scope->sc_def = df; - return df; + return MkDef(id, scope, kind); } struct def * diff --git a/lang/m2/comp/enter.c b/lang/m2/comp/enter.c index 4c9e14b7d..76fbc32ad 100644 --- a/lang/m2/comp/enter.c +++ b/lang/m2/comp/enter.c @@ -12,6 +12,7 @@ static char *RcsId = "$Header$"; #include "scope.h" #include "LLlex.h" #include "node.h" +#include "main.h" struct def * Enter(name, kind, type, pnam) @@ -126,6 +127,13 @@ node_error(IdList->nd_left,"Illegal type for address"); df->var_off = off; scope->sc_off = off; } + else if (DefinitionModule) { + char buf[256]; + char *sprint(); + + C_exa_dnam(sprint(buf,"%s_%s",df->df_scope->sc_name, + df->df_idf->id_text)); + } IdList = IdList->nd_right; } } @@ -137,17 +145,20 @@ lookfor(id, scope, give_error) { /* Look for an identifier in the visibility range started by "scope". - If it is not defined, give an error message, and + If it is not defined, maybe give an error message, and create a dummy definition. */ struct def *df; register struct scope *sc = scope; + struct def *MkDef(); while (sc) { df = lookup(id->nd_IDF, sc); if (df) return df; sc = nextvisible(sc); } + if (give_error) id_not_declared(id); - return define(id->nd_IDF, scope, D_ERROR); + + return MkDef(id->nd_IDF, scope, D_ERROR); } diff --git a/lang/m2/comp/error.c b/lang/m2/comp/error.c index 13eae686d..13280af66 100644 --- a/lang/m2/comp/error.c +++ b/lang/m2/comp/error.c @@ -11,6 +11,7 @@ static char *RcsId = "$Header$"; #include #include "errout.h" +#include "debug.h" #include "input.h" #include "f_info.h" diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 75655c90c..69a750c65 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -183,10 +183,15 @@ factor(struct node **p;) | %default number(p) | - STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot); + STRING { + *p = MkNode(Value, NULLNODE, NULLNODE, &dot); if (dot.TOK_SLE == 1) { - dot.TOK_INT = *(dot.TOK_STR); - (*p)->nd_type = char_type; + int i; + + i = *(dot.TOK_STR) & 0377; + (*p)->nd_type = charc_type; + free(dot.TOK_STR); + dot.TOK_INT = i; } else (*p)->nd_type = string_type; } diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index a135e6682..491d9f815 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -40,23 +40,24 @@ main(argc, argv) Nargv[Nargc++] = *argv++; } Nargv[Nargc] = 0; /* terminate the arg vector */ - if (Nargc != 2) { - fprint(STDERR, "%s: Use one file argument\n", ProgName); + if (Nargc < 2) { + fprint(STDERR, "%s: Use a file argument\n", ProgName); return 1; } #ifdef DEBUG - print("Mod2 compiler -- Debug version\n"); -#endif DEBUG + print("MODULA-2 compiler -- Debug version\n"); DO_DEBUG(1, debug("Debugging level: %d", options['D'])); - return !Compile(Nargv[1]); +#endif DEBUG + return !Compile(Nargv[1], Nargv[2]); } -Compile(src) - char *src; +Compile(src, dst) + char *src, *dst; { extern struct tokenname tkidf[]; DO_DEBUG(1, debug("Filename : %s", src)); + DO_DEBUG(1, (!dst || debug("Targetfile: %s", dst))); if (! InsertFile(src, (char **) 0, &src)) { fprint(STDERR,"%s: cannot open %s\n", ProgName, src); return 0; @@ -77,8 +78,15 @@ Compile(src) { (void) open_scope(CLOSEDSCOPE); GlobalScope = CurrentScope; + C_init(word_size, pointer_size); + if (! C_open(dst)) { + fatal("Could not open output file"); + } + C_magic(); + C_ms_emx(word_size, pointer_size); CompUnit(); } + C_close(); if (err_occurred) return 0; return 1; } @@ -87,6 +95,7 @@ Compile(src) LexScan() { register int symb; + char *symbol2str(); while ((symb = LLlex()) > 0) { print(">>> %s ", symbol2str(symb)); @@ -171,6 +180,8 @@ init_DEFPATH() if (*p) *p++ = '\0'; } } + else DEFPATH[i++] = ""; + DEFPATH[i] = 0; } diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g index 07930f4a7..a2c066c90 100644 --- a/lang/m2/comp/program.g +++ b/lang/m2/comp/program.g @@ -20,6 +20,9 @@ static int DEFofIMPL = 0; /* Flag indicating that we are currently implementation module currently being compiled */ +short nmcount = 0; /* count names in definition modules in order + to create suitable names in the object code + */ } /* The grammar as given by Wirth is already almost LL(1); the @@ -95,7 +98,7 @@ export(int def;) Export(ExportList, QUALflag); } else { - warning("export list in definition module ignored"); +node_warning(ExportList, "export list in definition module ignored"); FreeNode(ExportList); } } @@ -125,16 +128,20 @@ DefinitionModule { register struct def *df; struct idf *id; + int savnmcount = nmcount; } : DEFINITION MODULE IDENT { id = dot.TOK_IDF; df = define(id, GlobalScope, D_MODULE); if (!SYSTEMModule) open_scope(CLOSEDSCOPE); df->mod_scope = CurrentScope; + CurrentScope->sc_name = id->id_text; df->df_type = standard_type(T_RECORD, 0, (arith) 0); df->df_type->rec_scope = df->mod_scope; - DefinitionModule = 1; - DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text)); + DefinitionModule++; + nmcount = 0; + DO_DEBUG(1, debug("Definition module \"%s\" %d", + id->id_text, DefinitionModule)); } ';' import(0)* @@ -158,8 +165,9 @@ DefinitionModule df = df->df_nextinscope; } if (!SYSTEMModule) close_scope(SC_CHKFORW); - DefinitionModule = 0; + DefinitionModule--; match_id(id, dot.TOK_IDF); + nmcount = savnmcount; } '.' ; @@ -210,7 +218,6 @@ ProgramModule(int state;) df = GetDefinitionModule(id); CurrentScope = df->mod_scope; DEFofIMPL = 0; - DefinitionModule = 0; } else { df = define(id, CurrentScope, D_MODULE); diff --git a/lang/m2/comp/scope.C b/lang/m2/comp/scope.C index 79ebb5f84..8142ee416 100644 --- a/lang/m2/comp/scope.C +++ b/lang/m2/comp/scope.C @@ -15,6 +15,7 @@ static char *RcsId = "$Header$"; #include "debug.h" struct scope *CurrentScope, *PervasiveScope, *GlobalScope; +static int scp_level; /* STATICALLOCDEF "scope" */ @@ -26,6 +27,7 @@ open_scope(scopetype) assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE); sc->sc_scopeclosed = scopetype == CLOSEDSCOPE; + sc->sc_level = scp_level++; sc->sc_forw = 0; sc->sc_def = 0; sc->sc_off = 0; @@ -45,6 +47,7 @@ init_scope() sc->sc_scopeclosed = 0; sc->sc_forw = 0; sc->sc_def = 0; + sc->sc_level = scp_level++; sc->next = 0; PervasiveScope = sc; CurrentScope = sc; @@ -197,6 +200,7 @@ close_scope(flag) Reverse(&(sc->sc_def)); } CurrentScope = sc->next; + scp_level = CurrentScope->sc_level; } #ifdef DEBUG diff --git a/lang/m2/comp/scope.h b/lang/m2/comp/scope.h index 3dc7b4413..e2611f3da 100644 --- a/lang/m2/comp/scope.h +++ b/lang/m2/comp/scope.h @@ -15,9 +15,11 @@ struct scope { struct scope *next; struct forwards *sc_forw; + char *sc_name; /* name of this scope */ struct def *sc_def; /* list of definitions in this scope */ arith sc_off; /* offsets of variables in this scope */ char sc_scopeclosed; /* flag indicating closed or open scope */ + int sc_level; /* level of this scope */ }; extern struct scope diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index c2824a847..f206e6cd8 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -88,6 +88,7 @@ struct type { extern struct type *bool_type, *char_type, + *charc_type, *int_type, *card_type, *longint_type, diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index 581399992..21e4bb594 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -40,6 +40,7 @@ arith struct type *bool_type, *char_type, + *charc_type, *int_type, *card_type, *longint_type, @@ -134,6 +135,8 @@ init_types() char_type = standard_type(T_CHAR, 1, (arith) 1); char_type->enm_ncst = 256; + charc_type = standard_type(T_CHAR, 1, (arith) 1); + charc_type->enm_ncst = 256; bool_type = standard_type(T_ENUMERATION, 1, (arith) 1); bool_type->enm_ncst = 2; int_type = standard_type(T_INTEGER, int_align, int_size); diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 7fef09274..603d35fe2 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -111,3 +111,27 @@ TstCompat(tp1, tp2) ) ; } + +int TstAssCompat(tp1, tp2) + struct type *tp1, *tp2; +{ + /* Test if two types are assignment compatible. + */ + if (TstCompat(tp1, tp2)) return 1; + + if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next; + if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next; + if ((tp1->tp_fund & (T_INTEGER|T_CARDINAL)) && + (tp2->tp_fund & (T_INTEGER|T_CARDINAL))) return 1; + if (tp1 == char_type && tp2 == charc_type) return 1; + if (tp1->tp_fund == T_ARRAY && + (tp2 == charc_type || tp2 == string_type)) { + /* Unfortunately the length of the string is not + available here, so this must be tested somewhere else (???) + */ + tp1 = tp1->arr_elem; + if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next; + return tp1 == char_type; + } + return 0; +} -- 2.34.1