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

many changes; some cosmetic; coercions now explicit in tree

Browse source
This commit is contained in:
ceriel 1987-07-30 13:37:39 +00:00
parent 48a4d04b61
commit 0e397f09f3
25 changed files with 707 additions and 584 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -19,6 +19,7 @@
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "input.h"
#include "f_info.h"
#include "Lpars.h"
@ -26,7 +27,6 @@
#include "idf.h"
#include "def.h"
#include "type.h"
#include "LLlex.h"
#include "const.h"
#include "warning.h"
@ -278,6 +278,8 @@ again:
else if (nch == EOI) eofseen = 1;
else PushBack();
}
if (ch == '&') return tk->tk_symb = AND;
if (ch == '~') return tk->tk_symb = NOT;
return tk->tk_symb = ch;
case STCOMP:
@ -301,7 +303,6 @@ again:
return tk->tk_symb = LESSEQUAL;
}
if (nch == '>') {
lexwarning(W_STRICT, "'<>' is old-fashioned; use '#'");
return tk->tk_symb = '#';
}
break;

7
lang/m2/comp/Makefile
View file

@ -40,14 +40,14 @@ OBJ = $(COBJ) $(LOBJ) Lpars.o
GENH= errout.h\
idfsize.h numsize.h strsize.h target_sizes.h \
inputtype.h maxset.h density.h\
def.h debugcst.h type.h Lpars.h node.h
def.h debugcst.h type.h Lpars.h node.h desig.h
HFILES= LLlex.h\
chk_expr.h class.h const.h debug.h desig.h f_info.h idf.h\
chk_expr.h class.h const.h debug.h f_info.h idf.h\
input.h main.h misc.h scope.h standards.h tokenname.h\
walk.h warning.h SYSTEM.h $(GENH)
#
GENFILES = $(GENGFILES) $(GENC) $(GENH)
NEXTFILES = def.H type.H node.H scope.C tmpvar.C casestat.C
NEXTFILES = def.H type.H node.H desig.H scope.C tmpvar.C casestat.C
#EXCLEXCLEXCLEXCL
@ -113,6 +113,7 @@ symbol2str.c: tokenname.c make.tokcase
def.h: make.allocd
type.h: make.allocd
node.h: make.allocd
desig.h: make.allocd
scope.c: make.allocd
tmpvar.c: make.allocd
casestat.c: make.allocd

15
lang/m2/comp/casestat.C
View file

