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
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 \
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
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
}
struct node *
-getarg(argp, bases)
+getarg(argp, bases, designator)
struct node *argp;
{
struct type *tp;
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)) {
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) {
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;
}
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,
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;
}
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);
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);
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
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;
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:
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;
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:
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;
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! ??? ???
#include "Lpars.h"
extern label data_label();
+extern label text_label();
extern char *long2str();
extern char *symbol2str();
extern int proclevel;
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);
}
}
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);
struct desig *ds;
label true_label, false_label;
{
- struct desig ds1, ds2;
switch(nd->nd_class) {
case Def:
}
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) {
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.
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 '+':
}
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);
}
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) {
CodeValue(ds, size)
register struct desig *ds;
+ arith size;
{
/* Generate code to load the value of the designator described
in "ds"
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;
{
/* Found it. Now, act like it was a selection.
*/
*ds = wds->w_desig;
+ assert(ds->dsg_kind == DSG_PFIXED);
}
switch(ds->dsg_kind) {
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;
*/
/* ??? */
}
+ ds->dsg_kind = DSG_INDEXED;
break;
case Uoper:
*/
#ifdef DEBUG
-/*VARARGS2*/
+/*VARARGS1*/
debug(fmt, args)
char *fmt;
{
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);
--- /dev/null
+/* 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 <em_arith.h>
+#include <em_label.h>
+#include <em_reg.h>
+#include <alloc.h>
+#include <assert.h>
+
+#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;
+}
#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;
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;
{
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;
}
/* Generate code for this procedure
*/
C_pro_narg(CurrentScope->sc_name);
+ DoProfil();
/* generate calls to initialization routines of modules defined within
this procedure
*/
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--;
}
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
*/
{
struct scopelist link;
struct withdesig wds;
+ arith tmp = 0;
WalkDesignator(left);
if (left->nd_type->tp_fund != T_RECORD) {
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;
WalkNode(right, lab);
CurrVis = link.next;
WithDesigs = wds.w_next;
+ if (tmp) FreePtr(tmp);
break;
}
public / ack.git / commitdiff