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

newer version

Browse source
This commit is contained in:
ceriel 1986-04-23 22:12:22 +00:00
parent ce160b4f1a
commit a254a8acb1
11 changed files with 437 additions and 299 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -21,6 +21,8 @@ static char *RcsId = "$Header$";
#include "debug.h"
extern char *symbol2str();
int
chk_expr(expp)
register struct node *expp;
@ -32,11 +34,19 @@ chk_expr(expp)
switch(expp->nd_class) {
case Oper:
if (expp->nd_symb == '[') {
return chk_designator(expp, DESIGNATOR);
}
return chk_expr(expp->nd_left) &&
chk_expr(expp->nd_right) &&
chk_oper(expp);
case Uoper:
if (expp->nd_symb == '^') {
return chk_designator(expp, DESIGNATOR);
}
return chk_expr(expp->nd_right) &&
chk_uoper(expp);
@ -56,13 +66,13 @@ chk_expr(expp)
return chk_set(expp);
case Name:
return chk_name(expp);
return chk_designator(expp, DESIGNATOR);
case Call:
return chk_call(expp);
case Link:
return chk_name(expp);
return chk_designator(expp, DESIGNATOR);
default:
assert(0);
@ -89,7 +99,8 @@ chk_set(expp)
if (nd = expp->nd_left) {
/* A type was given. Check it out
*/
findname(nd);
if (! chk_designator(nd, QUALONLY)) return 0;
assert(nd->nd_class == Def);
df = nd->nd_def;
@ -259,7 +270,7 @@ getname(argp, kinds)
return 0;
}
argp = argp->nd_right;
findname(argp->nd_left);
if (! chk_designator(argp->nd_left, QUALONLY)) return 0;
assert(argp->nd_left->nd_class == Def);
if (!(argp->nd_left->nd_def->df_kind & kinds)) {
node_error(argp, "unexpected type");
@ -283,7 +294,7 @@ chk_call(expp)
*/
expp->nd_type = error_type;
left = expp->nd_left;
findname(left);
if (! chk_designator(left, DESIGNATOR)) return 0;
if (left->nd_type == error_type) return 0;
if (left->nd_class == Def &&
@ -300,7 +311,6 @@ node_error(expp, "only one parameter expected in type cast");
if (! chk_expr(arg)) return 0;
if (arg->nd_type->tp_size != left->nd_type->tp_size) {
node_error(expp, "size of type in type cast does not match size of operand");
return 0;
}
arg->nd_type = left->nd_type;
FreeNode(expp->nd_left);
@ -322,172 +332,7 @@ node_error(expp, "size of type in type cast does not match size of operand");
if (left->nd_type == std_type) {
/* A standard procedure
*/
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));
switch(left->nd_def->df_value.df_stdname) {
case S_ABS:
arg = getarg(arg, T_NUMERIC);
if (! arg) return 0;
left = arg->nd_left;
expp->nd_type = left->nd_type;
if (left->nd_class == Value) {
cstcall(expp, S_ABS);
}
break;
case S_CAP:
arg = getarg(arg, T_CHAR);
expp->nd_type = char_type;
if (!arg) return 0;
left = arg->nd_left;
if (left->nd_class == Value) {
cstcall(expp, S_CAP);
}
break;
case S_CHR:
arg = getarg(arg, T_INTORCARD);
expp->nd_type = char_type;
if (!arg) return 0;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_CHR);
}
break;
case S_FLOAT:
arg = getarg(arg, T_INTORCARD);
expp->nd_type = real_type;
if (!arg) return 0;
break;
case S_HIGH:
arg = getarg(arg, T_ARRAY);
if (!arg) return 0;
expp->nd_type = arg->nd_left->nd_type->next;
if (!expp->nd_type) {
/* A dynamic array has no explicit
index type
*/
expp->nd_type = intorcard_type;
}
else cstcall(expp, S_MAX);
break;
case S_MAX:
case S_MIN:
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
expp->nd_type = arg->nd_left->nd_type;
cstcall(expp,left->nd_def->df_value.df_stdname);
break;
case S_ODD:
arg = getarg(arg, T_INTORCARD);
if (!arg) return 0;
expp->nd_type = bool_type;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_ODD);
}
break;
case S_ORD:
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
expp->nd_type = card_type;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_ORD);
}
break;
case S_TSIZE: /* ??? */
case S_SIZE:
arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
expp->nd_type = intorcard_type;
if (!arg) return 0;
cstcall(expp, S_SIZE);
break;
case S_TRUNC:
arg = getarg(arg, T_REAL);
if (!arg) return 0;
expp->nd_type = card_type;
break;
case S_VAL: {
struct type *tp;
arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE);
if (!arg) return 0;
tp = arg->nd_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_right = arg->nd_right;
arg->nd_right = 0;
FreeNode(arg);
arg = getarg(expp, T_INTORCARD);
if (!arg) return 0;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_VAL);
}
break;
}
case S_ADR:
arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE);
expp->nd_type = address_type;
if (!arg) return 0;
break;
case S_DEC:
case S_INC:
expp->nd_type = 0;
arg = getname(arg, D_VARIABLE|D_FIELD);
if (!arg) return 0;
if (arg->nd_right) {
arg = getarg(arg, T_INTORCARD);
if (!arg) return 0;
}
break;
case S_HALT:
expp->nd_type = 0;
break;
case S_EXCL:
case S_INCL: {
struct type *tp;
expp->nd_type = 0;
arg = getname(arg, D_VARIABLE|D_FIELD);
if (!arg) return 0;
tp = arg->nd_left->nd_type;
if (tp->tp_fund != T_SET) {
node_error(arg, "EXCL and INCL expect a SET parameter");
return 0;
}
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
node_error(arg, "unexpected type");
return 0;
}
break;
}
default:
assert(0);
}
if (arg->nd_right) {
node_error(arg->nd_right,
"too many parameters supplied");
return 0;
}
return 1;
return chk_std(expp, left, arg);
}
/* Here, we have found a real procedure call. The left hand
side may also represent a procedure variable.
@ -534,7 +379,8 @@ node_error(arg->nd_left, "type incompatibility in value parameter");
return 1;
}
findname(expp)
int
chk_designator(expp, flag)
register struct node *expp;
{
/* Find the name indicated by "expp", starting from the current
@ -545,29 +391,31 @@ findname(expp)
struct def *lookfor();
expp->nd_type = error_type;
if (expp->nd_class == Name) {
expp->nd_def = lookfor(expp, CurrentScope, 1);
expp->nd_class = Def;
expp->nd_type = expp->nd_def->df_type;
return;
if (expp->nd_type == error_type) return 0;
}
if (expp->nd_class == Link) {
assert(expp->nd_symb == '.');
assert(expp->nd_right->nd_class == Name);
findname(expp->nd_left);
if (! chk_designator(expp->nd_left, flag)) return 0;
tp = expp->nd_left->nd_type;
if (tp == error_type) {
df = ill_df;
}
if (tp == error_type) return 0;
else if (tp->tp_fund != T_RECORD) {
/* This is also true for modules */
node_error(expp,"illegal selection");
df = ill_df;
return 0;
}
else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
if (!df) {
df = ill_df;
id_not_declared(expp->nd_right);
return 0;
}
else if (df != ill_df) {
expp->nd_type = df->df_type;
@ -575,8 +423,10 @@ findname(expp)
node_error(expp->nd_right,
"identifier \"%s\" not exported from qualifying module",
df->df_idf->id_text);
return 0;
}
}
if (expp->nd_left->nd_class == Def) {
expp->nd_class = Def;
expp->nd_def = df;
@ -584,45 +434,83 @@ df->df_idf->id_text);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
return;
else return 1;
}
if (expp->nd_class == Def) {
df = expp->nd_def;
if (df->df_kind & (D_ENUM | D_CONST)) {
if (df->df_kind == D_ENUM) {
expp->nd_class = Value;
expp->nd_INT = df->enm_val;
expp->nd_symb = INTEGER;
}
else {
assert(df->df_kind == D_CONST);
*expp = *(df->con_const);
}
}
return 1;
}
if (flag == QUALONLY) {
node_error(expp, "identifier expected");
return 0;
}
if (expp->nd_class == Oper) {
struct type *tpl, *tpr;
assert(expp->nd_symb == '[');
findname(expp->nd_left);
if (chk_expr(expp->nd_right) &&
expp->nd_left->nd_type != error_type &&
chk_oper(expp)) /* ??? */ ;
return;
}
if (expp->nd_class == Uoper && expp->nd_symb == '^') {
findname(expp->nd_right);
if (expp->nd_right->nd_type != error_type &&
chk_uoper(expp)) /* ??? */ ;
}
return;
}
int
chk_name(expp)
register struct node *expp;
{
register struct def *df;
if (
!chk_designator(expp->nd_left, DESIGNATOR)
||
!chk_expr(expp->nd_right)
||
expp->nd_left->nd_type == error_type
) return 0;
findname(expp);
assert(expp->nd_class == Def);
df = expp->nd_def;
if (df->df_kind == D_ERROR) return 0;
if (df->df_kind & (D_ENUM | D_CONST)) {
if (df->df_kind == D_ENUM) {
expp->nd_class = Value;
expp->nd_INT = df->enm_val;
expp->nd_symb = INTEGER;
tpr = expp->nd_right->nd_type;
tpl = expp->nd_left->nd_type;
if (tpl->tp_fund != T_ARRAY) {
node_error(expp,
"array index not belonging to an ARRAY");
return 0;
}
else if (df->df_kind == D_CONST) {
*expp = *(df->con_const);
/* Type of the index must be assignment compatible with
the index type of the array (Def 8.1)
*/
if ((tpl->next && !TstAssCompat(tpl->next, tpr)) ||
(!tpl->next && !TstAssCompat(intorcard_type, tpr))) {
node_error(expp, "incompatible index type");
return 0;
}
expp->nd_type = tpl->arr_elem;
return 1;
}
return 1;
if (expp->nd_class == Uoper) {
assert(expp->nd_symb == '^');
if (! chk_designator(expp->nd_right, DESIGNATOR)) return 0;
if (expp->nd_right->nd_type->tp_fund != T_POINTER) {
node_error(expp, "illegal operand for unary operator \"%s\"",
symbol2str(expp->nd_symb));
return 0;
}
expp->nd_type = expp->nd_right->nd_type->next;
return 1;
}
node_error(expp, "designator expected");
return 0;
}
int
@ -631,19 +519,20 @@ chk_oper(expp)
{
/* Check a binary operation.
*/
register struct type *tpl = expp->nd_left->nd_type;
register struct type *tpr = expp->nd_right->nd_type;
char *symbol2str();
register struct node *left = expp->nd_left;
register struct node *right = expp->nd_right;
struct type *tpl = left->nd_type;
struct type *tpr = right->nd_type;
int errval = 1;
if (tpl == intorcard_type) {
if (tpr == int_type || tpr == card_type) {
expp->nd_left->nd_type = tpl = tpr;
left->nd_type = tpl = tpr;
}
}
if (tpr == intorcard_type) {
if (tpl == int_type || tpl == card_type) {
expp->nd_right->nd_type = tpr = tpl;
right->nd_type = tpr = tpl;
}
}
expp->nd_type = error_type;
@ -655,42 +544,29 @@ chk_oper(expp)
node_error(expp, "RHS of IN operator not a SET type");
return 0;
}
if (!TstCompat(tpl, tpr->next)) {
if (!TstAssCompat(tpl, tpr->next)) {
/* Assignment compatible ???
I don't know! Should we be allowed th check
if a CARDINAL is a member of a BITSET???
*/
node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
return 0;
}
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Set) {
if (left->nd_class == Value && right->nd_class == Set) {
cstset(expp);
}
return 1;
}
if (expp->nd_symb == '[') {
/* Handle ARRAY selection specially too!
*/
if (tpl->tp_fund != T_ARRAY) {
node_error(expp,
"array index not belonging to an ARRAY");
return 0;
}
if ((tpl->next && !TstCompat(tpl->next, tpr)) ||
(!tpl->next && !TstCompat(intorcard_type, tpr)) {
node_error(expp, "incompatible index type");
}
expp->nd_type = tpl->arr_elem;
return 1;
}
if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
expp->nd_type = tpl;
/* Operands must be compatible (distilled from Def 8.2)
*/
if (!TstCompat(tpl, tpr)) {
node_error(expp,
"incompatible types for operator \"%s\"",
symbol2str(expp->nd_symb));
node_error(expp, "incompatible types for operator \"%s\"",
symbol2str(expp->nd_symb));
return 0;
}
@ -702,15 +578,13 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case T_INTEGER:
case T_CARDINAL:
case T_INTORCARD:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp);
}
return 1;
case T_SET:
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
}
/* Fall through */
@ -723,8 +597,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case '/':
switch(tpl->tp_fund) {
case T_SET:
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
}
/* Fall through */
@ -737,8 +610,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case DIV:
case MOD:
if (tpl->tp_fund & T_INTORCARD) {
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp);
}
return 1;
@ -749,8 +621,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case AND:
case '&':
if (tpl == bool_type) {
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp);
}
return 1;
@ -771,8 +642,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
if (expp->nd_symb == '<' || expp->nd_symb == '>') {
break;
}
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
}
return 1;
@ -782,8 +652,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case T_ENUMERATION: /* includes boolean */
case T_CHAR:
case T_INTORCARD:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp);
}
return 1;
@ -868,11 +737,6 @@ chk_uoper(expp)
}
break;
case '^':
if (tpr->tp_fund != T_POINTER) break;
expp->nd_type = tpr->next;
return 1;
default:
assert(0);
}
@ -880,3 +744,179 @@ chk_uoper(expp)
symbol2str(expp->nd_symb));
return 0;
}
struct node *
getvariable(arg)
register struct node *arg;
{
arg = arg->nd_right;
if (!arg) {
node_error(arg, "too few parameters supplied");
return 0;
}
if (! chk_designator(arg->nd_left, DESIGNATOR)) return 0;
if (arg->nd_left->nd_class == Oper || arg->nd_left->nd_class == Uoper) {
return arg;
}
if (arg->nd_left->nd_class != Def ||
!(arg->nd_left->nd_def->df_kind & (D_VARIABLE|D_FIELD))) {
node_error(arg, "variable expected");
return 0;
}
return arg;
}
int
chk_std(expp, left, arg)
register struct node *expp, *left, *arg;
{
/* Check a call of a standard procedure or function
*/
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));
switch(left->nd_def->df_value.df_stdname) {
case S_ABS:
if (!(arg = getarg(arg, T_NUMERIC))) return 0;
left = arg->nd_left;
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))) return 0;
left = arg->nd_left;
if (left->nd_class == Value) cstcall(expp, S_CAP);
break;
case S_CHR:
expp->nd_type = char_type;
if (!(arg = getarg(arg, T_INTORCARD))) return 0;
left = arg->nd_left;
if (left->nd_class == Value) cstcall(expp, S_CHR);
break;
case S_FLOAT:
expp->nd_type = real_type;
if (!(arg = getarg(arg, T_INTORCARD))) return 0;
break;
case S_HIGH:
if (!(arg = getarg(arg, T_ARRAY))) return 0;
expp->nd_type = arg->nd_left->nd_type->next;
if (!expp->nd_type) {
/* A dynamic array has no explicit index type
*/
expp->nd_type = intorcard_type;
}
else cstcall(expp, S_MAX);
break;
case S_MAX:
case S_MIN:
if (!(arg = getarg(arg, T_DISCRETE))) return 0;
expp->nd_type = arg->nd_left->nd_type;
cstcall(expp,left->nd_def->df_value.df_stdname);
break;
case S_ODD:
if (!(arg = getarg(arg, T_INTORCARD))) return 0;
expp->nd_type = bool_type;
if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD);
break;
case S_ORD:
if (!(arg = getarg(arg, T_DISCRETE))) return 0;
expp->nd_type = card_type;
if (arg->nd_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_TYPE|D_HIDDEN|D_HTYPE);
if (!arg) return 0;
cstcall(expp, S_SIZE);
break;
case S_TRUNC:
expp->nd_type = card_type;
if (!(arg = getarg(arg, T_REAL))) return 0;
break;
case S_VAL:
{
struct type *tp;
if (!(arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE))) return 0;
tp = arg->nd_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_right = arg->nd_right;
arg->nd_right = 0;
FreeNode(arg);
arg = getarg(expp, T_INTORCARD);
if (!arg) return 0;
if (arg->nd_left->nd_class == Value) cstcall(expp, S_VAL);
break;
}
case S_ADR:
expp->nd_type = address_type;
if (!(arg = getarg(arg, D_VARIABLE|D_FIELD))) return 0;
break;
case S_DEC:
case S_INC:
expp->nd_type = 0;
if (!(arg = getvariable(arg))) return 0;
if (arg->nd_right) {
if (!(arg = getarg(arg, T_INTORCARD))) return 0;
}
break;
case S_HALT:
expp->nd_type = 0;
break;
case S_EXCL:
case S_INCL:
{
struct type *tp;
expp->nd_type = 0;
if (!(arg = getvariable(arg))) return 0;
tp = arg->nd_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))) return 0;
if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
node_error(arg, "unexpected type");
return 0;
}
break;
}
default:
assert(0);
}
if (arg->nd_right) {
node_error(arg->nd_right, "too many parameters supplied");
return 0;
}
return 1;
}

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

