1404 lines
28 KiB
C
1404 lines
28 KiB
C
/* E X P R E S S I O N C H E C K I N G */
|
|
|
|
/* Check expressions, and try to evaluate them as far as possible.
|
|
*/
|
|
|
|
#include "parameters.h"
|
|
#include "debug.h"
|
|
|
|
#include <stdlib.h>
|
|
#include <alloc.h>
|
|
#include <assert.h>
|
|
#include <em_arith.h>
|
|
#include <em_label.h>
|
|
#include "print.h"
|
|
|
|
#include "LLlex.h"
|
|
#include "Lpars.h"
|
|
#include "chk_expr.h"
|
|
#include "const.h"
|
|
#include "def.h"
|
|
#include "idf.h"
|
|
#include "main.h"
|
|
#include "misc.h"
|
|
#include "node.h"
|
|
#include "required.h"
|
|
#include "scope.h"
|
|
#include "type.h"
|
|
#include "typequiv.h"
|
|
#include "readwrite.h"
|
|
#include "body.h"
|
|
#include "cstoper.h"
|
|
#include "error.h"
|
|
|
|
static int ChkValue(register struct node *);
|
|
static int ChkUnOper(register struct node *);
|
|
static int ChkStandard(register struct node *, register struct node *);
|
|
|
|
|
|
static void Xerror(register struct node *nd, char *mess)
|
|
{
|
|
if (nd->nd_class == Def && nd->nd_def)
|
|
{
|
|
if (nd->nd_def->df_kind != D_ERROR)
|
|
node_error(nd, "\"%s\": %s", nd->nd_def->df_idf->id_text, mess);
|
|
}
|
|
else
|
|
node_error(nd, "%s", mess);
|
|
}
|
|
|
|
struct node *ZeroParam(void)
|
|
{
|
|
register struct node *nd;
|
|
|
|
nd = MkLeaf(Value, &dot);
|
|
nd->nd_type = int_type;
|
|
nd->nd_symb = INTEGER;
|
|
nd->nd_INT = (arith) 0;
|
|
nd = MkNode(Link, nd, NULLNODE, &dot);
|
|
nd->nd_symb = ',';
|
|
|
|
return nd;
|
|
}
|
|
|
|
void MarkUsed(register struct node *nd)
|
|
{
|
|
while (nd && nd->nd_class != Def)
|
|
{
|
|
if ((nd->nd_class == Arrsel) || (nd->nd_class == LinkDef))
|
|
nd = nd->nd_left;
|
|
else if (nd->nd_class == Arrow)
|
|
nd = nd->nd_right;
|
|
else
|
|
break;
|
|
}
|
|
|
|
if (nd && nd->nd_class == Def)
|
|
{
|
|
register struct def *df = nd->nd_def;
|
|
|
|
if (df->df_kind != D_FIELD)
|
|
{
|
|
if (!(df->df_flags & (D_SET | D_VARPAR))
|
|
&& (df->df_scope == CurrentScope))
|
|
if (!is_anon_idf(df->df_idf))
|
|
{
|
|
warning("\"%s\" used before set", df->df_idf->id_text);
|
|
}
|
|
df->df_flags |= (D_USED | D_SET);
|
|
}
|
|
}
|
|
}
|
|
|
|
int ChkConstant(register struct node *expp)
|
|
{
|
|
register struct node *nd;
|
|
|
|
if (!(nd = expp->nd_right))
|
|
nd = expp;
|
|
|
|
if (nd->nd_class == Name && !ChkLinkOrName(nd))
|
|
return 0;
|
|
|
|
if (nd->nd_class != Value || expp->nd_left)
|
|
{
|
|
Xerror(nd, "constant expected");
|
|
return 0;
|
|
}
|
|
|
|
if (expp->nd_class == Uoper)
|
|
return ChkUnOper(expp);
|
|
else if (nd != expp)
|
|
{
|
|
Xerror(expp, "constant expected");
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
int ChkVariable(register struct node *expp)
|
|
{
|
|
/* Check that "expp" indicates an item that can be accessed */
|
|
|
|
if (!ChkLhs(expp))
|
|
return 0;
|
|
|
|
if (expp->nd_class == Def && expp->nd_def->df_kind == D_FUNCTION)
|
|
{
|
|
Xerror(expp, "illegal use of function name");
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
int ChkLhs(register struct node *expp)
|
|
{
|
|
int class;
|
|
|
|
|
|
if (!ChkVarAccess(expp)) return 0;
|
|
|
|
class = expp->nd_class;
|
|
|
|
/* a constant is replaced by it's value in ChkLinkOrName, check here !,
|
|
* the remaining classes are checked by ChkVarAccess
|
|
*/
|
|
if (class == Value)
|
|
{
|
|
node_error(expp, "can't access a value");
|
|
return 0;
|
|
}
|
|
|
|
if (class == Def
|
|
&& !(expp->nd_def->df_kind & (D_FIELD | D_FUNCTION | D_VARIABLE)))
|
|
{
|
|
Xerror(expp, "variable expected");
|
|
return 0;
|
|
}
|
|
|
|
/* assignment to function name */
|
|
if (class == Def && expp->nd_def->df_kind == D_FUNCTION)
|
|
if (expp->nd_def->prc_res)
|
|
expp->nd_type = ResultType(expp->nd_def->df_type);
|
|
else
|
|
{
|
|
Xerror(expp, "illegal assignment to function-name");
|
|
return 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
#ifdef DEBUG
|
|
static int ChkValue(register struct node *expp)
|
|
{
|
|
switch( expp->nd_symb )
|
|
{
|
|
case INTEGER:
|
|
case REAL:
|
|
case STRING:
|
|
case NIL:
|
|
return 1;
|
|
|
|
default:
|
|
crash("(ChkValue)");
|
|
}
|
|
/*NOTREACHED*/
|
|
}
|
|
#endif
|
|
|
|
int ChkLinkOrName(register struct node *expp)
|
|
{
|
|
register struct def *df;
|
|
|
|
expp->nd_type = error_type;
|
|
|
|
if (expp->nd_class == Name)
|
|
{
|
|
expp->nd_def = lookfor(expp, CurrVis, 1);
|
|
expp->nd_class = Def;
|
|
expp->nd_type = expp->nd_def->df_type;
|
|
}
|
|
else if (expp->nd_class == Link)
|
|
{
|
|
/* a selection from a record */
|
|
register struct node *left = expp->nd_left;
|
|
|
|
assert(expp->nd_symb == '.');
|
|
|
|
if (!ChkVariable(left))
|
|
return 0;
|
|
|
|
if (left->nd_type->tp_fund != T_RECORD)
|
|
{
|
|
Xerror(left, "illegal selection");
|
|
return 0;
|
|
}
|
|
|
|
if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_INUSE)))
|
|
{
|
|
id_not_declared(expp);
|
|
return 0;
|
|
}
|
|
else
|
|
{
|
|
expp->nd_def = df;
|
|
expp->nd_type = df->df_type;
|
|
expp->nd_class = LinkDef;
|
|
}
|
|
return 1;
|
|
}
|
|
assert(expp->nd_class == Def);
|
|
|
|
df = expp->nd_def;
|
|
|
|
if (df->df_kind & (D_ENUM | D_CONST))
|
|
{
|
|
MarkUsed(expp);
|
|
/* Replace an enum-literal or a CONST identifier by its value.
|
|
*/
|
|
if (df->df_kind == D_ENUM)
|
|
{
|
|
expp->nd_class = Value;
|
|
expp->nd_INT = df->enm_val;
|
|
expp->nd_symb = INTEGER;
|
|
}
|
|
else
|
|
{
|
|
unsigned int ln = expp->nd_lineno;
|
|
|
|
assert(df->df_kind == D_CONST);
|
|
*expp = *(df->con_const);
|
|
expp->nd_lineno = ln;
|
|
}
|
|
}
|
|
return df->df_kind != D_ERROR;
|
|
}
|
|
|
|
static int ChkExLinkOrName(register struct node *expp)
|
|
{
|
|
if (!ChkLinkOrName(expp))
|
|
return 0;
|
|
if (expp->nd_class != Def)
|
|
return 1;
|
|
|
|
if (!(expp->nd_def->df_kind & D_VALUE))
|
|
{
|
|
Xerror(expp, "value expected");
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
static int ChkUnOper(register struct node *expp)
|
|
{
|
|
/* Check an unary operation.
|
|
*/
|
|
register struct node *right = expp->nd_right;
|
|
register struct type *tpr;
|
|
|
|
if (!ChkExpression(right)) return 0;
|
|
|
|
MarkUsed(right);
|
|
|
|
expp->nd_type = tpr = BaseType(right->nd_type);
|
|
|
|
switch (expp->nd_symb)
|
|
{
|
|
case '+':
|
|
if (tpr->tp_fund & T_NUMERIC)
|
|
{
|
|
*expp = *right;
|
|
free_node(right);
|
|
return 1;
|
|
}
|
|
break;
|
|
|
|
case '-':
|
|
if (tpr->tp_fund == T_INTEGER || tpr->tp_fund == T_LONG)
|
|
{
|
|
if (right->nd_class == Value)
|
|
cstunary(expp);
|
|
return 1;
|
|
}
|
|
if (tpr->tp_fund == T_REAL)
|
|
{
|
|
if (right->nd_class == Value)
|
|
{
|
|
expp->nd_token.tk_data.tk_real = right->nd_RIV;
|
|
expp->nd_class = Value;
|
|
expp->nd_symb = REAL;
|
|
FreeNode(right);
|
|
expp->nd_right = NULLNODE;
|
|
}
|
|
return 1;
|
|
}
|
|
break;
|
|
|
|
case NOT:
|
|
if (tpr == bool_type)
|
|
{
|
|
if (right->nd_class == Value)
|
|
cstunary(expp);
|
|
return 1;
|
|
}
|
|
break;
|
|
|
|
case '(':
|
|
/* Delete the brackets */
|
|
*expp = *right;
|
|
free_node(right);
|
|
return 1;
|
|
|
|
default:
|
|
crash("(ChkUnOper)");
|
|
}
|
|
node_error(expp, "\"%s\": illegal operand", symbol2str(expp->nd_symb));
|
|
return 0;
|
|
}
|
|
|
|
static struct type *
|
|
ResultOfOperation(int operator, struct type *tpl, struct type *tpr)
|
|
{
|
|
/* Return the result type of the binary operation "operator",
|
|
with operand types "tpl" and "tpr".
|
|
*/
|
|
|
|
switch (operator)
|
|
{
|
|
case '=':
|
|
case NOTEQUAL:
|
|
case '<':
|
|
case '>':
|
|
case LESSEQUAL:
|
|
case GREATEREQUAL:
|
|
case IN:
|
|
return bool_type;
|
|
case '+':
|
|
case '-':
|
|
case '*':
|
|
if (tpl == real_type || tpr == real_type)
|
|
return real_type;
|
|
if (tpl == long_type || tpr == long_type)
|
|
return long_type;
|
|
return tpl;
|
|
case '/':
|
|
return real_type;
|
|
}
|
|
if (tpr == long_type && tpl == int_type)
|
|
return tpr;
|
|
return tpl;
|
|
}
|
|
|
|
static int AllowedTypes(int operator)
|
|
{
|
|
/* Return a bit mask indicating the allowed operand types for
|
|
binary operator "operator".
|
|
*/
|
|
|
|
switch (operator)
|
|
{
|
|
case '+':
|
|
case '-':
|
|
case '*':
|
|
return T_NUMERIC | T_SET;
|
|
case '/':
|
|
return T_NUMERIC;
|
|
case DIV:
|
|
case MOD:
|
|
return T_INTEGER | T_LONG;
|
|
case OR:
|
|
case AND:
|
|
return T_ENUMERATION;
|
|
case '=':
|
|
case NOTEQUAL:
|
|
return T_ENUMERATION | T_CHAR | T_NUMERIC | T_SET | T_POINTER
|
|
| T_STRINGCONST | T_STRING;
|
|
case LESSEQUAL:
|
|
case GREATEREQUAL:
|
|
return T_ENUMERATION | T_CHAR | T_NUMERIC | T_SET | T_STRINGCONST;
|
|
case '<':
|
|
case '>':
|
|
return T_ENUMERATION | T_CHAR | T_NUMERIC | T_STRINGCONST;
|
|
default:
|
|
crash("(AllowedTypes)");
|
|
}
|
|
/*NOTREACHED*/
|
|
}
|
|
|
|
static int Boolean(int operator)
|
|
{
|
|
return operator == OR || operator == AND;
|
|
}
|
|
|
|
static int ChkBinOper(register struct node *expp)
|
|
{
|
|
/* Check a binary operation.
|
|
*/
|
|
register struct node *left, *right;
|
|
struct type *tpl, *tpr;
|
|
int retval, allowed;
|
|
|
|
left = expp->nd_left;
|
|
right = expp->nd_right;
|
|
|
|
retval = ChkExpression(left);
|
|
retval &= ChkExpression(right);
|
|
|
|
MarkUsed(left);
|
|
MarkUsed(right);
|
|
|
|
tpl = BaseType(left->nd_type);
|
|
tpr = BaseType(right->nd_type);
|
|
|
|
expp->nd_type = ResultOfOperation(expp->nd_symb, tpl, tpr);
|
|
|
|
/* Check that the application of the operator is allowed on the type
|
|
of the operands.
|
|
There are some needles and pins:
|
|
- Boolean operators are only allowed on boolean operands, but the
|
|
"allowed-mask" of "AllowedTypes" can only indicate an enumeration
|
|
type.
|
|
- The IN-operator has as right-hand-side operand a set.
|
|
- Strings and packed arrays can be equivalent.
|
|
- In some cases, integers must be converted to reals.
|
|
- If one of the operands is the empty set then the result doesn't
|
|
have to be the empty set.
|
|
*/
|
|
|
|
if (expp->nd_symb == IN)
|
|
{
|
|
if (tpr->tp_fund != T_SET)
|
|
{
|
|
node_error(expp, "\"IN\": right operand must be a set");
|
|
return 0;
|
|
}
|
|
if (!TstAssCompat(tpl, ElementType(tpr) ))
|
|
{
|
|
node_error(expp, "\"IN\": incompatible types");
|
|
return 0;
|
|
}
|
|
if (left->nd_class == Value && right->nd_class == Set)
|
|
cstset(expp);
|
|
return retval;
|
|
}
|
|
|
|
if (!retval)
|
|
return 0;
|
|
|
|
allowed = AllowedTypes(expp->nd_symb);
|
|
|
|
if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed))
|
|
{
|
|
arith ub;
|
|
extern arith IsString();
|
|
|
|
if (allowed & T_STRINGCONST && (ub = IsString(tpl)))
|
|
{
|
|
if (ub == IsString(tpr))
|
|
return 1;
|
|
else
|
|
{
|
|
node_error(expp, "\"%s\": incompatible types",
|
|
symbol2str(expp->nd_symb));
|
|
return 0;
|
|
}
|
|
}
|
|
else if (allowed & T_STRING && tpl->tp_fund == T_STRING)
|
|
return 1;
|
|
|
|
node_error(expp, "\"%s\": illegal operand type(s)",
|
|
symbol2str(expp->nd_symb));
|
|
return 0;
|
|
}
|
|
|
|
if (Boolean(expp->nd_symb) && tpl != bool_type)
|
|
{
|
|
node_error(expp, "\"%s\": illegal operand type(s)",
|
|
symbol2str(expp->nd_symb));
|
|
return 0;
|
|
}
|
|
|
|
if (allowed & T_NUMERIC)
|
|
{
|
|
if ((tpl == int_type || tpl == long_type)
|
|
&& (tpr == real_type || expp->nd_symb == '/'))
|
|
{
|
|
expp->nd_left = MkNode(Cast, NULLNODE, expp->nd_left, &dot);
|
|
expp->nd_left->nd_type = tpl = real_type;
|
|
}
|
|
if (tpl == real_type && (tpr == int_type || tpr == long_type))
|
|
{
|
|
expp->nd_right = MkNode(Cast, NULLNODE, expp->nd_right, &dot);
|
|
expp->nd_right->nd_type = tpr = real_type;
|
|
}
|
|
if (tpl == int_type && tpr == long_type)
|
|
{
|
|
expp->nd_left = MkNode(IntCoerc, NULLNODE, expp->nd_left, &dot);
|
|
expp->nd_left->nd_type = long_type;
|
|
}
|
|
else if (tpl == long_type && tpr == int_type)
|
|
{
|
|
expp->nd_right = MkNode(IntCoerc, NULLNODE, expp->nd_right, &dot);
|
|
expp->nd_right->nd_type = long_type;
|
|
}
|
|
}
|
|
|
|
/* Operands must be compatible */
|
|
if (!TstCompat(tpl, tpr))
|
|
{
|
|
node_error(expp, "\"%s\": incompatible types",
|
|
symbol2str(expp->nd_symb));
|
|
return 0;
|
|
}
|
|
|
|
if (tpl->tp_fund & T_SET)
|
|
{
|
|
if (tpl == emptyset_type)
|
|
left->nd_type = tpr;
|
|
else if (tpr == emptyset_type)
|
|
right->nd_type = tpl;
|
|
|
|
if (expp->nd_type == emptyset_type)
|
|
expp->nd_type = tpr;
|
|
if (left->nd_class == Set && right->nd_class == Set)
|
|
cstset(expp);
|
|
}
|
|
else if (tpl->tp_fund != T_REAL && left->nd_class == Value
|
|
&& right->nd_class == Value)
|
|
cstbin(expp);
|
|
|
|
return 1;
|
|
}
|
|
|
|
static int ChkElement(register struct node *expp, register struct type **tp,
|
|
arith **set, unsigned *cnt)
|
|
{
|
|
/* Check elements of a set. This routine may call itself
|
|
recursively. Also try to compute the set!
|
|
*/
|
|
register struct node *left = expp->nd_left;
|
|
register struct node *right = expp->nd_right;
|
|
register int i;
|
|
extern char *Malloc();
|
|
|
|
if (expp->nd_class == Link && expp->nd_symb == UPTO)
|
|
{
|
|
/* [ ... , expr1 .. expr2, ... ]
|
|
First check expr1 and expr2, and try to compute them.
|
|
*/
|
|
if (!ChkElement(left, tp, set, cnt) || !ChkElement(right, tp, set, cnt))
|
|
return 0;
|
|
|
|
if (left->nd_class == Value && right->nd_class == Value && *set)
|
|
{
|
|
|
|
if (left->nd_INT > right->nd_INT)
|
|
{
|
|
/* Remove lower and upper bound of the range.
|
|
*/
|
|
*cnt -= 2;
|
|
(*set)[left->nd_INT / wrd_bits] &= ~(1
|
|
<< (left->nd_INT % wrd_bits));
|
|
(*set)[right->nd_INT / wrd_bits] &= ~(1
|
|
<< (right->nd_INT % wrd_bits));
|
|
}
|
|
else
|
|
/* We have a constant range. Put all elements
|
|
in the set.
|
|
*/
|
|
for (i = left->nd_INT + 1; i < right->nd_INT; i++)
|
|
(*set)[i / wrd_bits] |= (1 << (i % wrd_bits));
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
/* Here, a single element is checked
|
|
*/
|
|
if (!ChkExpression(expp)) return 0;
|
|
MarkUsed(expp);
|
|
|
|
if (*tp == emptyset_type)
|
|
{
|
|
/* first element in set determines the type of the set */
|
|
unsigned size;
|
|
|
|
*tp = set_type(expp->nd_type, 0);
|
|
size = (*tp)->tp_size * (sizeof(arith) / word_size);
|
|
*set = (arith *) Malloc(size);
|
|
clear((char *) *set, size);
|
|
}
|
|
else if (!TstCompat(ElementType(*tp), expp->nd_type))
|
|
{
|
|
node_error(expp, "set element has incompatible type");
|
|
return 0;
|
|
}
|
|
|
|
if (expp->nd_class == Value)
|
|
{
|
|
/* a constant element
|
|
*/
|
|
i = expp->nd_INT;
|
|
|
|
if (expp->nd_type == int_type)
|
|
{
|
|
/* Check only integer base-types because they are not
|
|
equal to the integer host-type. The other base-types
|
|
are equal to their host-types.
|
|
*/
|
|
|
|
if (i < 0 || i > max_intset)
|
|
{
|
|
node_error(expp, "set element out of range");
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
if (*set)
|
|
(*set)[i / wrd_bits] |= (1 << (i % wrd_bits));
|
|
(*cnt)++;
|
|
}
|
|
else if (*set)
|
|
{
|
|
free((char *) *set);
|
|
*set = (arith *) 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
static int ChkSet(register struct node *expp)
|
|
{
|
|
/* Check the legality of a SET aggregate, and try to evaluate it
|
|
compile time. Unfortunately this is all rather complicated.
|
|
*/
|
|
register struct node *nd = expp->nd_right;
|
|
arith *set = (arith *) 0;
|
|
unsigned cnt = 0;
|
|
|
|
assert(expp->nd_symb == SET);
|
|
|
|
expp->nd_type = emptyset_type;
|
|
|
|
/* Now check the elements given, and try to compute a constant set.
|
|
First allocate room for the set, but only if it isn't empty.
|
|
*/
|
|
if (!nd)
|
|
{
|
|
/* The resulting set IS empty, so we just return
|
|
*/
|
|
expp->nd_class = Set;
|
|
expp->nd_set = (arith *) 0;
|
|
return 1;
|
|
}
|
|
|
|
/* Now check the elements, one by one
|
|
*/
|
|
while (nd)
|
|
{
|
|
assert(nd->nd_class == Link && nd->nd_symb == ',');
|
|
|
|
if (!ChkElement(nd->nd_left, &(expp->nd_type), &set, &cnt))
|
|
return 0;
|
|
nd = nd->nd_right;
|
|
}
|
|
|
|
if (set)
|
|
{
|
|
/* Yes, it was a constant set, and we managed to compute it!
|
|
Notice that at the moment there is no such thing as
|
|
partial evaluation. Either we evaluate the set, or we
|
|
don't (at all). Improvement not neccesary (???)
|
|
??? sets have a contant part and a variable part ???
|
|
*/
|
|
expp->nd_class = Set;
|
|
if (!cnt)
|
|
{
|
|
/* after all the work we've done, the set turned out
|
|
out to be empty!
|
|
*/
|
|
free((char *) set);
|
|
set = (arith *) 0;
|
|
}
|
|
expp->nd_set = set;
|
|
FreeNode(expp->nd_right);
|
|
expp->nd_right = NULLNODE;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
char *ChkAllowedVar(register struct node *nd, int reading)
|
|
/* reading indicates read or readln */
|
|
|
|
{
|
|
char *message = 0;
|
|
|
|
switch (nd->nd_class)
|
|
{
|
|
case Def:
|
|
if (nd->nd_def->df_flags & D_INLOOP)
|
|
{
|
|
message = "control variable";
|
|
break;
|
|
}
|
|
if (nd->nd_def->df_kind != D_FIELD)
|
|
break;
|
|
/* FALL THROUGH */
|
|
|
|
case LinkDef:
|
|
assert(nd->nd_def->df_kind == D_FIELD);
|
|
|
|
if (nd->nd_def->fld_flags & F_PACKED)
|
|
message = "field of packed record";
|
|
else if (nd->nd_def->fld_flags & F_SELECTOR)
|
|
message = "variant selector";
|
|
break;
|
|
|
|
case Arrsel:
|
|
if (IsPacked(nd->nd_left->nd_type))
|
|
if (!reading)
|
|
message = "component of packed array";
|
|
break;
|
|
|
|
case Arrow:
|
|
if (nd->nd_right->nd_type->tp_fund == T_FILE)
|
|
message = "filebuffer variable";
|
|
break;
|
|
|
|
default:
|
|
crash("(ChkAllowedVar)");
|
|
/*NOTREACHED*/
|
|
}
|
|
MarkDef(nd, D_SET, 1);
|
|
return message;
|
|
}
|
|
|
|
static int ChkVarPar(register struct node *nd, register struct node *name)
|
|
{
|
|
/* ISO 6.6.3.3 :
|
|
An actual variable parameter shall not denote a field
|
|
that is the selector of a variant-part or a component
|
|
of a variable where that variable possesses a type
|
|
that is designated packed.
|
|
*/
|
|
static char err_mes[80];
|
|
char *message = (char *) 0;
|
|
|
|
if (!ChkVariable(nd))
|
|
return 0;
|
|
|
|
message = ChkAllowedVar(nd, 0);
|
|
|
|
if (message)
|
|
{
|
|
sprint(err_mes, "%s can't be a variable parameter", message);
|
|
Xerror(name, err_mes);
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
static struct node *
|
|
getarg(struct node **argp, int bases, int varaccess, struct node *name,
|
|
struct type *paramtp)
|
|
{
|
|
/* This routine is used to fetch the next argument from an
|
|
argument list. The argument list is indicated by "argp".
|
|
The parameter "bases" is a bitset indicating which types are
|
|
allowed at this point, and "varaccess" is a flag indicating
|
|
that the address from this argument is taken, so that it
|
|
must be a varaccess and may not be a register variable.
|
|
*/
|
|
register struct node *arg = (*argp)->nd_right;
|
|
register struct node *left;
|
|
|
|
if (!arg)
|
|
{
|
|
Xerror(name, "too few arguments supplied");
|
|
return 0;
|
|
}
|
|
|
|
left = arg->nd_left;
|
|
*argp = arg;
|
|
|
|
if (paramtp && paramtp->tp_fund & T_ROUTINE)
|
|
{
|
|
/* From the context it appears that the occurrence of the
|
|
procedure/function-identifier is not a call.
|
|
*/
|
|
if (left->nd_class != NameOrCall)
|
|
{
|
|
Xerror(name, "illegal proc/func parameter");
|
|
return 0;
|
|
}
|
|
else if (ChkLinkOrName(left->nd_left))
|
|
{
|
|
left->nd_type = left->nd_left->nd_type;
|
|
MarkUsed(left->nd_left);
|
|
}
|
|
else
|
|
return 0;
|
|
}
|
|
else if (varaccess)
|
|
{
|
|
if (!ChkVarPar(left, name))
|
|
{
|
|
MarkUsed(left);
|
|
return 0;
|
|
}
|
|
}
|
|
else if (!ChkExpression(left))
|
|
{
|
|
MarkUsed(left);
|
|
return 0;
|
|
}
|
|
|
|
MarkUsed(left);
|
|
|
|
if (!varaccess && bases == T_INTEGER
|
|
&& BaseType(left->nd_type)->tp_fund == T_LONG)
|
|
{
|
|
arg->nd_left = MkNode(IntReduc, NULLNODE, left, &dot);
|
|
arg->nd_left->nd_type = int_type;
|
|
left = arg->nd_left;
|
|
}
|
|
|
|
if (bases && !(BaseType(left->nd_type)->tp_fund & bases))
|
|
{
|
|
Xerror(name, "unexpected parameter type");
|
|
return 0;
|
|
}
|
|
|
|
return left;
|
|
}
|
|
|
|
static int ChkProcCall(struct node *expp)
|
|
{
|
|
/* Check a procedure call
|
|
*/
|
|
register struct node *left;
|
|
struct node *name;
|
|
register struct paramlist *param;
|
|
char ebuf[80];
|
|
int retval = 1;
|
|
int cnt = 0;
|
|
int new_par_section;
|
|
struct type *lasttp = NULLTYPE;
|
|
|
|
name = left = expp->nd_left;
|
|
|
|
if (left->nd_type == error_type)
|
|
{
|
|
/* Just check parameters as if they were value parameters
|
|
*/
|
|
expp->nd_type = error_type;
|
|
while (expp->nd_right)
|
|
(void) getarg(&expp, 0, 0, name, NULLTYPE );
|
|
return 0;
|
|
}
|
|
|
|
expp->nd_type = ResultType(left->nd_type);
|
|
|
|
/* Check parameter list
|
|
*/
|
|
for (param = ParamList(left->nd_type) ; param; param = param->next)
|
|
{
|
|
if (!(left = getarg(&expp, 0, (int) IsVarParam(param), name,
|
|
TypeOfParam(param))))
|
|
return 0;
|
|
|
|
cnt++;
|
|
new_par_section = lasttp != TypeOfParam(param);
|
|
if (!TstParCompat(TypeOfParam(param), left->nd_type,
|
|
(int) IsVarParam(param), left, new_par_section))
|
|
{
|
|
sprint(ebuf, "type incompatibility in parameter %d", cnt);
|
|
Xerror(name, ebuf);
|
|
retval = 0;
|
|
}
|
|
|
|
/* Convert between integers and longs.
|
|
*/
|
|
if (!IsVarParam(param) && options['d'])
|
|
{
|
|
if (left->nd_type->tp_fund == T_INTEGER
|
|
&& TypeOfParam(param)->tp_fund == T_LONG)
|
|
{
|
|
expp->nd_left = MkNode(IntCoerc, NULLNODE, left, &dot);
|
|
expp->nd_left->nd_type = long_type;
|
|
left = expp->nd_left;
|
|
}
|
|
else if (left->nd_type->tp_fund == T_LONG
|
|
&& TypeOfParam(param)->tp_fund == T_INTEGER)
|
|
{
|
|
expp->nd_left = MkNode(IntReduc, NULLNODE, left, &dot);
|
|
expp->nd_left->nd_type = int_type;
|
|
left = expp->nd_left;
|
|
}
|
|
}
|
|
|
|
if (left->nd_type == emptyset_type)
|
|
/* type of emptyset determined by the context */
|
|
left->nd_type = TypeOfParam(param);
|
|
|
|
lasttp = TypeOfParam(param);
|
|
}
|
|
|
|
if (expp->nd_right)
|
|
{
|
|
Xerror(name, "too many arguments supplied");
|
|
while (expp->nd_right)
|
|
(void) getarg(&expp, 0, 0, name, NULLTYPE );
|
|
return 0;
|
|
}
|
|
|
|
return retval;
|
|
}
|
|
|
|
int ChkCall(register struct node *expp)
|
|
{
|
|
/* Check something that looks like a procedure or function call.
|
|
Of course this does not have to be a call at all,
|
|
it may also be a standard procedure call.
|
|
*/
|
|
|
|
/* First, get the name of the function or procedure
|
|
*/
|
|
register struct node *left = expp->nd_left;
|
|
|
|
expp->nd_type = error_type;
|
|
|
|
if (ChkLinkOrName(left))
|
|
{
|
|
|
|
MarkUsed(left);
|
|
if (IsProcCall(left) || left->nd_type == error_type)
|
|
{
|
|
/* A call.
|
|
It may also be a call to a standard procedure
|
|
*/
|
|
|
|
if (left->nd_type == std_type)
|
|
/* A standard procedure
|
|
*/
|
|
return ChkStandard(expp, left);
|
|
|
|
/* Here, we have found a real procedure call.
|
|
*/
|
|
}
|
|
else
|
|
{
|
|
node_error(left, "procedure or function expected");
|
|
return 0;
|
|
}
|
|
}
|
|
return ChkProcCall(expp);
|
|
}
|
|
|
|
static int ChkExCall(register struct node *expp)
|
|
{
|
|
if (!ChkCall(expp))
|
|
return 0;
|
|
|
|
if (!expp->nd_type)
|
|
{
|
|
node_error(expp, "function call expected");
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
static int ChkNameOrCall(register struct node *expp)
|
|
{
|
|
/* From the context it appears that the occurrence of the function-
|
|
identifier is a call to that function
|
|
*/
|
|
assert(expp->nd_class == NameOrCall);
|
|
expp->nd_class = Call;
|
|
|
|
return ChkExCall(expp);
|
|
}
|
|
|
|
static int ChkStandard(register struct node *expp, register struct node *left)
|
|
{
|
|
/* Check a call of a standard procedure or function
|
|
*/
|
|
|
|
struct node *arg = expp;
|
|
struct node *name = left;
|
|
int req;
|
|
|
|
assert(left->nd_class == Def);
|
|
|
|
req = left->nd_def->df_value.df_reqname;
|
|
|
|
switch (req)
|
|
{
|
|
case R_ABS:
|
|
case R_SQR:
|
|
if (!(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE )))
|
|
return 0;
|
|
expp->nd_type = left->nd_type;
|
|
if (left->nd_class == Value && expp->nd_type->tp_fund != T_REAL)
|
|
cstcall(expp, req);
|
|
break;
|
|
|
|
case R_SIN:
|
|
case R_COS:
|
|
case R_EXP:
|
|
case R_LN:
|
|
case R_SQRT:
|
|
case R_ARCTAN:
|
|
if (!(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE )))
|
|
return 0;
|
|
expp->nd_type = real_type;
|
|
if (BaseType(left->nd_type)->tp_fund == T_INTEGER
|
|
|| BaseType(left->nd_type)->tp_fund == T_LONG)
|
|
{
|
|
arg->nd_left = MkNode(Cast, NULLNODE, arg->nd_left, &dot);
|
|
arg->nd_left->nd_type = real_type;
|
|
}
|
|
break;
|
|
|
|
case R_TRUNC:
|
|
case R_ROUND:
|
|
if (!(left = getarg(&arg, T_REAL, 0, name, NULLTYPE )))
|
|
return 0;
|
|
expp->nd_type = int_type;
|
|
break;
|
|
|
|
case R_ORD:
|
|
if (!(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE )))
|
|
return 0;
|
|
if (BaseType(left->nd_type)->tp_fund == T_LONG)
|
|
{
|
|
arg->nd_left = MkNode(IntReduc, NULLNODE, arg->nd_left, &dot);
|
|
arg->nd_left->nd_type = int_type;
|
|
}
|
|
expp->nd_type = int_type;
|
|
if (left->nd_class == Value)
|
|
cstcall(expp, R_ORD);
|
|
break;
|
|
|
|
case R_CHR:
|
|
if (!(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE )))
|
|
return 0;
|
|
expp->nd_type = char_type;
|
|
if (left->nd_class == Value)
|
|
cstcall(expp, R_CHR);
|
|
break;
|
|
|
|
case R_SUCC:
|
|
case R_PRED:
|
|
if (!(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE )))
|
|
return 0;
|
|
expp->nd_type = left->nd_type;
|
|
if (left->nd_class == Value && options['R'])
|
|
cstcall(expp, req);
|
|
break;
|
|
|
|
case R_ODD:
|
|
if (!(left = getarg(&arg, T_INTEGER | T_LONG, 0, name, NULLTYPE )))
|
|
return 0;
|
|
expp->nd_type = bool_type;
|
|
if (left->nd_class == Value)
|
|
cstcall(expp, R_ODD);
|
|
break;
|
|
|
|
case R_EOF:
|
|
case R_EOLN:
|
|
case R_GET:
|
|
case R_PAGE:
|
|
{
|
|
int st_out;
|
|
|
|
if (req == R_PAGE)
|
|
{
|
|
expp->nd_type = NULLTYPE;
|
|
st_out = 1;
|
|
}
|
|
else
|
|
{
|
|
st_out = 0;
|
|
if (req == R_GET)
|
|
{
|
|
expp->nd_type = NULLTYPE;
|
|
}
|
|
else
|
|
expp->nd_type = bool_type;
|
|
}
|
|
if (!arg->nd_right)
|
|
{
|
|
struct node *nd;
|
|
|
|
if (!(nd = ChkStdInOut(name->nd_IDF->id_text, st_out)))
|
|
return 0;
|
|
|
|
expp->nd_right = MkNode(Link, nd, NULLNODE, &dot);
|
|
expp->nd_right->nd_symb = ',';
|
|
arg = arg->nd_right;
|
|
}
|
|
else
|
|
{
|
|
if (!(left = getarg(&arg, T_FILE, 1, name, NULLTYPE )))
|
|
return 0;
|
|
if ((req == R_PAGE || req == R_EOLN) && left->nd_type != text_type)
|
|
{
|
|
Xerror(name, "textfile expected");
|
|
return 0;
|
|
}
|
|
}
|
|
break;
|
|
|
|
}
|
|
case R_REWRITE:
|
|
case R_PUT:
|
|
case R_RESET:
|
|
if (!(left = getarg(&arg, T_FILE, 1, name, NULLTYPE )))
|
|
return 0;
|
|
expp->nd_type = NULLTYPE;
|
|
break;
|
|
|
|
case R_PACK:
|
|
case R_UNPACK:
|
|
{
|
|
struct type *tp1, *tp2, *tp3;
|
|
|
|
if (req == R_PACK)
|
|
{
|
|
/* pack(a, i, z) */
|
|
if (!(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE )))
|
|
return 0;
|
|
tp1 = left->nd_type; /* (a) */
|
|
if (!(left = getarg(&arg, 0, 0, name, NULLTYPE )))
|
|
return 0;
|
|
tp2 = left->nd_type; /* (i) */
|
|
if (!(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE )))
|
|
return 0;
|
|
tp3 = left->nd_type; /* (z) */
|
|
}
|
|
else
|
|
{
|
|
/* unpack(z, a, i) */
|
|
if (!(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE )))
|
|
return 0;
|
|
tp3 = left->nd_type; /* (z) */
|
|
if (!(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE )))
|
|
return 0;
|
|
tp1 = left->nd_type; /* (a) */
|
|
if (!(left = getarg(&arg, 0, 0, name, NULLTYPE )))
|
|
return 0;
|
|
tp2 = left->nd_type; /* (i) */
|
|
}
|
|
if (IsConformantArray(tp1) || IsPacked(tp1))
|
|
{
|
|
Xerror(name, "unpacked array expected");
|
|
return 0;
|
|
}
|
|
if (!TstAssCompat(IndexType(tp1), tp2))
|
|
{
|
|
Xerror(name, "ordinal constant expected");
|
|
return 0;
|
|
}
|
|
if (IsConformantArray(tp3) || !IsPacked(tp3))
|
|
{
|
|
Xerror(name, "packed array expected");
|
|
return 0;
|
|
}
|
|
if (!TstTypeEquiv(tp1->arr_elem, tp3->arr_elem))
|
|
{
|
|
Xerror(name, "component types of arrays not equal");
|
|
return 0;
|
|
}
|
|
expp->nd_type = NULLTYPE;
|
|
break;
|
|
}
|
|
|
|
case R_NEW:
|
|
case R_DISPOSE:
|
|
if (!(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE )))
|
|
return 0;
|
|
if (arg->nd_right)
|
|
{
|
|
/* varargs new/dispose(p,c1,.....) */
|
|
register struct selector *sel;
|
|
register arith i;
|
|
|
|
if (PointedtoType(left->nd_type) ->tp_fund != T_RECORD)
|
|
break;
|
|
sel = PointedtoType(left->nd_type) ->rec_sel;
|
|
do
|
|
{
|
|
if (!sel)
|
|
break;
|
|
|
|
arg = arg->nd_right;
|
|
left = arg->nd_left;
|
|
|
|
/* ISO : COMPILETIME CONSTANTS NOT PERMITTED */
|
|
if (!ChkConstant(left))
|
|
return 0;
|
|
|
|
if (!TstCompat(left->nd_type, sel->sel_type))
|
|
{
|
|
node_error(left, "type incompatibility in caselabel");
|
|
return 0;
|
|
}
|
|
|
|
i = left->nd_INT - sel->sel_lb;
|
|
if (i < 0 || i >= sel->sel_ncst)
|
|
{
|
|
node_error(left, "case constant: out of bounds");
|
|
return 0;
|
|
}
|
|
|
|
sel = sel->sel_ptrs[i];
|
|
} while (arg->nd_right);
|
|
|
|
FreeNode(expp->nd_right->nd_right);
|
|
expp->nd_right->nd_right = NULLNODE;
|
|
}
|
|
expp->nd_type = NULLTYPE;
|
|
break;
|
|
|
|
case R_HALT:
|
|
if (!arg->nd_right) /* insert 0 parameter */
|
|
arg->nd_right = ZeroParam();
|
|
if (!(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE )))
|
|
return 0;
|
|
expp->nd_type = NULLTYPE;
|
|
break;
|
|
|
|
default:
|
|
crash("(ChkStandard)");
|
|
}
|
|
|
|
if (arg->nd_right)
|
|
{
|
|
Xerror(name, "too many arguments supplied");
|
|
return 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
static int ChkArrow(register struct node *expp)
|
|
{
|
|
/* Check an application of the '^' operator.
|
|
The operand must be a variable of a pointer-type or a
|
|
variable of a file-type.
|
|
*/
|
|
|
|
register struct type *tp;
|
|
|
|
assert(expp->nd_class == Arrow);
|
|
assert(expp->nd_symb == '^');
|
|
|
|
expp->nd_type = error_type;
|
|
|
|
if (!ChkVariable(expp->nd_right))
|
|
return 0;
|
|
|
|
MarkUsed(expp->nd_right);
|
|
|
|
tp = expp->nd_right->nd_type;
|
|
|
|
if (!(tp->tp_fund & (T_POINTER | T_FILE)))
|
|
{
|
|
node_error(expp, "\"^\": illegal operand");
|
|
return 0;
|
|
}
|
|
|
|
expp->nd_type = PointedtoType(tp);
|
|
return 1;
|
|
}
|
|
|
|
static int ChkArr(register struct node *expp)
|
|
{
|
|
/* Check an array selection.
|
|
The left hand side must be a variable of an array type,
|
|
and the right hand side must be an expression that is
|
|
assignment compatible with the array-index.
|
|
*/
|
|
|
|
register struct type *tpl, *tpr;
|
|
int retval;
|
|
|
|
assert(expp->nd_class == Arrsel);
|
|
assert(expp->nd_symb == '[');
|
|
|
|
expp->nd_type = error_type;
|
|
|
|
/* Check the index first, so a[a[j]] is checked in order of
|
|
* evaluation. This to make sure that warnings are generated
|
|
* in the right order.
|
|
*/
|
|
retval = ChkExpression(expp->nd_right);
|
|
MarkUsed(expp->nd_right);
|
|
retval &= ChkVariable(expp->nd_left);
|
|
|
|
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;
|
|
}
|
|
|
|
/* Type of the index must be assignment compatible with
|
|
the index type of the array.
|
|
*/
|
|
if (!TstCompat(IndexType(tpl), tpr))
|
|
{
|
|
node_error(expp, "incompatible index type");
|
|
return 0;
|
|
}
|
|
|
|
if (tpr == long_type)
|
|
{
|
|
expp->nd_right = MkNode(IntReduc, NULLNODE, expp->nd_right, &dot);
|
|
expp->nd_right->nd_type = int_type;
|
|
}
|
|
|
|
expp->nd_type = tpl->arr_elem;
|
|
return retval;
|
|
}
|
|
|
|
static int done_before(struct node *expp)
|
|
{
|
|
return 1;
|
|
}
|
|
|
|
static int no_var_access(struct node *expp)
|
|
{
|
|
node_error(expp, "variable-access expected");
|
|
return 0;
|
|
}
|
|
|
|
int (*ExprChkTable[])(struct node*) =
|
|
{
|
|
#ifdef DEBUG
|
|
ChkValue,
|
|
#else
|
|
done_before,
|
|
#endif
|
|
ChkExLinkOrName,
|
|
ChkUnOper,
|
|
ChkBinOper,
|
|
ChkSet,
|
|
NodeCrash,
|
|
ChkExCall,
|
|
ChkNameOrCall,
|
|
ChkArrow,
|
|
ChkArr,
|
|
NodeCrash,
|
|
ChkExLinkOrName,
|
|
NodeCrash,
|
|
NodeCrash,
|
|
NodeCrash,
|
|
NodeCrash
|
|
};
|
|
|
|
int (*VarAccChkTable[])(struct node*) =
|
|
{
|
|
no_var_access,
|
|
ChkLinkOrName,
|
|
no_var_access,
|
|
no_var_access,
|
|
no_var_access,
|
|
NodeCrash,
|
|
no_var_access,
|
|
no_var_access,
|
|
ChkArrow,
|
|
ChkArr,
|
|
done_before,
|
|
ChkLinkOrName,
|
|
done_before,
|
|
no_var_access,
|
|
no_var_access,
|
|
no_var_access
|
|
};
|