123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578 |
- /*
- * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
- * See the copyright notice in the ACK home directory, in the file "Copyright".
- *
- * Author: Ceriel J.H. Jacobs
- */
- /* E X P R E S S I O N C H E C K I N G */
- /* $Id$ */
- /* Check expressions, and try to evaluate them as far as possible.
- */
- #include <stdlib.h>
- #include <string.h>
- #include "debug.h"
- #include <em_arith.h>
- #include <em_label.h>
- #include <assert.h>
- #include <alloc.h>
- #include "strict3rd.h"
- #include "Lpars.h"
- #include "idf.h"
- #include "type.h"
- #include "LLlex.h"
- #include "def.h"
- #include "node.h"
- #include "scope.h"
- #include "standards.h"
- #include "chk_expr.h"
- #include "misc.h"
- #include "warning.h"
- #include "main.h"
- #include "nostrict.h"
- extern char *symbol2str();
- extern char *sprint();
- extern arith flt_flt2arith();
- STATIC
- df_error(nd, mess, edf)
- t_node *nd; /* node on which error occurred */
- char *mess; /* error message */
- register t_def *edf; /* do we have a name? */
- {
- if (edf) {
- if (edf->df_kind != D_ERROR) {
- node_error(nd,"\"%s\": %s", edf->df_idf->id_text, mess);
- }
- }
- else node_error(nd, mess);
- }
- MkCoercion(pnd, tp)
- t_node **pnd;
- register t_type *tp;
- {
- /* Make a coercion from the node indicated by *pnd to the
- type indicated by tp. If the node indicated by *pnd
- is constant, try to do the coercion compile-time.
- Coercions are inserted in the tree when
- - the expression is not constant or
- - we are in the second pass and the coercion might cause
- an error
- */
- register t_node *nd = *pnd;
- register t_type *nd_tp = nd->nd_type;
- extern int pass_1;
- char *wmess = 0;
- arith op;
- if (nd_tp == tp || nd_tp->tp_fund == T_STRING /* Why ??? */) return;
- nd_tp = BaseType(nd_tp);
- if (nd->nd_class == Value && nd->nd_type != error_type && tp != error_type) {
- if (nd_tp->tp_fund == T_REAL) {
- switch(tp->tp_fund) {
- case T_REAL:
- nd->nd_type = tp;
- return;
- case T_CARDINAL:
- op = flt_flt2arith(&nd->nd_RVAL, 1);
- break;
- case T_INTEGER:
- op = flt_flt2arith(&nd->nd_RVAL, 0);
- break;
- default:
- crash("MkCoercion");
- /*NOTREACHED*/
- }
- if (flt_status == FLT_OVFL) {
- wmess = "conversion";
- }
- if (!wmess || pass_1) {
- if (nd->nd_RSTR) free(nd->nd_RSTR);
- free_real(nd->nd_REAL);
- nd->nd_INT = op;
- nd->nd_symb = INTEGER;
- }
- }
- switch(tp->tp_fund) {
- case T_REAL: {
- struct real *p = new_real();
- switch(BaseType(nd_tp)->tp_fund) {
- case T_CARDINAL:
- case T_INTORCARD:
- flt_arith2flt(nd->nd_INT, &p->r_val, 1);
- break;
- case T_INTEGER:
- flt_arith2flt(nd->nd_INT, &p->r_val, 0);
- break;
- default:
- crash("MkCoercion");
- }
- nd->nd_REAL = p;
- nd->nd_symb = REAL;
- }
- break;
- case T_SUBRANGE:
- case T_ENUMERATION:
- case T_CHAR:
- if (! in_range(nd->nd_INT, tp)) {
- wmess = "range bound";
- }
- break;
- case T_INTORCARD:
- case T_CARDINAL:
- case T_POINTER:
- if ((nd_tp->tp_fund == T_INTEGER && nd->nd_INT < 0) ||
- (nd->nd_INT & ~full_mask[(int)(tp->tp_size)])) {
- wmess = "conversion";
- }
- break;
- case T_INTEGER:
- if (! chk_bounds(nd->nd_INT,
- max_int[(int)(tp->tp_size)],
- nd_tp->tp_fund) ||
- ! chk_bounds(min_int[(int)(tp->tp_size)],
- nd->nd_INT,
- T_INTEGER)) {
- wmess = "conversion";
- }
- break;
- }
- if (wmess) {
- node_warning(nd, W_ORDINARY, "might cause %s error", wmess);
- }
- if (!wmess || pass_1) {
- nd->nd_type = tp;
- return;
- }
- }
- *pnd = nd;
- nd = getnode(Uoper);
- nd->nd_symb = COERCION;
- nd->nd_type = tp;
- nd->nd_LEFT = NULLNODE;
- nd->nd_RIGHT = *pnd;
- nd->nd_lineno = (*pnd)->nd_lineno;
- *pnd = nd;
- }
- int
- ChkVariable(expp, flags)
- register t_node **expp;
- {
- /* Check that "expp" indicates an item that can be
- assigned to.
- */
- register t_node *exp;
- if (! ChkDesig(expp, flags)) return 0;
- exp = *expp;
- if (exp->nd_class == Def &&
- ! (exp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
- df_error(exp, "variable expected", exp->nd_def);
- return 0;
- }
- return 1;
- }
- STATIC int
- ChkArrow(expp)
- t_node **expp;
- {
- /* Check an application of the '^' operator.
- The operand must be a variable of a pointer type.
- */
- register t_type *tp;
- register t_node *exp = *expp;
- assert(exp->nd_class == Arrow);
- assert(exp->nd_symb == '^');
- exp->nd_type = error_type;
- if (! ChkVariable(&(exp->nd_RIGHT), D_USED)) return 0;
- tp = exp->nd_RIGHT->nd_type;
- if (tp->tp_fund != T_POINTER) {
- node_error(exp, "\"^\": illegal operand type");
- return 0;
- }
- if ((tp = RemoveEqual(PointedtoType(tp))) == 0) tp = error_type;
- exp->nd_type = tp;
- return 1;
- }
- STATIC int
- ChkArr(expp, flags)
- t_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 t_type *tpl;
- register t_node *exp = *expp;
- assert(exp->nd_class == Arrsel);
- assert(exp->nd_symb == '[' || exp->nd_symb == ',');
- exp->nd_type = error_type;
- if (! (ChkVariable(&(exp->nd_LEFT), flags) &
- ChkExpression(&(exp->nd_RIGHT)))) {
- /* Bitwise and, because we want them both evaluated.
- */
- return 0;
- }
- tpl = exp->nd_LEFT->nd_type;
- if (tpl->tp_fund != T_ARRAY) {
- node_error(exp, "not indexing an ARRAY type");
- return 0;
- }
- exp->nd_type = RemoveEqual(tpl->arr_elem);
- /* Type of the index must be assignment compatible with
- the index type of the array (Def 8.1).
- However, the index type of a conformant array is not specified.
- In our implementation it is CARDINAL.
- */
- return ChkAssCompat(&(exp->nd_RIGHT),
- BaseType(IndexType(tpl)),
- "index type");
- }
- /*ARGSUSED*/
- STATIC int
- ChkValue(expp)
- t_node **expp;
- {
- #ifdef DEBUG
- switch((*expp)->nd_symb) {
- case REAL:
- case STRING:
- case INTEGER:
- break;
- default:
- crash("(ChkValue)");
- }
- #endif
- return 1;
- }
- STATIC int
- ChkSelOrName(expp, flags)
- t_node **expp;
- {
- /* Check either an ID or a construction of the form
- ID.ID [ .ID ]*
- */
- register t_def *df;
- register t_node *exp = *expp;
- exp->nd_type = error_type;
- if (exp->nd_class == Name) {
- df = lookfor(exp, CurrVis, 1, flags);
- exp = getnode(Def);
- exp->nd_def = df;
- exp->nd_lineno = (*expp)->nd_lineno;
- exp->nd_type = RemoveEqual(df->df_type);
- FreeNode(*expp);
- *expp = exp;
- }
- else if (exp->nd_class == Select) {
- /* A selection from a record or a module.
- Modules also have a record type.
- */
- register t_node *left;
- assert(exp->nd_symb == '.');
- if (! ChkDesig(&(exp->nd_NEXT), flags)) return 0;
- left = exp->nd_NEXT;
- if (left->nd_class==Def &&
- (left->nd_type->tp_fund != T_RECORD ||
- !(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
- )
- ) {
- df_error(left, "illegal selection", left->nd_def);
- return 0;
- }
- if (left->nd_type->tp_fund != T_RECORD) {
- node_error(left, "illegal selection");
- return 0;
- }
- if (!(df = lookup(exp->nd_IDF, left->nd_type->rec_scope, D_IMPORTED, flags))) {
- id_not_declared(exp);
- return 0;
- }
- exp = getnode(Def);
- exp->nd_def = df;
- exp->nd_type = RemoveEqual(df->df_type);
- exp->nd_lineno = (*expp)->nd_lineno;
- free_node(*expp);
- *expp = exp;
- if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
- /* Fields of a record are always D_QEXPORTED,
- so ...
- */
- df_error(exp, "not exported from qualifying module", df);
- }
- if (!(left->nd_class == Def &&
- left->nd_def->df_kind == D_MODULE)) {
- exp->nd_NEXT = left;
- return 1;
- }
- FreeNode(left);
- }
- assert(exp->nd_class == Def);
- return exp->nd_def->df_kind != D_ERROR;
- }
- STATIC int
- ChkExSelOrName(expp)
- t_node **expp;
- {
- /* Check either an ID or an ID.ID [.ID]* occurring in an
- expression.
- */
- register t_def *df;
- register t_node *exp;
- if (! ChkSelOrName(expp, D_USED)) return 0;
- exp = *expp;
- df = exp->nd_def;
- if (df->df_kind & (D_ENUM | D_CONST)) {
- /* Replace an enum-literal or a CONST identifier by its value.
- */
- exp = getnode(Value);
- exp->nd_type = df->df_type;
- if (df->df_kind == D_ENUM) {
- exp->nd_INT = df->enm_val;
- exp->nd_symb = INTEGER;
- }
- else {
- assert(df->df_kind == D_CONST);
- exp->nd_token = df->con_const;
- }
- exp->nd_lineno = (*expp)->nd_lineno;
- if (df->df_type->tp_fund == T_SET) {
- exp->nd_class = Set;
- inc_refcount(exp->nd_set);
- }
- else if (df->df_type->tp_fund == T_PROCEDURE) {
- /* for procedure constants */
- exp->nd_class = Def;
- }
- if (df->df_type->tp_fund == T_REAL) {
- struct real *p = exp->nd_REAL;
- exp->nd_REAL = new_real();
- *(exp->nd_REAL) = *p;
- if (p->r_real) {
- p->r_real = Salloc(p->r_real,
- (unsigned)(strlen(p->r_real)+1));
- }
- }
- FreeNode(*expp);
- *expp = exp;
- }
- if (!(df->df_kind & D_VALUE)) {
- df_error(exp, "value expected", df);
- return 0;
- }
- if (df->df_kind == D_PROCEDURE) {
- /* Check that this procedure is one that we may take the
- address from.
- */
- if (df->df_type == std_type || df->df_scope->sc_level > 0) {
- /* Address of standard or nested procedure
- taken.
- */
- node_error(exp,
- "standard or local procedures may not be assigned");
- return 0;
- }
- }
- return 1;
- }
- STATIC int
- ChkEl(expp, tp)
- register t_node **expp;
- t_type *tp;
- {
- return ChkExpression(expp) && ChkCompat(expp, tp, "set element");
- }
- STATIC int
- ChkElement(expp, tp, set)
- t_node **expp;
- t_type *tp;
- arith *set;
- {
- /* Check elements of a set. This routine may call itself
- recursively.
- Also try to compute the set!
- */
- register t_node *expr = *expp;
- t_type *el_type = ElementType(tp);
- register unsigned int i;
- arith low, high;
- if (expr->nd_class == Link && expr->nd_symb == UPTO) {
- /* { ... , expr1 .. expr2, ... }
- First check expr1 and expr2, and try to compute them.
- */
- if (! (ChkEl(&(expr->nd_LEFT), el_type) &
- ChkEl(&(expr->nd_RIGHT), el_type))) {
- return 0;
- }
- if (!(expr->nd_LEFT->nd_class == Value &&
- expr->nd_RIGHT->nd_class == Value)) {
- return 1;
- }
- /* We have a constant range. Put all elements in the
- set
- */
- low = expr->nd_LEFT->nd_INT;
- high = expr->nd_RIGHT->nd_INT;
- }
- else {
- if (! ChkEl(expp, el_type)) return 0;
- expr = *expp;
- if (expr->nd_class != Value) {
- return 1;
- }
- low = high = expr->nd_INT;
- }
- if (! chk_bounds(low, high, BaseType(el_type)->tp_fund)) {
- node_error(expr, "lower bound exceeds upper bound in range");
- return 0;
- }
- if (! in_range(low, el_type) || ! in_range(high, el_type)) {
- node_error(expr, "set element out of range");
- return 0;
- }
- low -= tp->set_low;
- high -= tp->set_low;
- for (i=(unsigned)low; i<= (unsigned)high; i++) {
- set[i/wrd_bits] |= (1<<(i%wrd_bits));
- }
- FreeNode(expr);
- *expp = 0;
- return 1;
- }
- arith *
- MkSet(size)
- unsigned size;
- {
- register arith *s, *t;
- s = t = (arith *) Malloc(size);
- s++;
- size /= sizeof(arith);
- while (size--) *t++ = 0;
- inc_refcount(s);
- return s;
- }
- FreeSet(s)
- register arith *s;
- {
- dec_refcount(s);
- if (refcount(s) <= 0) {
- assert(refcount(s) == 0);
- free((char *) (s-1));
- }
- }
- STATIC int
- ChkSet(expp)
- t_node **expp;
- {
- /* Check the legality of a SET aggregate, and try to evaluate it
- compile time. Unfortunately this is all rather complicated.
- */
- register t_type *tp;
- register t_node *exp = *expp;
- register t_node *nd;
- register t_def *df;
- int retval = 1;
- int SetIsConstant = 1;
- assert(exp->nd_symb == SET);
- *expp = getnode(Set);
- (*expp)->nd_type = error_type;
- (*expp)->nd_lineno = exp->nd_lineno;
- /* First determine the type of the set
- */
- if (exp->nd_LEFT) {
- /* A type was given. Check it out
- */
- if (! ChkDesig(&(exp->nd_LEFT), D_USED)) return 0;
- nd = exp->nd_LEFT;
- assert(nd->nd_class == Def);
- df = nd->nd_def;
- if (!is_type(df) ||
- (df->df_type->tp_fund != T_SET)) {
- df_error(nd, "not a SET type", df);
- return 0;
- }
- tp = df->df_type;
- }
- else tp = bitset_type;
- (*expp)->nd_type = tp;
- nd = exp->nd_RIGHT;
- /* Now check the elements given, and try to compute a constant set.
- First allocate room for the set.
- */
- (*expp)->nd_set = MkSet(tp->set_sz);
- /* Now check the elements, one by one
- */
- while (nd) {
- assert(nd->nd_class == Link && nd->nd_symb == ',');
- if (!ChkElement(&(nd->nd_LEFT), tp, (*expp)->nd_set)) {
- retval = 0;
- }
- if (nd->nd_LEFT) SetIsConstant = 0;
- nd = nd->nd_RIGHT;
- }
- if (! SetIsConstant) {
- (*expp)->nd_NEXT = exp->nd_RIGHT;
- exp->nd_RIGHT = 0;
- }
- FreeNode(exp);
- return retval;
- }
- STATIC t_node *
- nextarg(argp, edf)
- t_node **argp;
- t_def *edf;
- {
- register t_node *arg = (*argp)->nd_RIGHT;
- if (! arg) {
- df_error(*argp, "too few arguments supplied", edf);
- return 0;
- }
- *argp = arg;
- return arg;
- }
- STATIC t_node *
- getarg(argp, bases, designator, edf)
- t_node **argp;
- t_def *edf;
- {
- /* 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 "designator" is a flag
- indicating that the address from this argument is taken, so
- that it must be a designator and may not be a register
- variable.
- */
- register t_node *arg = nextarg(argp, edf);
- register t_node *left;
- if (! arg ||
- ! arg->nd_LEFT ||
- ! (designator ? ChkVariable(&(arg->nd_LEFT), D_USED|D_DEFINED) : ChkExpression(&(arg->nd_LEFT)))) {
- return 0;
- }
- left = arg->nd_LEFT;
- if (designator && left->nd_class==Def) {
- left->nd_def->df_flags |= D_NOREG;
- }
- if (bases) {
- t_type *tp = BaseType(left->nd_type);
- if (! designator) MkCoercion(&(arg->nd_LEFT), tp);
- left = arg->nd_LEFT;
- if (!(tp->tp_fund & bases)) {
- df_error(left, "unexpected parameter type", edf);
- return 0;
- }
- }
- return left;
- }
- STATIC t_node *
- getname(argp, kinds, bases, edf)
- t_node **argp;
- t_def *edf;
- {
- /* Get the next argument from argument list "argp".
- The argument must indicate a definition, and the
- definition kind must be one of "kinds".
- */
- register t_node *arg = nextarg(argp, edf);
- register t_node *left;
- if (!arg || !arg->nd_LEFT || ! ChkDesig(&(arg->nd_LEFT), D_USED)) return 0;
- left = arg->nd_LEFT;
- if (left->nd_class != Def) {
- df_error(left, "identifier expected", edf);
- return 0;
- }
- if (!(left->nd_def->df_kind & kinds) ||
- (bases && !(left->nd_type->tp_fund & bases))) {
- df_error(left, "unexpected parameter type", edf);
- return 0;
- }
- return left;
- }
- STATIC int
- ChkProcCall(exp)
- register t_node *exp;
- {
- /* Check a procedure call
- */
- register t_node *left;
- t_node *argp;
- t_def *edf = 0;
- register t_param *param;
- int retval = 1;
- int cnt = 0;
- left = exp->nd_LEFT;
- if (left->nd_class == Def) {
- edf = left->nd_def;
- }
- if (left->nd_type == error_type) {
- /* Just check parameters as if they were value parameters
- */
- argp = exp;
- while (argp->nd_RIGHT) {
- if (getarg(&argp, 0, 0, edf)) { }
- }
- return 0;
- }
- exp->nd_type = RemoveEqual(ResultType(left->nd_type));
- /* Check parameter list
- */
- argp = exp;
- for (param = ParamList(left->nd_type); param; param = param->par_next) {
- if (!(left = getarg(&argp, 0, IsVarParam(param), edf))) {
- retval = 0;
- cnt++;
- continue;
- }
- cnt++;
- if (left->nd_symb == STRING) {
- TryToString(left, TypeOfParam(param));
- }
- if (! TstParCompat(cnt,
- RemoveEqual(TypeOfParam(param)),
- IsVarParam(param),
- &(argp->nd_LEFT),
- edf)) {
- retval = 0;
- }
- }
- exp = argp;
- if (exp->nd_RIGHT) {
- df_error(exp->nd_RIGHT,"too many parameters supplied",edf);
- while (argp->nd_RIGHT) {
- if (getarg(&argp, 0, 0, edf)) { }
- }
- return 0;
- }
- return retval;
- }
- STATIC int
- ChkFunCall(expp)
- register t_node **expp;
- {
- /* Check a call that must have a result
- */
- if (ChkCall(expp)) {
- if ((*expp)->nd_type != 0) return 1;
- node_error(*expp, "function call expected");
- }
- (*expp)->nd_type = error_type;
- return 0;
- }
- STATIC int ChkStandard();
- STATIC int ChkCast();
- int
- ChkCall(expp)
- t_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 cast or a standard procedure call.
- */
- /* First, get the name of the function or procedure
- */
- if (ChkDesig(&((*expp)->nd_LEFT), D_USED)) {
- register t_node *left = (*expp)->nd_LEFT;
-
- if (IsCast(left)) {
- /* It was a type cast.
- */
- return ChkCast(expp);
- }
- if (IsProc(left) || left->nd_type == error_type) {
- /* A procedure call.
- It may also be a call to a standard procedure
- */
- if (left->nd_type == std_type) {
- /* A standard procedure
- */
- return ChkStandard(expp);
- }
- /* Here, we have found a real procedure call.
- The left hand side may also represent a procedure
- variable.
- */
- }
- else {
- node_error(left, "procedure, type, or function expected");
- left->nd_type = error_type;
- }
- }
- return ChkProcCall(*expp);
- }
- STATIC t_type *
- ResultOfOperation(operator, tp)
- t_type *tp;
- {
- /* Return the result type of the binary operation "operator",
- with operand type "tp".
- */
- switch(operator) {
- case '=':
- case '#':
- case GREATEREQUAL:
- case LESSEQUAL:
- case '<':
- case '>':
- case IN:
- return bool_type;
- }
- return tp;
- }
- #define Boolean(operator) (operator == OR || operator == AND)
- 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_REAL|T_SET;
- case DIV:
- case MOD:
- return T_INTORCARD;
- case OR:
- case AND:
- return T_ENUMERATION;
- case '=':
- case '#':
- return T_POINTER|T_HIDDEN|T_SET|T_NUMERIC|T_ENUMERATION|T_CHAR;
- case GREATEREQUAL:
- case LESSEQUAL:
- return T_SET|T_NUMERIC|T_CHAR|T_ENUMERATION;
- case '<':
- case '>':
- return T_NUMERIC|T_CHAR|T_ENUMERATION;
- default:
- crash("(AllowedTypes)");
- }
- /*NOTREACHED*/
- }
- STATIC int
- ChkAddressOper(tpl, tpr, expp)
- register t_type *tpl, *tpr;
- register t_node *expp;
- {
- /* Check that either "tpl" or "tpr" are both of type
- address_type, or that one of them is, but the other is
- of a cardinal type.
- Also insert proper coercions, making sure that the EM pointer
- arithmetic instructions can be generated whenever possible
- */
- if (tpr == address_type && expp->nd_symb == '+') {
- /* use the fact that '+' is a commutative operator */
- t_type *tmptype = tpr;
- t_node *tmpnode = expp->nd_RIGHT;
- tpr = tpl;
- expp->nd_RIGHT = expp->nd_LEFT;
- tpl = tmptype;
- expp->nd_LEFT = tmpnode;
- }
-
- if (tpl == address_type) {
- expp->nd_type = address_type;
- if (tpr == address_type) {
- return 1;
- }
- if (tpr->tp_fund & T_CARDINAL) {
- MkCoercion(&(expp->nd_RIGHT),
- expp->nd_symb=='+' || expp->nd_symb=='-' ?
- tpr :
- address_type);
- return 1;
- }
- return 0;
- }
- if (tpr == address_type && tpl->tp_fund & T_CARDINAL) {
- expp->nd_type = address_type;
- MkCoercion(&(expp->nd_LEFT), address_type);
- return 1;
- }
- return 0;
- }
- STATIC int
- ChkBinOper(expp)
- t_node **expp;
- {
- /* Check a binary operation.
- */
- register t_node *exp = *expp;
- register t_type *tpl, *tpr;
- t_type *result_type;
- int allowed;
- int retval;
- char *symb;
- /* First, check BOTH operands */
- retval = ChkExpression(&(exp->nd_LEFT));
- retval &= ChkExpression(&(exp->nd_RIGHT));
- tpl = BaseType(exp->nd_LEFT->nd_type);
- tpr = BaseType(exp->nd_RIGHT->nd_type);
- if (intorcard(tpl, tpr) != 0) {
- if (tpl->tp_fund == T_INTORCARD) {
- exp->nd_LEFT->nd_type = tpl = tpr;
- }
- if (tpr->tp_fund == T_INTORCARD) {
- exp->nd_RIGHT->nd_type = tpr = tpl;
- }
- }
- exp->nd_type = result_type = ResultOfOperation(exp->nd_symb, tpr);
- /* Check that the application of the operator is allowed on the type
- of the operands.
- There are three tricky parts:
- - Boolean operators are only allowed on boolean operands, but
- the "allowed-mask" of "AllowedTypes" can only indicate
- an enumeration type.
- - All operations that are allowed on CARDINALS are also allowed
- on ADDRESS.
- - The IN-operator has as right-hand-size operand a set.
- */
- if (exp->nd_symb == IN) {
- if (tpr->tp_fund != T_SET) {
- node_error(exp, "\"IN\": right operand must be a set");
- return 0;
- }
- if (!TstAssCompat(ElementType(tpr), tpl)) {
- /* Assignment compatible ???
- I don't know! Should we be allowed to check
- if a INTEGER is a member of a BITSET???
- */
- node_error(exp->nd_LEFT, "type incompatibility in IN");
- return 0;
- }
- MkCoercion(&(exp->nd_LEFT), word_type);
- if (exp->nd_LEFT->nd_class == Value &&
- exp->nd_RIGHT->nd_class == Set &&
- ! exp->nd_RIGHT->nd_NEXT) {
- cstset(expp);
- }
- return retval;
- }
- if (!retval) return 0;
- allowed = AllowedTypes(exp->nd_symb);
- symb = symbol2str(exp->nd_symb);
- if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
- if (!((T_CARDINAL & allowed) &&
- ChkAddressOper(tpl, tpr, exp))) {
- node_error(exp, "\"%s\": illegal operand type(s)", symb);
- return 0;
- }
- if (result_type == bool_type) exp->nd_type = bool_type;
- }
- else {
- if (Boolean(exp->nd_symb) && tpl != bool_type) {
- node_error(exp, "\"%s\": illegal operand type(s)", symb);
- return 0;
- }
- /* Operands must be compatible (distilled from Def 8.2)
- */
- if (!TstCompat(tpr, tpl)) {
- extern char *incompat();
- node_error(exp, "\"%s\": %s in operands", symb, incompat(tpl, tpr));
- return 0;
- }
- MkCoercion(&(exp->nd_LEFT), tpl);
- MkCoercion(&(exp->nd_RIGHT), tpr);
- }
- if (tpl->tp_fund == T_SET) {
- if (exp->nd_LEFT->nd_class == Set &&
- ! exp->nd_LEFT->nd_NEXT &&
- exp->nd_RIGHT->nd_class == Set &&
- ! exp->nd_RIGHT->nd_NEXT) {
- cstset(expp);
- }
- }
- else if ( exp->nd_LEFT->nd_class == Value &&
- exp->nd_RIGHT->nd_class == Value) {
- if (tpl->tp_fund == T_INTEGER) {
- cstibin(expp);
- }
- else if (tpl->tp_fund == T_REAL) {
- cstfbin(expp);
- }
- else cstubin(expp);
- }
- return 1;
- }
- STATIC int
- ChkUnOper(expp)
- t_node **expp;
- {
- /* Check an unary operation.
- */
- register t_node *exp = *expp;
- register t_node *right = exp->nd_RIGHT;
- register t_type *tpr;
- if (exp->nd_symb == COERCION) return 1;
- if (exp->nd_symb == '(') {
- *expp = right;
- free_node(exp);
- return ChkExpression(expp);
- }
- exp->nd_type = error_type;
- if (! ChkExpression(&(exp->nd_RIGHT))) return 0;
- exp->nd_type = tpr = BaseType(exp->nd_RIGHT->nd_type);
- MkCoercion(&(exp->nd_RIGHT), tpr);
- right = exp->nd_RIGHT;
- if (tpr == address_type) tpr = card_type;
- switch(exp->nd_symb) {
- case '+':
- if (!(tpr->tp_fund & T_NUMERIC)) break;
- *expp = right;
- free_node(exp);
- return 1;
- case '-':
- if (tpr->tp_fund == T_INTORCARD || tpr->tp_fund == T_INTEGER) {
- if (tpr == intorcard_type) {
- exp->nd_type = int_type;
- }
- else if (tpr == longintorcard_type) {
- exp->nd_type = longint_type;
- }
- if (right->nd_class == Value) {
- cstunary(expp);
- }
- return 1;
- }
- else if (tpr->tp_fund == T_REAL) {
- if (right->nd_class == Value) {
- *expp = right;
- flt_umin(&(right->nd_RVAL));
- if (right->nd_RSTR) {
- free(right->nd_RSTR);
- right->nd_RSTR = 0;
- }
- free_node(exp);
- }
- return 1;
- }
- break;
- case NOT:
- case '~':
- if (tpr == bool_type) {
- if (right->nd_class == Value) {
- cstunary(expp);
- }
- return 1;
- }
- break;
- default:
- crash("ChkUnOper");
- }
- node_error(exp, "\"%s\": illegal operand type", symbol2str(exp->nd_symb));
- return 0;
- }
- STATIC t_node *
- getvariable(argp, edf, flags)
- t_node **argp;
- t_def *edf;
- {
- /* Get the next argument from argument list "argp".
- It must obey the rules of "ChkVariable".
- */
- register t_node *arg = nextarg(argp, edf);
- if (! arg ||
- ! arg->nd_LEFT ||
- ! ChkVariable(&(arg->nd_LEFT), flags)) return 0;
- return arg->nd_LEFT;
- }
- STATIC int
- ChkStandard(expp)
- t_node **expp;
- {
- /* Check a call of a standard procedure or function
- */
- register t_node *exp = *expp;
- t_node *arglink = exp;
- register t_node *arg;
- register t_def *edf = exp->nd_LEFT->nd_def;
- int free_it = 0;
- int isconstant = 0;
- assert(exp->nd_LEFT->nd_class == Def);
- exp->nd_type = error_type;
- switch(edf->df_value.df_stdname) {
- case S_ABS:
- if (!(arg = getarg(&arglink, T_NUMERIC, 0, edf))) return 0;
- exp->nd_type = BaseType(arg->nd_type);
- MkCoercion(&(arglink->nd_LEFT), exp->nd_type);
- arg = arglink->nd_LEFT;
- if (! (exp->nd_type->tp_fund & (T_INTEGER|T_REAL))) {
- free_it = 1;
- }
- if (arg->nd_class == Value) {
- switch(exp->nd_type->tp_fund) {
- case T_REAL:
- arg->nd_RVAL.flt_sign = 0;
- free_it = 1;
- break;
- case T_INTEGER:
- isconstant = 1;
- break;
- }
- }
- break;
- case S_CAP:
- exp->nd_type = char_type;
- if (!(arg = getarg(&arglink, T_CHAR, 0, edf))) return 0;
- if (arg->nd_class == Value) isconstant = 1;
- break;
- case S_FLOATD:
- case S_FLOAT:
- if (! getarg(&arglink, T_INTORCARD, 0, edf)) return 0;
- arg = arglink;
- if (edf->df_value.df_stdname == S_FLOAT) {
- MkCoercion(&(arg->nd_LEFT), card_type);
- }
- MkCoercion(&(arg->nd_LEFT),
- edf->df_value.df_stdname == S_FLOATD ?
- longreal_type :
- real_type);
- free_it = 1;
- break;
- case S_SHORT:
- case S_LONG: {
- t_type *tp;
- t_type *s1, *s2, *s3, *d1, *d2, *d3;
- if (!(arg = getarg(&arglink, 0, 0, edf))) {
- return 0;
- }
- tp = BaseType(arg->nd_type);
- if (edf->df_value.df_stdname == S_SHORT) {
- s1 = longint_type;
- d1 = int_type;
- s2 = longreal_type;
- d2 = real_type;
- s3 = longcard_type;
- d3 = card_type;
- }
- else {
- d1 = longint_type;
- s1 = int_type;
- d2 = longreal_type;
- s2 = real_type;
- d3 = longcard_type;
- s3 = card_type;
- }
- if (tp == s1) {
- MkCoercion(&(arglink->nd_LEFT), d1);
- }
- else if (tp == s2) {
- MkCoercion(&(arglink->nd_LEFT), d2);
- }
- else if (options['l'] && tp == s3) {
- MkCoercion(&(arglink->nd_LEFT), d3);
- }
- else {
- df_error(arg, "unexpected parameter type", edf);
- break;
- }
- free_it = 1;
- break;
- }
- case S_HIGH:
- if (!(arg = getarg(&arglink, T_ARRAY|T_STRING|T_CHAR, 0, edf))) {
- return 0;
- }
- if (arg->nd_type->tp_fund == T_ARRAY) {
- exp->nd_type = IndexType(arg->nd_type);
- if (! IsConformantArray(arg->nd_type)) {
- arg->nd_type = exp->nd_type;
- isconstant = 1;
- }
- break;
- }
- if (arg->nd_symb != STRING) {
- df_error(arg,"array parameter expected", edf);
- return 0;
- }
- exp = getnode(Value);
- exp->nd_type = card_type;
- /* Notice that we could disallow HIGH("") here by checking
- that arg->nd_type->tp_fund != T_CHAR || arg->nd_INT != 0.
- ??? For the time being, we don't. !!!
- Maybe the empty string should not be allowed at all.
- */
- exp->nd_INT = arg->nd_type->tp_fund == T_CHAR ? 0 :
- arg->nd_SLE - 1;
- exp->nd_symb = INTEGER;
- exp->nd_lineno = (*expp)->nd_lineno;
- (*expp)->nd_RIGHT = 0;
- FreeNode(*expp);
- *expp = exp;
- break;
- case S_MAX:
- case S_MIN:
- if (!(arg = getname(&arglink, D_ISTYPE, T_DISCRETE, edf))) {
- return 0;
- }
- exp->nd_type = arg->nd_type;
- isconstant = 1;
- break;
- case S_ODD:
- if (! (arg = getarg(&arglink, T_INTORCARD, 0, edf))) return 0;
- MkCoercion(&(arglink->nd_LEFT), BaseType(arg->nd_type));
- exp->nd_type = bool_type;
- if (arglink->nd_LEFT->nd_class == Value) isconstant = 1;
- break;
- case S_ORD:
- if (! (arg = getarg(&arglink, T_NOSUB, 0, edf))) return 0;
- exp->nd_type = card_type;
- if (arg->nd_class == Value) {
- arg->nd_type = card_type;
- free_it = 1;
- }
- break;
- #ifndef STRICT_3RD_ED
- case S_NEW:
- case S_DISPOSE:
- {
- static int warning_given = 0;
- if (!warning_given) {
- warning_given = 1;
- if (! options['3'])
- node_warning(exp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
- else
- node_error(exp, "NEW and DISPOSE are obsolete");
- }
- }
- exp->nd_type = 0;
- arg = getvariable(&arglink, edf, D_USED|D_DEFINED);
- if (! arg) return 0;
- if (! (arg->nd_type->tp_fund == T_POINTER)) {
- df_error(arg, "pointer variable expected", edf);
- return 0;
- }
- /* Now, make it look like a call to ALLOCATE or DEALLOCATE */
- arglink->nd_RIGHT = arg = getnode(Link);
- arg->nd_lineno = exp->nd_lineno;
- arg->nd_symb = ',';
- arg->nd_LEFT = getnode(Value);
- arg = arg->nd_LEFT;
- arg->nd_INT = PointedtoType(arglink->nd_LEFT->nd_type)->tp_size;
- arg->nd_symb = INTEGER;
- arg->nd_lineno = exp->nd_lineno;
- arg->nd_type = card_type;
- /* Ignore other arguments to NEW and/or DISPOSE ??? */
- FreeNode(exp->nd_LEFT);
- exp->nd_LEFT = arg = getnode(Name);
- arg->nd_symb = IDENT;
- arg->nd_lineno = exp->nd_lineno;
- arg->nd_IDF = str2idf(edf->df_value.df_stdname==S_NEW ?
- "ALLOCATE" : "DEALLOCATE", 0);
- return ChkCall(expp);
- #endif
- case S_TSIZE: /* ??? */
- case S_SIZE:
- exp->nd_type = intorcard_type;
- if (!(arg = getname(&arglink,D_FIELD|D_VARIABLE|D_ISTYPE,0,edf))) {
- return 0;
- }
- if (! IsConformantArray(arg->nd_type)) isconstant = 1;
- #ifndef NOSTRICT
- else node_warning(exp,
- W_STRICT,
- "%s on conformant array",
- edf->df_idf->id_text);
- #endif
- #ifndef STRICT_3RD_ED
- if (! options['3'] && edf->df_value.df_stdname == S_TSIZE) {
- if (arg = arglink->nd_RIGHT) {
- node_warning(arg,
- W_OLDFASHIONED,
- "TSIZE with multiple parameters, only first parameter used");
- FreeNode(arg);
- arglink->nd_RIGHT = 0;
- }
- }
- #endif
- break;
- case S_TRUNCD:
- case S_TRUNC:
- if (! getarg(&arglink, T_REAL, 0, edf)) return 0;
- MkCoercion(&(arglink->nd_LEFT),
- edf->df_value.df_stdname == S_TRUNCD ?
- options['l'] ? longcard_type : longint_type
- : card_type);
- free_it = 1;
- break;
- case S_VAL:
- if (!(arg = getname(&arglink, D_ISTYPE, T_NOSUB, edf))) {
- return 0;
- }
- exp->nd_type = arg->nd_def->df_type;
- exp->nd_RIGHT = arglink->nd_RIGHT;
- arglink->nd_RIGHT = 0;
- FreeNode(arglink);
- arglink = exp;
- /* fall through */
- case S_CHR:
- if (! getarg(&arglink, T_CARDINAL, 0, edf)) return 0;
- if (edf->df_value.df_stdname == S_CHR) {
- exp->nd_type = char_type;
- }
- if (exp->nd_type != int_type) {
- MkCoercion(&(arglink->nd_LEFT), exp->nd_type);
- free_it = 1;
- }
- break;
- case S_ADR:
- exp->nd_type = address_type;
- if (! getarg(&arglink, 0, 1, edf)) return 0;
- break;
- case S_DEC:
- case S_INC:
- exp->nd_type = 0;
- if (! (arg = getvariable(&arglink, edf, D_USED|D_DEFINED))) return 0;
- if (! (arg->nd_type->tp_fund & T_DISCRETE)) {
- df_error(arg,"illegal parameter type", edf);
- return 0;
- }
- if (arglink->nd_RIGHT) {
- if (! getarg(&arglink, T_INTORCARD, 0, edf)) return 0;
- }
- break;
- case S_HALT:
- exp->nd_type = 0;
- break;
- case S_EXCL:
- case S_INCL:
- {
- register t_type *tp;
- t_node *dummy;
- exp->nd_type = 0;
- if (!(arg = getvariable(&arglink, edf, D_USED|D_DEFINED))) return 0;
- tp = arg->nd_type;
- if (tp->tp_fund != T_SET) {
- df_error(arg, "SET parameter expected", edf);
- return 0;
- }
- if (!(dummy = getarg(&arglink, 0, 0, edf))) return 0;
- if (!ChkAssCompat(&dummy, ElementType(tp), "EXCL/INCL")) {
- /* What type of compatibility do we want here?
- apparently assignment compatibility! ??? ???
- But we don't want the coercion in the tree, because
- we don't want a range check here. We want a SET
- error.
- */
- return 0;
- }
- MkCoercion(&(arglink->nd_LEFT), word_type);
- break;
- }
- default:
- crash("(ChkStandard)");
- }
- arg = arglink;
- if (arg->nd_RIGHT) {
- df_error(arg->nd_RIGHT, "too many parameters supplied", edf);
- return 0;
- }
- if (isconstant) {
- cstcall(expp, edf->df_value.df_stdname);
- return 1;
- }
- if (free_it) {
- *expp = arg->nd_LEFT;
- exp->nd_RIGHT = arg;
- arg->nd_LEFT = 0;
- FreeNode(exp);
- }
- return 1;
- }
- STATIC int
- ChkCast(expp)
- t_node **expp;
- {
- /* Check a cast and perform it if the argument is constant.
- If the sizes don't match, only complain if at least one of them
- has a size larger than the word size.
- If both sizes are equal to or smaller than the word size, there
- is no problem as such values take a word on the EM stack
- anyway.
- */
- register t_node *exp = *expp;
- register t_node *arg = exp->nd_RIGHT;
- register t_type *lefttype = exp->nd_LEFT->nd_type;
- t_def *df = exp->nd_LEFT->nd_def;
- if ((! arg) || arg->nd_RIGHT) {
- df_error(exp, "type cast must have 1 parameter", df);
- return 0;
- }
- if (! ChkExpression(&(arg->nd_LEFT))) return 0;
- MkCoercion(&(arg->nd_LEFT), BaseType(arg->nd_LEFT->nd_type));
- arg = arg->nd_LEFT;
- if (arg->nd_type->tp_size != lefttype->tp_size &&
- (arg->nd_type->tp_size > word_size ||
- lefttype->tp_size > word_size)) {
- df_error(exp, "unequal sizes in type cast", df);
- return 0;
- }
- if (IsConformantArray(arg->nd_type)) {
- df_error(exp,
- "type transfer function on conformant array not supported",
- df);
- return 0;
- }
- exp->nd_RIGHT->nd_LEFT = 0;
- FreeNode(exp);
- if (arg->nd_class == Value) {
- exp = arg;
- if (lefttype->tp_fund == T_SET) {
- /* User deserves what he gets here ... */
- exp = getnode(Set);
- exp->nd_set = MkSet((unsigned)(lefttype->set_sz));
- exp->nd_set[0] = arg->nd_INT;
- exp->nd_lineno = arg->nd_lineno;
- FreeNode(arg);
- }
- }
- else {
- exp = getnode(Uoper);
- exp->nd_symb = CAST;
- exp->nd_lineno = arg->nd_lineno;
- exp->nd_RIGHT = arg;
- }
- *expp = exp;
- exp->nd_type = lefttype;
- return 1;
- }
- TryToString(nd, tp)
- register t_node *nd;
- t_type *tp;
- {
- /* Try a coercion from character constant to string.
- */
- static char buf[8];
- assert(nd->nd_symb == STRING);
- if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
- buf[0] = nd->nd_INT;
- nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
- nd->nd_SSTR =
- (struct string *) Malloc(sizeof(struct string));
- nd->nd_STR = Salloc(buf, (unsigned) word_size);
- nd->nd_SLE = 1;
- }
- }
- STATIC int
- no_desig(expp)
- t_node **expp;
- {
- node_error(*expp, "designator expected");
- return 0;
- }
- STATIC int
- add_flags(expp, flags)
- t_node **expp;
- {
- (*expp)->nd_def->df_flags |= flags;
- return 1;
- }
- extern int PNodeCrash();
- int (*ExprChkTable[])() = {
- ChkValue,
- ChkArr,
- ChkBinOper,
- ChkUnOper,
- ChkArrow,
- ChkFunCall,
- ChkExSelOrName,
- PNodeCrash,
- ChkSet,
- add_flags,
- PNodeCrash,
- ChkExSelOrName,
- PNodeCrash,
- };
- int (*DesigChkTable[])() = {
- no_desig,
- ChkArr,
- no_desig,
- no_desig,
- ChkArrow,
- no_desig,
- ChkSelOrName,
- PNodeCrash,
- no_desig,
- add_flags,
- PNodeCrash,
- ChkSelOrName,
- PNodeCrash,
- };
|