godzil/tack
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

newer version

Browse Source
This commit is contained in:
ceriel
1986-04-23 22:12:22 +00:00
parent e8977ebb57
commit c11efeb1fe
11 changed files with 437 additions and 299 deletions
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;
}