@ -117,7 +117,8 @@ FormalParameters(int doparams;
{ *tp = 0; }
[ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type",
(struct node **) 0)
{ *tp = df->df_type; }
{ *tp = df->df_type;
}
]?
;
@ -364,14 +365,14 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
*/
{ warning("Old fashioned Modula-2 syntax!");
id = gen_anon_idf();
findname(nd);
assert(nd->nd_class == Def);
df = nd->nd_def;
if (!(df->df_kind &
(D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN))) {
error("identifier \"%s\" is not a type",
df->df_idf->id_text);
df = ill_df;
if (chk_designator(nd, QUALONLY) &&
(nd->nd_class != Def ||
!(nd->nd_def->df_kind &
(D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN)))) {
node_error(nd, "type expected");
}
else df = nd->nd_def;
FreeNode(nd);
}
]

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

@ -439,6 +439,16 @@ DeclProc(type)
return df;
}
InitProc(nd, df)
struct node *nd;
struct def *df;
{
/* Create an initialization procedure for a module.
*/
df->mod_body = nd;
/* Keep it this way, or really create a procedure out of it??? */
}
#ifdef DEBUG
PrDef(df)
register struct def *df;

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

@ -134,10 +134,7 @@ _error(class, node, fmt, argv)
case LEXERROR:
case CRASH:
case FATAL:
/* ????
if (C_busy())
C_ms_err();
*/
if (C_busy()) C_ms_err();
err_occurred = 1;
break;

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