@ -30,6 +30,7 @@
#include "node.h"
#include "desig.h"
#include "walk.h"
#include "chk_expr.h"
#include "density.h"
@ -81,14 +82,16 @@ CaseCode(nd, exitlabel)
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
WalkExpr(pnode->nd_left); /* evaluate case expression */
if (ChkExpression(pnode->nd_left)) {
MkCoercion(&(pnode->nd_left),BaseType(pnode->nd_left->nd_type));
CodePExpr(pnode->nd_left);
}
sh->sh_type = pnode->nd_left->nd_type;
sh->sh_break = ++text_label;
/* Now, create case label list
*/
while (pnode->nd_right) {
pnode = pnode->nd_right;
while (pnode = pnode->nd_right) {
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
/* non-empty case
@ -168,8 +171,7 @@ CaseCode(nd, exitlabel)
/* Now generate code for the cases
*/
pnode = nd;
while (pnode->nd_right) {
pnode = pnode->nd_right;
while (pnode = pnode->nd_right) {
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
C_df_ilb(pnode->nd_lab);
@ -252,8 +254,7 @@ AddOneCase(sh, node, lbl)
ce->ce_label = lbl;
ce->ce_value = node->nd_INT;
if (! TstCompat(sh->sh_type, node->nd_type)) {
node_error(node, "type incompatibility in case");
if (! ChkCompat(&node, sh->sh_type, "case")) {
free_case_entry(ce);
return 0;
}

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

@ -22,8 +22,8 @@
#include "Lpars.h"
#include "idf.h"
#include "type.h"
#include "def.h"
#include "LLlex.h"
#include "def.h"
#include "node.h"
#include "scope.h"
#include "const.h"
@ -35,7 +35,7 @@
extern char *symbol2str();
extern char *sprint();
STATIC
STATIC int
Xerror(nd, mess, edf)
struct node *nd;
char *mess;
@ -45,9 +45,86 @@ Xerror(nd, mess, edf)
if (edf->df_kind != D_ERROR) {
node_error(nd,"\"%s\": %s", edf->df_idf->id_text, mess);
}
return;
}
node_error(nd, "%s", mess);
else node_error(nd, "%s", mess);
return 0;
}
MkCoercion(pnd, tp)
struct node **pnd;
register struct type *tp;
{
register struct node *nd = *pnd;
register struct type *nd_tp = nd->nd_type;
extern int pass_1;
int w = 0;
if (nd_tp == tp) return;
if (nd_tp->tp_fund == T_STRING) return;
nd_tp = BaseType(nd_tp);
if (nd->nd_class == Value) {
switch(tp->tp_fund) {
case T_REAL:
if (nd_tp->tp_fund == T_REAL) {
break;
}
goto Out;
case T_SUBRANGE:
if (! chk_bounds(tp->sub_lb, nd->nd_INT,
BaseType(tp)->tp_fund) ||
! chk_bounds(nd->nd_INT, tp->sub_ub,
BaseType(tp)->tp_fund)) {
node_warning(nd,
W_ORDINARY,
"might cause range bound error");
w = 1;
}
break;
case T_ENUMERATION:
case T_CHAR:
if (nd->nd_INT < 0 || nd->nd_INT >= tp->enm_ncst) {
node_warning(nd,
W_ORDINARY,
"might cause range bound error");
w = 1;
}
break;
case T_INTORCARD:
case T_CARDINAL:
case T_POINTER:
if ((nd_tp->tp_fund == T_INTEGER &&
nd->nd_INT < 0) ||
(nd->nd_INT & ~full_mask[(int)(tp->tp_size)])) {
node_warning(nd,
W_ORDINARY,
"might cause conversion error");
w = 1;
}
break;
case T_INTEGER: {
long i = ~int_mask[(int)(tp->tp_size)];
long j = nd->nd_INT & i;
if ((nd_tp->tp_fund == T_INTEGER &&
j != i && j != 0) ||
(nd_tp->tp_fund != T_INTEGER && j)) {
node_warning(nd,
W_ORDINARY,
"might cause conversion error");
w = 1;
}
}
break;
}
if (!w || pass_1) {
nd->nd_type = tp;
return;
}
}
Out:
*pnd = nd = MkNode(Uoper, NULLNODE, nd, &(nd->nd_token));
nd->nd_symb = COERCION;
nd->nd_type = tp;
}
int
@ -58,15 +135,10 @@ ChkVariable(expp)
assigned to.
*/
if (! ChkDesignator(expp)) return 0;
if ((expp->nd_class == Def || expp->nd_class == LinkDef) &&
!(expp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
Xerror(expp, "variable expected", expp->nd_def);
return 0;
}
return 1;
return ChkDesignator(expp) &&
( expp->nd_class != Def ||
( expp->nd_def->df_kind & (D_FIELD|D_VARIABLE)) ||
Xerror(expp, "variable expected", expp->nd_def));
}
STATIC int
@ -106,37 +178,33 @@ ChkArr(expp)
assignment compatible with the array-index.
*/
register struct type *tpl, *tpr;
int retval;
register struct type *tpl;
assert(expp->nd_class == Arrsel);
assert(expp->nd_symb == '[');
expp->nd_type = error_type;
retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right);
if (! (ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right))) {
return 0;
}
tpl = expp->nd_left->nd_type;
tpr = expp->nd_right->nd_type;
if (tpl == error_type || tpr == error_type) return 0;
if (tpl->tp_fund != T_ARRAY) {
node_error(expp, "not indexing an ARRAY type");
return 0;
}
expp->nd_type = RemoveEqual(tpl->arr_elem);
/* Type of the index must be assignment compatible with
the index type of the array (Def 8.1).
However, the index type of a conformant array is not specified.
In our implementation it is CARDINAL.
*/
if (!TstAssCompat(IndexType(tpl), tpr)) {
node_error(expp, "incompatible index type");
return 0;
}
expp->nd_type = RemoveEqual(tpl->arr_elem);
return retval;
return ChkAssCompat(&(expp->nd_right),
BaseType(IndexType(tpl)),
"index type");
}
#ifdef DEBUG
@ -183,13 +251,12 @@ ChkLinkOrName(expp)
if (! ChkDesignator(left)) return 0;
if ((left->nd_class==Def || left->nd_class==LinkDef) &&
if (left->nd_class==Def &&
(left->nd_type->tp_fund != T_RECORD ||
!(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
)
) {
Xerror(left, "illegal selection", left->nd_def);
return 0;
return Xerror(left, "illegal selection", left->nd_def);
}
if (left->nd_type->tp_fund != T_RECORD) {
node_error(left, "illegal selection");
@ -200,25 +267,22 @@ ChkLinkOrName(expp)
id_not_declared(expp);
return 0;
}
else {
expp->nd_def = df;
expp->nd_type = RemoveEqual(df->df_type);
expp->nd_class = LinkDef;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
/* Fields of a record are always D_QEXPORTED,
so ...
*/
expp->nd_def = df;
expp->nd_type = RemoveEqual(df->df_type);
expp->nd_class = Def;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
/* Fields of a record are always D_QEXPORTED,
so ...
*/
Xerror(expp, "not exported from qualifying module", df);
}
}
if ((left->nd_class == Def || left->nd_class == LinkDef) &&
left->nd_def->df_kind == D_MODULE) {
expp->nd_class = Def;
FreeNode(left);
expp->nd_left = 0;
if (!(left->nd_class == Def &&
left->nd_def->df_kind == D_MODULE)) {
return 1;
}
else return 1;
FreeNode(left);
expp->nd_left = 0;
}
assert(expp->nd_class == Def);
@ -242,8 +306,11 @@ ChkExLinkOrName(expp)
if (df->df_kind & (D_ENUM | D_CONST)) {
/* Replace an enum-literal or a CONST identifier by its value.
*/
if (df->df_type->tp_fund == T_SET) {
expp->nd_class = Set;
}
else expp->nd_class = Value;
if (df->df_kind == D_ENUM) {
expp->nd_class = Value;
expp->nd_INT = df->enm_val;
expp->nd_symb = INTEGER;
}
@ -251,7 +318,7 @@ ChkExLinkOrName(expp)
unsigned int ln = expp->nd_lineno;
assert(df->df_kind == D_CONST);
*expp = *(df->con_const);
expp->nd_token = df->con_const;
expp->nd_lineno = ln;
}
}
@ -278,32 +345,24 @@ node_error(expp, "standard or local procedures may not be assigned");
STATIC int
ChkEl(expr, tp)
register struct node *expr;
register struct node **expr;
struct type *tp;
{
if (!ChkExpression(expr)) return 0;
if (!TstCompat(tp, expr->nd_type)) {
node_error(expr, "set element has incompatible type");
return 0;
}
return 1;
return ChkExpression(*expr) && ChkCompat(expr, tp, "set element");
}
STATIC int
ChkElement(expp, tp, set)
struct node **expp;
struct type *tp;
arith **set;
arith *set;
{
/* Check elements of a set. This routine may call itself
recursively.
Also try to compute the set!
*/
register struct node *expr = *expp;
register struct node *left = expr->nd_left;
register struct node *right = expr->nd_right;
register unsigned int i;
arith lo, hi, low, high;
@ -311,22 +370,25 @@ ChkElement(expp, tp, set)
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
*/
if (! (ChkEl(left, tp) & ChkEl(right, tp))) {
if (! (ChkEl(&(expr->nd_left), tp) &
ChkEl(&(expr->nd_right), tp))) {
return 0;
}
if (!(left->nd_class == Value && right->nd_class == Value)) {
if (!(expr->nd_left->nd_class == Value &&
expr->nd_right->nd_class == Value)) {
return 1;
}
/* We have a constant range. Put all elements in the
set
*/
low = left->nd_INT;
high = right->nd_INT;
low = expr->nd_left->nd_INT;
high = expr->nd_right->nd_INT;
}
else {
if (! ChkEl(expr, tp)) return 0;
if (! ChkEl(expp, tp)) return 0;
expr = *expp;
if (expr->nd_class != Value) {
return 1;
}
@ -344,7 +406,7 @@ ChkElement(expp, tp, set)
}
for (i=(unsigned)low; i<= (unsigned)high; i++) {
(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
set[i/wrd_bits] |= (1<<(i%wrd_bits));
}
FreeNode(expr);
*expp = 0;
@ -374,7 +436,7 @@ ChkSet(expp)
/* A type was given. Check it out
*/
if (! ChkDesignator(nd)) return 0;
assert(nd->nd_class == Def || nd->nd_class == LinkDef);
assert(nd->nd_class == Def);
df = nd->nd_def;
if (!is_type(df) ||
@ -406,7 +468,7 @@ ChkSet(expp)
assert(nd->nd_class == Link && nd->nd_symb == ',');
if (!ChkElement(&(nd->nd_left), ElementType(tp),
&(expp->nd_set))) {
expp->nd_set)) {
retval = 0;
}
if (nd->nd_left) expp->nd_class = Xset;
@ -420,6 +482,21 @@ ChkSet(expp)
return retval;
}
STATIC struct node *
nextarg(argp, edf)
struct node **argp;
struct def *edf;
{
register struct node *arg = (*argp)->nd_right;
if (! arg) {
return (struct node *)Xerror(*argp, "too few arguments supplied", edf);
}
*argp = arg;
return arg->nd_left;
}
STATIC struct node *
getarg(argp, bases, designator, edf)
struct node **argp;
@ -433,29 +510,23 @@ getarg(argp, bases, designator, edf)
that it must be a designator and may not be a register
variable.
*/
register struct node *arg = (*argp)->nd_right;
register struct node *left;
register struct node *left = nextarg(argp, edf);
if (! arg) {
Xerror(*argp, "too few arguments supplied", edf);
if (!left || (designator ? !ChkVariable(left) : !ChkExpression(left))) {
return 0;
}
left = arg->nd_left;
*argp = arg;
if (designator ? !ChkVariable(left) : !ChkExpression(left)) {
return 0;
}
if (designator && (left->nd_class==Def || left->nd_class==LinkDef)) {
if (designator && left->nd_class==Def) {
left->nd_def->df_flags |= D_NOREG;
}
if (bases) {
if (!(BaseType(left->nd_type)->tp_fund & bases)) {
Xerror(arg, "unexpected parameter type", edf);
return 0;
struct type *tp = BaseType(left->nd_type);
MkCoercion(&((*argp)->nd_left), tp);
left = (*argp)->nd_left;
if (!(tp->tp_fund & bases)) {
return (struct node *)Xerror(left, "unexpected parameter type", edf);
}
}
@ -471,35 +542,17 @@ getname(argp, kinds, bases, edf)
The argument must indicate a definition, and the
definition kind must be one of "kinds".
*/
register struct node *arg = *argp;
register struct node *left;
register struct node *left = nextarg(argp, edf);
*argp = arg->nd_right;
if (!left || ! ChkDesignator(left)) return 0;
if (!arg->nd_right) {
Xerror(arg, "too few arguments supplied", edf);
return 0;
if (left->nd_class != Def) {
return (struct node *)Xerror(left, "identifier expected", edf);
}
arg = arg->nd_right;
left = arg->nd_left;
if (! ChkDesignator(left)) return 0;
if (left->nd_class != Def && left->nd_class != LinkDef) {
Xerror(arg, "identifier expected", edf);
return 0;
}
if (!(left->nd_def->df_kind & kinds)) {
Xerror(arg, "unexpected parameter type", edf);
return 0;
}
if (bases) {
if (!(left->nd_type->tp_fund & bases)) {
Xerror(arg, "unexpected parameter type", edf);
return 0;
}
if (!(left->nd_def->df_kind & kinds) ||
(bases && !(left->nd_type->tp_fund & bases))) {
return (struct node *)Xerror(left, "unexpected parameter type", edf);
}
return left;
@ -514,12 +567,11 @@ ChkProcCall(expp)
register struct node *left;
struct def *edf = 0;
register struct paramlist *param;
char ebuf[256];
int retval = 1;
int cnt = 0;
left = expp->nd_left;
if (left->nd_class == Def || left->nd_class == LinkDef) {
if (left->nd_class == Def) {
edf = left->nd_def;
}
if (left->nd_type == error_type) {
@ -544,13 +596,11 @@ ChkProcCall(expp)
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
left->nd_type,
if (! TstParCompat(cnt,
RemoveEqual(TypeOfParam(param)),
IsVarParam(param),
left)) {
sprint(ebuf, "type incompatibility in parameter %d",
cnt);
Xerror(left, ebuf, edf);
&(expp->nd_left),
edf)) {
retval = 0;
}
}
@ -591,19 +641,18 @@ ChkCall(expp)
Of course this does not have to be a call at all,
it may also be a cast or a standard procedure call.
*/
register struct node *left;
register struct node *left = expp->nd_left;
STATIC int ChkStandard();
STATIC int ChkCast();
/* First, get the name of the function or procedure
*/
expp->nd_type = error_type;
left = expp->nd_left;
if (ChkDesignator(left)) {
if (IsCast(left)) {
/* It was a type cast.
*/
return ChkCast(expp, left);
return ChkCast(expp);
}
if (IsProcCall(left) || left->nd_type == error_type) {
@ -613,7 +662,7 @@ ChkCall(expp)
if (left->nd_type == std_type) {
/* A standard procedure
*/
return ChkStandard(expp, left);
return ChkStandard(expp);
}
/* Here, we have found a real procedure call.
The left hand side may also represent a procedure
@ -650,7 +699,7 @@ ResultOfOperation(operator, tp)
STATIC int
Boolean(operator)
{
return operator == OR || operator == AND || operator == '&';
return operator == OR || operator == AND;
}
STATIC int
@ -672,7 +721,6 @@ AllowedTypes(operator)
return T_INTORCARD;
case OR:
case AND:
case '&':
return T_ENUMERATION;
case '=':
case '#':
@ -756,15 +804,16 @@ ChkBinOper(expp)
node_error(expp, "\"IN\": right operand must be a set");
return 0;
}
if (!TstAssCompat(tpl, ElementType(tpr))) {
if (!TstAssCompat(ElementType(tpr), tpl)) {
/* Assignment compatible ???
I don't know! Should we be allowed to check
if a INTEGER is a member of a BITSET???
*/
node_error(expp, "\"IN\": incompatible types");
node_error(left, "type incompatibility in IN");
return 0;
}
MkCoercion(&(expp->nd_left), word_type);
left = expp->nd_left;
if (left->nd_class == Value && right->nd_class == Set) {
cstset(expp);
}
@ -795,11 +844,15 @@ ChkBinOper(expp)
/* Operands must be compatible (distilled from Def 8.2)
*/
if (!TstCompat(tpl, tpr)) {
node_error(expp, "\"%s\": incompatible types", symbol2str(expp->nd_symb));
if (!TstCompat(tpr, tpl)) {
node_error(expp,"\"%s\": incompatible types",
symbol2str(expp->nd_symb));
return 0;
}
MkCoercion(&(expp->nd_left), tpl);
MkCoercion(&(expp->nd_right), tpr);
if (tpl->tp_fund == T_SET) {
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
@ -823,8 +876,10 @@ ChkUnOper(expp)
register struct type *tpr;
if (! ChkExpression(right)) return 0;
expp->nd_type = tpr = BaseType(right->nd_type);
MkCoercion(&(expp->nd_right), tpr);
right = expp->nd_right;
if (tpr == address_type) tpr = card_type;
switch(expp->nd_symb) {
@ -862,7 +917,6 @@ ChkUnOper(expp)
break;
case NOT:
case '~':
if (tpr == bool_type) {
if (right->nd_class == Value) {
cstunary(expp);
@ -886,38 +940,31 @@ getvariable(argp, edf)
/* Get the next argument from argument list "argp".
It must obey the rules of "ChkVariable".
*/
register struct node *arg = *argp;
register struct node *left = nextarg(argp, edf);
arg = arg->nd_right;
if (!arg) {
Xerror(arg, "too few parameters supplied", edf);
return 0;
}
if (!left || !ChkVariable(left)) return 0;
*argp = arg;
arg = arg->nd_left;
if (! ChkVariable(arg)) return 0;
return arg;
return left;
}
STATIC int
ChkStandard(expp, left)
register struct node *expp, *left;
ChkStandard(expp)
register struct node *expp;
{
/* Check a call of a standard procedure or function
*/
struct node *arg = expp;
register struct def *edf;
int std;
register struct node *left = expp->nd_left;
register struct def *edf = left->nd_def;
int free_it = 0;
assert(left->nd_class == Def || left->nd_class == LinkDef);
edf = left->nd_def;
std = edf->df_value.df_stdname;
assert(left->nd_class == Def);
switch(std) {
switch(edf->df_value.df_stdname) {
case S_ABS:
if (!(left = getarg(&arg, T_NUMERIC, 0, edf))) return 0;
MkCoercion(&(arg->nd_left), BaseType(left->nd_type));
left = arg->nd_left;
expp->nd_type = left->nd_type;
if (left->nd_class == Value &&
expp->nd_type->tp_fund != T_REAL) {
@ -934,47 +981,57 @@ ChkStandard(expp, left)
case S_CHR:
expp->nd_type = char_type;
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
if (left->nd_class == Value) cstcall(expp, S_CHR);
MkCoercion(&(arg->nd_left), char_type);
free_it = 1;
break;
case S_FLOATD:
case S_FLOAT:
expp->nd_type = real_type;
if (std == S_FLOATD) expp->nd_type = longreal_type;
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
if (edf->df_value.df_stdname == S_FLOAT) {
MkCoercion(&(arg->nd_left), card_type);
}
MkCoercion(&(arg->nd_left),
edf->df_value.df_stdname == S_FLOATD ?
longreal_type :
real_type);
free_it = 1;
break;
case S_SHORT:
case S_LONG: {
struct type *tp;
struct type *s1, *s2, *d1, *d2;
if (edf->df_value.df_stdname == S_SHORT) {
s1 = longint_type;
d1 = int_type;
s2 = longreal_type;
d2 = real_type;
}
else {
d1 = longint_type;
s1 = int_type;
d2 = longreal_type;
s2 = real_type;
}
if (!(left = getarg(&arg, 0, 0, edf))) {
return 0;
}
tp = BaseType(left->nd_type);
if (tp == int_type) expp->nd_type = longint_type;
else if (tp == real_type) expp->nd_type = longreal_type;
if (tp == s1) {
MkCoercion(&(arg->nd_left), d1);
}
else if (tp == s2) {
MkCoercion(&(arg->nd_left), d2);
}
else {
expp->nd_type = error_type;
Xerror(left, "unexpected parameter type", edf);
break;
}
if (left->nd_class == Value) cstcall(expp, S_LONG);
break;
}
case S_SHORT: {
struct type *tp;
if (!(left = getarg(&arg, 0, 0, edf))) {
return 0;
}
tp = BaseType(left->nd_type);
if (tp == longint_type) expp->nd_type = int_type;
else if (tp == longreal_type) expp->nd_type = real_type;
else {
expp->nd_type = error_type;
Xerror(left, "unexpected parameter type", edf);
}
if (left->nd_class == Value) cstcall(expp, S_SHORT);
free_it = 1;
break;
}
@ -990,8 +1047,7 @@ ChkStandard(expp, left)
break;
}
if (left->nd_symb != STRING) {
Xerror(left,"array parameter expected", edf);
return 0;
return Xerror(left,"array parameter expected", edf);
}
expp->nd_type = card_type;
expp->nd_class = Value;
@ -1011,19 +1067,20 @@ ChkStandard(expp, left)
return 0;
}
expp->nd_type = left->nd_type;
cstcall(expp,std);
cstcall(expp,edf->df_value.df_stdname);
break;
case S_ODD:
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
if (! (left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
MkCoercion(&(arg->nd_left), BaseType(left->nd_type));
expp->nd_type = bool_type;
if (left->nd_class == Value) cstcall(expp, S_ODD);
if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD);
break;
case S_ORD:
if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0;
expp->nd_type = card_type;
if (left->nd_class == Value) cstcall(expp, S_ORD);
if (! getarg(&arg, T_DISCRETE, 0, edf)) return 0;
MkCoercion(&(arg->nd_left), card_type);
free_it = 1;
break;
case S_NEW:
@ -1038,8 +1095,7 @@ ChkStandard(expp, left)
}
if (! (left = getvariable(&arg, edf))) return 0;
if (! (left->nd_type->tp_fund == T_POINTER)) {
Xerror(left, "pointer variable expected", edf);
return 0;
return Xerror(left, "pointer variable expected", edf);
}
/* Now, make it look like a call to ALLOCATE or DEALLOCATE */
{
@ -1058,7 +1114,7 @@ ChkStandard(expp, left)
FreeNode(expp->nd_left);
dt.tk_symb = IDENT;
dt.tk_lineno = expp->nd_left->nd_lineno;
dt.TOK_IDF = str2idf(std == S_NEW ?
dt.TOK_IDF = str2idf(edf->df_value.df_stdname==S_NEW ?
"ALLOCATE" : "DEALLOCATE", 0);
expp->nd_left = MkLeaf(Name, &dt);
}
@ -1080,8 +1136,12 @@ ChkStandard(expp, left)
case S_TRUNCD:
case S_TRUNC:
expp->nd_type = card_type;
if (std == S_TRUNCD) expp->nd_type = longint_type;
if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0;
if (edf->df_value.df_stdname == S_TRUNCD) {
expp->nd_type = longint_type;
}
if (! getarg(&arg, T_REAL, 0, edf)) return 0;
MkCoercion(&(arg->nd_left), expp->nd_type);
free_it = 1;
break;
case S_VAL:
@ -1094,12 +1154,13 @@ ChkStandard(expp, left)
FreeNode(arg);
arg = expp;
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
if (left->nd_class == Value) cstcall(expp, S_VAL);
MkCoercion(&(arg->nd_left), expp->nd_type);
free_it = 1;
break;
case S_ADR:
expp->nd_type = address_type;
if (!(left = getarg(&arg, 0, 1, edf))) return 0;
if (! getarg(&arg, 0, 1, edf)) return 0;
break;
case S_DEC:
@ -1107,8 +1168,7 @@ ChkStandard(expp, left)
expp->nd_type = 0;
if (! (left = getvariable(&arg, edf))) return 0;
if (! (left->nd_type->tp_fund & T_DISCRETE)) {
Xerror(left,"illegal parameter type", edf);
return 0;
return Xerror(left,"illegal parameter type", edf);
}
if (arg->nd_right) {
if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
@ -1122,23 +1182,26 @@ ChkStandard(expp, left)
case S_EXCL:
case S_INCL:
{
struct type *tp;
register struct type *tp;
struct node *dummy;
expp->nd_type = 0;
if (!(left = getvariable(&arg, edf))) return 0;
tp = left->nd_type;
if (tp->tp_fund != T_SET) {
Xerror(arg, "SET parameter expected", edf);
return 0;
return Xerror(arg, "SET parameter expected", edf);
}
if (!(left = getarg(&arg, T_DISCRETE, 0, edf))) return 0;
if (!TstAssCompat(ElementType(tp), left->nd_type)) {
if (!(dummy = getarg(&arg, 0, 0, edf))) return 0;
if (!ChkAssCompat(&dummy, ElementType(tp), "EXCL/INCL")) {
/* What type of compatibility do we want here?
apparently assignment compatibility! ??? ???
But we don't want the coercion in the tree, because
we don't want a range check here. We want a SET
error.
*/
Xerror(arg, "unexpected parameter type", edf);
return 0;
}
MkCoercion(&(arg->nd_left), word_type);
break;
}
@ -1147,16 +1210,22 @@ ChkStandard(expp, left)
}
if (arg->nd_right) {
Xerror(arg->nd_right, "too many parameters supplied", edf);
return 0;
return Xerror(arg->nd_right, "too many parameters supplied", edf);
}
if (free_it) {
FreeNode(expp->nd_left);
*expp = *(arg->nd_left);
arg->nd_left = 0;
FreeNode(arg);
}
return 1;
}
STATIC int
ChkCast(expp, left)
register struct node *expp, *left;
ChkCast(expp)
register struct node *expp;
{
/* 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
@ -1165,17 +1234,19 @@ ChkCast(expp, left)
is no problem as such values take a word on the EM stack
anyway.
*/
register struct type *lefttype = left->nd_type;
register struct node *left = expp->nd_left;
register struct node *arg = expp->nd_right;
register struct type *lefttype = left->nd_type;
if ((! arg) || arg->nd_right) {
Xerror(expp, "too many parameters in type cast", left->nd_def);
return 0;
return Xerror(expp, "type cast must have 1 parameter", left->nd_def);
}
arg = arg->nd_left;
if (! ChkExpression(arg)) return 0;
if (! ChkExpression(arg->nd_left)) return 0;
MkCoercion(&(arg->nd_left), BaseType(arg->nd_left->nd_type));
arg = arg->nd_left;
if (arg->nd_type->tp_size != lefttype->tp_size &&
(arg->nd_type->tp_size > word_size ||
lefttype->tp_size > word_size)) {
@ -1186,11 +1257,9 @@ ChkCast(expp, left)
FreeNode(left);
expp->nd_right->nd_left = 0;
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
*expp = *arg;
expp->nd_type = lefttype;
}
else expp->nd_type = lefttype;
expp->nd_type = lefttype;
return 1;
}
@ -1201,17 +1270,16 @@ TryToString(nd, tp)
{
/* Try a coercion from character constant to string.
*/
static char buf[2];
assert(nd->nd_symb == STRING);
if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
int ch = nd->nd_INT;
buf[0] = nd->nd_INT;
nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
nd->nd_token.tk_data.tk_str =
(struct string *) Malloc(sizeof(struct string));
nd->nd_STR = Salloc("X", 2);
*(nd->nd_STR) = ch;
nd->nd_STR = Salloc(buf, 2);
nd->nd_SLE = 1;
}
}

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

@ -19,12 +19,13 @@
#include <em_code.h>
#include <em_abs.h>
#include <assert.h>
#include <alloc.h>
#include "type.h"
#include "LLlex.h"
#include "def.h"
#include "scope.h"
#include "desig.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "standards.h"
@ -90,7 +91,6 @@ CodeExpr(nd, ds, true_label, false_label)
/* Fall through */
case Link:
case LinkDef:
case Arrsel:
case Arrow:
CodeDesig(nd, ds);
@ -263,10 +263,21 @@ CodeCoercion(t1, t2)
C_cfi();
break;
case T_CARDINAL:
{
label lb = ++text_label;
C_dup(t1->tp_size);
C_zrf(t1->tp_size);
C_cmf(t1->tp_size);
C_zge(lb);
C_loc((arith) ECONV);
C_trp();
C_df_ilb(lb);
C_loc(t1->tp_size);
C_loc(t2->tp_size);
C_cfu();
break;
}
default:
crash("Funny REAL conversion");
}
@ -400,7 +411,6 @@ CodeParameters(param, arg)
case Arrsel:
case Arrow:
case Def:
case LinkDef:
CodeDAddress(left);
break;
default:{
@ -425,14 +435,6 @@ CodeParameters(param, arg)
return;
}
CodePExpr(left);
CodeCheckExpr(left_type, tp);
}
CodeCheckExpr(tp1, tp2)
struct type *tp1, *tp2;
{
CodeCoercion(tp1, tp2);
RangeCheck(tp2, tp1);
}
CodePString(nd, tp)
@ -486,11 +488,6 @@ CodeStd(nd)
C_and(word_size);
break;
case S_CHR:
CodePExpr(left);
RangeCheck(char_type, tp);
break;
case S_HIGH:
assert(IsConformantArray(tp));
DoHIGH(left->nd_def);
@ -519,52 +516,15 @@ CodeStd(nd)
}
break;
case S_ORD:
CodePExpr(left);
break;
case S_FLOAT:
CodePExpr(left);
RangeCheck(card_type, left->nd_type);
CodeCoercion(tp, nd->nd_type);
break;
case S_TRUNC: {
label lb = ++text_label;
CodePExpr(left);
C_dup(tp->tp_size);
C_zrf(tp->tp_size);
C_cmf(tp->tp_size);
C_zge(lb);
C_loc((arith) ECONV);
C_trp();
C_df_ilb(lb);
CodeCoercion(tp, nd->nd_type);
}
break;
case S_TRUNCD:
case S_FLOATD:
case S_LONG:
case S_SHORT:
CodePExpr(left);
CodeCoercion(tp, nd->nd_type);
break;
case S_VAL:
CodePExpr(left);
RangeCheck(nd->nd_type, tp);
break;
case S_ADR:
CodeDAddress(left);
break;
case S_DEC:
case S_INC: {
register arith size = tp->tp_size;
register arith size;
size = left->nd_type->tp_size;
if (size < word_size) size = word_size;
CodePExpr(left);
if (arg) {
@ -584,7 +544,7 @@ CodeStd(nd)
else C_adu(size);
}
if (size == word_size) {
RangeCheck(tp, tp->tp_fund == T_INTEGER ?
RangeCheck(left->nd_type, tp->tp_fund == T_INTEGER ?
int_type : card_type);
}
CodeDStore(left);
@ -628,24 +588,24 @@ RangeCheck(tpl, tpr)
if (!bounded(tpr)) {
/* yes, we need one */
genrck(tpl);
return;
}
else {
/* both types are restricted. check the bounds
to see wether we need a range check.
We don't need one if the range of values of the
right hand side is a subset of the range of values
of the left hand side.
*/
getbounds(tpl, &llo, &lhi);
getbounds(tpr, &rlo, &rhi);
if (llo > rlo || lhi < rhi) {
genrck(tpl);
}
/* both types are restricted. check the bounds
to see wether we need a range check.
We don't need one if the range of values of the
right hand side is a subset of the range of values
of the left hand side.
*/
getbounds(tpl, &llo, &lhi);
getbounds(tpr, &rlo, &rhi);
if (llo > rlo || lhi < rhi) {
genrck(tpl);
}
return;
}
else if (tpl->tp_size <= tpr->tp_size &&
((tpl->tp_fund == T_INTEGER && tpr == card_type) ||
(tpr->tp_fund == T_INTEGER && tpl == card_type))) {
if (tpl->tp_size <= tpr->tp_size &&
((tpl->tp_fund == T_INTEGER && tpr == card_type) ||
(tpr->tp_fund == T_INTEGER && tpl == card_type))) {
label lb = ++text_label;
C_dup(word_size);
@ -654,18 +614,14 @@ RangeCheck(tpl, tpr)
C_trp();
C_df_ilb(lb);
}
}
Operands(leftop, rightop, tp)
Operands(leftop, rightop)
register struct node *leftop, *rightop;
struct type *tp;
{
CodePExpr(leftop);
CodeCoercion(leftop->nd_type, tp);
CodePExpr(rightop);
CodeCoercion(rightop->nd_type, tp);
}
CodeOper(expr, true_label, false_label)
@ -679,7 +635,7 @@ CodeOper(expr, true_label, false_label)
switch (expr->nd_symb) {
case '+':
Operands(leftop, rightop, tp);
Operands(leftop, rightop);
switch (tp->tp_fund) {
case T_INTEGER:
C_adi(tp->tp_size);
@ -701,7 +657,7 @@ CodeOper(expr, true_label, false_label)
}
break;
case '-':
Operands(leftop, rightop, tp);
Operands(leftop, rightop);
switch (tp->tp_fund) {
case T_INTEGER:
C_sbi(tp->tp_size);
@ -724,7 +680,7 @@ CodeOper(expr, true_label, false_label)
}
break;
case '*':
Operands(leftop, rightop, tp);
Operands(leftop, rightop);
switch (tp->tp_fund) {
case T_INTEGER:
C_mli(tp->tp_size);
@ -746,7 +702,7 @@ CodeOper(expr, true_label, false_label)
}
break;
case '/':
Operands(leftop, rightop, tp);
Operands(leftop, rightop);
switch (tp->tp_fund) {
case T_REAL:
C_dvf(tp->tp_size);
@ -759,7 +715,7 @@ CodeOper(expr, true_label, false_label)
}
break;
case DIV:
Operands(leftop, rightop, tp);
Operands(leftop, rightop);
switch(tp->tp_fund) {
case T_INTEGER:
C_dvi(tp->tp_size);
@ -775,7 +731,7 @@ CodeOper(expr, true_label, false_label)
}
break;
case MOD:
Operands(leftop, rightop, tp);
Operands(leftop, rightop);
switch(tp->tp_fund) {
case T_INTEGER:
C_rmi(tp->tp_size);
@ -796,9 +752,9 @@ CodeOper(expr, true_label, false_label)
case GREATEREQUAL:
case '=':
case '#':
Operands(leftop, rightop);
tp = BaseType(leftop->nd_type);
if (tp == intorcard_type) tp = BaseType(rightop->nd_type);
Operands(leftop, rightop, tp);
switch (tp->tp_fund) {
case T_INTEGER:
C_cmi(tp->tp_size);
@ -854,7 +810,6 @@ CodeOper(expr, true_label, false_label)
*/
CodePExpr(rightop);
CodePExpr(leftop);
CodeCoercion(leftop->nd_type, word_type);
C_inn(rightop->nd_type->tp_size);
if (true_label != NO_LABEL) {
C_zne(true_label);
@ -862,10 +817,9 @@ CodeOper(expr, true_label, false_label)
}
break;
case OR:
case AND:
case '&': {
case AND: {
label l_maybe = ++text_label, l_end;
struct desig Des;
struct desig *Des = new_desig();
int genlabels = 0;
if (true_label == NO_LABEL) {
@ -875,14 +829,14 @@ CodeOper(expr, true_label, false_label)
l_end = ++text_label;
}
Des = InitDesig;
if (expr->nd_symb == OR) {
CodeExpr(leftop, &Des, true_label, l_maybe);
CodeExpr(leftop, Des, true_label, l_maybe);
}
else CodeExpr(leftop, &Des, l_maybe, false_label);
else CodeExpr(leftop, Des, l_maybe, false_label);
C_df_ilb(l_maybe);
Des = InitDesig;
CodeExpr(rightop, &Des, true_label, false_label);
free_desig(Des);
Des = new_desig();
CodeExpr(rightop, Des, true_label, false_label);
if (genlabels) {
C_df_ilb(true_label);
C_loc((arith)1);
@ -891,6 +845,7 @@ CodeOper(expr, true_label, false_label)
C_loc((arith)0);
C_df_ilb(l_end);
}
free_desig(Des);
break;
}
default:
@ -962,7 +917,6 @@ CodeUoper(nd)
CodePExpr(nd->nd_right);
switch(nd->nd_symb) {
case '~':
case NOT:
C_teq();
break;
@ -979,6 +933,10 @@ CodeUoper(nd)
crash("Bad operand to unary -");
}
break;
case COERCION:
CodeCoercion(nd->nd_right->nd_type, tp);
RangeCheck(tp, nd->nd_right->nd_type);
break;
default:
crash("Bad unary operator");
}
@ -1010,7 +968,7 @@ CodeEl(nd, tp)
C_loc(eltype->sub_ub);
}
else C_loc((arith) (eltype->enm_ncst - 1));
Operands(nd->nd_left, nd->nd_right, word_type);
Operands(nd->nd_left, nd->nd_right);
C_cal("_LtoUset"); /* library routine to fill set */
C_asp(4 * word_size);
}
@ -1027,11 +985,11 @@ CodePExpr(nd)
/* Generate code to push the value of the expression "nd"
on the stack.
*/
struct desig designator;
register struct desig *designator = new_desig();
designator = InitDesig;
CodeExpr(nd, &designator, NO_LABEL, NO_LABEL);
CodeValue(&designator, nd->nd_type);
CodeExpr(nd, designator, NO_LABEL, NO_LABEL);
CodeValue(designator, nd->nd_type);
free_desig(designator);
}
CodeDAddress(nd)
@ -1041,11 +999,11 @@ CodeDAddress(nd)
on the stack.
*/
struct desig designator;
register struct desig *designator = new_desig();
designator = InitDesig;
CodeDesig(nd, &designator);
CodeAddress(&designator);
CodeDesig(nd, designator);
CodeAddress(designator);
free_desig(designator);
}
CodeDStore(nd)
@ -1055,11 +1013,11 @@ CodeDStore(nd)
designator "nd".
*/
struct desig designator;
register struct desig *designator = new_desig();
designator = InitDesig;
CodeDesig(nd, &designator);
CodeStore(&designator, nd->nd_type);
CodeDesig(nd, designator);
CodeStore(designator, nd->nd_type);
free_desig(designator);
}
DoHIGH(df)

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

@ -27,6 +27,7 @@
long mach_long_sign; /* sign bit of the machine long */
int mach_long_size; /* size of long on this machine == sizeof(long) */
long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
long int_mask[MAXSIZE]; /* int_mask[1] == 0x7F, int_mask[2] == 0x7FFF, .. */
arith max_int; /* maximum integer on target machine */
arith max_unsigned; /* maximum unsigned on target machine */
arith max_longint; /* maximum longint on target machine */
@ -200,14 +201,7 @@ cstbin(expp)
/* Fall through */
case GREATEREQUAL:
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 >= o2 : 1) :
(o2 & mach_long_sign ? 0 : o1 >= o2)
);
}
else
o1 = (o1 >= o2);
o1 = chk_bounds(o2, o1, uns ? T_CARDINAL : T_INTEGER);
break;
case '=':
@ -251,6 +245,7 @@ cstset(expp)
assert(expp->nd_right->nd_class == Set);
assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
set2 = expp->nd_right->nd_set;
setsize = (unsigned) expp->nd_right->nd_type->tp_size / (unsigned) word_size;
@ -390,22 +385,11 @@ cstcall(expp, call)
CutSize(expp);
break;
case S_LONG:
case S_SHORT: {
struct type *tp = expp->nd_type;
*expp = *expr;
expp->nd_type = tp;
break;
}
case S_CAP:
if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
expr->nd_INT = expr->nd_INT + ('A' - 'a');
}
/* fall through */
case S_CHR:
expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_MAX:
@ -443,35 +427,10 @@ cstcall(expp, call)
expp->nd_INT = (expr->nd_INT & 1);
break;
case S_ORD:
expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_SIZE:
expp->nd_INT = expr->nd_type->tp_size;
break;
case S_VAL:
expp->nd_INT = expr->nd_INT;
if ( /* Check overflow of subranges or enumerations */
( expp->nd_type->tp_fund == T_SUBRANGE
&&
( expp->nd_INT < expp->nd_type->sub_lb
|| expp->nd_INT > expp->nd_type->sub_ub
)
)
||
( expp->nd_type->tp_fund == T_ENUMERATION
&&
( expp->nd_INT < 0
|| expp->nd_INT >= expp->nd_type->enm_ncst
)
)
) node_warning(expp, W_ORDINARY, ovflow);
else CutSize(expp);
break;
default:
crash("(cstcall)");
}
@ -501,9 +460,9 @@ CutSize(expr)
}
else {
int nbits = (int) (mach_long_size - size) * 8;
long remainder = o1 & ~full_mask[size];
long remainder = o1 & ~int_mask[size];
if (remainder != 0 && remainder != ~full_mask[size]) {
if (remainder != 0 && remainder != ~int_mask[size]) {
node_warning(expr, W_ORDINARY, ovflow);
o1 <<= nbits;
o1 >>= nbits;
@ -522,6 +481,7 @@ InitCst()
if (i == MAXSIZE)
fatal("array full_mask too small for this machine");
full_mask[i] = bt;
int_mask[i] = bt & ~(1L << ((i << 3) - 1));
}
mach_long_size = i;
mach_long_sign = 1L << (mach_long_size * 8 - 1);
@ -529,8 +489,8 @@ InitCst()
fatal("sizeof (long) insufficient on this machine");
}
max_int = full_mask[int_size] & ~(1L << (int_size * 8 - 1));
max_int = int_mask[int_size];
max_unsigned = full_mask[int_size];
max_longint = full_mask[long_size] & ~(1L << (long_size * 8 - 1));
max_longint = int_mask[long_size];
wrd_bits = 8 * (unsigned) word_size;
}

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

@ -387,22 +387,22 @@ CaseLabels(struct type **ptp; register struct node **pnd;)
register struct node *nd;
}:
ConstExpression(pnd)
{ nd = *pnd; }
{
if (*ptp != 0) {
ChkCompat(pnd, *ptp, "case label");
}
nd = *pnd;
}
[
UPTO { *pnd = MkNode(Link,nd,NULLNODE,&dot); }
ConstExpression(&(*pnd)->nd_right)
{ if (!TstCompat(nd->nd_type,
(*pnd)->nd_right->nd_type)) {
node_error((*pnd)->nd_right,
"type incompatibility in case label");
{ if (!ChkCompat(&((*pnd)->nd_right), nd->nd_type,
"case label")) {
nd->nd_type = error_type;
}
}
]?
{ if (*ptp != 0 && !TstCompat(*ptp, nd->nd_type)) {
node_error(nd,
"type incompatibility in case label");
}
{
*ptp = nd->nd_type;
}
;
@ -486,10 +486,15 @@ ConstantDeclaration
{
struct idf *id;
struct node *nd;
register struct def *df;
}:
IDENT { id = dot.TOK_IDF; }
'=' ConstExpression(&nd)
{ define(id,CurrentScope,D_CONST)->con_const = nd; }
{ df = define(id,CurrentScope,D_CONST);
df->con_const = nd->nd_token;
df->df_type = nd->nd_type;
FreeNode(nd);
}
;
VariableDeclaration
@ -508,10 +513,14 @@ VariableDeclaration
{ EnterVarList(VarList, tp, proclevel > 0); }
;
IdentAddr(register struct node **pnd;) :
IDENT { *pnd = MkLeaf(Name, &dot); }
IdentAddr(struct node **pnd;)
{
register struct node *nd;
} :
IDENT { nd = MkLeaf(Name, &dot); }
[ '['
ConstExpression(&((*pnd)->nd_left))
ConstExpression(&(nd->nd_left))
']'
]?
{ *pnd = nd; }
;

2
lang/m2/comp/def.H
View file

@ -26,7 +26,7 @@ struct variable {
};
struct constant {
struct node *co_const; /* result of a constant expression */
struct token co_const; /* result of a constant expression */
#define con_const df_value.df_constant.co_const
};

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

@ -16,17 +16,15 @@
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "main.h"
#include "def.h"
#include "type.h"
#include "idf.h"
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
extern int (*c_inp)();
STATIC
DefInFront(df)
register struct def *df;
@ -272,7 +270,10 @@ DeclProc(type, id)
df = define(id, CurrentScope, type);
sprint(buf,"_%d_%s",++nmcount,id->id_text);
name = Salloc(buf, (unsigned)(strlen(buf)+1));
(*c_inp)(buf);
if (options['x']) {
C_exp(buf);
}
else C_inp(buf);
}
open_scope(OPENSCOPE);
scope = CurrentScope;
@ -342,7 +343,10 @@ DefineLocalModule(id)
/* Generate code that indicates that the initialization procedure
for this module is local.
*/
(*c_inp)(buf);
if (options['x']) {
C_exp(buf);
}
else C_inp(buf);
return df;
}

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

@ -19,8 +19,8 @@
#include "idf.h"
#include "input.h"
#include "scope.h"
#include "def.h"
#include "LLlex.h"
#include "def.h"
#include "Lpars.h"
#include "f_info.h"
#include "main.h"

66
lang/m2/comp/desig.H Normal file
View file

@ -0,0 +1,66 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E S I G N A T O R D E S C R I P T I O N S */
/* $Header$ */
/* Generating code for designators is not particularly easy, especially if
you don't know wether you want the address or the value.
The next structure is used to generate code for designators.
It contains information on how to find the designator, after generation
of the code that is common to both address and value computations.
*/
struct desig {
int dsg_kind;
#define DSG_INIT 0 /* don't know anything yet */
#define DSG_LOADED 1 /* designator loaded on top of the stack */
#define DSG_PLOADED 2 /* designator accessible through pointer on
stack, possibly with an offset
*/
#define DSG_FIXED 3 /* designator directly accessible */
#define DSG_PFIXED 4 /* designator accessible through directly
accessible pointer
*/
#define DSG_INDEXED 5 /* designator accessible through array
operation. Address of array descriptor on
top of the stack, index beneath that, and
base address beneath that
*/
arith dsg_offset; /* contains an offset for PLOADED,
or for FIXED or PFIXED it contains an
offset from dsg_name, if it exists,
or from the current Local Base
*/
char *dsg_name; /* name of global variable, used for
FIXED and PFIXED
*/
struct def *dsg_def; /* def structure associated with this
designator, or 0
*/
};
/* ALLOCDEF "desig" 5 */
/* The next structure describes the designator in a with-statement.
We have a linked list of them, as with-statements may be nested.
*/
struct withdesig {
struct withdesig *w_next;
struct scope *w_scope; /* scope in which fields of this record
reside
*/
struct desig w_desig; /* a desig structure for this particular
designator
*/
};
extern struct withdesig *WithDesigs;
#define NO_LABEL ((label) 0)

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

@ -22,16 +22,16 @@
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include <alloc.h>
#include "type.h"
#include "LLlex.h"
#include "def.h"
#include "scope.h"
#include "desig.h"
#include "LLlex.h"
#include "node.h"
extern int proclevel;
struct desig InitDesig = {DSG_INIT, 0, 0, 0};
int
WordOrDouble(ds, size)
@ -86,9 +86,9 @@ DoStore(ds, size)
}
STATIC int
properly(ds, size, al)
properly(ds, tp)
register struct desig *ds;
arith size;
register struct type *tp;
{
/* Check if it is allowed to load or store the value indicated
by "ds" with LOI/STI.
@ -100,16 +100,17 @@ properly(ds, size, al)
with DSG_FIXED.
*/
int szmodword = (int) size % (int) word_size; /* 0 if multiple of wordsize */
int wordmodsz = word_size % size; /* 0 if dividor of wordsize */
int szmodword = (int) (tp->tp_size) % (int) word_size;
/* 0 if multiple of wordsize */
int wordmodsz = word_size % tp->tp_size;/* 0 if dividor of wordsize */
if (szmodword && wordmodsz) return 0;
if (al >= word_align) return 1;
if (szmodword && al >= szmodword) return 1;
if (tp->tp_align >= word_align) return 1;
if (szmodword && tp->tp_align >= szmodword) return 1;
return ds->dsg_kind == DSG_FIXED &&
((! szmodword && (int) (ds->dsg_offset) % word_align == 0) ||
(! wordmodsz && ds->dsg_offset % size == 0));
(! wordmodsz && ds->dsg_offset % tp->tp_size == 0));
}
CodeValue(ds, tp)
@ -131,7 +132,7 @@ CodeValue(ds, tp)
case DSG_PLOADED:
case DSG_PFIXED:
sz = WA(tp->tp_size);
if (properly(ds, tp->tp_size, tp->tp_align)) {
if (properly(ds, tp)) {
CodeAddress(ds);
C_loi(tp->tp_size);
break;
@ -162,9 +163,6 @@ CodeValue(ds, tp)
}
ds->dsg_kind = DSG_LOADED;
if (tp->tp_fund == T_SUBRANGE) {
CodeCoercion(tp, BaseType(tp));
}
}
CodeStore(ds, tp)
@ -184,7 +182,7 @@ CodeStore(ds, tp)
case DSG_PLOADED:
case DSG_PFIXED:
CodeAddress(&save);
if (properly(ds, tp->tp_size, tp->tp_align)) {
if (properly(ds, tp)) {
C_sti(tp->tp_size);
break;
}
@ -225,13 +223,10 @@ CodeMove(rhs, left, rtp)
register struct node *left;
struct type *rtp;
{
struct desig dsl;
register struct desig *lhs = &dsl;
register struct desig *lhs = new_desig();
register struct type *tp = left->nd_type;
int loadedflag = 0;
dsl = InitDesig;
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
Go through some (considerable) trouble to see if a BLM can be
@ -247,10 +242,10 @@ CodeMove(rhs, left, rtp)
C_loc(tp->tp_size);
C_cal("_StringAssign");
C_asp(word_size << 2);
return;
break;
}
CodeStore(lhs, tp);
return;
break;
case DSG_PLOADED:
case DSG_PFIXED:
CodeAddress(rhs);
@ -259,11 +254,11 @@ CodeMove(rhs, left, rtp)
CodeDesig(left, lhs);
CodeAddress(lhs);
C_blm(tp->tp_size);
return;
break;
}
CodeValue(rhs, tp);
CodeDStore(left);
return;
break;
case DSG_FIXED:
CodeDesig(left, lhs);
if (lhs->dsg_kind == DSG_FIXED &&
@ -313,7 +308,7 @@ CodeMove(rhs, left, rtp)
CodeCopy(lhs, rhs, (arith) sz, &size);
}
}
return;
break;
}
if (lhs->dsg_kind == DSG_PLOADED ||
lhs->dsg_kind == DSG_INDEXED) {
@ -326,7 +321,7 @@ CodeMove(rhs, left, rtp)
if (loadedflag) C_exg(pointer_size);
else CodeAddress(lhs);
C_blm(tp->tp_size);
return;
break;
}
{
arith tmp;
@ -343,11 +338,12 @@ CodeMove(rhs, left, rtp)
CodeValue(rhs, tp);
CodeStore(lhs, tp);
if (loadedflag) FreePtr(tmp);
return;
break;
}
default:
crash("CodeMove");
}
free_desig(lhs);
}
CodeAddress(ds)
@ -529,6 +525,7 @@ CodeDesig(nd, ds)
switch(nd->nd_class) { /* Divide */
case Def:
df = nd->nd_def;
if (nd->nd_left) CodeDesig(nd->nd_left, ds);
switch(df->df_kind) {
case D_FIELD:
@ -544,22 +541,12 @@ CodeDesig(nd, ds)
}
break;
case LinkDef:
assert(nd->nd_symb == '.');
CodeDesig(nd->nd_left, ds);
CodeFieldDesig(nd->nd_def, ds);
break;
case Arrsel:
assert(nd->nd_symb == '[');
CodeDesig(nd->nd_left, ds);
CodeAddress(ds);
CodePExpr(nd->nd_right);
if (nd->nd_right->nd_type->tp_size > word_size) {
CodeCoercion(nd->nd_right->nd_type, int_type);
}
/* Now load address of descriptor
*/

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

@ -18,10 +18,10 @@
#include <assert.h>
#include "idf.h"
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "main.h"
#include "misc.h"

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

@ -146,19 +146,21 @@ AddOperator:
term(struct node **pnd;)
{
register struct node *nd;
}:
factor(pnd)
factor(pnd) { nd = *pnd; }
[
/* MulOperator */
[ '*' | '/' | DIV | MOD | AND | '&' ]
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
factor(&((*pnd)->nd_right))
[ '*' | '/' | DIV | MOD | AND ]
{ nd = MkNode(Oper, nd, NULLNODE, &dot); }
factor(&(nd->nd_right))
]*
{ *pnd = nd; }
;
/* inline in "term"
MulOperator:
'*' | '/' | DIV | MOD | AND | '&'
'*' | '/' | DIV | MOD | AND
;
*/

5
lang/m2/comp/input.c
View file

@ -12,11 +12,6 @@
#include "f_info.h"
struct f_info file_info;
#include "input.h"
#include <em_arith.h>
#include <em_label.h>
#include "def.h"
#include "idf.h"
#include "scope.h"
#include <inp_pkg.body>

10
lang/m2/comp/lookup.c
View file

@ -15,10 +15,10 @@
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "def.h"
#include "idf.h"
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "type.h"
#include "misc.h"
@ -52,9 +52,11 @@ lookup(id, scope, import)
df->df_next = id->id_def;
id->id_def = df;
}
if (import && df->df_kind == D_IMPORT) {
assert(df->imp_def != 0);
return df->imp_def;
if (import) {
while (df->df_kind == D_IMPORT) {
assert(df->imp_def != 0);
df = df->imp_def;
}
}
}
return df;

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

