d0p1/ack
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

newer version

Browse source
This commit is contained in:
ceriel 1986-05-23 09:46:31 +00:00
parent 0f04bc72bd
commit 1cfe2b5dac
9 changed files with 267 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
lang/m2/comp/Makefile
View file

@ -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

70
lang/m2/comp/chk_expr.c
View file

@ -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! ??? ???

24
lang/m2/comp/code.c
View file

@ -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 '+':

7
lang/m2/comp/cstoper.c
View file

@ -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) {

47
lang/m2/comp/desig.c
View file

@ -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:

2
lang/m2/comp/error.c
View file

@ -49,7 +49,7 @@ extern char *symbol2str();
*/
#ifdef DEBUG
/*VARARGS2*/
/*VARARGS1*/
debug(fmt, args)
char *fmt;
{

2
lang/m2/comp/expression.g
View file

@ -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);

114
lang/m2/comp/tmpvar.C Normal file
View file

@ -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 <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;
}

48
lang/m2/comp/walk.c
View file

@ -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;
}