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-30 18:48:00 +00:00
parent 6382054ae5
commit db795bc07a
23 changed files with 594 additions and 318 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
lang/m2/comp/LLlex.c
View file

@ -182,6 +182,10 @@ again:
if (nch == '=') {
return tk->tk_symb = LESSEQUAL;
}
if (nch == '>') {
lexwarning("'<>' is old-fashioned; use '#'");
return tk->tk_symb = '#';
}
PushBack(nch);
return tk->tk_symb = ch;

7
lang/m2/comp/Makefile
View file

@ -54,7 +54,6 @@ tokenfile.g: tokenname.c make.tokfile
symbol2str.c: tokenname.c make.tokcase
make.tokcase <tokenname.c >symbol2str.c
misc.h: misc.H make.allocd
def.h: def.H make.allocd
type.h: type.H make.allocd
node.h: node.H make.allocd
@ -90,13 +89,13 @@ symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
input.o: f_info.h input.h inputtype.h
type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h target_sizes.h type.h
type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h scope.h target_sizes.h type.h
def.o: LLlex.h Lpars.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 debug.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 main.h scope.h
typequiv.o: def.h type.h
typequiv.o: LLlex.h def.h node.h type.h
node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h debug.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
@ -104,7 +103,7 @@ options.o: idfsize.h main.h ndir.h type.h
walk.o: LLlex.h Lpars.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.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
code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h
tmpvar.o: debug.h def.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

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