@ -33,27 +33,33 @@ number(struct node **p;)
qualident(int types; struct def **pdf; char *str; struct node **p;)
{
register struct def *df;
register struct node **pnd;
struct node *nd;
} :
IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot);
pnd = &nd;
}
[
selector(pnd)
selector(&nd)
]*
{ if (types) {
findname(nd);
assert(nd->nd_class == Def);
*pdf = df = nd->nd_def;
if ( !((types|D_ERROR) & df->df_kind)) {
if (df->df_kind == D_FORWARD) {
node_error(*pnd,"%s \"%s\" not declared", str, df->df_idf->id_text);
}
else {
node_error(*pnd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
df = ill_df;
if (chk_designator(nd, QUALONLY)) {
if (nd->nd_class != Def) {
node_error(nd, "%s expected", str);
}
else {
df = nd->nd_def;
if ( !((types|D_ERROR) & df->df_kind)) {
if (df->df_kind == D_FORWARD) {
node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
}
else {
node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
}
}
}
}
*pdf = df;
}
if (!p) FreeNode(nd);
else *p = nd;

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

@ -36,3 +36,5 @@ struct node {
extern struct node *MkNode();
#define NULLNODE ((struct node *) 0)
#define QUALONLY 0
#define DESIGNATOR 1

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

@ -51,6 +51,7 @@ ModuleDeclaration
extern int proclevel;
static int modulecount = 0;
char buf[256];
struct node *nd;
extern char *sprint(), *Malloc(), *strcpy();
} :
MODULE IDENT {
@ -78,8 +79,9 @@ ModuleDeclaration
';'
import(1)*
export(0)?
block(&(df->mod_body))
IDENT { close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
block(&nd)
IDENT { InitProc(nd, df);
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
currentdef = savecurr;
}
@ -226,6 +228,7 @@ ProgramModule(int state;)
struct idf *id;
struct def *GetDefinitionModule();
register struct def *df;
struct node *nd;
} :
MODULE
IDENT {
@ -243,12 +246,14 @@ ProgramModule(int state;)
open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope;
df->mod_number = 0;
CurrentScope->sc_name = id->id_text;
}
}
priority(&(df->mod_priority))?
';' import(0)*
block(&(df->mod_body)) IDENT
{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
block(&nd) IDENT
{ InitProc(nd, df);
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
}
'.'

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

@ -74,7 +74,12 @@ error("a module body has no result value");
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);
}
}
]
]?
;

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

