123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179 |
- /* 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 "debug.h"
- #include <alloc.h>
- #include <assert.h>
- #include <em_arith.h>
- #include <em_label.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"
- extern char *symbol2str();
- STATIC
- Xerror(nd, mess)
- 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);
- }
- STATIC int
- ChkConstant(expp)
- 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(expp)
- 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(expp)
- register struct node *expp;
- {
- int class;
- /* Check that "expp" indicates an item that can be the lhs
- of an assignment.
- */
- 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(expp)
- register struct node *expp;
- {
- switch( expp->nd_symb ) {
- case INTEGER:
- case REAL:
- case STRING:
- case NIL:
- return 1;
- default:
- crash("(ChkValue)");
- }
- /*NOTREACHED*/
- }
- #endif
- STATIC int
- ChkLinkOrName(expp)
- 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)) ) {
- 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) ) {
- /* 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(expp)
- 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(expp)
- register struct node *expp;
- {
- /* Check an unary operation.
- */
- register struct node *right = expp->nd_right;
- register struct type *tpr;
- if( !ChkExpression(right) ) return 0;
- 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 ) {
- 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 '(':
- return 1;
- default:
- crash("(ChkUnOper)");
- }
- node_error(expp, "\"%s\": illegal operand", symbol2str(expp->nd_symb));
- return 0;
- }
- STATIC struct type *
- ResultOfOperation(operator, tpl, tpr)
- struct type *tpl, *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;
- return tpl;
- case '/' :
- return real_type;
- }
- return tpl;
- }
- STATIC int
- AllowedTypes(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;
- case OR :
- case AND :
- return T_ENUMERATION;
- case '=' :
- case NOTEQUAL :
- return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_SET | T_POINTER | T_STRING;
- case LESSEQUAL :
- case GREATEREQUAL:
- return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_SET | T_STRING;
- case '<' :
- case '>' :
- return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_STRING;
- default :
- crash("(AllowedTypes)");
- }
- /*NOTREACHED*/
- }
- STATIC int
- Boolean(operator)
- {
- return operator == OR || operator == AND;
- }
- STATIC int
- ChkBinOper(expp)
- 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) & ChkExpression(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 "AllowedTyped" 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_STRING && (ub = IsString(tpl)) )
- if( ub == IsString(tpr) )
- return 1;
- else {
- node_error(expp, "\"%s\": incompatible types",
- symbol2str(expp->nd_symb));
- return 0;
- }
- 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 &&
- (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 ) {
- expp->nd_right =
- MkNode(Cast, NULLNODE, expp->nd_right, &dot);
- expp->nd_right->nd_type = tpr = real_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(expp, tp, set, cnt)
- 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;
- 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(expp)
- 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(set);
- set = (arith *) 0;
- }
- expp->nd_set = set;
- FreeNode(expp->nd_right);
- expp->nd_right = NULLNODE;
- }
- return 1;
- }
- ChkVarPar(nd, name)
- register struct node *nd, *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 var_mes[] = "can't be a variable parameter";
- static char err_mes[64];
- char *message = (char *) 0;
- extern char *sprint();
- if( !ChkVariable(nd) ) return 0;
- switch( nd->nd_class ) {
- case Def:
- 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 %s";
- else if( nd->nd_def->fld_flags & F_SELECTOR )
- message = "variant selector %s";
- break;
- case Arrsel:
- if( IsPacked(nd->nd_left->nd_type) )
- message = "component of packed array %s";
- break;
- case Arrow:
- if( nd->nd_right->nd_type->tp_fund == T_FILE )
- message = "filebuffer variable %s";
- break;
- default:
- crash("(ChkVarPar)");
- /*NOTREACHED*/
- }
- if( message ) {
- sprint(err_mes, message, var_mes);
- Xerror(name, err_mes);
- return 0;
- }
- return 1;
- }
- STATIC struct node *
- getarg(argp, bases, varaccess, name, paramtp)
- struct node **argp, *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;
- else return 0;
- }
- else if( varaccess ? !ChkVarPar(left, name) : !ChkExpression(left) )
- return 0;
- if( bases && !(BaseType(left->nd_type)->tp_fund & bases) ) {
- Xerror(name, "unexpected parameter type");
- return 0;
- }
- return left;
- }
- STATIC int
- ChkProcCall(expp)
- struct node *expp;
- {
- /* Check a procedure call
- */
- register struct node *left;
- struct node *name;
- register struct paramlist *param;
- char ebuf[64];
- 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, IsVarParam(param), name,
- TypeOfParam(param))) )
- return 0;
- cnt++;
- new_par_section = lasttp != TypeOfParam(param);
- if( !TstParCompat(TypeOfParam(param), left->nd_type,
- IsVarParam(param), left, new_par_section) ) {
- sprint(ebuf, "type incompatibility in parameter %d",
- cnt);
- Xerror(name, ebuf);
- retval = 0;
- }
- 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(expp)
- 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;
- STATIC int ChkStandard();
- expp->nd_type = error_type;
- if( ChkLinkOrName(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(expp)
- 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(expp)
- 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(expp,left)
- register struct node *expp, *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 ) {
- 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;
- 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, 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_PAGE: {
- int st_out;
- if( req == R_PAGE ) {
- expp->nd_type = NULLTYPE;
- st_out = 1;
- }
- else {
- expp->nd_type = bool_type;
- st_out = 0;
- }
- if( !arg->nd_right ) {
- struct node *nd;
- if( !(nd = ChkStdInOut(name, 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_EOF && left->nd_type != text_type ) {
- Xerror(name, "textfile expected");
- return 0;
- }
- }
- break;
- }
- case R_REWRITE:
- case R_PUT:
- case R_RESET:
- case R_GET:
- 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;
- default:
- crash("(ChkStandard)");
- }
-
- if( arg->nd_right ) {
- Xerror(name, "too many arguments supplied");
- return 0;
- }
- return 1;
- }
- STATIC int
- ChkArrow(expp)
- 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;
- 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(expp)
- 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;
- retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right);
- 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;
- }
- expp->nd_type = tpl->arr_elem;
- return retval;
- }
- STATIC int
- done_before()
- {
- return 1;
- }
- STATIC int
- no_var_access(expp)
- struct node *expp;
- {
- node_error(expp, "variable-access expected");
- return 0;
- }
- extern int NodeCrash();
- int (*ExprChkTable[])() = {
- #ifdef DEBUG
- ChkValue,
- #else
- done_before,
- #endif
- ChkExLinkOrName,
- ChkUnOper,
- ChkBinOper,
- ChkSet,
- NodeCrash,
- ChkExCall,
- ChkNameOrCall,
- ChkArrow,
- ChkArr,
- NodeCrash,
- ChkExLinkOrName,
- NodeCrash,
- NodeCrash
- };
- int (*VarAccChkTable[])() = {
- 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
- };
|