From 1cfe2b5dac26deaf04471f5e537037a5e169f2a9 Mon Sep 17 00:00:00 2001 From: ceriel Date: Fri, 23 May 1986 09:46:31 +0000 Subject: [PATCH] newer version --- lang/m2/comp/Makefile | 10 +++- lang/m2/comp/chk_expr.c | 70 +++++++++++------------ lang/m2/comp/code.c | 24 ++++++-- lang/m2/comp/cstoper.c | 7 ++- lang/m2/comp/desig.c | 47 ++++++++++++++++ lang/m2/comp/error.c | 2 +- lang/m2/comp/expression.g | 2 +- lang/m2/comp/tmpvar.C | 114 ++++++++++++++++++++++++++++++++++++++ lang/m2/comp/walk.c | 48 +++++++++++++--- 9 files changed, 267 insertions(+), 57 deletions(-) create mode 100644 lang/m2/comp/tmpvar.C diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index ee5c819f5..42805283b 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -5,7 +5,7 @@ HDIR = ../../em/h PKGDIR = ../../em/pkg LIBDIR = ../../em/lib -INCLUDES = -I$(HDIR) -I$(PKGDIR) -I/user1/erikb/em/h +INCLUDES = -I$(HDIR) -I/usr/em/h -I$(PKGDIR) -I/user1/erikb/em/h LSRC = tokenfile.g program.g declar.g expression.g statement.g CC = cc @@ -18,7 +18,8 @@ LOBJ = tokenfile.o program.o declar.o expression.o statement.o COBJ = LLlex.o LLmessage.o char.o error.o main.o \ symbol2str.o tokenname.o idf.o input.o type.o def.o \ scope.o misc.o enter.o defmodule.o typequiv.o node.o \ - cstoper.o chk_expr.o options.o walk.o casestat.o desig.o code.o + cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \ + code.o tmpvar.o OBJ = $(COBJ) $(LOBJ) Lpars.o GENFILES= tokenfile.c \ program.c declar.c expression.c statement.c \ @@ -58,6 +59,7 @@ def.h: def.H make.allocd type.h: type.H make.allocd node.h: node.H make.allocd scope.c: scope.C make.allocd +tmpvar.c: tmpvar.C make.allocd casestat.c: casestat.C make.allocd char.c: char.tab tab @@ -100,7 +102,9 @@ cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type. 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 main.h ndir.h type.h walk.o: LLlex.h Lpars.h debug.h def.h desig.h main.h node.h scope.h type.h -casestat.o: LLlex.h Lpars.h debug.h density.h node.h type.h +casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h +desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h +code.o: LLlex.h Lpars.h debug.h def.h desig.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 declar.o: LLlex.h Lpars.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 5934c4061..31e505ded 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -244,7 +244,7 @@ rem_set(set) } struct node * -getarg(argp, bases) +getarg(argp, bases, designator) struct node *argp; { struct type *tp; @@ -254,7 +254,10 @@ getarg(argp, bases) return 0; } argp = argp->nd_right; - if (!chk_expr(argp->nd_left)) return 0; + if ((!designator && !chk_expr(argp->nd_left)) || + (designator && !chk_designator(argp->nd_left, DESIGNATOR))) { + return 0; + } tp = argp->nd_left->nd_type; if (tp->tp_fund == T_SUBRANGE) tp = tp->next; if (bases && !(tp->tp_fund & bases)) { @@ -305,7 +308,6 @@ chk_call(expp) 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. - No runtime action. Remove it. */ arg = expp->nd_right; if ((! arg) || arg->nd_right) { @@ -317,14 +319,18 @@ node_error(expp, "only one parameter expected in type cast"); if (arg->nd_type->tp_size != left->nd_type->tp_size) { node_error(expp, "unequal sizes in type cast"); } - arg->nd_type = left->nd_type; - FreeNode(expp->nd_left); - expp->nd_right->nd_left = 0; - FreeNode(expp->nd_right); - *expp = *arg; - arg->nd_left = 0; - arg->nd_right = 0; - FreeNode(arg); + if (arg->nd_class == Value) { + struct type *tp = left->nd_type; + + FreeNode(expp->nd_left); + expp->nd_right->nd_left = 0; + FreeNode(expp->nd_right); + expp->nd_left = expp->nd_right = 0; + *expp = *arg; + expp->nd_type = tp; + } + else expp->nd_type = left->nd_type; + return 1; } @@ -362,7 +368,7 @@ chk_proccall(expp) param = left->nd_type->prc_params; while (param) { - if (!(arg = getarg(arg, 0))) return 0; + if (!(arg = getarg(arg, 0, param->par_var))) return 0; if (! TstParCompat(param->par_type, arg->nd_left->nd_type, @@ -371,12 +377,6 @@ node_error(arg->nd_left, "type incompatibility in parameter"); return 0; } - if (param->par_var && - !chk_designator(arg->nd_left, VARIABLE|DESIGNATOR)) { - node_error(arg->nd_left,"VAR parameter expected"); - return 0; - } - param = param->next; } @@ -451,20 +451,14 @@ chk_designator(expp, flag) if (expp->nd_class == Link) { assert(expp->nd_symb == '.'); + assert(expp->nd_right->nd_class == Name); if (! chk_designator(expp->nd_left, (flag|HASSELECTORS))) return 0; tp = expp->nd_left->nd_type; - if (expp->nd_right->nd_class == Def) { - /* We were here already! - */ - return 1; - } - assert(tp->tp_fund == T_RECORD); - assert(expp->nd_right->nd_class == Name); df = lookup(expp->nd_right->nd_IDF, tp->rec_scope); @@ -892,7 +886,7 @@ 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: - if (!(arg = getarg(arg, T_NUMERIC))) return 0; + if (!(arg = getarg(arg, T_NUMERIC, 0))) return 0; left = arg->nd_left; expp->nd_type = left->nd_type; if (left->nd_class == Value) cstcall(expp, S_ABS); @@ -900,25 +894,25 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); case S_CAP: expp->nd_type = char_type; - if (!(arg = getarg(arg, T_CHAR))) return 0; + if (!(arg = getarg(arg, T_CHAR, 0))) return 0; left = arg->nd_left; if (left->nd_class == Value) cstcall(expp, S_CAP); break; case S_CHR: expp->nd_type = char_type; - if (!(arg = getarg(arg, T_INTORCARD))) return 0; + if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0; left = arg->nd_left; if (left->nd_class == Value) cstcall(expp, S_CHR); break; case S_FLOAT: expp->nd_type = real_type; - if (!(arg = getarg(arg, T_INTORCARD))) return 0; + if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0; break; case S_HIGH: - if (!(arg = getarg(arg, T_ARRAY))) return 0; + if (!(arg = getarg(arg, T_ARRAY, 0))) return 0; expp->nd_type = arg->nd_left->nd_type->next; if (!expp->nd_type) { /* A dynamic array has no explicit index type @@ -930,19 +924,19 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); case S_MAX: case S_MIN: - if (!(arg = getarg(arg, T_DISCRETE))) return 0; + if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0; expp->nd_type = arg->nd_left->nd_type; cstcall(expp,left->nd_def->df_value.df_stdname); break; case S_ODD: - if (!(arg = getarg(arg, T_INTORCARD))) return 0; + if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0; expp->nd_type = bool_type; if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD); break; case S_ORD: - if (!(arg = getarg(arg, T_DISCRETE))) return 0; + if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0; expp->nd_type = card_type; if (arg->nd_left->nd_class == Value) cstcall(expp, S_ORD); break; @@ -957,7 +951,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); case S_TRUNC: expp->nd_type = card_type; - if (!(arg = getarg(arg, T_REAL))) return 0; + if (!(arg = getarg(arg, T_REAL, 0))) return 0; break; case S_VAL: @@ -975,7 +969,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); expp->nd_right = arg->nd_right; arg->nd_right = 0; FreeNode(arg); - arg = getarg(expp, T_INTORCARD); + arg = getarg(expp, T_INTORCARD, 0); if (!arg) return 0; if (arg->nd_left->nd_class == Value) cstcall(expp, S_VAL); break; @@ -983,7 +977,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); case S_ADR: expp->nd_type = address_type; - if (!(arg = getarg(arg, D_VARIABLE|D_FIELD))) return 0; + if (!(arg = getarg(arg, 0, 1))) return 0; break; case S_DEC: @@ -991,7 +985,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); expp->nd_type = 0; if (!(arg = getvariable(arg))) return 0; if (arg->nd_right) { - if (!(arg = getarg(arg, T_INTORCARD))) return 0; + if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0; } break; @@ -1011,7 +1005,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); node_error(arg, "EXCL and INCL expect a SET parameter"); return 0; } - if (!(arg = getarg(arg, T_DISCRETE))) return 0; + if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0; if (!TstAssCompat(tp->next, arg->nd_left->nd_type)) { /* What type of compatibility do we want here? apparently assignment compatibility! ??? ??? diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index f47349e1e..668d527b1 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -22,6 +22,7 @@ static char *RcsId = "$Header$"; #include "Lpars.h" extern label data_label(); +extern label text_label(); extern char *long2str(); extern char *symbol2str(); extern int proclevel; @@ -42,7 +43,7 @@ CodeConst(cst, size) else { C_df_dlb(dlab = data_label()); C_rom_icon(long2str((long) cst), 10); - C_lae_dlb(dlab); + C_lae_dlb(dlab, (arith) 0); C_loi(size); } } @@ -53,6 +54,10 @@ CodeString(nd) label lab; + if (nd->nd_type == charc_type) { + C_loc(nd->nd_INT); + return; + } C_df_dlb(lab = data_label()); C_rom_scon(nd->nd_STR, nd->nd_SLE); C_lae_dlb(lab); @@ -74,7 +79,6 @@ CodeExpr(nd, ds, true_label, false_label) struct desig *ds; label true_label, false_label; { - struct desig ds1, ds2; switch(nd->nd_class) { case Def: @@ -174,6 +178,18 @@ CodeCall(nd) } tp = left->nd_type; + if (left->nd_class == Def && + (left->nd_def->df_kind & (D_TYPE|D_HTYPE|D_HIDDEN))) { + /* it was just a cast. Simply ignore it + */ + Des = InitDesig; + CodeExpr(nd->nd_right->nd_left, &Des, NO_LABEL, NO_LABEL); + CodeValue(&Des); + *nd = *(nd->nd_right->nd_left); + nd->nd_type = left->nd_def->df_type; + return; + } + assert(tp->tp_fund == T_PROCEDURE); for (param = left->nd_type->prc_params; param; param = param->next) { @@ -223,7 +239,7 @@ CodeStd(nd) CodeAssign(nd, dst, dss) struct node *nd; - struct desig *dst, dss; + struct desig *dst, *dss; { /* Generate code for an assignment. Testing of type compatibility and the like is already done. @@ -262,8 +278,6 @@ CodeOper(expr, true_label, false_label) register struct node *leftop = expr->nd_left; register struct node *rightop = expr->nd_right; register struct type *tp = expr->nd_type; - struct desig Des; - register struct desig *ds = &Des; switch (oper) { case '+': diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c index aba69405f..b298221ab 100644 --- a/lang/m2/comp/cstoper.c +++ b/lang/m2/comp/cstoper.c @@ -289,9 +289,13 @@ cstset(expp) } if (j == setsize) expp->nd_INT = expp->nd_symb == '='; expp->nd_class = Value; + expp->nd_symb = INTEGER; free((char *) expp->nd_left->nd_set); free((char *) expp->nd_right->nd_set); - break; + FreeNode(expp->nd_left); + FreeNode(expp->nd_right); + expp->nd_left = expp->nd_right = 0; + return; default: assert(0); } @@ -319,6 +323,7 @@ cstcall(expp, call) FreeNode(expp->nd_right); } expp->nd_class = Value; + expp->nd_symb = INTEGER; switch(call) { case S_ABS: if (expr->nd_type->tp_fund == T_REAL) { diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c index 7f09be6c2..79d0f600a 100644 --- a/lang/m2/comp/desig.c +++ b/lang/m2/comp/desig.c @@ -30,6 +30,7 @@ struct desig InitDesig = {DSG_INIT, 0, 0}; CodeValue(ds, size) register struct desig *ds; + arith size; { /* Generate code to load the value of the designator described in "ds" @@ -73,6 +74,49 @@ CodeValue(ds, size) ds->dsg_kind = DSG_LOADED; } +CodeStore(ds, size) + register struct desig *ds; + arith size; +{ + /* Generate code to store the value on the stack in the designator + described in "ds" + */ + + switch(ds->dsg_kind) { + case DSG_FIXED: + if (size == word_size) { + if (ds->dsg_name) { + C_ste_dnam(ds->dsg_name, ds->dsg_offset); + } + else C_stl(ds->dsg_offset); + break; + } + + if (size == dword_size) { + if (ds->dsg_name) { + C_sde_dnam(ds->dsg_name, ds->dsg_offset); + } + else C_sdl(ds->dsg_offset); + break; + } + /* Fall through */ + case DSG_PLOADED: + case DSG_PFIXED: + CodeAddress(ds); + C_sti(size); + break; + + case DSG_INDEXED: + C_sar(word_size); + break; + + default: + crash("(CodeStore)"); + } + + ds->dsg_kind = DSG_INIT; +} + CodeAddress(ds) register struct desig *ds; { @@ -144,6 +188,7 @@ CodeFieldDesig(df, ds) /* Found it. Now, act like it was a selection. */ *ds = wds->w_desig; + assert(ds->dsg_kind == DSG_PFIXED); } switch(ds->dsg_kind) { @@ -277,6 +322,7 @@ CodeDesig(nd, ds) case Link: assert(nd->nd_symb == '.'); assert(nd->nd_right->nd_class == Def); + CodeDesig(nd->nd_left, ds); CodeFieldDesig(nd->nd_right->nd_def, ds); break; @@ -297,6 +343,7 @@ CodeDesig(nd, ds) */ /* ??? */ } + ds->dsg_kind = DSG_INDEXED; break; case Uoper: diff --git a/lang/m2/comp/error.c b/lang/m2/comp/error.c index 38a29fff9..a430f70b5 100644 --- a/lang/m2/comp/error.c +++ b/lang/m2/comp/error.c @@ -49,7 +49,7 @@ extern char *symbol2str(); */ #ifdef DEBUG -/*VARARGS2*/ +/*VARARGS1*/ debug(fmt, args) char *fmt; { diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 6825795f0..8f306e290 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -200,8 +200,8 @@ factor(struct node **p;) tp = charc_type; i = *(dot.TOK_STR) & 0377; - free(dot.TOK_STR); free((char *) dot.tk_data.tk_str); + free(dot.TOK_STR); dot.TOK_INT = i; } else tp = standard_type(T_STRING, 1, dot.TOK_SLE); diff --git a/lang/m2/comp/tmpvar.C b/lang/m2/comp/tmpvar.C new file mode 100644 index 000000000..c4778bf29 --- /dev/null +++ b/lang/m2/comp/tmpvar.C @@ -0,0 +1,114 @@ +/* T E M P O R A R Y V A R I A B L E S */ + +#ifndef NORCSID +static char *RcsId = "$Header$"; +#endif + +/* Code for the allocation and de-allocation of temporary variables, + allowing re-use. +*/ + +#include "debug.h" + +#include +#include +#include +#include +#include + +#include "def.h" +#include "type.h" +#include "scope.h" + +struct tmpvar { + struct tmpvar *next; + arith t_offset; /* offset from LocalBase */ +}; + +/* STATICALLOCDEF "tmpvar" */ + +static struct tmpvar *TmpInts, /* for integer temporaries */ + *TmpPtrs; /* for pointer temporaries */ + +extern arith align(); + +arith +NewInt() +{ + arith offset; + register struct tmpvar *tmp; + + if (!TmpInts) { + offset = - align(int_size - CurrentScope->sc_off, int_align); + CurrentScope->sc_off = offset; + C_ms_reg(offset, int_size, reg_any, 0); + } + else { + tmp = TmpInts; + offset = tmp->t_offset; + TmpInts = tmp->next; + free_tmpvar(tmp); + } + return offset; +} + +arith +NewPtr() +{ + arith offset; + register struct tmpvar *tmp; + + if (!TmpPtrs) { + offset = - align(pointer_size - CurrentScope->sc_off, pointer_align); + CurrentScope->sc_off = offset; + C_ms_reg(offset, pointer_size, reg_pointer, 0); + } + else { + tmp = TmpPtrs; + offset = tmp->t_offset; + TmpPtrs = tmp->next; + free_tmpvar(tmp); + } + return offset; +} + +FreeInt(off) + arith off; +{ + register struct tmpvar *tmp; + + tmp = new_tmpvar(); + tmp->next = TmpInts; + tmp->t_offset = off; + TmpInts = tmp; +} + +FreePtr(off) + arith off; +{ + register struct tmpvar *tmp; + + tmp = new_tmpvar(); + tmp->next = TmpPtrs; + tmp->t_offset = off; + TmpPtrs = tmp; +} + +TmpClose() +{ + register struct tmpvar *tmp, *tmp1; + + tmp = TmpInts; + while (tmp) { + tmp1 = tmp; + tmp = tmp->next; + free_tmpvar(tmp1); + } + tmp = TmpPtrs; + while (tmp) { + tmp1 = tmp; + tmp = tmp->next; + free_tmpvar(tmp1); + } + TmpInts = TmpPtrs = 0; +} diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index 1ea53dd6e..f71cd5ed0 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -22,8 +22,10 @@ static char *RcsId = "$Header$"; #include "node.h" #include "Lpars.h" #include "desig.h" +#include "f_info.h" extern arith align(); +extern arith NewPtr(); extern int proclevel; static label instructionlabel; static char return_expr_occurred; @@ -44,6 +46,22 @@ data_label() return ++datalabel; } +static +DoProfil() +{ + static label filename_label = 0; + + if (options['p']) { + if (!filename_label) { + filename_label = data_label(); + C_df_dlb(filename_label); + C_rom_scon(FileName, (arith) strlen(FileName)); + } + + C_fil_dlb(filename_label, (arith) 0); + } +} + WalkModule(module) register struct def *module; { @@ -96,11 +114,13 @@ WalkModule(module) instructionlabel = 2; func_type = 0; C_pro_narg(CurrentScope->sc_name); + DoProfil(); MkCalls(CurrentScope->sc_def); WalkNode(module->mod_body, (label) 0); C_df_ilb((label) 1); C_ret(0); - C_end(align(-CurrentScope->sc_off, word_align)); + C_end(-CurrentScope->sc_off); + TmpClose(); CurrVis = vis; } @@ -121,6 +141,7 @@ WalkProcedure(procedure) /* Generate code for this procedure */ C_pro_narg(CurrentScope->sc_name); + DoProfil(); /* generate calls to initialization routines of modules defined within this procedure */ @@ -137,7 +158,8 @@ node_error(procedure->prc_body,"function procedure does not return a value"); C_ret((int) align(func_type->tp_size, word_align)); } else C_ret(0); - C_end(align(-CurrentScope->sc_off, word_align)); + C_end(-CurrentScope->sc_off); + TmpClose(); CurrVis = vis; proclevel--; } @@ -203,6 +225,8 @@ WalkStat(nd, lab) register struct node *left = nd->nd_left; register struct node *right = nd->nd_right; + if (options['p']) C_lin((arith) nd->nd_lineno); + if (!nd) { /* Empty statement */ @@ -306,6 +330,7 @@ WalkStat(nd, lab) { struct scopelist link; struct withdesig wds; + arith tmp = 0; WalkDesignator(left); if (left->nd_type->tp_fund != T_RECORD) { @@ -316,12 +341,18 @@ WalkStat(nd, lab) wds.w_next = WithDesigs; WithDesigs = &wds; wds.w_scope = left->nd_type->rec_scope; - /* - Decide here wether to use a temporary variable or - not, depending on the value of Desig. - Suggestion: temporary if Desig != DSG_FIXED - ??? - */ + if (Desig.dsg_kind != DSG_PFIXED) { + /* In this case, we use a temporary variable + */ + CodeAddress(&Desig); + Desig.dsg_kind = DSG_FIXED; + /* Only for the store ... */ + Desig.dsg_offset = tmp = NewPtr(); + Desig.dsg_name = 0; + CodeStore(&Desig, pointer_size); + Desig.dsg_kind = DSG_PFIXED; + /* the record is indirectly available */ + } wds.w_desig = Desig; link.sc_scope = wds.w_scope; link.next = CurrVis; @@ -329,6 +360,7 @@ WalkStat(nd, lab) WalkNode(right, lab); CurrVis = link.next; WithDesigs = wds.w_next; + if (tmp) FreePtr(tmp); break; } -- 2.34.1