@ -90,23 +90,34 @@ construct_type(fund, tp)
dtp->tp_align = pointer_align;
dtp->tp_size = pointer_size;
dtp->next = tp;
if (fund == T_PROCEDURE && tp) {
if (tp != bitset_type &&
!(tp->tp_fund&(T_NUMERIC|T_INDEX|T_WORD|T_POINTER))) {
error("illegal procedure result type");
}
}
break;
case T_SET:
dtp->tp_align = word_align;
dtp->next = tp;
break;
case T_ARRAY:
dtp->tp_align = tp->tp_align;
dtp->next = tp;
break;
case T_SUBRANGE:
dtp->tp_align = tp->tp_align;
dtp->tp_size = tp->tp_size;
dtp->next = tp;
break;
default:
assert(0);
}
return dtp;
}

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

@ -95,15 +95,15 @@ TstCompat(tp1, tp2)
&&
(tp2 == int_type || tp2 == card_type)
)
||
(tp1 == char_type && tp2 == charc_type)
||
(tp2 == char_type && tp1 == charc_type)
||
( tp2 == intorcard_type
&&
(tp1 == int_type || tp1 == card_type)
)
||
(tp1 == char_type && tp2 == charc_type)
||
(tp2 == char_type && tp1 == charc_type)
||
( tp1 == address_type
&&

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

@ -24,6 +24,9 @@ extern arith align();
static int prclev = 0;
static label instructionlabel = 0;
static label datalabel = 0;
static label return_label;
static char return_expr_occurred;
static struct type *func_type;
WalkModule(module)
register struct def *module;
@ -72,9 +75,14 @@ WalkModule(module)
this module.
*/
CurrentScope->sc_off = 0;
instructionlabel = 1;
return_label = instructionlabel++;
func_type = 0;
C_pro_narg(CurrentScope->sc_name);
MkCalls(CurrentScope->sc_def);
WalkNode(module->mod_body, (label) 0);
C_df_ilb(return_label);
C_ret((label) 0);
C_end(align(-CurrentScope->sc_off, word_size));
CurrentScope = scope;
@ -100,9 +108,14 @@ WalkProcedure(procedure)
/* generate calls to initialization routines of modules defined within
this procedure
*/
instructionlabel = 1;
return_label = 1;
instructionlabel = 2;
func_type = procedure->df_type->next;
MkCalls(CurrentScope->sc_def);
WalkNode(procedure->prc_body, (label) 0);
C_df_ilb(return_label);
if (func_type) C_ret((arith) align(func_type->tp_size, word_align));
else C_ret((arith) 0);
C_end(align(-CurrentScope->sc_off, word_size));
CurrentScope = scope;
prclev--;
@ -255,7 +268,13 @@ WalkStat(nd, lab)
break;
case RETURN:
/* ??? */
if (right) {
WalkExpr(right);
if (!TstCompat(right->nd_type, func_type)) {
node_error(right, "type incompatibility in RETURN statement");
}
}
C_bra(return_label);
break;
default:
@ -270,13 +289,55 @@ ExpectBool(nd)
generate code to evaluate the expression.
*/
chk_expr(nd);
WalkExpr(nd);
if (nd->nd_type != bool_type && nd->nd_type != error_type) {
node_error(nd, "boolean expression expected");
}
/* generate code
*/
/* ??? */
}
WalkExpr(nd)
struct node *nd;
{
/* Check an expression and generate code for it
*/
DO_DEBUG(1, (DumpTree(nd), print("\n")));
if (chk_expr(nd)) {
/* ??? */
}
}
#ifdef DEBUG
DumpTree(nd)
struct node *nd;
{
char *s;
extern char *symbol2str();
if (!nd) {
print("()");
return;
}
print("(");
DumpTree(nd->nd_left);
switch(nd->nd_class) {
case Def: s = "Def"; break;
case Oper: s = "Oper"; break;
case Uoper: s = "Uoper"; break;
case Name: s = "Name"; break;
case Set: s = "Set"; break;
case Value: s = "Value"; break;
case Call: s = "Call"; break;
case Xset: s = "Xset"; break;
case Stat: s = "Stat"; break;
case Link: s = "Link"; break;
default: s = "ERROR"; break;
}
print("%s %s", s, symbol2str(nd->nd_symb));
DumpTree(nd->nd_right);
print(")");
}
#endif