lang/m2/comp/chk_expr.c

   1 /*
   2  * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
   3  * See the copyright notice in the ACK home directory, in the file "Copyright".
   4  *
   5  * Author: Ceriel J.H. Jacobs
   6  */
   7
   8 /* E X P R E S S I O N   C H E C K I N G */
   9
  10 /* $Id: chk_expr.c,v 1.103 1996/08/14 07:42:25 ceriel Exp $ */
  11
  12 /*      Check expressions, and try to evaluate them as far as possible.
  13 */
  14
  15 #include        "debug.h"
  16
  17 #include        <em_arith.h>
  18 #include        <em_label.h>
  19 #include        <assert.h>
  20 #include        <alloc.h>
  21
  22 #include        "strict3rd.h"
  23 #include        "Lpars.h"
  24 #include        "idf.h"
  25 #include        "type.h"
  26 #include        "LLlex.h"
  27 #include        "def.h"
  28 #include        "node.h"
  29 #include        "scope.h"
  30 #include        "standards.h"
  31 #include        "chk_expr.h"
  32 #include        "misc.h"
  33 #include        "warning.h"
  34 #include        "main.h"
  35 #include        "nostrict.h"
  36
  37 extern char *symbol2str();
  38 extern char *sprint();
  39 extern arith flt_flt2arith();
  40
  41 STATIC
  42 df_error(nd, mess, edf)
  43         t_node          *nd;            /* node on which error occurred */
  44         char            *mess;          /* error message */
  45         register t_def  *edf;           /* do we have a name? */
  46 {
  47         if (edf) {
  48                 if (edf->df_kind != D_ERROR)  {
  49                         node_error(nd,"\"%s\": %s", edf->df_idf->id_text, mess);
  50                 }
  51         }
  52         else node_error(nd, mess);
  53 }
  54
  55 MkCoercion(pnd, tp)
  56         t_node          **pnd;
  57         register t_type *tp;
  58 {
  59         /*      Make a coercion from the node indicated by *pnd to the
  60                 type indicated by tp. If the node indicated by *pnd
  61                 is constant, try to do the coercion compile-time.
  62                 Coercions are inserted in the tree when
  63                 - the expression is not constant or
  64                 - we are in the second pass and the coercion might cause
  65                   an error
  66         */
  67         register t_node *nd = *pnd;
  68         register t_type *nd_tp = nd->nd_type;
  69         extern int      pass_1;
  70         char            *wmess = 0;
  71         arith           op;
  72
  73         if (nd_tp == tp || nd_tp->tp_fund == T_STRING /* Why ??? */) return;
  74         nd_tp = BaseType(nd_tp);
  75         if (nd->nd_class == Value && nd->nd_type != error_type && tp != error_type) {
  76                 if (nd_tp->tp_fund == T_REAL) {
  77                         switch(tp->tp_fund) {
  78                         case T_REAL:
  79                                 nd->nd_type = tp;
  80                                 return;
  81                         case T_CARDINAL:
  82                                 op = flt_flt2arith(&nd->nd_RVAL, 1);
  83                                 break;
  84                         case T_INTEGER:
  85                                 op = flt_flt2arith(&nd->nd_RVAL, 0);
  86                                 break;
  87                         default:
  88                                 crash("MkCoercion");
  89                                 /*NOTREACHED*/
  90                         }
  91                         if (flt_status == FLT_OVFL) {
  92                                 wmess = "conversion";
  93                         }
  94                         if (!wmess || pass_1) {
  95                                 if (nd->nd_RSTR) free(nd->nd_RSTR);
  96                                 free_real(nd->nd_REAL);
  97                                 nd->nd_INT = op;
  98                                 nd->nd_symb = INTEGER;
  99                         }
 100                 }
 101                 switch(tp->tp_fund) {
 102                 case T_REAL: {
 103                         struct real *p = new_real();
 104                         switch(BaseType(nd_tp)->tp_fund) {
 105                         case T_CARDINAL:
 106                         case T_INTORCARD:
 107                                 flt_arith2flt(nd->nd_INT, &p->r_val, 1);
 108                                 break;
 109                         case T_INTEGER:
 110                                 flt_arith2flt(nd->nd_INT, &p->r_val, 0);
 111                                 break;
 112                         default:
 113                                 crash("MkCoercion");
 114                         }
 115                         nd->nd_REAL = p;
 116                         nd->nd_symb = REAL;
 117                         }
 118                         break;
 119                 case T_SUBRANGE:
 120                 case T_ENUMERATION:
 121                 case T_CHAR:
 122                         if (! in_range(nd->nd_INT, tp)) {
 123                                 wmess = "range bound";
 124                         }
 125                         break;
 126                 case T_INTORCARD:
 127                 case T_CARDINAL:
 128                 case T_POINTER:
 129                         if ((nd_tp->tp_fund == T_INTEGER && nd->nd_INT < 0) ||
 130                             (nd->nd_INT & ~full_mask[(int)(tp->tp_size)])) {
 131                                 wmess = "conversion";
 132                         }
 133                         break;
 134                 case T_INTEGER:
 135                         if (! chk_bounds(nd->nd_INT,
 136                                          max_int[(int)(tp->tp_size)],
 137                                          nd_tp->tp_fund) ||
 138                             ! chk_bounds(min_int[(int)(tp->tp_size)],
 139                                          nd->nd_INT,
 140                                          T_INTEGER)) {
 141                                 wmess = "conversion";
 142                         }
 143                         break;
 144                 }
 145                 if (wmess) {
 146                    node_warning(nd, W_ORDINARY, "might cause %s error", wmess);
 147                 }
 148                 if (!wmess || pass_1) {
 149                         nd->nd_type = tp;
 150                         return;
 151                 }
 152         }
 153         *pnd = nd;
 154         nd = getnode(Uoper);
 155         nd->nd_symb = COERCION;
 156         nd->nd_type = tp;
 157         nd->nd_LEFT = NULLNODE;
 158         nd->nd_RIGHT = *pnd;
 159         nd->nd_lineno = (*pnd)->nd_lineno;
 160         *pnd = nd;
 161 }
 162
 163 int
 164 ChkVariable(expp, flags)
 165         register t_node **expp;
 166 {
 167         /*      Check that "expp" indicates an item that can be
 168                 assigned to.
 169         */
 170         register t_node *exp;
 171
 172         if (! ChkDesig(expp, flags)) return 0;
 173
 174         exp = *expp;
 175         if (exp->nd_class == Def &&
 176             ! (exp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
 177                 df_error(exp, "variable expected", exp->nd_def);
 178                 return 0;
 179         }
 180         return 1;
 181 }
 182
 183 STATIC int
 184 ChkArrow(expp)
 185         t_node **expp;
 186 {
 187         /*      Check an application of the '^' operator.
 188                 The operand must be a variable of a pointer type.
 189         */
 190         register t_type *tp;
 191         register t_node *exp = *expp;
 192
 193         assert(exp->nd_class == Arrow);
 194         assert(exp->nd_symb == '^');
 195
 196         exp->nd_type = error_type;
 197
 198         if (! ChkVariable(&(exp->nd_RIGHT), D_USED)) return 0;
 199
 200         tp = exp->nd_RIGHT->nd_type;
 201
 202         if (tp->tp_fund != T_POINTER) {
 203                 node_error(exp, "\"^\": illegal operand type");
 204                 return 0;
 205         }
 206
 207         if ((tp = RemoveEqual(PointedtoType(tp))) == 0) tp = error_type;
 208         exp->nd_type = tp;
 209         return 1;
 210 }
 211
 212 STATIC int
 213 ChkArr(expp, flags)
 214         t_node **expp;
 215 {
 216         /*      Check an array selection.
 217                 The left hand side must be a variable of an array type,
 218                 and the right hand side must be an expression that is
 219                 assignment compatible with the array-index.
 220         */
 221
 222         register t_type *tpl;
 223         register t_node *exp = *expp;
 224
 225         assert(exp->nd_class == Arrsel);
 226         assert(exp->nd_symb == '[' || exp->nd_symb == ',');
 227
 228         exp->nd_type = error_type;
 229
 230         if (! (ChkVariable(&(exp->nd_LEFT), flags) &
 231                ChkExpression(&(exp->nd_RIGHT)))) {
 232                 /* Bitwise and, because we want them both evaluated.
 233                 */
 234                 return 0;
 235         }
 236
 237         tpl = exp->nd_LEFT->nd_type;
 238
 239         if (tpl->tp_fund != T_ARRAY) {
 240                 node_error(exp, "not indexing an ARRAY type");
 241                 return 0;
 242         }
 243         exp->nd_type = RemoveEqual(tpl->arr_elem);
 244
 245         /* Type of the index must be assignment compatible with
 246            the index type of the array (Def 8.1).
 247            However, the index type of a conformant array is not specified.
 248            In our implementation it is CARDINAL.
 249         */
 250         return ChkAssCompat(&(exp->nd_RIGHT),
 251                             BaseType(IndexType(tpl)),
 252                             "index type");
 253 }
 254
 255 /*ARGSUSED*/
 256 STATIC int
 257 ChkValue(expp)
 258         t_node **expp;
 259 {
 260 #ifdef DEBUG
 261         switch((*expp)->nd_symb) {
 262         case REAL:
 263         case STRING:
 264         case INTEGER:
 265                 break;
 266
 267         default:
 268                 crash("(ChkValue)");
 269         }
 270 #endif
 271         return 1;
 272 }
 273
 274 STATIC int
 275 ChkSelOrName(expp, flags)
 276         t_node **expp;
 277 {
 278         /*      Check either an ID or a construction of the form
 279                 ID.ID [ .ID ]*
 280         */
 281         register t_def *df;
 282         register t_node *exp = *expp;
 283
 284         exp->nd_type = error_type;
 285
 286         if (exp->nd_class == Name) {
 287                 df = lookfor(exp, CurrVis, 1, flags);
 288                 exp = getnode(Def);
 289                 exp->nd_def = df;
 290                 exp->nd_lineno = (*expp)->nd_lineno;
 291                 exp->nd_type = RemoveEqual(df->df_type);
 292                 FreeNode(*expp);
 293                 *expp = exp;
 294         }
 295         else if (exp->nd_class == Select) {
 296                 /*      A selection from a record or a module.
 297                         Modules also have a record type.
 298                 */
 299                 register t_node *left;
 300
 301                 assert(exp->nd_symb == '.');
 302
 303                 if (! ChkDesig(&(exp->nd_NEXT), flags)) return 0;
 304
 305                 left = exp->nd_NEXT;
 306                 if (left->nd_class==Def &&
 307                     (left->nd_type->tp_fund != T_RECORD ||
 308                     !(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
 309                     )
 310                    ) {
 311                         df_error(left, "illegal selection", left->nd_def);
 312                         return 0;
 313                 }
 314                 if (left->nd_type->tp_fund != T_RECORD) {
 315                         node_error(left, "illegal selection");
 316                         return 0;
 317                 }
 318
 319                 if (!(df = lookup(exp->nd_IDF, left->nd_type->rec_scope, D_IMPORTED, flags))) {
 320                         id_not_declared(exp);
 321                         return 0;
 322                 }
 323                 exp = getnode(Def);
 324                 exp->nd_def = df;
 325                 exp->nd_type = RemoveEqual(df->df_type);
 326                 exp->nd_lineno = (*expp)->nd_lineno;
 327                 free_node(*expp);
 328                 *expp = exp;
 329                 if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
 330                         /* Fields of a record are always D_QEXPORTED,
 331                            so ...
 332                         */
 333                         df_error(exp, "not exported from qualifying module", df);
 334                 }
 335
 336                 if (!(left->nd_class == Def &&
 337                       left->nd_def->df_kind == D_MODULE)) {
 338                         exp->nd_NEXT = left;
 339                         return 1;
 340                 }
 341                 FreeNode(left);
 342         }
 343
 344         assert(exp->nd_class == Def);
 345
 346         return exp->nd_def->df_kind != D_ERROR;
 347 }
 348
 349 STATIC int
 350 ChkExSelOrName(expp)
 351         t_node **expp;
 352 {
 353         /*      Check either an ID or an ID.ID [.ID]* occurring in an
 354                 expression.
 355         */
 356         register t_def *df;
 357         register t_node *exp;
 358
 359         if (! ChkSelOrName(expp, D_USED)) return 0;
 360
 361         exp = *expp;
 362
 363         df = exp->nd_def;
 364
 365         if (df->df_kind & (D_ENUM | D_CONST)) {
 366                 /* Replace an enum-literal or a CONST identifier by its value.
 367                 */
 368                 exp = getnode(Value);
 369                 exp->nd_type = df->df_type;
 370                 if (df->df_kind == D_ENUM) {
 371                         exp->nd_INT = df->enm_val;
 372                         exp->nd_symb = INTEGER;
 373                 }
 374                 else  {
 375                         assert(df->df_kind == D_CONST);
 376                         exp->nd_token = df->con_const;
 377                 }
 378                 exp->nd_lineno = (*expp)->nd_lineno;
 379                 if (df->df_type->tp_fund == T_SET) {
 380                         exp->nd_class = Set;
 381                         inc_refcount(exp->nd_set);
 382                 }
 383                 else if (df->df_type->tp_fund == T_PROCEDURE) {
 384                         /* for procedure constants */
 385                         exp->nd_class = Def;
 386                 }
 387                 if (df->df_type->tp_fund == T_REAL) {
 388                         struct real *p = exp->nd_REAL;
 389
 390                         exp->nd_REAL = new_real();
 391                         *(exp->nd_REAL) = *p;
 392                         if (p->r_real) {
 393                                 p->r_real = Salloc(p->r_real,
 394                                            (unsigned)(strlen(p->r_real)+1));
 395                         }
 396                 }
 397                 FreeNode(*expp);
 398                 *expp = exp;
 399         }
 400
 401         if (!(df->df_kind & D_VALUE)) {
 402                 df_error(exp, "value expected", df);
 403                 return 0;
 404         }
 405
 406         if (df->df_kind == D_PROCEDURE) {
 407                 /* Check that this procedure is one that we may take the
 408                    address from.
 409                 */
 410                 if (df->df_type == std_type || df->df_scope->sc_level > 0) {
 411                         /* Address of standard or nested procedure
 412                            taken.
 413                         */
 414                         node_error(exp,
 415                            "standard or local procedures may not be assigned");
 416                         return 0;
 417                 }
 418         }
 419
 420         return 1;
 421 }
 422
 423 STATIC int
 424 ChkEl(expp, tp)
 425         register t_node **expp;
 426         t_type *tp;
 427 {
 428
 429         return ChkExpression(expp) && ChkCompat(expp, tp, "set element");
 430 }
 431
 432 STATIC int
 433 ChkElement(expp, tp, set)
 434         t_node **expp;
 435         t_type *tp;
 436         arith *set;
 437 {
 438         /*      Check elements of a set. This routine may call itself
 439                 recursively.
 440                 Also try to compute the set!
 441         */
 442         register t_node *expr = *expp;
 443         t_type *el_type = ElementType(tp);
 444         register unsigned int i;
 445         arith low, high;
 446
 447         if (expr->nd_class == Link && expr->nd_symb == UPTO) {
 448                 /* { ... , expr1 .. expr2,  ... }
 449                    First check expr1 and expr2, and try to compute them.
 450                 */
 451                 if (! (ChkEl(&(expr->nd_LEFT), el_type) &
 452                        ChkEl(&(expr->nd_RIGHT), el_type))) {
 453                         return 0;
 454                 }
 455
 456                 if (!(expr->nd_LEFT->nd_class == Value &&
 457                       expr->nd_RIGHT->nd_class == Value)) {
 458                         return 1;
 459                 }
 460                 /* We have a constant range. Put all elements in the
 461                   set
 462                 */
 463
 464                 low = expr->nd_LEFT->nd_INT;
 465                 high = expr->nd_RIGHT->nd_INT;
 466         }
 467         else {
 468                 if (! ChkEl(expp, el_type)) return 0;
 469                 expr = *expp;
 470                 if (expr->nd_class != Value) {
 471                         return 1;
 472                 }
 473                 low = high = expr->nd_INT;
 474         }
 475         if (! chk_bounds(low, high, BaseType(el_type)->tp_fund)) {
 476                 node_error(expr, "lower bound exceeds upper bound in range");
 477                 return 0;
 478         }
 479
 480         if (! in_range(low, el_type) || ! in_range(high, el_type)) {
 481                 node_error(expr, "set element out of range");
 482                 return 0;
 483         }
 484
 485         low -= tp->set_low;
 486         high -= tp->set_low;
 487         for (i=(unsigned)low; i<= (unsigned)high; i++) {
 488                 set[i/wrd_bits] |= (1<<(i%wrd_bits));
 489         }
 490         FreeNode(expr);
 491         *expp = 0;
 492         return 1;
 493 }
 494
 495 arith *
 496 MkSet(size)
 497         unsigned size;
 498 {
 499         register arith  *s, *t;
 500
 501         s = t = (arith *) Malloc(size);
 502         s++;
 503         size /= sizeof(arith);
 504         while (size--) *t++ = 0;
 505         inc_refcount(s);
 506         return s;
 507 }
 508
 509 FreeSet(s)
 510         register arith *s;
 511 {
 512         dec_refcount(s);
 513         if (refcount(s) <= 0) {
 514                 assert(refcount(s) == 0);
 515                 free((char *) (s-1));
 516         }
 517 }
 518
 519 STATIC int
 520 ChkSet(expp)
 521         t_node **expp;
 522 {
 523         /*      Check the legality of a SET aggregate, and try to evaluate it
 524                 compile time. Unfortunately this is all rather complicated.
 525         */
 526         register t_type *tp;
 527         register t_node *exp = *expp;
 528         register t_node *nd;
 529         register t_def *df;
 530         int retval = 1;
 531         int SetIsConstant = 1;
 532
 533         assert(exp->nd_symb == SET);
 534
 535         *expp = getnode(Set);
 536         (*expp)->nd_type = error_type;
 537         (*expp)->nd_lineno = exp->nd_lineno;
 538
 539         /* First determine the type of the set
 540         */
 541         if (exp->nd_LEFT) {
 542                 /* A type was given. Check it out
 543                 */
 544                 if (! ChkDesig(&(exp->nd_LEFT), D_USED)) return 0;
 545                 nd = exp->nd_LEFT;
 546                 assert(nd->nd_class == Def);
 547                 df = nd->nd_def;
 548
 549                 if (!is_type(df) ||
 550                     (df->df_type->tp_fund != T_SET)) {
 551                         df_error(nd, "not a SET type", df);
 552                         return 0;
 553                 }
 554                 tp = df->df_type;
 555         }
 556         else    tp = bitset_type;
 557         (*expp)->nd_type = tp;
 558
 559         nd = exp->nd_RIGHT;
 560
 561         /* Now check the elements given, and try to compute a constant set.
 562            First allocate room for the set.
 563         */
 564
 565         (*expp)->nd_set = MkSet(tp->set_sz);
 566
 567         /* Now check the elements, one by one
 568         */
 569         while (nd) {
 570                 assert(nd->nd_class == Link && nd->nd_symb == ',');
 571
 572                 if (!ChkElement(&(nd->nd_LEFT), tp, (*expp)->nd_set)) {
 573                         retval = 0;
 574                 }
 575                 if (nd->nd_LEFT) SetIsConstant = 0;
 576                 nd = nd->nd_RIGHT;
 577         }
 578
 579         if (! SetIsConstant) {
 580                 (*expp)->nd_NEXT = exp->nd_RIGHT;
 581                 exp->nd_RIGHT = 0;
 582         }
 583         FreeNode(exp);
 584         return retval;
 585 }
 586
 587 STATIC t_node *
 588 nextarg(argp, edf)
 589         t_node **argp;
 590         t_def *edf;
 591 {
 592         register t_node *arg = (*argp)->nd_RIGHT;
 593
 594         if (! arg) {
 595                 df_error(*argp, "too few arguments supplied", edf);
 596                 return 0;
 597         }
 598
 599         *argp = arg;
 600         return arg;
 601 }
 602
 603 STATIC t_node *
 604 getarg(argp, bases, designator, edf)
 605         t_node **argp;
 606         t_def *edf;
 607 {
 608         /*      This routine is used to fetch the next argument from an
 609                 argument list. The argument list is indicated by "argp".
 610                 The parameter "bases" is a bitset indicating which types
 611                 are allowed at this point, and "designator" is a flag
 612                 indicating that the address from this argument is taken, so
 613                 that it must be a designator and may not be a register
 614                 variable.
 615         */
 616         register t_node *arg = nextarg(argp, edf);
 617         register t_node *left;
 618
 619         if (! arg ||
 620             ! arg->nd_LEFT ||
 621             ! (designator ? ChkVariable(&(arg->nd_LEFT), D_USED|D_DEFINED) : ChkExpression(&(arg->nd_LEFT)))) {
 622                 return 0;
 623         }
 624         left = arg->nd_LEFT;
 625
 626         if (designator && left->nd_class==Def) {
 627                 left->nd_def->df_flags |= D_NOREG;
 628         }
 629
 630         if (bases) {
 631                 t_type *tp = BaseType(left->nd_type);
 632
 633                 if (! designator) MkCoercion(&(arg->nd_LEFT), tp);
 634                 left = arg->nd_LEFT;
 635                 if (!(tp->tp_fund & bases)) {
 636                         df_error(left, "unexpected parameter type", edf);
 637                         return 0;
 638                 }
 639         }
 640
 641         return left;
 642 }
 643
 644 STATIC t_node *
 645 getname(argp, kinds, bases, edf)
 646         t_node **argp;
 647         t_def *edf;
 648 {
 649         /*      Get the next argument from argument list "argp".
 650                 The argument must indicate a definition, and the
 651                 definition kind must be one of "kinds".
 652         */
 653         register t_node *arg = nextarg(argp, edf);
 654         register t_node *left;
 655
 656         if (!arg || !arg->nd_LEFT || ! ChkDesig(&(arg->nd_LEFT), D_USED)) return 0;
 657
 658         left = arg->nd_LEFT;
 659         if (left->nd_class != Def) {
 660                 df_error(left, "identifier expected", edf);
 661                 return 0;
 662         }
 663
 664         if (!(left->nd_def->df_kind & kinds) ||
 665             (bases && !(left->nd_type->tp_fund & bases))) {
 666                 df_error(left, "unexpected parameter type", edf);
 667                 return 0;
 668         }
 669
 670         return left;
 671 }
 672
 673 STATIC int
 674 ChkProcCall(exp)
 675         register t_node *exp;
 676 {
 677         /*      Check a procedure call
 678         */
 679         register t_node *left;
 680         t_node *argp;
 681         t_def *edf = 0;
 682         register t_param *param;
 683         int retval = 1;
 684         int cnt = 0;
 685
 686         left = exp->nd_LEFT;
 687         if (left->nd_class == Def) {
 688                 edf = left->nd_def;
 689         }
 690         if (left->nd_type == error_type) {
 691                 /* Just check parameters as if they were value parameters
 692                 */
 693                 argp = exp;
 694                 while (argp->nd_RIGHT) {
 695                         if (getarg(&argp, 0, 0, edf)) { }
 696                 }
 697                 return 0;
 698         }
 699
 700         exp->nd_type = RemoveEqual(ResultType(left->nd_type));
 701
 702         /* Check parameter list
 703         */
 704         argp = exp;
 705         for (param = ParamList(left->nd_type); param; param = param->par_next) {
 706                 if (!(left = getarg(&argp, 0, IsVarParam(param), edf))) {
 707                         retval = 0;
 708                         cnt++;
 709                         continue;
 710                 }
 711                 cnt++;
 712                 if (left->nd_symb == STRING) {
 713                         TryToString(left, TypeOfParam(param));
 714                 }
 715                 if (! TstParCompat(cnt,
 716                                    RemoveEqual(TypeOfParam(param)),
 717                                    IsVarParam(param),
 718                                    &(argp->nd_LEFT),
 719                                    edf)) {
 720                         retval = 0;
 721                 }
 722         }
 723
 724         exp = argp;
 725         if (exp->nd_RIGHT) {
 726                 df_error(exp->nd_RIGHT,"too many parameters supplied",edf);
 727                 while (argp->nd_RIGHT) {
 728                         if (getarg(&argp, 0, 0, edf)) { }
 729                 }
 730                 return 0;
 731         }
 732
 733         return retval;
 734 }
 735
 736 STATIC int
 737 ChkFunCall(expp)
 738         register t_node **expp;
 739 {
 740         /*      Check a call that must have a result
 741         */
 742
 743         if (ChkCall(expp)) {
 744                 if ((*expp)->nd_type != 0) return 1;
 745                 node_error(*expp, "function call expected");
 746         }
 747         (*expp)->nd_type = error_type;
 748         return 0;
 749 }
 750
 751 STATIC int ChkStandard();
 752 STATIC int ChkCast();
 753
 754 int
 755 ChkCall(expp)
 756         t_node **expp;
 757 {
 758         /*      Check something that looks like a procedure or function call.
 759                 Of course this does not have to be a call at all,
 760                 it may also be a cast or a standard procedure call.
 761         */
 762
 763         /* First, get the name of the function or procedure
 764         */
 765         if (ChkDesig(&((*expp)->nd_LEFT), D_USED)) {
 766                 register t_node *left = (*expp)->nd_LEFT;
 767
 768                 if (IsCast(left)) {
 769                         /* It was a type cast.
 770                         */
 771                         return ChkCast(expp);
 772                 }
 773
 774                 if (IsProc(left) || left->nd_type == error_type) {
 775                         /* A procedure call.
 776                            It may also be a call to a standard procedure
 777                         */
 778                         if (left->nd_type == std_type) {
 779                                 /* A standard procedure
 780                                 */
 781                                 return ChkStandard(expp);
 782                         }
 783                         /* Here, we have found a real procedure call.
 784                            The left hand side may also represent a procedure
 785                            variable.
 786                         */
 787                 }
 788                 else {
 789                         node_error(left, "procedure, type, or function expected");
 790                         left->nd_type = error_type;
 791                 }
 792         }
 793         return ChkProcCall(*expp);
 794 }
 795
 796 STATIC t_type *
 797 ResultOfOperation(operator, tp)
 798         t_type *tp;
 799 {
 800         /*      Return the result type of the binary operation "operator",
 801                 with operand type "tp".
 802         */
 803
 804         switch(operator) {
 805         case '=':
 806         case '#':
 807         case GREATEREQUAL:
 808         case LESSEQUAL:
 809         case '<':
 810         case '>':
 811         case IN:
 812                 return bool_type;
 813         }
 814
 815         return tp;
 816 }
 817
 818 #define Boolean(operator) (operator == OR || operator == AND)
 819
 820 STATIC int
 821 AllowedTypes(operator)
 822 {
 823         /*      Return a bit mask indicating the allowed operand types
 824                 for binary operator "operator".
 825         */
 826
 827         switch(operator) {
 828         case '+':
 829         case '-':
 830         case '*':
 831                 return T_NUMERIC|T_SET;
 832         case '/':
 833                 return T_REAL|T_SET;
 834         case DIV:
 835         case MOD:
 836                 return T_INTORCARD;
 837         case OR:
 838         case AND:
 839                 return T_ENUMERATION;
 840         case '=':
 841         case '#':
 842                 return T_POINTER|T_HIDDEN|T_SET|T_NUMERIC|T_ENUMERATION|T_CHAR;
 843         case GREATEREQUAL:
 844         case LESSEQUAL:
 845                 return T_SET|T_NUMERIC|T_CHAR|T_ENUMERATION;
 846         case '<':
 847         case '>':
 848                 return T_NUMERIC|T_CHAR|T_ENUMERATION;
 849         default:
 850                 crash("(AllowedTypes)");
 851         }
 852         /*NOTREACHED*/
 853 }
 854
 855 STATIC int
 856 ChkAddressOper(tpl, tpr, expp)
 857         register t_type *tpl, *tpr;
 858         register t_node *expp;
 859 {
 860         /*      Check that either "tpl" or "tpr" are both of type
 861                 address_type, or that one of them is, but the other is
 862                 of a cardinal type.
 863                 Also insert proper coercions, making sure that the EM pointer
 864                 arithmetic instructions can be generated whenever possible
 865         */
 866
 867         if (tpr == address_type && expp->nd_symb == '+') {
 868                 /* use the fact that '+' is a commutative operator */
 869                 t_type *tmptype = tpr;
 870                 t_node *tmpnode = expp->nd_RIGHT;
 871
 872                 tpr = tpl;
 873                 expp->nd_RIGHT = expp->nd_LEFT;
 874                 tpl = tmptype;
 875                 expp->nd_LEFT = tmpnode;
 876         }
 877
 878         if (tpl == address_type) {
 879                 expp->nd_type = address_type;
 880                 if (tpr == address_type) {
 881                         return 1;
 882                 }
 883                 if (tpr->tp_fund & T_CARDINAL) {
 884                         MkCoercion(&(expp->nd_RIGHT),
 885                                    expp->nd_symb=='+' || expp->nd_symb=='-' ?
 886                                         tpr :
 887                                         address_type);
 888                         return 1;
 889                 }
 890                 return 0;
 891         }
 892
 893         if (tpr == address_type && tpl->tp_fund & T_CARDINAL) {
 894                 expp->nd_type = address_type;
 895                 MkCoercion(&(expp->nd_LEFT), address_type);
 896                 return 1;
 897         }
 898
 899         return 0;
 900 }
 901
 902 STATIC int
 903 ChkBinOper(expp)
 904         t_node **expp;
 905 {
 906         /*      Check a binary operation.
 907         */
 908         register t_node *exp = *expp;
 909         register t_type *tpl, *tpr;
 910         t_type *result_type;
 911         int allowed;
 912         int retval;
 913         char *symb;
 914
 915         /* First, check BOTH operands */
 916
 917         retval = ChkExpression(&(exp->nd_LEFT));
 918         retval &= ChkExpression(&(exp->nd_RIGHT));
 919
 920         tpl = BaseType(exp->nd_LEFT->nd_type);
 921         tpr = BaseType(exp->nd_RIGHT->nd_type);
 922
 923         if (intorcard(tpl, tpr) != 0) {
 924                 if (tpl->tp_fund == T_INTORCARD) {
 925                          exp->nd_LEFT->nd_type = tpl = tpr;
 926                 }
 927                 if (tpr->tp_fund == T_INTORCARD) {
 928                         exp->nd_RIGHT->nd_type = tpr = tpl;
 929                 }
 930         }
 931
 932         exp->nd_type = result_type = ResultOfOperation(exp->nd_symb, tpr);
 933
 934         /* Check that the application of the operator is allowed on the type
 935            of the operands.
 936            There are three tricky parts:
 937            - Boolean operators are only allowed on boolean operands, but
 938              the "allowed-mask" of "AllowedTypes" can only indicate
 939              an enumeration type.
 940            - All operations that are allowed on CARDINALS are also allowed
 941              on ADDRESS.
 942            - The IN-operator has as right-hand-size operand a set.
 943         */
 944         if (exp->nd_symb == IN) {
 945                 if (tpr->tp_fund != T_SET) {
 946                         node_error(exp, "\"IN\": right operand must be a set");
 947                         return 0;
 948                 }
 949                 if (!TstAssCompat(ElementType(tpr), tpl)) {
 950                         /* Assignment compatible ???
 951                            I don't know! Should we be allowed to check
 952                            if a INTEGER is a member of a BITSET???
 953                         */
 954                         node_error(exp->nd_LEFT, "type incompatibility in IN");
 955                         return 0;
 956                 }
 957                 MkCoercion(&(exp->nd_LEFT), word_type);
 958                 if (exp->nd_LEFT->nd_class == Value &&
 959                     exp->nd_RIGHT->nd_class == Set &&
 960                     ! exp->nd_RIGHT->nd_NEXT) {
 961                         cstset(expp);
 962                 }
 963                 return retval;
 964         }
 965
 966         if (!retval) return 0;
 967
 968         allowed = AllowedTypes(exp->nd_symb);
 969
 970         symb = symbol2str(exp->nd_symb);
 971         if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
 972                 if (!((T_CARDINAL & allowed) &&
 973                      ChkAddressOper(tpl, tpr, exp))) {
 974                         node_error(exp, "\"%s\": illegal operand type(s)", symb);
 975                         return 0;
 976                 }
 977                 if (result_type == bool_type) exp->nd_type = bool_type;
 978         }
 979         else {
 980                 if (Boolean(exp->nd_symb) && tpl != bool_type) {
 981                         node_error(exp, "\"%s\": illegal operand type(s)", symb);
 982                         return 0;
 983                 }
 984
 985                 /* Operands must be compatible (distilled from Def 8.2)
 986                 */
 987                 if (!TstCompat(tpr, tpl)) {
 988                         extern char *incompat();
 989                         node_error(exp, "\"%s\": %s in operands", symb, incompat(tpl, tpr));
 990                         return 0;
 991                 }
 992
 993                 MkCoercion(&(exp->nd_LEFT), tpl);
 994                 MkCoercion(&(exp->nd_RIGHT), tpr);
 995         }
 996
 997         if (tpl->tp_fund == T_SET) {
 998                 if (exp->nd_LEFT->nd_class == Set &&
 999                     ! exp->nd_LEFT->nd_NEXT &&
1000                     exp->nd_RIGHT->nd_class == Set &&
1001                         ! exp->nd_RIGHT->nd_NEXT) {
1002                         cstset(expp);
1003                 }
1004         }
1005         else if ( exp->nd_LEFT->nd_class == Value &&
1006                   exp->nd_RIGHT->nd_class == Value) {
1007                 if (tpl->tp_fund == T_INTEGER) {
1008                         cstibin(expp);
1009                 }
1010                 else if (tpl->tp_fund == T_REAL) {
1011                         cstfbin(expp);
1012                 }
1013                 else    cstubin(expp);
1014         }
1015
1016         return 1;
1017 }
1018
1019 STATIC int
1020 ChkUnOper(expp)
1021         t_node **expp;
1022 {
1023         /*      Check an unary operation.
1024         */
1025         register t_node *exp = *expp;
1026         register t_node *right = exp->nd_RIGHT;
1027         register t_type *tpr;
1028
1029         if (exp->nd_symb == COERCION) return 1;
1030         if (exp->nd_symb == '(') {
1031                 *expp = right;
1032                 free_node(exp);
1033                 return ChkExpression(expp);
1034         }
1035         exp->nd_type = error_type;
1036         if (! ChkExpression(&(exp->nd_RIGHT))) return 0;
1037         exp->nd_type = tpr = BaseType(exp->nd_RIGHT->nd_type);
1038         MkCoercion(&(exp->nd_RIGHT), tpr);
1039         right = exp->nd_RIGHT;
1040
1041         if (tpr == address_type) tpr = card_type;
1042
1043         switch(exp->nd_symb) {
1044         case '+':
1045                 if (!(tpr->tp_fund & T_NUMERIC)) break;
1046                 *expp = right;
1047                 free_node(exp);
1048                 return 1;
1049
1050         case '-':
1051                 if (tpr->tp_fund == T_INTORCARD || tpr->tp_fund == T_INTEGER) {
1052                         if (tpr == intorcard_type) {
1053                                 exp->nd_type = int_type;
1054                         }
1055                         else if (tpr == longintorcard_type) {
1056                                 exp->nd_type = longint_type;
1057                         }
1058                         if (right->nd_class == Value) {
1059                                 cstunary(expp);
1060                         }
1061                         return 1;
1062                 }
1063                 else if (tpr->tp_fund == T_REAL) {
1064                         if (right->nd_class == Value) {
1065                                 *expp = right;
1066                                 flt_umin(&(right->nd_RVAL));
1067                                 if (right->nd_RSTR) {
1068                                         free(right->nd_RSTR);
1069                                         right->nd_RSTR = 0;
1070                                 }
1071                                 free_node(exp);
1072                         }
1073                         return 1;
1074                 }
1075                 break;
1076
1077         case NOT:
1078         case '~':
1079                 if (tpr == bool_type) {
1080                         if (right->nd_class == Value) {
1081                                 cstunary(expp);
1082                         }
1083                         return 1;
1084                 }
1085                 break;
1086
1087         default:
1088                 crash("ChkUnOper");
1089         }
1090         node_error(exp, "\"%s\": illegal operand type", symbol2str(exp->nd_symb));
1091         return 0;
1092 }
1093
1094 STATIC t_node *
1095 getvariable(argp, edf, flags)
1096         t_node **argp;
1097         t_def *edf;
1098 {
1099         /*      Get the next argument from argument list "argp".
1100                 It must obey the rules of "ChkVariable".
1101         */
1102         register t_node *arg = nextarg(argp, edf);
1103
1104         if (! arg ||
1105             ! arg->nd_LEFT ||
1106             ! ChkVariable(&(arg->nd_LEFT), flags)) return 0;
1107
1108         return arg->nd_LEFT;
1109 }
1110
1111 STATIC int
1112 ChkStandard(expp)
1113         t_node **expp;
1114 {
1115         /*      Check a call of a standard procedure or function
1116         */
1117         register t_node *exp = *expp;
1118         t_node *arglink = exp;
1119         register t_node *arg;
1120         register t_def *edf = exp->nd_LEFT->nd_def;
1121         int free_it = 0;
1122         int isconstant = 0;
1123
1124         assert(exp->nd_LEFT->nd_class == Def);
1125
1126         exp->nd_type = error_type;
1127         switch(edf->df_value.df_stdname) {
1128         case S_ABS:
1129                 if (!(arg = getarg(&arglink, T_NUMERIC, 0, edf))) return 0;
1130                 exp->nd_type = BaseType(arg->nd_type);
1131                 MkCoercion(&(arglink->nd_LEFT), exp->nd_type);
1132                 arg = arglink->nd_LEFT;
1133                 if (! (exp->nd_type->tp_fund & (T_INTEGER|T_REAL))) {
1134                         free_it = 1;
1135                 }
1136                 if (arg->nd_class == Value) {
1137                         switch(exp->nd_type->tp_fund) {
1138                         case T_REAL:
1139                                 arg->nd_RVAL.flt_sign = 0;
1140                                 free_it = 1;
1141                                 break;
1142                         case T_INTEGER:
1143                                 isconstant = 1;
1144                                 break;
1145                         }
1146                 }
1147                 break;
1148
1149         case S_CAP:
1150                 exp->nd_type = char_type;
1151                 if (!(arg = getarg(&arglink, T_CHAR, 0, edf))) return 0;
1152                 if (arg->nd_class == Value) isconstant = 1;
1153                 break;
1154
1155         case S_FLOATD:
1156         case S_FLOAT:
1157                 if (! getarg(&arglink, T_INTORCARD, 0, edf)) return 0;
1158                 arg = arglink;
1159                 if (edf->df_value.df_stdname == S_FLOAT) {
1160                         MkCoercion(&(arg->nd_LEFT), card_type);
1161                 }
1162                 MkCoercion(&(arg->nd_LEFT),
1163                            edf->df_value.df_stdname == S_FLOATD ?
1164                                 longreal_type :
1165                                 real_type);
1166                 free_it = 1;
1167                 break;
1168
1169         case S_SHORT:
1170         case S_LONG: {
1171                 t_type *tp;
1172                 t_type *s1, *s2, *s3, *d1, *d2, *d3;
1173
1174                 if (!(arg = getarg(&arglink, 0, 0, edf))) {
1175                         return 0;
1176                 }
1177                 tp = BaseType(arg->nd_type);
1178
1179                 if (edf->df_value.df_stdname == S_SHORT) {
1180                         s1 = longint_type;
1181                         d1 = int_type;
1182                         s2 = longreal_type;
1183                         d2 = real_type;
1184                         s3 = longcard_type;
1185                         d3 = card_type;
1186                 }
1187                 else {
1188                         d1 = longint_type;
1189                         s1 = int_type;
1190                         d2 = longreal_type;
1191                         s2 = real_type;
1192                         d3 = longcard_type;
1193                         s3 = card_type;
1194                 }
1195
1196                 if (tp == s1) {
1197                         MkCoercion(&(arglink->nd_LEFT), d1);
1198                 }
1199                 else if (tp == s2) {
1200                         MkCoercion(&(arglink->nd_LEFT), d2);
1201                 }
1202                 else if (options['l'] && tp == s3) {
1203                         MkCoercion(&(arglink->nd_LEFT), d3);
1204                 }
1205                 else {
1206                         df_error(arg, "unexpected parameter type", edf);
1207                         break;
1208                 }
1209                 free_it = 1;
1210                 break;
1211                 }
1212
1213         case S_HIGH:
1214                 if (!(arg = getarg(&arglink, T_ARRAY|T_STRING|T_CHAR, 0, edf))) {
1215                         return 0;
1216                 }
1217                 if (arg->nd_type->tp_fund == T_ARRAY) {
1218                         exp->nd_type = IndexType(arg->nd_type);
1219                         if (! IsConformantArray(arg->nd_type)) {
1220                                 arg->nd_type = exp->nd_type;
1221                                 isconstant = 1;
1222                         }
1223                         break;
1224                 }
1225                 if (arg->nd_symb != STRING) {
1226                         df_error(arg,"array parameter expected", edf);
1227                         return 0;
1228                 }
1229                 exp = getnode(Value);
1230                 exp->nd_type = card_type;
1231                 /* Notice that we could disallow HIGH("") here by checking
1232                    that arg->nd_type->tp_fund != T_CHAR || arg->nd_INT != 0.
1233                    ??? For the time being, we don't. !!!
1234                    Maybe the empty string should not be allowed at all.
1235                 */
1236                 exp->nd_INT = arg->nd_type->tp_fund == T_CHAR ? 0 :
1237                                         arg->nd_SLE - 1;
1238                 exp->nd_symb = INTEGER;
1239                 exp->nd_lineno = (*expp)->nd_lineno;
1240                 (*expp)->nd_RIGHT = 0;
1241                 FreeNode(*expp);
1242                 *expp = exp;
1243                 break;
1244
1245         case S_MAX:
1246         case S_MIN:
1247                 if (!(arg = getname(&arglink, D_ISTYPE, T_DISCRETE, edf))) {
1248                         return 0;
1249                 }
1250                 exp->nd_type = arg->nd_type;
1251                 isconstant = 1;
1252                 break;
1253
1254         case S_ODD:
1255                 if (! (arg = getarg(&arglink, T_INTORCARD, 0, edf))) return 0;
1256                 MkCoercion(&(arglink->nd_LEFT), BaseType(arg->nd_type));
1257                 exp->nd_type = bool_type;
1258                 if (arglink->nd_LEFT->nd_class == Value) isconstant = 1;
1259                 break;
1260
1261         case S_ORD:
1262                 if (! (arg = getarg(&arglink, T_NOSUB, 0, edf))) return 0;
1263                 exp->nd_type = card_type;
1264                 if (arg->nd_class == Value) {
1265                         arg->nd_type = card_type;
1266                         free_it = 1;
1267                 }
1268                 break;
1269
1270 #ifndef STRICT_3RD_ED
1271         case S_NEW:
1272         case S_DISPOSE:
1273                 {
1274                         static int warning_given = 0;
1275
1276                         if (!warning_given) {
1277                                 warning_given = 1;
1278                                 if (! options['3'])
1279         node_warning(exp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
1280                                 else
1281         node_error(exp, "NEW and DISPOSE are obsolete");
1282                         }
1283                 }
1284                 exp->nd_type = 0;
1285                 arg = getvariable(&arglink, edf, D_USED|D_DEFINED);
1286                 if (! arg) return 0;
1287                 if (! (arg->nd_type->tp_fund == T_POINTER)) {
1288                         df_error(arg, "pointer variable expected", edf);
1289                         return 0;
1290                 }
1291                 /* Now, make it look like a call to ALLOCATE or DEALLOCATE */
1292                 arglink->nd_RIGHT = arg = getnode(Link);
1293                 arg->nd_lineno = exp->nd_lineno;
1294                 arg->nd_symb = ',';
1295                 arg->nd_LEFT = getnode(Value);
1296                 arg = arg->nd_LEFT;
1297                 arg->nd_INT = PointedtoType(arglink->nd_LEFT->nd_type)->tp_size;
1298                 arg->nd_symb = INTEGER;
1299                 arg->nd_lineno = exp->nd_lineno;
1300                 arg->nd_type = card_type;
1301                 /* Ignore other arguments to NEW and/or DISPOSE ??? */
1302
1303                 FreeNode(exp->nd_LEFT);
1304                 exp->nd_LEFT = arg = getnode(Name);
1305                 arg->nd_symb = IDENT;
1306                 arg->nd_lineno = exp->nd_lineno;
1307                 arg->nd_IDF = str2idf(edf->df_value.df_stdname==S_NEW ?
1308                                         "ALLOCATE" : "DEALLOCATE", 0);
1309                 return ChkCall(expp);
1310 #endif
1311
1312         case S_TSIZE:   /* ??? */
1313         case S_SIZE:
1314                 exp->nd_type = intorcard_type;
1315                 if (!(arg = getname(&arglink,D_FIELD|D_VARIABLE|D_ISTYPE,0,edf))) {
1316                         return 0;
1317                 }
1318                 if (! IsConformantArray(arg->nd_type)) isconstant = 1;
1319 #ifndef NOSTRICT
1320                 else node_warning(exp,
1321                                   W_STRICT,
1322                                   "%s on conformant array",
1323                                   edf->df_idf->id_text);
1324 #endif
1325 #ifndef STRICT_3RD_ED
1326                 if (! options['3'] && edf->df_value.df_stdname == S_TSIZE) {
1327                         if (arg = arglink->nd_RIGHT) {
1328                                 node_warning(arg,
1329                                              W_OLDFASHIONED,
1330                                              "TSIZE with multiple parameters, only first parameter used");
1331                                 FreeNode(arg);
1332                                 arglink->nd_RIGHT = 0;
1333                         }
1334                 }
1335 #endif
1336                 break;
1337
1338         case S_TRUNCD:
1339         case S_TRUNC:
1340                 if (! getarg(&arglink, T_REAL, 0, edf)) return 0;
1341                 MkCoercion(&(arglink->nd_LEFT),
1342                            edf->df_value.df_stdname == S_TRUNCD ?
1343                                 options['l'] ? longcard_type : longint_type
1344                                         : card_type);
1345                 free_it = 1;
1346                 break;
1347
1348         case S_VAL:
1349                 if (!(arg = getname(&arglink, D_ISTYPE, T_NOSUB, edf))) {
1350                         return 0;
1351                 }
1352                 exp->nd_type = arg->nd_def->df_type;
1353                 exp->nd_RIGHT = arglink->nd_RIGHT;
1354                 arglink->nd_RIGHT = 0;
1355                 FreeNode(arglink);
1356                 arglink = exp;
1357                 /* fall through */
1358         case S_CHR:
1359                 if (! getarg(&arglink, T_CARDINAL, 0, edf)) return 0;
1360                 if (edf->df_value.df_stdname == S_CHR) {
1361                         exp->nd_type = char_type;
1362                 }
1363                 if (exp->nd_type != int_type) {
1364                         MkCoercion(&(arglink->nd_LEFT), exp->nd_type);
1365                         free_it = 1;
1366                 }
1367                 break;
1368
1369         case S_ADR:
1370                 exp->nd_type = address_type;
1371                 if (! getarg(&arglink, 0, 1, edf)) return 0;
1372                 break;
1373
1374         case S_DEC:
1375         case S_INC:
1376                 exp->nd_type = 0;
1377                 if (! (arg = getvariable(&arglink, edf, D_USED|D_DEFINED))) return 0;
1378                 if (! (arg->nd_type->tp_fund & T_DISCRETE)) {
1379                         df_error(arg,"illegal parameter type", edf);
1380                         return 0;
1381                 }
1382                 if (arglink->nd_RIGHT) {
1383                         if (! getarg(&arglink, T_INTORCARD, 0, edf)) return 0;
1384                 }
1385                 break;
1386
1387         case S_HALT:
1388                 exp->nd_type = 0;
1389                 break;
1390
1391         case S_EXCL:
1392         case S_INCL:
1393                 {
1394                 register t_type *tp;
1395                 t_node *dummy;
1396
1397                 exp->nd_type = 0;
1398                 if (!(arg = getvariable(&arglink, edf, D_USED|D_DEFINED))) return 0;
1399                 tp = arg->nd_type;
1400                 if (tp->tp_fund != T_SET) {
1401                         df_error(arg, "SET parameter expected", edf);
1402                         return 0;
1403                 }
1404                 if (!(dummy = getarg(&arglink, 0, 0, edf))) return 0;
1405                 if (!ChkAssCompat(&dummy, ElementType(tp), "EXCL/INCL")) {
1406                         /* What type of compatibility do we want here?
1407                            apparently assignment compatibility! ??? ???
1408                            But we don't want the coercion in the tree, because
1409                            we don't want a range check here. We want a SET
1410                            error.
1411                         */
1412                         return 0;
1413                 }
1414                 MkCoercion(&(arglink->nd_LEFT), word_type);
1415                 break;
1416                 }
1417
1418         default:
1419                 crash("(ChkStandard)");
1420         }
1421
1422         arg = arglink;
1423
1424         if (arg->nd_RIGHT) {
1425                 df_error(arg->nd_RIGHT, "too many parameters supplied", edf);
1426                 return 0;
1427         }
1428
1429         if (isconstant) {
1430                 cstcall(expp, edf->df_value.df_stdname);
1431                 return 1;
1432         }
1433         if (free_it) {
1434                 *expp = arg->nd_LEFT;
1435                 exp->nd_RIGHT = arg;
1436                 arg->nd_LEFT = 0;
1437                 FreeNode(exp);
1438         }
1439
1440         return 1;
1441 }
1442
1443 STATIC int
1444 ChkCast(expp)
1445         t_node **expp;
1446 {
1447         /*      Check a cast and perform it if the argument is constant.
1448                 If the sizes don't match, only complain if at least one of them
1449                 has a size larger than the word size.
1450                 If both sizes are equal to or smaller than the word size, there
1451                 is no problem as such values take a word on the EM stack
1452                 anyway.
1453         */
1454         register t_node *exp = *expp;
1455         register t_node *arg = exp->nd_RIGHT;
1456         register t_type *lefttype = exp->nd_LEFT->nd_type;
1457         t_def           *df = exp->nd_LEFT->nd_def;
1458
1459         if ((! arg) || arg->nd_RIGHT) {
1460                 df_error(exp, "type cast must have 1 parameter", df);
1461                 return 0;
1462         }
1463
1464         if (! ChkExpression(&(arg->nd_LEFT))) return 0;
1465
1466         MkCoercion(&(arg->nd_LEFT), BaseType(arg->nd_LEFT->nd_type));
1467
1468         arg = arg->nd_LEFT;
1469         if (arg->nd_type->tp_size != lefttype->tp_size &&
1470             (arg->nd_type->tp_size > word_size ||
1471              lefttype->tp_size > word_size)) {
1472                 df_error(exp, "unequal sizes in type cast", df);
1473                 return 0;
1474         }
1475
1476         if (IsConformantArray(arg->nd_type)) {
1477                 df_error(exp,
1478                   "type transfer function on conformant array not supported",
1479                   df);
1480                 return 0;
1481         }
1482
1483         exp->nd_RIGHT->nd_LEFT = 0;
1484         FreeNode(exp);
1485         if (arg->nd_class == Value) {
1486                 exp = arg;
1487                 if (lefttype->tp_fund == T_SET) {
1488                         /* User deserves what he gets here ... */
1489                         exp = getnode(Set);
1490                         exp->nd_set = MkSet((unsigned)(lefttype->set_sz));
1491                         exp->nd_set[0] = arg->nd_INT;
1492                         exp->nd_lineno = arg->nd_lineno;
1493                         FreeNode(arg);
1494                 }
1495         }
1496         else {
1497                 exp = getnode(Uoper);
1498                 exp->nd_symb = CAST;
1499                 exp->nd_lineno = arg->nd_lineno;
1500                 exp->nd_RIGHT = arg;
1501         }
1502         *expp = exp;
1503         exp->nd_type = lefttype;
1504
1505         return 1;
1506 }
1507
1508 TryToString(nd, tp)
1509         register t_node *nd;
1510         t_type *tp;
1511 {
1512         /*      Try a coercion from character constant to string.
1513         */
1514         static char buf[8];
1515
1516         assert(nd->nd_symb == STRING);
1517
1518         if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
1519                 buf[0] = nd->nd_INT;
1520                 nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
1521                 nd->nd_SSTR =
1522                         (struct string *) Malloc(sizeof(struct string));
1523                 nd->nd_STR = Salloc(buf, (unsigned) word_size);
1524                 nd->nd_SLE = 1;
1525         }
1526 }
1527
1528 STATIC int
1529 no_desig(expp)
1530         t_node **expp;
1531 {
1532         node_error(*expp, "designator expected");
1533         return 0;
1534 }
1535
1536 STATIC int
1537 add_flags(expp, flags)
1538         t_node **expp;
1539 {
1540         (*expp)->nd_def->df_flags |= flags;
1541         return 1;
1542 }
1543
1544 extern int      PNodeCrash();
1545
1546 int (*ExprChkTable[])() = {
1547         ChkValue,
1548         ChkArr,
1549         ChkBinOper,
1550         ChkUnOper,
1551         ChkArrow,
1552         ChkFunCall,
1553         ChkExSelOrName,
1554         PNodeCrash,
1555         ChkSet,
1556         add_flags,
1557         PNodeCrash,
1558         ChkExSelOrName,
1559         PNodeCrash,
1560 };
1561
1562 int (*DesigChkTable[])() = {
1563         no_desig,
1564         ChkArr,
1565         no_desig,
1566         no_desig,
1567         ChkArrow,
1568         no_desig,
1569         ChkSelOrName,
1570         PNodeCrash,
1571         no_desig,
1572         add_flags,
1573         PNodeCrash,
1574         ChkSelOrName,
1575         PNodeCrash,
1576 };