@ -254,47 +254,53 @@ rem_set(set)
struct node *
getarg(argp, bases, designator)
struct node *argp;
struct node **argp;
{
struct type *tp;
register struct node *arg = *argp;
if (!argp->nd_right) {
node_error(argp, "too few arguments supplied");
if (!arg->nd_right) {
node_error(arg, "too few arguments supplied");
return 0;
}
argp = argp->nd_right;
if ((!designator && !chk_expr(argp->nd_left)) ||
(designator && !chk_designator(argp->nd_left, DESIGNATOR, D_REFERRED))) {
arg = arg->nd_right;
if ((!designator && !chk_expr(arg->nd_left)) ||
(designator && !chk_designator(arg->nd_left, DESIGNATOR, D_REFERRED))) {
return 0;
}
tp = argp->nd_left->nd_type;
tp = arg->nd_left->nd_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (bases && !(tp->tp_fund & bases)) {
node_error(argp, "unexpected type");
node_error(arg, "unexpected type");
return 0;
}
return argp;
*argp = arg;
return arg->nd_left;
}
struct node *
getname(argp, kinds)
struct node *argp;
struct node **argp;
{
if (!argp->nd_right) {
node_error(argp, "too few arguments supplied");
register struct node *arg = *argp;
if (!arg->nd_right) {
node_error(arg, "too few arguments supplied");
return 0;
}
argp = argp->nd_right;
if (! chk_designator(argp->nd_left, 0, D_REFERRED)) return 0;
arg = arg->nd_right;
if (! chk_designator(arg->nd_left, 0, D_REFERRED)) return 0;
assert(argp->nd_left->nd_class == Def);
assert(arg->nd_left->nd_class == Def);
if (!(argp->nd_left->nd_def->df_kind & kinds)) {
node_error(argp, "unexpected type");
if (!(arg->nd_left->nd_def->df_kind & kinds)) {
node_error(arg, "unexpected type");
return 0;
}
return argp;
*argp = arg;
return arg->nd_left;
}
int
@ -314,44 +320,20 @@ chk_call(expp)
left = expp->nd_left;
if (! chk_designator(left, 0, D_USED)) return 0;
if (left->nd_class == Def && is_type(left->nd_def)) {
if (IsCast(left)) {
/* It was a type cast. This is of course not portable.
*/
arg = expp->nd_right;
if ((! arg) || arg->nd_right) {
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, "unequal sizes in type cast");
}
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;
return chk_cast(expp, left);
}
if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) ||
left->nd_type->tp_fund == T_PROCEDURE) {
if (IsProcCall(left)) {
/* A procedure call. it may also be a call to a
standard procedure
*/
arg = expp;
if (left->nd_type == std_type) {
/* A standard procedure
*/
return chk_std(expp, left, arg);
return chk_std(expp, left);
}
/* Here, we have found a real procedure call. The left hand
side may also represent a procedure variable.
@ -363,12 +345,12 @@ node_error(expp, "unequal sizes in type cast");
}
chk_proccall(expp)
struct node *expp;
register struct node *expp;
{
/* Check a procedure call
*/
register struct node *left;
register struct node *arg;
struct node *arg;
register struct paramlist *param;
left = 0;
@ -383,20 +365,21 @@ chk_proccall(expp)
left = expp->nd_left;
arg = expp;
arg->nd_type = left->nd_type->next;
expp->nd_type = left->nd_type->next;
param = left->nd_type->prc_params;
while (param) {
if (!(arg = getarg(arg, 0, param->par_var))) return 0;
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (! TstParCompat(param->par_type,
arg->nd_left->nd_type,
param->par_var)) {
node_error(arg->nd_left, "type incompatibility in parameter");
if (! TstParCompat(TypeOfParam(param),
left->nd_type,
IsVarParam(param),
left)) {
node_error(left, "type incompatibility in parameter");
return 0;
}
if (param->par_var && arg->nd_left->nd_class == Def) {
arg->nd_left->nd_def->df_flags |= D_NOREG;
if (IsVarParam(param) && left->nd_class == Def) {
left->nd_def->df_flags |= D_NOREG;
}
param = param->next;
@ -475,7 +458,6 @@ chk_designator(expp, flag, dflags)
if (expp->nd_class == Link) {
assert(expp->nd_symb == '.');
assert(expp->nd_right->nd_class == Name);
if (! chk_designator(expp->nd_left,
flag|HASSELECTORS,
@ -485,19 +467,17 @@ chk_designator(expp, flag, dflags)
assert(tp->tp_fund == T_RECORD);
df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
df = lookup(expp->nd_IDF, tp->rec_scope);
if (!df) {
id_not_declared(expp->nd_right);
id_not_declared(expp);
return 0;
}
else {
expp->nd_right->nd_class = Def;
expp->nd_right->nd_def = df;
expp->nd_def = df;
expp->nd_type = df->df_type;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
node_error(expp->nd_right,
"identifier \"%s\" not exported from qualifying module",
node_error(expp, "identifier \"%s\" not exported from qualifying module",
df->df_idf->id_text);
return 0;
}
@ -508,11 +488,10 @@ df->df_idf->id_text);
expp->nd_class = Def;
expp->nd_def = df;
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
expp->nd_left = 0;
}
else {
return FlagCheck(expp->nd_right, df, flag);
return FlagCheck(expp, df, flag);
}
}
@ -869,10 +848,11 @@ chk_uoper(expp)
}
struct node *
getvariable(arg)
register struct node *arg;
getvariable(argp)
struct node **argp;
{
struct def *df;
register struct node *arg = *argp;
register struct def *df;
register struct node *left;
arg = arg->nd_right;
@ -885,62 +865,65 @@ getvariable(arg)
if (! chk_designator(left, DESIGNATOR, D_REFERRED)) return 0;
if (left->nd_class == Oper || left->nd_class == Uoper) {
return arg;
*argp = arg;
return left;
}
df = 0;
if (left->nd_class == Link) df = left->nd_right->nd_def;
else if (left->nd_class == Def) df = left->nd_def;
if (left->nd_class == Link || left->nd_class == Def) {
df = left->nd_def;
}
if (!df || !(df->df_kind & (D_VARIABLE|D_FIELD))) {
node_error(arg, "variable expected");
return 0;
}
return arg;
*argp = arg;
return left;
}
int
chk_std(expp, left, arg)
register struct node *expp, *left, *arg;
chk_std(expp, left)
register struct node *expp, *left;
{
/* Check a call of a standard procedure or function
*/
struct node *arg = expp;
int std;
assert(left->nd_class == Def);
DO_DEBUG(3, debug("standard name \"%s\", %d",
left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
std = left->nd_def->df_value.df_stdname;
switch(left->nd_def->df_value.df_stdname) {
DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
switch(std) {
case S_ABS:
if (!(arg = getarg(arg, T_NUMERIC, 0))) return 0;
left = arg->nd_left;
if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
expp->nd_type = left->nd_type;
if (left->nd_class == Value) cstcall(expp, S_ABS);
break;
case S_CAP:
expp->nd_type = char_type;
if (!(arg = getarg(arg, T_CHAR, 0))) return 0;
left = arg->nd_left;
if (!(left = getarg(&arg, T_CHAR, 0))) return 0;
if (left->nd_class == Value) cstcall(expp, S_CAP);
break;
case S_CHR:
expp->nd_type = char_type;
if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
left = arg->nd_left;
if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
if (left->nd_class == Value) cstcall(expp, S_CHR);
break;
case S_FLOAT:
expp->nd_type = real_type;
if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
break;
case S_HIGH:
if (!(arg = getarg(arg, T_ARRAY, 0))) return 0;
expp->nd_type = arg->nd_left->nd_type->next;
if (!(left = getarg(&arg, T_ARRAY, 0))) return 0;
expp->nd_type = left->nd_type->next;
if (!expp->nd_type) {
/* A dynamic array has no explicit index type
*/
@ -951,68 +934,75 @@ 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, 0))) return 0;
expp->nd_type = arg->nd_left->nd_type;
cstcall(expp,left->nd_def->df_value.df_stdname);
if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
expp->nd_type = left->nd_type;
cstcall(expp,std);
break;
case S_ODD:
if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
expp->nd_type = bool_type;
if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD);
if (left->nd_class == Value) cstcall(expp, S_ODD);
break;
case S_ORD:
if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0;
if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
if (left->nd_type->tp_size > word_size) {
node_error(left, "illegal type in argument of ORD");
return 0;
}
expp->nd_type = card_type;
if (arg->nd_left->nd_class == Value) cstcall(expp, S_ORD);
if (left->nd_class == Value) cstcall(expp, S_ORD);
break;
case S_TSIZE: /* ??? */
case S_SIZE:
expp->nd_type = intorcard_type;
arg = getname(arg, D_FIELD|D_VARIABLE|D_ISTYPE);
if (!arg) return 0;
if (! getname(&arg, D_FIELD|D_VARIABLE|D_ISTYPE)) return 0;
cstcall(expp, S_SIZE);
break;
case S_TRUNC:
expp->nd_type = card_type;
if (!(arg = getarg(arg, T_REAL, 0))) return 0;
if (!(left = getarg(&arg, T_REAL, 0))) return 0;
break;
case S_VAL:
{
struct type *tp;
if (!(arg = getname(arg, D_ISTYPE))) return 0;
tp = arg->nd_left->nd_def->df_type;
if (!(left = getname(&arg, D_ISTYPE))) return 0;
tp = left->nd_def->df_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (!(tp->tp_fund & T_DISCRETE)) {
node_error(arg, "unexpected type");
return 0;
}
expp->nd_type = arg->nd_left->nd_def->df_type;
expp->nd_type = left->nd_def->df_type;
expp->nd_right = arg->nd_right;
arg->nd_right = 0;
FreeNode(arg);
arg = getarg(expp, T_INTORCARD, 0);
if (!arg) return 0;
if (arg->nd_left->nd_class == Value) cstcall(expp, S_VAL);
arg = expp;
if (!(left = getarg(&arg, T_INTORCARD, 0))) return 0;
if (left->nd_class == Value) cstcall(expp, S_VAL);
break;
}
case S_ADR:
expp->nd_type = address_type;
if (!(arg = getarg(arg, 0, 1))) return 0;
if (!(left = getarg(&arg, 0, 1))) return 0;
break;
case S_DEC:
case S_INC:
expp->nd_type = 0;
if (!(arg = getvariable(arg))) return 0;
if (! (left = getvariable(&arg))) return 0;
if (! (left->nd_type->tp_fund & T_DISCRETE)) {
node_error(left, "illegal type in argument of INC or DEC");
return 0;
}
if (arg->nd_right) {
if (!(arg = getarg(arg, T_INTORCARD, 0))) return 0;
if (! getarg(&arg, T_INTORCARD, 0)) return 0;
}
break;
@ -1026,14 +1016,14 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
struct type *tp;
expp->nd_type = 0;
if (!(arg = getvariable(arg))) return 0;
tp = arg->nd_left->nd_type;
if (!(left = getvariable(&arg))) return 0;
tp = left->nd_type;
if (tp->tp_fund != T_SET) {
node_error(arg, "EXCL and INCL expect a SET parameter");
return 0;
}
if (!(arg = getarg(arg, T_DISCRETE, 0))) return 0;
if (!TstAssCompat(tp->next, arg->nd_left->nd_type)) {
if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
if (!TstAssCompat(tp->next, left->nd_type)) {
/* What type of compatibility do we want here?
apparently assignment compatibility! ??? ???
*/
@ -1044,7 +1034,7 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
}
default:
assert(0);
crash("(chk_std)");
}
if (arg->nd_right) {
@ -1054,3 +1044,44 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
return 1;
}
chk_cast(expp, left)
register struct node *expp, *left;
{
/* Check a cast and perform it if the argument is constant.
If the sizes don't match, only complain if at least one of them
has a size larger than the word size.
If both sizes are equal to or smaller than the word size, there
is no problem as such values take a word on the EM stack
anyway.
*/
register struct node *arg = expp->nd_right;
if ((! arg) || arg->nd_right) {
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 &&
(arg->nd_type->tp_size > word_size ||
left->nd_type->tp_size > word_size)) {
node_error(expp, "unequal sizes in type cast");
}
if (arg->nd_class == Value) {
struct type *tp = left->nd_type;
FreeNode(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;
}

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

@ -20,6 +20,7 @@ static char *RcsId = "$Header$";
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "standards.h"
extern label data_label();
extern label text_label();
@ -81,6 +82,11 @@ CodeExpr(nd, ds, true_label, false_label)
switch(nd->nd_class) {
case Def:
if (nd->nd_def->df_kind == D_PROCEDURE) {
C_lpi(nd->nd_def->prc_vis->sc_scope->sc_name);
ds->dsg_kind = DSG_LOADED;
break;
}
CodeDesig(nd, ds);
break;
@ -102,8 +108,7 @@ CodeExpr(nd, ds, true_label, false_label)
CodeDesig(nd, ds);
break;
}
CodeExpr(nd->nd_right, ds, NO_LABEL, NO_LABEL);
CodeValue(ds, nd->nd_right->nd_type->tp_size);
CodePExpr(nd->nd_right);
CodeUoper(nd);
ds->dsg_kind = DSG_LOADED;
break;
@ -181,6 +186,7 @@ CodeCoercion(t1, t2)
if ((fund2 = t2->tp_fund) == T_WORD) fund2 = T_INTEGER;
switch(fund1) {
case T_INTEGER:
case T_INTORCARD:
switch(fund2) {
case T_INTEGER:
if (t2->tp_size != t1->tp_size) {
@ -274,7 +280,6 @@ CodeCall(nd)
register struct paramlist *param;
struct type *tp;
arith pushed = 0;
struct desig Des;
if (left->nd_type == std_type) {
CodeStd(nd);
@ -282,32 +287,27 @@ CodeCall(nd)
}
tp = left->nd_type;
if (left->nd_class == Def && is_type(left->nd_def)) {
if (IsCast(left)) {
/* it was just a cast. Simply ignore it
*/
Des = InitDesig;
CodeExpr(nd->nd_right->nd_left, &Des, NO_LABEL, NO_LABEL);
CodeValue(&Des, tp->tp_size);
CodePExpr(nd->nd_right->nd_left);
*nd = *(nd->nd_right->nd_left);
nd->nd_type = left->nd_def->df_type;
return;
}
assert(tp->tp_fund == T_PROCEDURE);
assert(IsProcCall(left));
for (param = left->nd_type->prc_params; param; param = param->next) {
Des = InitDesig;
arg = arg->nd_right;
assert(arg != 0);
if (param->par_var) {
CodeDesig(arg->nd_left, &Des);
CodeAddress(&Des);
if (IsVarParam(param)) {
CodeDAddress(arg->nd_left);
pushed += pointer_size;
}
else {
CodeExpr(arg->nd_left, &Des, NO_LABEL, NO_LABEL);
CodeValue(&Des, arg->nd_left->nd_type->tp_size);
CheckAssign(arg->nd_left->nd_type, param->par_type);
CodePExpr(arg->nd_left);
CheckAssign(arg->nd_left->nd_type, TypeOfParam(param));
pushed += align(arg->nd_left->nd_type->tp_size, word_align);
}
/* ??? Conformant arrays */
@ -324,9 +324,7 @@ CodeCall(nd)
C_cal(left->nd_def->for_name);
}
else {
Des = InitDesig;
CodeDesig(left, &Des);
CodeAddress(&Des);
CodePExpr(left);
C_cai();
}
C_asp(pushed);
@ -338,7 +336,141 @@ CodeCall(nd)
CodeStd(nd)
struct node *nd;
{
/* ??? */
register struct node *arg = nd->nd_right;
register struct node *left = 0;
register struct type *tp = 0;
int std;
if (arg) {
left = arg->nd_left;
tp = left->nd_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
arg = arg->nd_right;
}
Desig = InitDesig;
switch(std = nd->nd_left->nd_def->df_value.df_stdname) {
case S_ABS:
CodePExpr(left);
if (tp->tp_fund == T_INTEGER) {
if (tp->tp_size == int_size) {
C_cal("_absi");
}
else C_cal("_absl");
}
else if (tp->tp_fund == T_REAL) {
if (tp->tp_size == float_size) {
C_cal("_absf");
}
else C_cal("_absd");
}
C_lfr(tp->tp_size);
break;
case S_CAP:
CodePExpr(left);
C_loc((arith) 0137);
C_and(word_size);
break;
case S_CHR:
CodePExpr(left);
CheckAssign(char_type, tp);
break;
case S_FLOAT:
CodePExpr(left);
CodeCoercion(tp, real_type);
break;
case S_HIGH:
assert(IsConformantArray(tp));
/* ??? */
break;
case S_ODD:
if (tp->tp_size == word_size) {
C_loc((arith) 1);
C_and(word_size);
}
else {
assert(tp->tp_size == dword_size);
C_ldc((arith) 1);
C_and(dword_size);
C_ior(word_size);
}
break;
case S_ORD:
CodePExpr(left);
break;
case S_TRUNC:
CodePExpr(left);
CodeCoercion(tp, card_type);
break;
case S_VAL:
CodePExpr(left);
CheckAssign(nd->nd_type, tp);
break;
case S_ADR:
CodeDAddress(left);
break;
case S_DEC:
case S_INC:
CodePExpr(left);
if (arg) CodePExpr(arg->nd_left);
else C_loc((arith) 1);
if (tp->tp_size <= word_size) {
if (std == S_DEC) {
if (tp->tp_fund == T_INTEGER) C_sbi(word_size);
else C_sbu(word_size);
}
else {
if (tp->tp_fund == T_INTEGER) C_adi(word_size);
else C_adu(word_size);
}
CheckAssign(tp, int_type);
}
else {
CodeCoercion(int_type, tp);
if (std == S_DEC) {
if (tp->tp_fund==T_INTEGER) C_sbi(tp->tp_size);
else C_sbu(tp->tp_size);
}
else {
if (tp->tp_fund==T_INTEGER) C_adi(tp->tp_size);
else C_adu(tp->tp_size);
}
}
CodeDStore(left);
break;
case S_HALT:
C_cal("_halt");
break;
case S_INCL:
case S_EXCL:
CodePExpr(left);
CodePExpr(arg->nd_left);
C_set(tp->tp_size);
if (std == S_INCL) {
C_ior(tp->tp_size);
}
else {
C_com(tp->tp_size);
C_and(tp->tp_size);
}
CodeDStore(left);
break;
default:
crash("(CodeStd)");
}
}
CodeAssign(nd, dss, dst)
@ -353,6 +485,7 @@ CodeAssign(nd, dss, dst)
CodeStore(dst, nd->nd_left->nd_type->tp_size);
}
else {
CodeAddress(dss);
CodeAddress(dst);
C_blm(nd->nd_left->nd_type->tp_size);
}
@ -395,12 +528,8 @@ CheckAssign(tpl, tpr)
Operands(leftop, rightop)
register struct node *leftop, *rightop;
{
struct desig Des;
Des = InitDesig;
CodeExpr(leftop, &Des, NO_LABEL, NO_LABEL);
CodeValue(&Des, leftop->nd_type->tp_size);
Des = InitDesig;
CodePExpr(leftop);
if (rightop->nd_type->tp_fund == T_POINTER &&
leftop->nd_type->tp_size != pointer_size) {
@ -408,8 +537,7 @@ Operands(leftop, rightop)
leftop->nd_type = rightop->nd_type;
}
CodeExpr(rightop, &Des, NO_LABEL, NO_LABEL);
CodeValue(&Des, rightop->nd_type->tp_size);
CodePExpr(rightop);
}
CodeOper(expr, true_label, false_label)
@ -787,11 +915,48 @@ CodeEl(nd, tp)
C_asp(2 * word_size + pointer_size);
}
else {
struct desig Des;
Des = InitDesig;
CodeExpr(nd, &Des, NO_LABEL, NO_LABEL);
CodeValue(&Des, word_size);
CodePExpr(nd);
C_set(tp->tp_size);
}
}
CodePExpr(nd)
struct node *nd;
{
/* Generate code to push the value of the expression "nd"
on the stack.
*/
struct desig designator;
designator = InitDesig;
CodeExpr(nd, &designator, NO_LABEL, NO_LABEL);
CodeValue(&designator, nd->nd_type->tp_size);
}
CodeDAddress(nd)
struct node *nd;
{
/* Generate code to push the address of the designator "nd"
on the stack.
*/
struct desig designator;
designator = InitDesig;
CodeDesig(nd, &designator);
CodeAddress(&designator);
}
CodeDStore(nd)
register struct node *nd;
{
/* Generate code to store the expression on the stack into the
designator "nd".
*/
struct desig designator;
designator = InitDesig;
CodeDesig(nd, &designator);
CodeStore(&designator, nd->nd_type->tp_size);
}

63
lang/m2/comp/declar.g
View file

@ -23,25 +23,23 @@ static char *RcsId = "$Header$";
int proclevel = 0; /* nesting level of procedures */
extern char *sprint();
extern struct def *currentdef;
}
ProcedureDeclaration
{
struct def *df;
struct def *savecurr = currentdef;
} :
{ proclevel++; }
ProcedureHeading(&df, D_PROCEDURE)
{
currentdef = df;
CurrentScope->sc_definedby = df;
df->prc_vis = CurrVis;
}
';' block(&(df->prc_body)) IDENT
{
match_id(dot.TOK_IDF, df->df_idf);
df->prc_vis = CurrVis;
close_scope(SC_CHKFORW|SC_REVERSE);
proclevel--;
currentdef = savecurr;
}
;
@ -54,17 +52,16 @@ ProcedureHeading(struct def **pdf; int type;)
} :
PROCEDURE IDENT
{
if (type == D_PROCEDURE) proclevel++;
df = DeclProc(type);
tp = construct_type(T_PROCEDURE, tp);
if (proclevel > 1) {
if (proclevel) {
/* Room for static link
*/
tp->prc_nbpar = pointer_size;
}
else tp->prc_nbpar = 0;
}
FormalParameters(type == D_PROCEDURE, &params, &(tp->next), &(tp->prc_nbpar))?
FormalParameters(&params, &(tp->next), &(tp->prc_nbpar))?
{
tp->prc_params = params;
if (df->df_type) {
@ -79,6 +76,8 @@ error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
df->df_type = tp;
*pdf = df;
if (type == D_PROCHEAD) close_scope(0);
DO_DEBUG(1, type == D_PROCEDURE &&
(print("proc %s:", df->df_idf->id_text),
DumpType(tp), print("\n")));
@ -110,20 +109,17 @@ declaration:
ModuleDeclaration ';'
;
FormalParameters(int doparams;
struct paramlist **pr;
FormalParameters(struct paramlist **pr;
struct type **tp;
arith *parmaddr;)
{
struct def *df;
register struct paramlist *pr1;
} :
'('
[
FPSection(doparams, pr, parmaddr)
FPSection(pr, parmaddr)
[
{ for (pr1 = *pr; pr1->next; pr1 = pr1->next) ; }
';' FPSection(doparams, &(pr1->next), parmaddr)
';' FPSection(pr, parmaddr)
]*
]?
')'
@ -134,16 +130,9 @@ FormalParameters(int doparams;
]?
;
/* In the next nonterminal, "doparams" is a flag indicating whether
the identifiers representing the parameters must be added to the
symbol table. We must not do so when reading a Definition Module,
because in this case we only read the header. The Implementation
might contain different identifiers representing the same paramters.
*/
FPSection(int doparams; struct paramlist **ppr; arith *addr;)
FPSection(struct paramlist **ppr; arith *parmaddr;)
{
struct node *FPList;
struct paramlist *ParamList();
struct type *tp;
int VARp = 0;
} :
@ -152,11 +141,7 @@ FPSection(int doparams; struct paramlist **ppr; arith *addr;)
]?
IdentList(&FPList) ':' FormalType(&tp)
{
if (doparams) {
EnterIdList(FPList, D_VARIABLE, VARp,
tp, CurrentScope, addr);
}
*ppr = ParamList(FPList, tp, VARp);
ParamList(ppr, FPList, tp, VARp, parmaddr);
FreeNode(FPList);
}
;
@ -530,27 +515,29 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;)
} :
'(' { *ppr = 0; }
[
[ VAR { VARp = 1; }
| { VARp = 0; }
[ VAR { VARp = D_VARPAR; }
| { VARp = D_VALPAR; }
]
FormalType(&tp)
{ *ppr = p = new_paramlist();
p->par_type = tp;
p->par_var = VARp;
p->next = 0;
p->par_def = df = new_def();
df->df_type = tp;
df->df_flags = VARp;
}
[
','
[ VAR {VARp = 1; }
| {VARp = 0; }
[ VAR {VARp = D_VARPAR; }
| {VARp = D_VALPAR; }
]
FormalType(&tp)
{ p->next = new_paramlist();
p = p->next;
p->par_type = tp;
p->par_var = VARp;
{ p = new_paramlist();
p->next = *ppr; *ppr = p;
p->par_def = df = new_def();
df->df_type = tp;
df->df_flags = VARp;
}
]*
{ p->next = 0; }
]?
')'
[ ':' qualident(D_TYPE, &df, "type", (struct node **) 0)

6
lang/m2/comp/def.c
View file

@ -20,7 +20,10 @@ static char *RcsId = "$Header$";
#include "node.h"
#include "Lpars.h"
struct def *h_def; /* Pointer to free list of def structures */
struct def *h_def; /* pointer to free list of def structures */
#ifdef DEBUG
int cnt_def; /* count number of allocated ones */
#endif
struct def *ill_df;
@ -455,6 +458,7 @@ DeclProc(type)
df->for_name = Malloc((unsigned) (strlen(buf)+1));
strcpy(df->for_name, buf);
C_exp(df->for_name);
open_scope(OPENSCOPE);
}
else {
df = lookup(dot.TOK_IDF, CurrentScope);

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

@ -326,10 +326,9 @@ 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);
CodeFieldDesig(nd->nd_def, ds);
break;
case Oper:

9
lang/m2/comp/enter.c
View file

@ -73,15 +73,6 @@ EnterIdList(idlist, kind, flags, type, scope, addr)
}
if (*addr >= 0) {
if (scope->sc_level && kind != D_FIELD) {
/* alignment of parameters is on
word boundaries. We cannot do any
better, because we don't know the
alignment of the stack pointer when
starting to push parameters
*/
xalign = word_align;
}
off = align(*addr, xalign);
*addr = off + type->tp_size;
}

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

@ -72,7 +72,7 @@ node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
selector(struct node **pnd;):
'.' { *pnd = MkNode(Link,*pnd,NULLNODE,&dot); }
IDENT { (*pnd)->nd_right = MkNode(Name,NULLNODE,NULLNODE,&dot); }
IDENT { (*pnd)->nd_IDF = dot.TOK_IDF; }
;
ExpList(struct node **pnd;)

19
lang/m2/comp/main.c
View file

@ -101,6 +101,9 @@ Compile(src, dst)
}
WalkModule(Defined);
C_close();
#ifdef DEBUG
if (options['m']) MemUse();
#endif
if (err_occurred) return 0;
return 1;
}
@ -217,3 +220,19 @@ AtEoIT()
*/
return 1;
}
#ifdef DEBUG
MemUse()
{
extern int cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar;
print("\
%6d def\n%6d node\n%6d paramlist\n%6d type\n%6d switch_hdr\n\
%6d case_entry\n%6d scope\n%6d scopelist\n%6d forwards\n%6d tmpvar\n",
cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar);
}
#endif

18
lang/m2/comp/make.allocd
View file

@ -3,15 +3,23 @@ s:^.*[ ]ALLOCDEF[ ].*"\(.*\)".*$:\
/* allocation definitions of struct \1 */\
extern char *st_alloc();\
extern struct \1 *h_\1;\
#define new_\1() ((struct \1 *) \\\
st_alloc((char **)\&h_\1, sizeof(struct \1)))\
#ifdef DEBUG\
extern int cnt_\1;\
#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \&cnt_\1))\
#else\
#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1)))\
#endif\
#define free_\1(p) st_free(p, h_\1, sizeof(struct \1))\
:' -e '
s:^.*[ ]STATICALLOCDEF[ ].*"\(.*\)".*$:\
/* allocation definitions of struct \1 */\
extern char *st_alloc();\
static struct \1 *h_\1;\
#define new_\1() ((struct \1 *) \\\
st_alloc((char **)\&h_\1, sizeof(struct \1)))\
struct \1 *h_\1;\
#ifdef DEBUG\
int cnt_\1;\
#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \&cnt_\1))\
#else\
#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1)))\
#endif\
#define free_\1(p) st_free(p, h_\1, sizeof(struct \1))\
:'

8
lang/m2/comp/misc.h Normal file
View file

@ -0,0 +1,8 @@
/* M I S C E L L A N E O U S */
/* $Header$ */
#define is_anon_idf(x) ((x)->id_text[0] == '#')
extern struct idf
*gen_anon_idf();

3
lang/m2/comp/node.H
View file

@ -41,3 +41,6 @@ extern struct node *MkNode();
#define HASSELECTORS 2
#define VARIABLE 4
#define VALUE 8
#define IsCast(lnd) ((lnd)->nd_class == Def && is_type((lnd)->nd_def))
#define IsProcCall(lnd) ((lnd)->nd_type->tp_fund == T_PROCEDURE)

3
lang/m2/comp/node.c
View file

@ -17,6 +17,9 @@ static char *RcsId = "$Header$";
#include "node.h"
struct node *h_node; /* header of free list */
#ifdef DEBUG
int cnt_node; /* count number of allocated ones */
#endif
struct node *
MkNode(class, left, right, token)

6
lang/m2/comp/options.c
View file

@ -25,8 +25,8 @@ DoOption(text)
options[text[-1]] = 1; /* flags, debug options etc. */
break;
case 'L' :
warning("-L: default no EM profiling; use -p for EM profiling");
case 'L' : /* don't generate fil/lin */
options['L'] = 1;
break;
case 'M': /* maximum identifier length */
@ -37,7 +37,7 @@ DoOption(text)
fatal("maximum identifier length is %d", IDFSIZE);
break;
case 'p' : /* generate profiling code (fil/lin) */
case 'p' : /* generate profiling code procentry/procexit ???? */
options['p'] = 1;
break;

7
lang/m2/comp/program.g
View file

@ -24,7 +24,6 @@ static int DEFofIMPL = 0; /* Flag indicating that we are currently
implementation module currently being
compiled
*/
struct def *currentdef; /* current definition of module or procedure */
}
/*
The grammar as given by Wirth is already almost LL(1); the
@ -49,7 +48,6 @@ ModuleDeclaration
{
struct idf *id;
register struct def *df;
struct def *savecurr = currentdef;
extern int proclevel;
static int modulecount = 0;
char buf[256];
@ -61,7 +59,6 @@ ModuleDeclaration
MODULE IDENT {
id = dot.TOK_IDF;
df = define(id, CurrentScope, D_MODULE);
currentdef = df;
if (!df->mod_vis) {
open_scope(CLOSEDSCOPE);
@ -71,6 +68,7 @@ ModuleDeclaration
CurrVis = df->mod_vis;
CurrentScope->sc_level = proclevel;
}
CurrentScope->sc_definedby = df;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_vis->sc_scope;
@ -93,7 +91,6 @@ ModuleDeclaration
}
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
currentdef = savecurr;
}
;
@ -244,7 +241,6 @@ ProgramModule
if (state == IMPLEMENTATION) {
DEFofIMPL = 1;
df = GetDefinitionModule(id);
currentdef = df;
CurrVis = df->mod_vis;
CurrentScope = CurrVis->sc_scope;
DEFofIMPL = 0;
@ -256,6 +252,7 @@ ProgramModule
df->mod_vis = CurrVis;
CurrentScope->sc_name = id->id_text;
}
CurrentScope->sc_definedby = df;
}
priority(&(df->mod_priority))?
';' import(0)*

5
lang/m2/comp/scope.C
View file

@ -35,11 +35,10 @@ open_scope(scopetype)
register struct scopelist *ls = new_scopelist();
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
clear((char *) sc, sizeof (*sc));
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
sc->sc_level = proclevel;
sc->sc_forw = 0;
sc->sc_def = 0;
sc->sc_off = 0;
if (scopetype == OPENSCOPE) {
ls->next = CurrVis;
}

1
lang/m2/comp/scope.h
View file

@ -23,6 +23,7 @@ struct 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 */
struct def *sc_definedby; /* The def structure defining this scope */
};
struct scopelist {

68
lang/m2/comp/statement.g
View file

@ -16,7 +16,6 @@ static char *RcsId = "$Header$";
#include "node.h"
static int loopcount = 0; /* Count nested loops */
extern struct def *currentdef;
}
statement(struct node **pnd;)
@ -61,28 +60,11 @@ statement(struct node **pnd;)
WithStatement(pnd)
|
EXIT
{ if (!loopcount) {
error("EXIT not in a LOOP");
}
{ if (!loopcount) error("EXIT not in a LOOP");
*pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
}
|
RETURN { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
[
expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) {
error("a module body has no result value");
}
else if (! currentdef->df_type->next) {
error("procedure \"%s\" has no result value", currentdef->df_idf->id_text);
}
}
|
{ if (currentdef->df_type->next) {
error("procedure \"%s\" must return a value", currentdef->df_idf->id_text);
}
}
]
ReturnStatement(pnd)
]?
;
@ -193,18 +175,28 @@ RepeatStatement(struct node **pnd;)
ForStatement(struct node **pnd;)
{
register struct node *nd;
struct node *dummy;
}:
FOR { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
BECOMES { nd = MkNode(BECOMES, nd, NULLNODE, &dot); }
expression(&(nd->nd_right))
TO { (*pnd)->nd_left=nd=MkNode(Link,nd,NULLNODE,&dot); }
IDENT { (*pnd)->nd_IDF = dot.TOK_IDF; }
BECOMES { nd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
(*pnd)->nd_left = nd;
}
expression(&(nd->nd_left))
TO
expression(&(nd->nd_right))
[
BY { nd->nd_right=MkNode(Link,NULLNODE,nd->nd_right,&dot);
BY
ConstExpression(&dummy)
{
if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
error("illegal type in BY clause");
}
nd->nd_INT = dummy->nd_INT;
FreeNode(dummy);
}
ConstExpression(&(nd->nd_right->nd_left))
|
{ nd->nd_INT = 1; }
]
DO
StatementSequence(&((*pnd)->nd_right))
@ -227,3 +219,27 @@ WithStatement(struct node **pnd;)
StatementSequence(&(nd->nd_right))
END
;
ReturnStatement(struct node **pnd;)
{
register struct def *df = CurrentScope->sc_definedby;
register struct node *nd;
} :
RETURN { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
[
expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) {
error("a module body has no result value");
}
else if (! df->df_type->next) {
error("procedure \"%s\" has no result value", df->df_idf->id_text);
}
}
|
{ if (df->df_type->next) {
error("procedure \"%s\" must return a value", df->df_idf->id_text);
}
}
]
;

5
lang/m2/comp/type.H
View file

@ -4,8 +4,9 @@
struct paramlist { /* structure for parameterlist of a PROCEDURE */
struct paramlist *next;
struct type *par_type; /* Parameter type */
int par_var; /* flag, set if VAR parameter */
struct def *par_def; /* "df" of parameter */
#define IsVarParam(xpar) ((xpar)->par_def->df_flags & D_VARPAR)
#define TypeOfParam(xpar) ((xpar)->par_def->df_type)
};
/* ALLOCDEF "paramlist" */

49
lang/m2/comp/type.c
View file

@ -19,6 +19,7 @@ static char *RcsId = "$Header$";
#include "LLlex.h"
#include "node.h"
#include "const.h"
#include "scope.h"
/* To be created dynamically in main() from defaults or from command
line parameters.
@ -58,8 +59,14 @@ struct type
*error_type;
struct paramlist *h_paramlist;
#ifdef DEBUG
int cnt_paramlist;
#endif
struct type *h_type;
#ifdef DEBUG
int cnt_type;
#endif
extern label data_label();
@ -215,31 +222,33 @@ init_types()
error_type = standard_type(T_CHAR, 1, (arith) 1);
}
/* Create a parameterlist of a procedure and return a pointer to it.
"ids" indicates the list of identifiers, "tp" their type, and
"VARp" is set when the parameters are VAR-parameters.
Actually, "ids" is only used because it tells us how many parameters
there were with this type.
*/
struct paramlist *
ParamList(ids, tp, VARp)
ParamList(ppr, ids, tp, VARp, off)
register struct node *ids;
struct paramlist **ppr;
struct type *tp;
arith *off;
{
/* Create (part of) a parameterlist of a procedure.
"ids" indicates the list of identifiers, "tp" their type, and
"VARp" is set when the parameters are VAR-parameters.
*/
register struct paramlist *pr;
register struct def *df;
struct paramlist *pstart;
pstart = pr = new_paramlist();
pr->par_type = tp;
pr->par_var = VARp;
for (ids = ids->next; ids; ids = ids->next) {
pr->next = new_paramlist();
pr = pr->next;
pr->par_type = tp;
pr->par_var = VARp;
while (ids) {
pr = new_paramlist();
pr->next = *ppr;
*ppr = pr;
df = define(ids->nd_IDF, CurrentScope, D_VARIABLE);
pr->par_def = df;
df->df_type = tp;
if (VARp) df->df_flags = D_VARPAR;
else df->df_flags = D_VALPAR;
df->var_off = align(*off, word_align);
*off = df->var_off + tp->tp_size;
ids = ids->next;
}
pr->next = 0;
return pstart;
}
chk_basesubrange(tp, base)
@ -551,8 +560,8 @@ DumpType(tp)
if (par) {
print("; p:");
while(par) {
if (par->par_var) print("VAR ");
DumpType(par->par_type);
if (IsVarParam(par)) print("VAR ");
DumpType(TypeOfParam(par));
par = par->next;
}
}

43
lang/m2/comp/typequiv.c
View file

@ -12,6 +12,8 @@ static char *RcsId = "$Header$";
#include "type.h"
#include "def.h"
#include "LLlex.h"
#include "node.h"
int
TstTypeEquiv(tp1, tp2)
@ -70,8 +72,8 @@ TstProcEquiv(tp1, tp2)
/* Now check the parameters
*/
while (p1 && p2) {
if (p1->par_var != p2->par_var ||
!TstParEquiv(p1->par_type, p2->par_type)) return 0;
if (IsVarParam(p1) != IsVarParam(p2) ||
!TstParEquiv(TypeOfParam(p1), TypeOfParam(p2))) return 0;
p1 = p1->next;
p2 = p2->next;
}
@ -172,11 +174,11 @@ TstAssCompat(tp1, tp2)
}
int
TstParCompat(formaltype, actualtype, VARflag)
TstParCompat(formaltype, actualtype, VARflag, nd)
struct type *formaltype, *actualtype;
struct node *nd;
{
/* Check type compatibility for a parameter in a procedure
call. Ordinary type compatibility is sufficient in any case.
/* Check type compatibility for a parameter in a procedure call.
Assignment compatibility may do if the parameter is
a value parameter.
Otherwise, a conformant array may do, or an ARRAY OF WORD
@ -185,11 +187,20 @@ TstParCompat(formaltype, actualtype, VARflag)
*/
return
TstCompat(formaltype, actualtype)
TstTypeEquiv(formaltype, actualtype)
||
( !VARflag && TstAssCompat(formaltype, actualtype))
||
( formaltype == word_type && actualtype->tp_size == word_size)
( formaltype == word_type
&&
( actualtype->tp_size == word_size
||
( !VARflag
&&
actualtype->tp_size <= word_size
)
)
)
||
( IsConformantArray(formaltype)
&&
@ -203,5 +214,21 @@ TstParCompat(formaltype, actualtype, VARflag)
&& TstTypeEquiv(formaltype->arr_elem, char_type)
)
)
);
)
||
( VARflag && OldCompat(formaltype, actualtype, nd))
;
}
int
OldCompat(ft, at, nd)
struct type *ft, *at;
struct node *nd;
{
if (TstCompat(ft, at)) {
node_warning(nd, "oldfashioned! types of formal and actual must be identical");
return 1;
}
return 0;
}

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

@ -54,7 +54,7 @@ DoProfil()
{
static label filename_label = 0;
if (options['p']) {
if (! options['L']) {
if (!filename_label) {
filename_label = data_label();
C_df_dlb(filename_label);
@ -278,10 +278,16 @@ WalkStat(nd, lab)
return;
}
if (options['p']) C_lin((arith) nd->nd_lineno);
if (options['L']) C_lin((arith) nd->nd_lineno);
if (nd->nd_class == Call) {
if (chk_call(nd)) CodeCall(nd);
if (chk_call(nd)) {
if (nd->nd_type != 0) {
node_error(nd, "procedure call expected");
return;
}
CodeCall(nd);
}
return;
}
@ -289,7 +295,7 @@ WalkStat(nd, lab)
switch(nd->nd_symb) {
case BECOMES:
DoAssign(nd, left, right, 0);
DoAssign(nd, left, right);
break;
case IF:
@ -362,51 +368,27 @@ WalkStat(nd, lab)
struct node *fnd;
label l1 = instructionlabel++;
label l2 = instructionlabel++;
arith incr = 1;
arith size;
assert(left->nd_symb == TO);
assert(left->nd_left->nd_symb == BECOMES);
DoAssign(left->nd_left,
left->nd_left->nd_left,
left->nd_left->nd_right, 1);
if (! DoForInit(nd, left)) break;
fnd = left->nd_right;
if (fnd->nd_symb == BY) {
incr = fnd->nd_left->nd_INT;
fnd = fnd->nd_right;
}
if (! chk_expr(fnd)) return;
size = fnd->nd_type->tp_size;
if (fnd->nd_class != Value) {
*pds = InitDesig;
CodeExpr(fnd, pds, NO_LABEL, NO_LABEL);
CodeValue(pds, size);
CodePExpr(fnd);
tmp = NewInt();
C_stl(tmp);
}
if (!TstCompat(left->nd_left->nd_left->nd_type,
fnd->nd_type)) {
node_error(fnd, "type incompatibility in limit of FOR loop");
break;
}
C_bra(l1);
C_df_ilb(l2);
WalkNode(right, lab);
*pds = InitDesig;
C_loc(incr);
CodeDesig(left->nd_left->nd_left, pds);
CodeValue(pds, size);
C_loc(left->nd_INT);
CodePExpr(nd);
C_adi(int_size);
*pds = InitDesig;
CodeDesig(left->nd_left->nd_left, pds);
CodeStore(pds, size);
CodeDStore(nd);
C_df_ilb(l1);
*pds = InitDesig;
CodeDesig(left->nd_left->nd_left, pds);
CodeValue(pds, size);
CodePExpr(nd);
if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
if (incr > 0) {
if (left->nd_INT > 0) {
C_ble(l2);
}
else C_bge(l2);
@ -461,8 +443,7 @@ node_error(fnd, "type incompatibility in limit of FOR loop");
case RETURN:
if (right) {
WalkExpr(right, NO_LABEL, NO_LABEL);
/* What kind of compatibility do we need here ???
assignment compatibility?
/* Assignment compatibility? Yes, see Rep. 9.11
*/
if (!TstAssCompat(func_type, right->nd_type)) {
node_error(right, "type incompatibility in RETURN statement");
@ -519,27 +500,51 @@ WalkDesignator(nd)
Desig = InitDesig;
CodeDesig(nd, &Desig);
}
DoAssign(nd, left, right, forloopass)
DoForInit(nd, left)
register struct node *nd, *left;
{
nd->nd_left = nd->nd_right = 0;
nd->nd_class = Name;
nd->nd_symb = IDENT;
if (! chk_designator(nd, VARIABLE, D_DEFINED) ||
! chk_expr(left->nd_left) ||
! chk_expr(left->nd_right)) return;
if (nd->nd_type->tp_size > word_size ||
!(nd->nd_type->tp_fund & T_DISCRETE)) {
node_error(nd, "illegal type of FOR loop variable");
return 0;
}
if (!TstCompat(nd->nd_type, left->nd_left->nd_type) ||
!TstCompat(nd->nd_type, left->nd_right->nd_type)) {
if (!TstAssCompat(nd->nd_type, left->nd_left->nd_type) ||
!TstAssCompat(nd->nd_type, left->nd_right->nd_type)) {
node_error(nd, "type incompatibility in FOR statement");
return 0;
}
node_warning(nd, "old-fashioned! compatibility required in FOR statement");
}
CodePExpr(left->nd_left);
CodeDStore(nd);
}
DoAssign(nd, left, right)
struct node *nd;
register struct node *left, *right;
{
/* May we do it in this order (expression first) ??? */
/* May we do it in this order (expression first) ??? */
struct desig ds;
WalkExpr(right, NO_LABEL, NO_LABEL);
if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
if (forloopass) {
if (! TstCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in FOR loop");
return;
}
/* Test if the left hand side may be a for loop variable ??? */
}
else if (! TstAssCompat(left->nd_type, right->nd_type)) {
if (! TstAssCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in assignment");
return;
}