#include "debug.h"
+extern char *symbol2str();
+
int
chk_expr(expp)
register struct node *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);
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);
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;
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");
*/
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 &&
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);
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.
return 1;
}
-findname(expp)
+int
+chk_designator(expp, flag)
register struct node *expp;
{
/* Find the name indicated by "expp", starting from the current
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;
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;
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;
+
+ tpr = expp->nd_right->nd_type;
+ tpl = expp->nd_left->nd_type;
- 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;
+ 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
{
/* 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;
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;
}
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 */
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 */
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;
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;
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;
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;
}
break;
- case '^':
- if (tpr->tp_fund != T_POINTER) break;
- expp->nd_type = tpr->next;
- return 1;
-
default:
assert(0);
}
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;
+}
public / ack.git / commitdiff