@ -36,13 +36,11 @@ int DefinitionModule;
char *ProgName;
char **DEFPATH;
int nDEF, mDEF;
int pass_1;
struct def *Defined;
extern int err_occurred;
extern int fp_used; /* set if floating point used */
extern C_inp(), C_exp();
int (*c_inp)() = C_inp;
main(argc, argv)
register char **argv;
{
@ -66,7 +64,6 @@ main(argc, argv)
fprint(STDERR, "%s: Use a file argument\n", ProgName);
exit(1);
}
if (options['x']) c_inp = C_exp;
exit(!Compile(Nargv[1], Nargv[2]));
}
@ -103,9 +100,11 @@ Compile(src, dst)
C_magic();
C_ms_emx(word_size, pointer_size);
CheckForLineDirective();
pass_1 = 1;
CompUnit();
C_ms_src((int)LineNumber - 1, FileName);
if (!err_occurred) {
pass_1 = 0;
C_exp(Defined->mod_vis->sc_scope->sc_name);
WalkModule(Defined);
if (fp_used) C_ms_flt();
@ -186,7 +185,7 @@ AddStandards()
{
register struct def *df;
register struct stdproc *p;
static struct node nilnode = { 0, 0, Value, 0, { INTEGER, 0}};
static struct token nilconst = { INTEGER, 0};
for (p = stdproc; p->st_nam != 0; p++) {
Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con);
@ -200,9 +199,7 @@ AddStandards()
EnterType("BOOLEAN", bool_type);
EnterType("CARDINAL", card_type);
df = Enter("NIL", D_CONST, address_type, 0);
df->con_const = &nilnode;
nilnode.nd_INT = 0;
nilnode.nd_type = address_type;
df->con_const = nilconst;
EnterType("PROC", construct_type(T_PROCEDURE, NULLTYPE));
EnterType("BITSET", bitset_type);

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

@ -16,9 +16,9 @@
#include <alloc.h>
#include <system.h>
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "LLlex.h"
#include "node.h"
struct node *

1
lang/m2/comp/tmpvar.C
View file

@ -24,6 +24,7 @@
#include <alloc.h>
#include <assert.h>
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "scope.h"

1
lang/m2/comp/tokenname.c
View file

@ -85,6 +85,7 @@ struct tokenname tkidf[] = { /* names of the identifier tokens */
#ifdef ___XXX___
struct tokenname tkinternal[] = { /* internal keywords */
{PROGRAM, ""},
{COERCION, ""},
{0, "0"}
};

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

@ -179,6 +179,7 @@ struct type
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED)
extern long full_mask[];
extern long int_mask[];
#define fit(n, i) (((n) + ((arith)0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0)
#define ufit(n, i) (((n) & ~full_mask[(i)]) == 0)

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

@ -19,10 +19,10 @@
#include <em_label.h>
#include <em_code.h>
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "idf.h"
#include "LLlex.h"
#include "node.h"
#include "const.h"
#include "scope.h"
@ -287,7 +287,10 @@ chk_basesubrange(tp, base)
/* Check that the bounds of "tp" fall within the range
of "base".
*/
if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
int fund = base->tp_next->tp_fund;
if (! chk_bounds(base->sub_lb, tp->sub_lb, fund) ||
! chk_bounds(base->sub_ub, tp->sub_ub, fund)) {
error("base type has insufficient range");
}
base = base->tp_next;
@ -314,6 +317,21 @@ chk_basesubrange(tp, base)
tp->tp_align = base->tp_align;
}
int
chk_bounds(l1, l2, fund)
arith l1, l2;
{
/* compare to arith's, but be careful. They might be unsigned
*/
if (fund == T_INTEGER) {
return l2 >= l1;
}
return (l2 & mach_long_sign ?
(l1 & mach_long_sign ? l2 >= l1 : 1) :
(l1 & mach_long_sign ? 0 : l2 >= l1)
);
}
struct type *
subr_type(lb, ub)
register struct node *lb;
@ -326,11 +344,6 @@ subr_type(lb, ub)
register struct type *tp = BaseType(lb->nd_type);
register struct type *res;
if (!TstCompat(lb->nd_type, ub->nd_type)) {
node_error(lb, "types of subrange bounds not equal");
return error_type;
}
if (tp == intorcard_type) {
/* Lower bound >= 0; in this case, the base type is CARDINAL,
according to the language definition, par. 6.3
@ -339,6 +352,10 @@ subr_type(lb, ub)
tp = card_type;
}
if (!ChkCompat(&ub, tp, "subrange bounds")) {
return error_type;
}
/* Check base type
*/
if (! (tp->tp_fund & T_DISCRETE)) {
@ -348,7 +365,7 @@ subr_type(lb, ub)
/* Check bounds
*/
if (lb->nd_INT > ub->nd_INT) {
if (! chk_bounds(lb->nd_INT, ub->nd_INT, tp->tp_fund)) {
node_error(lb, "lower bound exceeds upper bound");
}
@ -490,7 +507,7 @@ ArraySizes(tp)
*/
register struct type *index_type = IndexType(tp);
register struct type *elem_type = tp->arr_elem;
arith lo, hi;
arith lo, hi, diff;
tp->arr_elsize = ArrayElSize(elem_type);
tp->tp_align = elem_type->tp_align;
@ -504,20 +521,21 @@ ArraySizes(tp)
}
getbounds(index_type, &lo, &hi);
diff = hi - lo;
tp->tp_size = (hi - lo + 1) * tp->arr_elsize;
tp->tp_size = (diff + 1) * tp->arr_elsize;
/* generate descriptor and remember label.
*/
tp->arr_descr = ++data_label;
C_df_dlb(tp->arr_descr);
C_rom_cst(lo);
C_rom_cst(hi - lo);
C_rom_cst(diff);
C_rom_cst(tp->arr_elsize);
}
FreeType(tp)
struct type *tp;
register struct type *tp;
{
/* Release type structures indicated by "tp".
This procedure is only called for types, constructed with
@ -549,19 +567,20 @@ DeclareType(nd, df, tp)
"df" is already bound. In that case, it is either an opaque
type, or an error message was given when "df" was created.
*/
register struct type *df_tp = df->df_type;
if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
if (df_tp && df_tp->tp_fund == T_HIDDEN) {
if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
node_error(nd,
"opaque type \"%s\" is not a pointer type",
df->df_idf->id_text);
}
df->df_type->tp_next = tp;
df->df_type->tp_fund = T_EQUAL;
while (tp != df->df_type && tp->tp_fund == T_EQUAL) {
df_tp->tp_next = tp;
df_tp->tp_fund = T_EQUAL;
while (tp != df_tp && tp->tp_fund == T_EQUAL) {
tp = tp->tp_next;
}
if (tp == df->df_type) {
if (tp == df_tp) {
/* Circular definition! */
node_error(nd,
"opaque type \"%s\" has a circular definition",
@ -588,7 +607,7 @@ type_or_forward(ptp)
in "dot". This routine handles the different cases.
*/
register struct node *nd;
register struct def *df1;
register struct def *df, *df1;
if ((df1 = lookup(dot.TOK_IDF, CurrentScope, 1))) {
/* Either a Module or a Type, but in both cases defined
@ -622,21 +641,17 @@ type_or_forward(ptp)
may have forward references that must howewer be declared in the
same scope.
*/
{
register struct def *df =
define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
df = define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
if (df->df_kind == D_TYPE) {
(*ptp)->tp_next = df->df_type;
free_node(nd);
}
else {
nd->nd_type = *ptp;
df->df_forw_node = nd;
if (df1->df_kind == D_TYPE) {
df->df_type = df1->df_type;
}
}
if (df->df_kind == D_TYPE) {
(*ptp)->tp_next = df->df_type;
free_node(nd);
return 0;
}
nd->nd_type = *ptp;
df->df_forw_node = nd;
if (df1->df_kind == D_TYPE) {
df->df_type = df1->df_type;
}
return 0;
}

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

@ -19,8 +19,9 @@
#include <assert.h>
#include "type.h"
#include "def.h"
#include "LLlex.h"
#include "idf.h"
#include "def.h"
#include "node.h"
#include "warning.h"
@ -175,9 +176,10 @@ TstAssCompat(tp1, tp2)
}
int
TstParCompat(formaltype, actualtype, VARflag, nd)
register struct type *formaltype, *actualtype;
struct node *nd;
TstParCompat(parno, formaltype, VARflag, nd, edf)
register struct type *formaltype;
struct node **nd;
struct def *edf;
{
/* Check type compatibility for a parameter in a procedure call.
Assignment compatibility may do if the parameter is
@ -186,11 +188,19 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
may do too.
Or: a WORD may do.
*/
register struct type *actualtype = (*nd)->nd_type;
char ebuf[256];
char ebuf1[256];
return
if (edf) {
sprintf(ebuf, "\"%s\", parameter %d: %%s", edf->df_idf->id_text, parno);
}
else sprint(ebuf, "parameter %d: %%s", parno);
if (
TstTypeEquiv(formaltype, actualtype)
||
( !VARflag && TstAssCompat(formaltype, actualtype))
( !VARflag && ChkAssCompat(nd, formaltype, (char *) 0))
||
( formaltype == address_type
&& actualtype->tp_fund == T_POINTER
@ -225,13 +235,62 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
)
)
)
||
( VARflag
&& ( TstCompat(formaltype, actualtype)
&&
(node_warning(nd, W_OLDFASHIONED, "types of formal and actual must be identical"),
1)
)
)
;
)
return 1;
if (VARflag && TstCompat(formaltype, actualtype)) {
if (formaltype->tp_size == actualtype->tp_size) {
sprint(ebuf1, ebuf, "identical types required");
node_warning(*nd,
W_OLDFASHIONED,
ebuf1);
return 1;
}
sprint(ebuf1, ebuf, "equal sized types required");
node_error(*nd, ebuf1);
return 0;
}
sprint(ebuf1, ebuf, "type incompatibility");
node_error(*nd, ebuf1);
return 0;
}
CompatCheck(nd, tp, message, fc)
struct node **nd;
struct type *tp;
char *message;
int (*fc)();
{
if (! (*fc)(tp, (*nd)->nd_type)) {
if (message) {
node_error(*nd, "type incompatibility in %s", message);
}
return 0;
}
MkCoercion(nd, tp);
return 1;
}
ChkAssCompat(nd, tp, message)
struct node **nd;
struct type *tp;
char *message;
{
/* Check assignment compatibility of node "nd" with type "tp".
Give an error message when it fails
*/
return CompatCheck(nd, tp, message, TstAssCompat);
}
ChkCompat(nd, tp, message)
struct node **nd;
struct type *tp;
char *message;
{
/* Check compatibility of node "nd" with type "tp".
Give an error message when it fails
*/
return CompatCheck(nd, tp, message, TstCompat);
}

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

@ -21,12 +21,13 @@
#include <em_code.h>
#include <m2_traps.h>
#include <assert.h>
#include <alloc.h>
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "scope.h"
#include "main.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "desig.h"
@ -40,7 +41,7 @@ extern arith NewPtr();
extern arith NewInt();
extern int proclevel;
label text_label;
label data_label;
label data_label = 1;
static struct type *func_type;
struct withdesig *WithDesigs;
struct node *Modules;
@ -55,8 +56,11 @@ DoPriority()
/* For the time being (???), handle priorities by calls to
the runtime system
*/
if (priority) {
C_loc(priority->nd_INT);
register struct node *p;
if (p = priority) {
C_loc(p->nd_INT);
C_cal("_stackprio");
C_asp(word_size);
}
@ -77,13 +81,13 @@ DoProfil()
if (! options['L']) {
if (!filename_label) {
filename_label = ++data_label;
C_df_dlb(filename_label);
if (! filename_label) {
filename_label = 1;
C_df_dlb((label) 1);
C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
}
C_fil_dlb(filename_label, (arith) 0);
C_fil_dlb((label) 1, (arith) 0);
}
}
@ -215,14 +219,14 @@ WalkProcedure(procedure)
param;
param = param->par_next) {
if (! IsVarParam(param)) {
register struct type *TpParam = TypeOfParam(param);
tp = TypeOfParam(param);
if (! IsConformantArray(TpParam)) {
if (TpParam->tp_size < word_size &&
(int) word_size % (int) TpParam->tp_size == 0) {
if (! IsConformantArray(tp)) {
if (tp->tp_size < word_size &&
(int) word_size % (int) tp->tp_size == 0) {
C_lol(param->par_def->var_off);
C_lal(param->par_def->var_off);
C_sti(TpParam->tp_size);
C_sti(tp->tp_size);
}
}
else {
@ -239,7 +243,7 @@ WalkProcedure(procedure)
if (! StackAdjustment) {
/* First time we get here
*/
if (tp && !func_res_label) {
if (func_type && !func_res_label) {
/* Some local space, only
needed if the value itself
is returned
@ -290,21 +294,20 @@ WalkProcedure(procedure)
C_str((arith) 1);
}
C_lae_dlb(func_res_label, (arith) 0);
EndPriority();
C_ret(pointer_size);
func_res_size = pointer_size;
}
else if (StackAdjustment) {
/* First save the function result in a safe place.
Then remove copies of conformant arrays,
and put function result back on the stack
*/
if (tp) {
if (func_type) {
C_lal(retsav);
C_sti(func_res_size);
}
C_lol(StackAdjustment);
C_str((arith) 1);
if (tp) {
if (func_type) {
C_lal(retsav);
C_loi(func_res_size);
}
@ -410,7 +413,7 @@ WalkStat(nd, exit_label)
break;
case BECOMES:
DoAssign(nd, left, right);
DoAssign(left, right);
break;
case IF:
@ -478,43 +481,47 @@ WalkStat(nd, exit_label)
int good_forvar;
label l1 = ++text_label;
label l2 = ++text_label;
int uns = 0;
good_forvar = DoForInit(nd, left);
#ifdef DEBUG
nd->nd_left = left;
nd->nd_right = right;
#endif
fnd = left->nd_right;
if (fnd->nd_class != Value) {
/* Upperbound not constant.
The expression may only be evaluated once,
so generate a temporary for it
*/
CodePExpr(fnd);
tmp = NewInt();
C_stl(tmp);
}
C_df_ilb(l1);
C_dup(int_size);
if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
if (left->nd_INT > 0) {
C_bgt(l2);
}
else C_blt(l2);
if (good_forvar) {
RangeCheck(nd->nd_type, int_type);
uns = BaseType(nd->nd_type)->tp_fund != T_INTEGER;
if (fnd->nd_class != Value) {
/* Upperbound not constant.
The expression may only be evaluated
once, so generate a temporary for it
*/
CodePExpr(fnd);
tmp = NewInt();
C_stl(tmp);
}
C_df_ilb(l1);
C_dup(int_size);
if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
if (uns) C_cmu(int_size);
else C_cmi(int_size);
if (left->nd_INT > 0) {
C_zgt(l2);
}
else C_zlt(l2);
CodeDStore(nd);
}
WalkNode(right, exit_label);
if (good_forvar) {
CodePExpr(nd);
C_loc(left->nd_INT);
C_adi(int_size);
if (uns) C_adu(int_size);
else C_adi(int_size);
C_bra(l1);
C_df_ilb(l2);
C_asp(int_size);
}
if (tmp) FreeInt(tmp);
#ifdef DEBUG
nd->nd_left = left;
nd->nd_right = right;
#endif
}
break;
@ -566,15 +573,14 @@ WalkStat(nd, exit_label)
assignment compatible with the result type of the
function procedure (See Rep. 9.11).
*/
if (!TstAssCompat(func_type, right->nd_type)) {
node_error(right, "type incompatibility in RETURN statement");
if (!ChkAssCompat(&(nd->nd_right), func_type, "RETURN")) {
break;
}
right = nd->nd_right;
if (right->nd_type->tp_fund == T_STRING) {
CodePString(right, func_type);
}
else CodePExpr(right);
RangeCheck(func_type, right->nd_type);
}
C_bra(RETURN_LABEL);
break;
@ -609,29 +615,16 @@ ExpectBool(nd, true_label, false_label)
/* "nd" must indicate a boolean expression. Check this and
generate code to evaluate the expression.
*/
struct desig ds;
register struct desig *ds = new_desig();
if (!ChkExpression(nd)) return;
if (ChkExpression(nd)) {
if (nd->nd_type != bool_type && nd->nd_type != error_type) {
node_error(nd, "boolean expression expected");
}
if (nd->nd_type != bool_type && nd->nd_type != error_type) {
node_error(nd, "boolean expression expected");
CodeExpr(nd, ds, true_label, false_label);
}
ds = InitDesig;
CodeExpr(nd, &ds, true_label, false_label);
}
int
WalkExpr(nd)
register struct node *nd;
{
/* Check an expression and generate code for it
*/
if (! ChkExpression(nd)) return 0;
CodePExpr(nd);
return 1;
free_desig(ds);
}
int
@ -644,7 +637,7 @@ WalkDesignator(nd, ds)
if (! ChkVariable(nd)) return 0;
*ds = InitDesig;
clear((char *) ds, sizeof(struct desig));
CodeDesig(nd, ds);
return 1;
}
@ -653,13 +646,14 @@ DoForInit(nd, left)
register struct node *nd, *left;
{
register struct def *df;
struct type *tpl, *tpr;
nd->nd_left = nd->nd_right = 0;
nd->nd_class = Name;
nd->nd_symb = IDENT;
if (!( ChkVariable(nd) &
WalkExpr(left->nd_left) &
ChkExpression(left->nd_left) &
ChkExpression(left->nd_right))) return 0;
df = nd->nd_def;
@ -694,21 +688,22 @@ DoForInit(nd, left)
return 1;
}
if (!TstCompat(df->df_type, left->nd_left->nd_type) ||
!TstCompat(df->df_type, left->nd_right->nd_type)) {
if (!TstAssCompat(df->df_type, left->nd_left->nd_type) ||
!TstAssCompat(df->df_type, left->nd_right->nd_type)) {
node_error(nd, "type incompatibility in FOR statement");
return 1;
}
tpl = left->nd_left->nd_type;
tpr = left->nd_right->nd_type;
if (!ChkAssCompat(&(left->nd_left), df->df_type, "FOR statement") ||
!ChkAssCompat(&(left->nd_right), df->df_type,"FOR statement")) {
return 1;
}
if (!TstCompat(df->df_type, tpl) ||
!TstCompat(df->df_type, tpr)) {
node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
}
CodePExpr(left->nd_left);
return 1;
}
DoAssign(nd, left, right)
struct node *nd;
DoAssign(left, right)
register struct node *left, *right;
{
/* May we do it in this order (expression first) ???
@ -716,32 +711,32 @@ DoAssign(nd, left, right)
it sais that the left hand side is evaluated first.
DAMN THE BOOK!
*/
struct desig dsr;
register struct desig *dsr;
register struct type *rtp, *ltp;
struct node *rht = right;
if (! (ChkExpression(right) & ChkVariable(left))) return;
rtp = right->nd_type;
ltp = left->nd_type;
if (right->nd_symb == STRING) TryToString(right, ltp);
dsr = InitDesig;
if (! TstAssCompat(ltp, rtp)) {
node_error(nd, "type incompatibility in assignment");
if (! ChkAssCompat(&rht, ltp, "assignment")) {
return;
}
dsr = new_desig();
#define StackNeededFor(ds) ((ds)->dsg_kind == DSG_PLOADED \
|| (ds)->dsg_kind == DSG_INDEXED)
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
CodeExpr(rht, dsr, NO_LABEL, NO_LABEL);
if (complex(rtp)) {
if (StackNeededFor(&dsr)) CodeAddress(&dsr);
if (StackNeededFor(dsr)) CodeAddress(dsr);
}
else {
CodeValue(&dsr, rtp);
CodeCheckExpr(rtp, ltp);
CodeValue(dsr, rtp);
}
CodeMove(&dsr, left, rtp);
CodeMove(dsr, left, rtp);
free_desig(dsr);
}
RegisterMessages(df)

2
lang/m2/comp/walk.h
View file

@ -14,7 +14,7 @@
extern int (*WalkTable[])();
#define WalkNode(xnd, xlab) ((xnd) && (*WalkTable[(xnd)->nd_class])((xnd), (xlab)))
#define WalkNode(xnd, xlab) if (! xnd) ; else (*WalkTable[(xnd)->nd_class])((xnd), (xlab))
extern label text_label;
extern label data_label;