lang/pc/comp/chk_expr.c

   1 /* E X P R E S S I O N   C H E C K I N G */
   2
   3 /*      Check expressions, and try to evaluate them as far as possible.
   4 */
   5
   6 #include        "debug.h"
   7
   8 #include        <alloc.h>
   9 #include        <assert.h>
  10 #include        <em_arith.h>
  11 #include        <em_label.h>
  12 #include        <system.h>
  13 #include        <print.h>
  14
  15 #include        "LLlex.h"
  16 #include        "Lpars.h"
  17 #include        "chk_expr.h"
  18 #include        "const.h"
  19 #include        "def.h"
  20 #include        "idf.h"
  21 #include        "main.h"
  22 #include        "misc.h"
  23 #include        "node.h"
  24 #include        "required.h"
  25 #include        "scope.h"
  26 #include        "type.h"
  27
  28 extern char *symbol2str();
  29 STATIC int ChkUnOper();
  30
  31 STATIC
  32 Xerror(nd, mess)
  33         register struct node *nd;
  34         char *mess;
  35 {
  36         if( nd->nd_class == Def && nd->nd_def ) {
  37                 if( nd->nd_def->df_kind != D_ERROR )
  38                         node_error(nd,"\"%s\": %s",
  39                                     nd->nd_def->df_idf->id_text, mess);
  40         }
  41         else    node_error(nd, "%s", mess);
  42 }
  43
  44 struct node *
  45 ZeroParam()
  46 {
  47         register struct node *nd;
  48
  49         nd = MkLeaf(Value, &dot);
  50         nd->nd_type = int_type;
  51         nd->nd_symb = INTEGER;
  52         nd->nd_INT = (arith) 0;
  53         nd = MkNode(Link, nd, NULLNODE, &dot);
  54         nd->nd_symb = ',';
  55
  56         return nd;
  57 }
  58
  59 MarkUsed(nd)
  60         register struct node *nd;
  61 {
  62         while( nd && nd->nd_class != Def ) {
  63                 if( (nd->nd_class == Arrsel) || (nd->nd_class == LinkDef) )
  64                         nd = nd->nd_left;
  65                 else if( nd->nd_class == Arrow)
  66                         nd = nd->nd_right;
  67                 else break;
  68         }
  69
  70         if( nd && nd->nd_class == Def ) {
  71                 register struct def *df = nd->nd_def;
  72
  73                 if( df->df_kind != D_FIELD ) {
  74                         if( !(df->df_flags & (D_SET|D_VARPAR)) &&
  75                             (df->df_scope == CurrentScope) )
  76                                 if( !is_anon_idf(df->df_idf) ) {
  77                                         warning("\"%s\" used before set",
  78                                                 df->df_idf->id_text);
  79                                 }
  80                         df->df_flags |= (D_USED | D_SET);
  81                 }
  82         }
  83 }
  84
  85 int
  86 ChkConstant(expp)
  87         register struct node *expp;
  88 {
  89         register struct node *nd;
  90
  91         if( !(nd = expp->nd_right) ) nd = expp;
  92
  93         if( nd->nd_class == Name &&  !ChkLinkOrName(nd) ) return 0;
  94
  95         if( nd->nd_class != Value || expp->nd_left )    {
  96                 Xerror(nd, "constant expected");
  97                 return 0;
  98         }
  99
 100         if( expp->nd_class == Uoper )
 101                 return ChkUnOper(expp);
 102         else if( nd != expp )   {
 103                 Xerror(expp, "constant expected");
 104                 return 0;
 105         }
 106         return 1;
 107 }
 108
 109 int
 110 ChkVariable(expp)
 111         register struct node *expp;
 112 {
 113         /* Check that "expp" indicates an item that can be accessed */
 114
 115         if( !ChkLhs(expp) ) return 0;
 116
 117         if( expp->nd_class == Def && expp->nd_def->df_kind == D_FUNCTION ) {
 118                 Xerror(expp, "illegal use of function name");
 119                 return 0;
 120         }
 121         return 1;
 122 }
 123
 124 int
 125 ChkLhs(expp)
 126         register struct node *expp;
 127 {
 128         int class;
 129
 130         /* Check that "expp" indicates an item that can be the lhs
 131            of an assignment.
 132         */
 133         if( !ChkVarAccess(expp) ) return 0;
 134
 135         class = expp->nd_class;
 136
 137         /* a constant is replaced by it's value in ChkLinkOrName, check here !,
 138          * the remaining classes are checked by ChkVarAccess
 139          */
 140         if( class == Value )    {
 141                 node_error(expp, "can't access a value");
 142                 return 0;
 143         }
 144
 145         if( class == Def &&
 146             !(expp->nd_def->df_kind & (D_FIELD | D_FUNCTION | D_VARIABLE)) ) {
 147                 Xerror(expp, "variable expected");
 148                 return 0;
 149         }
 150
 151         /* assignment to function name */
 152         if( class == Def && expp->nd_def->df_kind == D_FUNCTION )
 153                 if( expp->nd_def->prc_res )
 154                         expp->nd_type = ResultType(expp->nd_def->df_type);
 155                 else    {
 156                         Xerror(expp, "illegal assignment to function-name");
 157                         return 0;
 158                 }
 159
 160         return 1;
 161 }
 162
 163 #ifdef DEBUG
 164 STATIC int
 165 ChkValue(expp)
 166         register struct node *expp;
 167 {
 168         switch( expp->nd_symb ) {
 169                 case INTEGER:
 170                 case REAL:
 171                 case STRING:
 172                 case NIL:
 173                         return 1;
 174
 175                 default:
 176                         crash("(ChkValue)");
 177         }
 178         /*NOTREACHED*/
 179 }
 180 #endif
 181
 182 int
 183 ChkLinkOrName(expp)
 184         register struct node *expp;
 185 {
 186         register struct def *df;
 187
 188         expp->nd_type = error_type;
 189
 190         if( expp->nd_class == Name )    {
 191                 expp->nd_def = lookfor(expp, CurrVis, 1);
 192                 expp->nd_class = Def;
 193                 expp->nd_type = expp->nd_def->df_type;
 194         }
 195         else if( expp->nd_class == Link )       {
 196                 /* a selection from a record */
 197                 register struct node *left = expp->nd_left;
 198
 199                 assert(expp->nd_symb == '.');
 200
 201                 if( !ChkVariable(left) ) return 0;
 202
 203                 if( left->nd_type->tp_fund != T_RECORD )        {
 204                         Xerror(left, "illegal selection");
 205                         return 0;
 206                 }
 207
 208                 if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_INUSE)) ) {
 209                         id_not_declared(expp);
 210                         return 0;
 211                 }
 212                 else    {
 213                         expp->nd_def = df;
 214                         expp->nd_type = df->df_type;
 215                         expp->nd_class = LinkDef;
 216                 }
 217                 return 1;
 218         }
 219         assert(expp->nd_class == Def);
 220
 221         df = expp->nd_def;
 222
 223         if( df->df_kind & (D_ENUM | D_CONST) )  {
 224                 MarkUsed(expp);
 225                 /* Replace an enum-literal or a CONST identifier by its value.
 226                 */
 227                 if( df->df_kind == D_ENUM )     {
 228                         expp->nd_class = Value;
 229                         expp->nd_INT = df->enm_val;
 230                         expp->nd_symb = INTEGER;
 231                 }
 232                 else  {
 233                         unsigned int ln = expp->nd_lineno;
 234
 235                         assert(df->df_kind == D_CONST);
 236                         *expp = *(df->con_const);
 237                         expp->nd_lineno = ln;
 238                 }
 239         }
 240         return df->df_kind != D_ERROR;
 241 }
 242
 243 STATIC int
 244 ChkExLinkOrName(expp)
 245         register struct node *expp;
 246 {
 247         if( !ChkLinkOrName(expp) ) return 0;
 248         if( expp->nd_class != Def ) return 1;
 249
 250         if( !(expp->nd_def->df_kind & D_VALUE) ) {
 251                 Xerror(expp, "value expected");
 252         }
 253
 254         return 1;
 255 }
 256
 257 STATIC int
 258 ChkUnOper(expp)
 259         register struct node *expp;
 260 {
 261         /*      Check an unary operation.
 262         */
 263         register struct node *right = expp->nd_right;
 264         register struct type *tpr;
 265
 266         if( !ChkExpression(right) ) return 0;
 267
 268         MarkUsed(right);
 269
 270         expp->nd_type = tpr = BaseType(right->nd_type);
 271
 272         switch( expp->nd_symb ) {
 273         case '+':
 274                 if( tpr->tp_fund & T_NUMERIC )  {
 275                         *expp = *right;
 276                         free_node(right);
 277                         return 1;
 278                 }
 279                 break;
 280
 281         case '-':
 282                 if( tpr->tp_fund == T_INTEGER || tpr->tp_fund == T_LONG ) {
 283                         if( right->nd_class == Value )
 284                                 cstunary(expp);
 285                         return 1;
 286                 }
 287                 if( tpr->tp_fund == T_REAL )    {
 288                         if( right->nd_class == Value )  {
 289                                 expp->nd_token.tk_data.tk_real = right->nd_RIV;
 290                                 expp->nd_class = Value;
 291                                 expp->nd_symb = REAL;
 292                                 FreeNode(right);
 293                                 expp->nd_right = NULLNODE;
 294                         }
 295                         return 1;
 296                 }
 297                 break;
 298
 299         case NOT:
 300                 if( tpr == bool_type )  {
 301                         if( right->nd_class == Value )
 302                                 cstunary(expp);
 303                         return 1;
 304                 }
 305                 break;
 306
 307         case '(':
 308                 /* Delete the brackets */
 309                 *expp = *right;
 310                 free_node(right);
 311                 return 1;
 312
 313         default:
 314                 crash("(ChkUnOper)");
 315         }
 316         node_error(expp, "\"%s\": illegal operand", symbol2str(expp->nd_symb));
 317         return 0;
 318 }
 319
 320 STATIC struct type *
 321 ResultOfOperation(operator, tpl, tpr)
 322         struct type *tpl, *tpr;
 323 {
 324         /* Return the result type of the binary operation "operator",
 325            with operand types "tpl" and "tpr".
 326          */
 327
 328         switch( operator )      {
 329                 case '='        :
 330                 case NOTEQUAL   :
 331                 case '<'        :
 332                 case '>'        :
 333                 case LESSEQUAL  :
 334                 case GREATEREQUAL:
 335                 case IN         :
 336                                 return bool_type;
 337                 case '+'        :
 338                 case '-'        :
 339                 case '*'        :
 340                                 if( tpl == real_type || tpr == real_type )
 341                                         return real_type;
 342                                 if( tpl == long_type || tpr == long_type)
 343                                         return long_type;
 344                                 return tpl;
 345                 case '/'        :
 346                                 return real_type;
 347         }
 348         if (tpr == long_type && tpl == int_type) return tpr;
 349         return tpl;
 350 }
 351
 352 STATIC int
 353 AllowedTypes(operator)
 354 {
 355         /* Return a bit mask indicating the allowed operand types for
 356            binary operator "operator".
 357          */
 358
 359         switch( operator )      {
 360                 case '+'        :
 361                 case '-'        :
 362                 case '*'        :
 363                                 return T_NUMERIC | T_SET;
 364                 case '/'        :
 365                                 return T_NUMERIC;
 366                 case DIV        :
 367                 case MOD        :
 368                                 return T_INTEGER | T_LONG;
 369                 case OR         :
 370                 case AND        :
 371                                 return T_ENUMERATION;
 372                 case '='        :
 373                 case NOTEQUAL   :
 374                                 return T_ENUMERATION | T_CHAR | T_NUMERIC |
 375                                         T_SET | T_POINTER | T_STRINGCONST |
 376                                         T_STRING;
 377                 case LESSEQUAL  :
 378                 case GREATEREQUAL:
 379                                 return T_ENUMERATION | T_CHAR | T_NUMERIC |
 380                                         T_SET | T_STRINGCONST;
 381                 case '<'        :
 382                 case '>'        :
 383                                 return T_ENUMERATION | T_CHAR | T_NUMERIC |
 384                                         T_STRINGCONST;
 385                 default         :
 386                                 crash("(AllowedTypes)");
 387         }
 388         /*NOTREACHED*/
 389 }
 390
 391 STATIC int
 392 Boolean(operator)
 393 {
 394         return operator == OR || operator == AND;
 395 }
 396
 397 STATIC int
 398 ChkBinOper(expp)
 399         register struct node *expp;
 400 {
 401         /*      Check a binary operation.
 402          */
 403         register struct node *left, *right;
 404         struct type *tpl, *tpr;
 405         int retval, allowed;
 406
 407         left = expp->nd_left;
 408         right = expp->nd_right;
 409
 410         retval = ChkExpression(left);
 411         retval &= ChkExpression(right);
 412
 413         MarkUsed(left);
 414         MarkUsed(right);
 415
 416         tpl = BaseType(left->nd_type);
 417         tpr = BaseType(right->nd_type);
 418
 419         expp->nd_type = ResultOfOperation(expp->nd_symb, tpl ,tpr);
 420
 421         /* Check that the application of the operator is allowed on the type
 422            of the operands.
 423            There are some needles and pins:
 424            - Boolean operators are only allowed on boolean operands, but the
 425              "allowed-mask" of "AllowedTypes" can only indicate an enumeration
 426              type.
 427            - The IN-operator has as right-hand-side operand a set.
 428            - Strings and packed arrays can be equivalent.
 429            - In some cases, integers must be converted to reals.
 430            - If one of the operands is the empty set then the result doesn't
 431              have to be the empty set.
 432         */
 433
 434         if( expp->nd_symb == IN )       {
 435                 if( tpr->tp_fund != T_SET )     {
 436                         node_error(expp, "\"IN\": right operand must be a set");
 437                         return 0;
 438                 }
 439                 if( !TstAssCompat(tpl, ElementType(tpr)) )      {
 440                         node_error(expp, "\"IN\": incompatible types");
 441                         return 0;
 442                 }
 443                 if( left->nd_class == Value && right->nd_class == Set )
 444                         cstset(expp);
 445                 return retval;
 446         }
 447
 448         if( !retval ) return 0;
 449
 450         allowed = AllowedTypes(expp->nd_symb);
 451
 452         if( !(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed) )    {
 453                 arith ub;
 454                 extern arith IsString();
 455
 456                 if( allowed & T_STRINGCONST && (ub = IsString(tpl)) )   {
 457                         if( ub == IsString(tpr) )
 458                                 return 1;
 459                         else    {
 460                                 node_error(expp, "\"%s\": incompatible types",
 461                                                 symbol2str(expp->nd_symb));
 462                                 return 0;
 463                         }
 464                 }
 465                 else if( allowed & T_STRING && tpl->tp_fund == T_STRING )
 466                                 return 1;
 467
 468                 node_error(expp, "\"%s\": illegal operand type(s)",
 469                                                 symbol2str(expp->nd_symb));
 470                 return 0;
 471         }
 472
 473         if( Boolean(expp->nd_symb) && tpl != bool_type )        {
 474                 node_error(expp, "\"%s\": illegal operand type(s)",
 475                                                 symbol2str(expp->nd_symb));
 476                 return 0;
 477         }
 478
 479         if( allowed & T_NUMERIC )       {
 480                 if( (tpl == int_type || tpl == long_type) &&
 481                     (tpr == real_type || expp->nd_symb == '/') ) {
 482                         expp->nd_left =
 483                                 MkNode(Cast, NULLNODE, expp->nd_left, &dot);
 484                         expp->nd_left->nd_type = tpl = real_type;
 485                 }
 486                 if( tpl == real_type &&
 487                                 (tpr == int_type || tpr == long_type))  {
 488                         expp->nd_right =
 489                                 MkNode(Cast, NULLNODE, expp->nd_right, &dot);
 490                         expp->nd_right->nd_type = tpr = real_type;
 491                 }
 492                 if( tpl == int_type && tpr == long_type) {
 493                         expp->nd_left =
 494                                 MkNode(IntCoerc, NULLNODE, expp->nd_left, &dot);
 495                         expp->nd_left->nd_type = long_type;
 496                 }
 497                 else if( tpl == long_type && tpr == int_type) {
 498                         expp->nd_right =
 499                                 MkNode(IntCoerc, NULLNODE, expp->nd_right, &dot);
 500                         expp->nd_right->nd_type = long_type;
 501                 }
 502         }
 503
 504         /* Operands must be compatible */
 505         if( !TstCompat(tpl, tpr) )      {
 506                 node_error(expp, "\"%s\": incompatible types",
 507                                                 symbol2str(expp->nd_symb));
 508                 return 0;
 509         }
 510
 511         if( tpl->tp_fund & T_SET )      {
 512                 if( tpl == emptyset_type )
 513                         left->nd_type = tpr;
 514                 else if( tpr == emptyset_type )
 515                         right->nd_type = tpl;
 516
 517                 if( expp->nd_type == emptyset_type )
 518                         expp->nd_type = tpr;
 519                 if( left->nd_class == Set && right->nd_class == Set )
 520                         cstset(expp);
 521         }
 522         else if( tpl->tp_fund != T_REAL &&
 523                 left->nd_class == Value && right->nd_class == Value )
 524                         cstbin(expp);
 525
 526         return 1;
 527 }
 528
 529 STATIC int
 530 ChkElement(expp, tp, set, cnt)
 531         register struct node *expp;
 532         register struct type **tp;
 533         arith **set;
 534         unsigned *cnt;
 535 {
 536         /*      Check elements of a set. This routine may call itself
 537                 recursively. Also try to compute the set!
 538         */
 539         register struct node *left = expp->nd_left;
 540         register struct node *right = expp->nd_right;
 541         register int i;
 542         extern char *Malloc();
 543
 544         if( expp->nd_class == Link && expp->nd_symb == UPTO )   {
 545                 /* [ ... , expr1 .. expr2,  ... ]
 546                    First check expr1 and expr2, and try to compute them.
 547                 */
 548                 if( !ChkElement(left, tp, set, cnt) ||
 549                                         !ChkElement(right, tp, set, cnt) )
 550                         return 0;
 551
 552                 if( left->nd_class == Value &&
 553                                 right->nd_class == Value && *set )      {
 554
 555                         if( left->nd_INT > right->nd_INT )      {
 556                                 /* Remove lower and upper bound of the range.
 557                                 */
 558                                 *cnt -= 2;
 559                                 (*set)[left->nd_INT/wrd_bits] &=
 560                                                 ~(1 << (left->nd_INT%wrd_bits));
 561                                 (*set)[right->nd_INT/wrd_bits] &=
 562                                                ~(1 << (right->nd_INT%wrd_bits));
 563                         }
 564                         else
 565                                 /* We have a constant range. Put all elements
 566                                    in the set.
 567                                 */
 568                             for( i = left->nd_INT + 1; i < right->nd_INT; i++ )
 569                                 (*set)[i/wrd_bits] |= ( 1 << (i%wrd_bits) );
 570                 }
 571                 return 1;
 572         }
 573
 574         /* Here, a single element is checked
 575         */
 576         if( !ChkExpression(expp) ) return 0;
 577         MarkUsed(expp);
 578
 579         if( *tp == emptyset_type )      {
 580                 /* first element in set determines the type of the set */
 581                 unsigned size;
 582
 583                 *tp = set_type(expp->nd_type, 0);
 584                 size = (*tp)->tp_size * (sizeof(arith) / word_size);
 585                 *set = (arith *) Malloc(size);
 586                 clear((char *) *set, size);
 587         }
 588         else if( !TstCompat(ElementType(*tp), expp->nd_type) )  {
 589                 node_error(expp, "set element has incompatible type");
 590                 return 0;
 591         }
 592
 593         if( expp->nd_class == Value )   {
 594                 /* a constant element
 595                 */
 596                 i = expp->nd_INT;
 597
 598                 if( expp->nd_type == int_type ) {
 599                         /* Check only integer base-types because they are not
 600                            equal to the integer host-type. The other base-types
 601                            are equal to their host-types.
 602                         */
 603
 604                         if( i < 0 || i > max_intset )   {
 605                                 node_error(expp, "set element out of range");
 606                                 return 0;
 607                         }
 608                 }
 609
 610                 if( *set ) (*set)[i/wrd_bits] |= ( 1 << (i%wrd_bits));
 611                 (*cnt)++;
 612         }
 613         else if( *set ) {
 614                 free((char *) *set);
 615                 *set = (arith *) 0;
 616         }
 617
 618         return 1;
 619 }
 620
 621 STATIC int
 622 ChkSet(expp)
 623         register struct node *expp;
 624 {
 625         /*      Check the legality of a SET aggregate, and try to evaluate it
 626                 compile time. Unfortunately this is all rather complicated.
 627         */
 628         register struct node *nd = expp->nd_right;
 629         arith *set = (arith *) 0;
 630         unsigned cnt = 0;
 631
 632         assert(expp->nd_symb == SET);
 633
 634         expp->nd_type = emptyset_type;
 635
 636         /* Now check the elements given, and try to compute a constant set.
 637            First allocate room for the set, but only if it isn't empty.
 638         */
 639         if( !nd )       {
 640                 /* The resulting set IS empty, so we just return
 641                 */
 642                 expp->nd_class = Set;
 643                 expp->nd_set = (arith *) 0;
 644                 return 1;
 645         }
 646
 647         /* Now check the elements, one by one
 648         */
 649         while( nd )     {
 650                 assert(nd->nd_class == Link && nd->nd_symb == ',');
 651
 652                 if( !ChkElement(nd->nd_left, &(expp->nd_type), &set, &cnt) )
 653                         return 0;
 654                 nd = nd->nd_right;
 655         }
 656
 657         if( set )       {
 658                 /* Yes, it was a constant set, and we managed to compute it!
 659                    Notice that at the moment there is no such thing as
 660                    partial evaluation. Either we evaluate the set, or we
 661                    don't (at all). Improvement not neccesary (???)
 662                    ??? sets have a contant part and a variable part ???
 663                 */
 664                 expp->nd_class = Set;
 665                 if( !cnt )      {
 666                         /* after all the work we've done, the set turned out
 667                            out to be empty!
 668                         */
 669                         free((char *) set);
 670                         set = (arith *) 0;
 671                 }
 672                 expp->nd_set = set;
 673                 FreeNode(expp->nd_right);
 674                 expp->nd_right = NULLNODE;
 675         }
 676
 677         return 1;
 678 }
 679
 680 char *
 681 ChkAllowedVar(nd, reading)              /* reading indicates read or readln */
 682         register struct node *nd;
 683 {
 684         char *message = 0;
 685
 686         switch( nd->nd_class )  {
 687         case Def:
 688                 if( nd->nd_def->df_flags & D_INLOOP ) {
 689                         message = "control variable";
 690                         break;
 691                 }
 692                 if( nd->nd_def->df_kind != D_FIELD ) break;
 693                 /* FALL THROUGH */
 694
 695         case LinkDef:
 696                 assert(nd->nd_def->df_kind == D_FIELD);
 697
 698                 if( nd->nd_def->fld_flags & F_PACKED )
 699                         message = "field of packed record";
 700                 else if( nd->nd_def->fld_flags & F_SELECTOR )
 701                         message = "variant selector";
 702                 break;
 703
 704         case Arrsel:
 705                 if( IsPacked(nd->nd_left->nd_type) )
 706                         if( !reading ) message = "component of packed array";
 707                 break;
 708
 709         case Arrow:
 710                 if( nd->nd_right->nd_type->tp_fund == T_FILE )
 711                         message = "filebuffer variable";
 712                 break;
 713
 714         default:
 715                 crash("(ChkAllowedVar)");
 716                 /*NOTREACHED*/
 717         }
 718         MarkDef(nd, D_SET, 1);
 719         return message;
 720 }
 721
 722 int
 723 ChkVarPar(nd, name)
 724         register struct node *nd, *name;
 725 {
 726         /*      ISO 6.6.3.3 :
 727                 An actual variable parameter shall not denote a field
 728                 that is the selector of a variant-part or a component
 729                 of a variable where that variable possesses a type
 730                 that is designated packed.
 731         */
 732         static char err_mes[80];
 733         char *message = (char *) 0;
 734
 735         if( !ChkVariable(nd) ) return 0;
 736
 737         message = ChkAllowedVar(nd, 0);
 738
 739         if( message )   {
 740                 sprint(err_mes, "%s can't be a variable parameter", message);
 741                 Xerror(name, err_mes);
 742                 return 0;
 743         }
 744         return 1;
 745 }
 746
 747 STATIC struct node *
 748 getarg(argp, bases, varaccess, name, paramtp)
 749         struct node **argp, *name;
 750         struct type *paramtp;
 751 {
 752         /*      This routine is used to fetch the next argument from an
 753                 argument list. The argument list is indicated by "argp".
 754                 The parameter "bases" is a bitset indicating which types are
 755                 allowed at this point, and "varaccess" is a flag indicating
 756                 that the address from this argument is taken, so that it
 757                 must be a varaccess and may not be a register variable.
 758         */
 759         register struct node *arg = (*argp)->nd_right;
 760         register struct node *left;
 761
 762         if( !arg )      {
 763                 Xerror(name, "too few arguments supplied");
 764                 return 0;
 765         }
 766
 767         left = arg->nd_left;
 768         *argp = arg;
 769
 770         if( paramtp && paramtp->tp_fund & T_ROUTINE )   {
 771                 /* From the context it appears that the occurrence of the
 772                    procedure/function-identifier is not a call.
 773                 */
 774                 if( left->nd_class != NameOrCall )      {
 775                         Xerror(name, "illegal proc/func parameter");
 776                         return 0;
 777                 }
 778                 else if( ChkLinkOrName(left->nd_left) ) {
 779                         left->nd_type = left->nd_left->nd_type;
 780                         MarkUsed(left->nd_left);
 781                 }
 782                 else return 0;
 783         }
 784         else if( varaccess ) {
 785             if( !ChkVarPar(left, name) ) {
 786                 MarkUsed(left);
 787                 return 0;
 788             }
 789         }
 790         else if( !ChkExpression(left) ) {
 791                 MarkUsed(left);
 792                 return 0;
 793         }
 794
 795         MarkUsed(left);
 796
 797         if( !varaccess &&  bases == T_INTEGER &&
 798                     BaseType(left->nd_type)->tp_fund == T_LONG) {
 799                 arg->nd_left = MkNode(IntReduc, NULLNODE, left, &dot);
 800                 arg->nd_left->nd_type = int_type;
 801                 left = arg->nd_left;
 802         }
 803
 804         if( bases && !(BaseType(left->nd_type)->tp_fund & bases) )      {
 805                 Xerror(name, "unexpected parameter type");
 806                 return 0;
 807         }
 808
 809         return left;
 810 }
 811
 812 STATIC int
 813 ChkProcCall(expp)
 814         struct node *expp;
 815 {
 816         /*      Check a procedure call
 817         */
 818         register struct node *left;
 819         struct node *name;
 820         register struct paramlist *param;
 821         char ebuf[80];
 822         int retval = 1;
 823         int cnt = 0;
 824         int new_par_section;
 825         struct type *lasttp = NULLTYPE;
 826
 827         name = left = expp->nd_left;
 828
 829         if( left->nd_type == error_type )       {
 830                 /* Just check parameters as if they were value parameters
 831                 */
 832                 expp->nd_type = error_type;
 833                 while( expp->nd_right )
 834                         (void) getarg(&expp, 0, 0, name, NULLTYPE);
 835                 return 0;
 836         }
 837
 838         expp->nd_type = ResultType(left->nd_type);
 839
 840         /* Check parameter list
 841         */
 842         for( param = ParamList(left->nd_type); param; param = param->next ) {
 843                 if( !(left = getarg(&expp, 0, (int) IsVarParam(param), name,
 844                                                         TypeOfParam(param))) )
 845                         return 0;
 846
 847                 cnt++;
 848                 new_par_section = lasttp != TypeOfParam(param);
 849                 if( !TstParCompat(TypeOfParam(param), left->nd_type,
 850                             (int) IsVarParam(param), left, new_par_section) ) {
 851                         sprint(ebuf, "type incompatibility in parameter %d",
 852                                         cnt);
 853                         Xerror(name, ebuf);
 854                         retval = 0;
 855                 }
 856
 857                 /* Convert between integers and longs.
 858                  */
 859                 if( !IsVarParam(param) && options['d'] )        {
 860                         if( left->nd_type->tp_fund == T_INTEGER &&
 861                                         TypeOfParam(param)->tp_fund == T_LONG) {
 862                                 expp->nd_left =
 863                                         MkNode(IntCoerc, NULLNODE, left, &dot);
 864                                 expp->nd_left->nd_type = long_type;
 865                                 left = expp->nd_left;
 866                         }
 867                         else if( left->nd_type->tp_fund == T_LONG &&
 868                                     TypeOfParam(param)->tp_fund == T_INTEGER) {
 869                                 expp->nd_left =
 870                                         MkNode(IntReduc, NULLNODE, left, &dot);
 871                                 expp->nd_left->nd_type = int_type;
 872                                 left = expp->nd_left;
 873                         }
 874                 }
 875
 876                 if( left->nd_type == emptyset_type )
 877                         /* type of emptyset determined by the context */
 878                         left->nd_type = TypeOfParam(param);
 879
 880                 lasttp = TypeOfParam(param);
 881         }
 882
 883         if( expp->nd_right )    {
 884                 Xerror(name, "too many arguments supplied");
 885                 while( expp->nd_right )
 886                         (void) getarg(&expp, 0, 0, name, NULLTYPE);
 887                 return 0;
 888         }
 889
 890         return retval;
 891 }
 892
 893 STATIC int ChkStandard();
 894
 895 int
 896 ChkCall(expp)
 897         register struct node *expp;
 898 {
 899         /*      Check something that looks like a procedure or function call.
 900                 Of course this does not have to be a call at all,
 901                 it may also be a standard procedure call.
 902         */
 903
 904         /* First, get the name of the function or procedure
 905         */
 906         register struct node *left = expp->nd_left;
 907
 908         expp->nd_type = error_type;
 909
 910         if( ChkLinkOrName(left) )       {
 911
 912                 MarkUsed(left);
 913                 if( IsProcCall(left) || left->nd_type == error_type )   {
 914                         /* A call.
 915                            It may also be a call to a standard procedure
 916                         */
 917
 918                         if( left->nd_type == std_type )
 919                                 /* A standard procedure
 920                                 */
 921                                 return ChkStandard(expp, left);
 922
 923                         /* Here, we have found a real procedure call.
 924                         */
 925                 }
 926                 else    {
 927                         node_error(left, "procedure or function expected");
 928                         return 0;
 929                 }
 930         }
 931         return ChkProcCall(expp);
 932 }
 933
 934 STATIC int
 935 ChkExCall(expp)
 936         register struct node *expp;
 937 {
 938         if( !ChkCall(expp) ) return 0;
 939
 940         if( !expp->nd_type )    {
 941                 node_error(expp, "function call expected");
 942                 return 0;
 943         }
 944         return 1;
 945 }
 946
 947 STATIC int
 948 ChkNameOrCall(expp)
 949         register struct node *expp;
 950 {
 951         /* From the context it appears that the occurrence of the function-
 952            identifier is a call to that function
 953         */
 954         assert(expp->nd_class == NameOrCall);
 955         expp->nd_class = Call;
 956
 957         return ChkExCall(expp);
 958 }
 959
 960 STATIC int
 961 ChkStandard(expp,left)
 962         register struct node *expp, *left;
 963 {
 964         /*      Check a call of a standard procedure or function
 965         */
 966
 967         struct node *arg = expp;
 968         struct node *name = left;
 969         int req;
 970
 971         assert(left->nd_class == Def);
 972
 973         req = left->nd_def->df_value.df_reqname;
 974
 975         switch( req )   {
 976             case R_ABS:
 977             case R_SQR:
 978                 if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
 979                         return 0;
 980                 expp->nd_type = left->nd_type;
 981                 if( left->nd_class == Value &&
 982                                         expp->nd_type->tp_fund != T_REAL )
 983                         cstcall(expp, req);
 984                 break;
 985
 986             case R_SIN:
 987             case R_COS:
 988             case R_EXP:
 989             case R_LN:
 990             case R_SQRT:
 991             case R_ARCTAN:
 992                 if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
 993                         return 0;
 994                 expp->nd_type = real_type;
 995                 if( BaseType(left->nd_type)->tp_fund == T_INTEGER ||
 996                             BaseType(left->nd_type)->tp_fund == T_LONG) {
 997                         arg->nd_left = MkNode(Cast,NULLNODE, arg->nd_left,&dot);
 998                         arg->nd_left->nd_type = real_type;
 999                 }
1000                 break;
1001
1002             case R_TRUNC:
1003             case R_ROUND:
1004                 if( !(left = getarg(&arg, T_REAL, 0, name, NULLTYPE)) )
1005                         return 0;
1006                 expp->nd_type = int_type;
1007                 break;
1008
1009             case R_ORD:
1010                 if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
1011                         return 0;
1012                 if( BaseType(left->nd_type)->tp_fund == T_LONG )        {
1013                         arg->nd_left = MkNode(IntReduc, NULLNODE, arg->nd_left, &dot);
1014                         arg->nd_left->nd_type = int_type;
1015                 }
1016                 expp->nd_type = int_type;
1017                 if( left->nd_class == Value )
1018                         cstcall(expp, R_ORD);
1019                 break;
1020
1021             case R_CHR:
1022                 if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
1023                         return 0;
1024                 expp->nd_type = char_type;
1025                 if( left->nd_class == Value )
1026                         cstcall(expp, R_CHR);
1027                 break;
1028
1029             case R_SUCC:
1030             case R_PRED:
1031                 if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
1032                         return 0;
1033                 expp->nd_type = left->nd_type;
1034                 if( left->nd_class == Value && options['R'] )
1035                         cstcall(expp, req);
1036                 break;
1037
1038             case R_ODD:
1039                 if( !(left = getarg(&arg, T_INTEGER | T_LONG , 0, name, NULLTYPE)) )
1040                         return 0;
1041                 expp->nd_type = bool_type;
1042                 if( left->nd_class == Value )
1043                         cstcall(expp, R_ODD);
1044                 break;
1045
1046             case R_EOF:
1047             case R_EOLN:
1048             case R_GET:
1049             case R_PAGE:        {
1050                 int st_out;
1051
1052                 if( req == R_PAGE )     {
1053                         expp->nd_type = NULLTYPE;
1054                         st_out = 1;
1055                 }
1056                 else    {
1057                         st_out = 0;
1058                         if (req == R_GET) {
1059                                 expp->nd_type = NULLTYPE;
1060                         }
1061                         else    expp->nd_type = bool_type;
1062                 }
1063                 if( !arg->nd_right )    {
1064                         struct node *nd;
1065
1066                         if( !(nd = ChkStdInOut(name->nd_IDF->id_text, st_out)) )
1067                                 return 0;
1068
1069                         expp->nd_right = MkNode(Link, nd, NULLNODE, &dot);
1070                         expp->nd_right->nd_symb = ',';
1071                         arg = arg->nd_right;
1072                 }
1073                 else    {
1074                         if( !(left = getarg(&arg, T_FILE, 1, name, NULLTYPE)) )
1075                                 return 0;
1076                         if( (req == R_PAGE || req == R_EOLN)
1077                             && left->nd_type != text_type ) {
1078                                 Xerror(name, "textfile expected");
1079                                 return 0;
1080                         }
1081                 }
1082                 break;
1083
1084             }
1085             case R_REWRITE:
1086             case R_PUT:
1087             case R_RESET:
1088                 if( !(left = getarg(&arg, T_FILE, 1, name, NULLTYPE)) )
1089                         return 0;
1090                 expp->nd_type = NULLTYPE;
1091                 break;
1092
1093             case R_PACK:
1094             case R_UNPACK:      {
1095                 struct type *tp1, *tp2, *tp3;
1096
1097                 if( req == R_PACK )     {
1098                         /* pack(a, i, z) */
1099                         if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
1100                                 return 0;
1101                         tp1 = left->nd_type;            /* (a) */
1102                         if( !(left = getarg(&arg, 0, 0, name, NULLTYPE)) )
1103                                 return 0;
1104                         tp2 = left->nd_type;            /* (i) */
1105                         if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
1106                                 return 0;
1107                         tp3 = left->nd_type;            /* (z) */
1108                 }
1109                 else    {
1110                         /* unpack(z, a, i) */
1111                         if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
1112                                 return 0;
1113                         tp3 = left->nd_type;            /* (z) */
1114                         if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
1115                                 return 0;
1116                         tp1 = left->nd_type;            /* (a) */
1117                         if( !(left = getarg(&arg, 0, 0, name, NULLTYPE)) )
1118                                 return 0;
1119                         tp2 = left->nd_type;            /* (i) */
1120                 }
1121                 if( IsConformantArray(tp1) || IsPacked(tp1) )   {
1122                         Xerror(name, "unpacked array expected");
1123                         return 0;
1124                 }
1125                 if( !TstAssCompat(IndexType(tp1), tp2) )        {
1126                         Xerror(name, "ordinal constant expected");
1127                         return 0;
1128                 }
1129                 if( IsConformantArray(tp3) || !IsPacked(tp3) )  {
1130                         Xerror(name, "packed array expected");
1131                         return 0;
1132                 }
1133                 if( !TstTypeEquiv(tp1->arr_elem, tp3->arr_elem) )       {
1134                         Xerror(name, "component types of arrays not equal");
1135                         return 0;
1136                 }
1137                 expp->nd_type = NULLTYPE;
1138                 break;
1139             }
1140
1141             case R_NEW:
1142             case R_DISPOSE:
1143                 if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
1144                         return 0;
1145                 if( arg->nd_right )     {
1146                         /* varargs new/dispose(p,c1,.....) */
1147                         register struct selector *sel;
1148                         register arith i;
1149
1150                         if( PointedtoType(left->nd_type)->tp_fund != T_RECORD )
1151                                 break;
1152                         sel = PointedtoType(left->nd_type)->rec_sel;
1153                         do      {
1154                                 if( !sel ) break;
1155
1156                                 arg = arg->nd_right;
1157                                 left = arg->nd_left;
1158
1159                                 /* ISO : COMPILETIME CONSTANTS NOT PERMITTED */
1160                                 if( !ChkConstant(left) ) return 0;
1161
1162                                 if( !TstCompat(left->nd_type, sel->sel_type) ) {
1163                                         node_error(left,
1164                                            "type incompatibility in caselabel");
1165                                         return 0;
1166                                 }
1167
1168                                 i = left->nd_INT - sel->sel_lb;
1169                                 if( i < 0 || i >= sel->sel_ncst )       {
1170                                         node_error(left,
1171                                                 "case constant: out of bounds");
1172                                         return 0;
1173                                 }
1174
1175                                 sel = sel->sel_ptrs[i];
1176                         } while( arg->nd_right );
1177
1178                         FreeNode(expp->nd_right->nd_right);
1179                         expp->nd_right->nd_right = NULLNODE;
1180                 }
1181                 expp->nd_type = NULLTYPE;
1182                 break;
1183
1184             case R_MARK:
1185             case R_RELEASE:
1186                 if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
1187                         return 0;
1188                 expp->nd_type = NULLTYPE;
1189                 break;
1190
1191             case R_HALT:
1192                 if( !arg->nd_right )            /* insert 0 parameter */
1193                         arg->nd_right = ZeroParam();
1194                 if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
1195                         return 0;
1196                 expp->nd_type = NULLTYPE;
1197                 break;
1198
1199             default:
1200                 crash("(ChkStandard)");
1201         }
1202
1203         if( arg->nd_right )     {
1204                 Xerror(name, "too many arguments supplied");
1205                 return 0;
1206         }
1207
1208         return 1;
1209 }
1210
1211 STATIC int
1212 ChkArrow(expp)
1213         register struct node *expp;
1214 {
1215         /*      Check an application of the '^' operator.
1216                 The operand must be a variable of a pointer-type or a
1217                 variable of a file-type.
1218         */
1219
1220         register struct type *tp;
1221
1222         assert(expp->nd_class == Arrow);
1223         assert(expp->nd_symb == '^');
1224
1225         expp->nd_type = error_type;
1226
1227         if( !ChkVariable(expp->nd_right) ) return 0;
1228
1229         MarkUsed(expp->nd_right);
1230
1231         tp = expp->nd_right->nd_type;
1232
1233         if( !(tp->tp_fund & (T_POINTER | T_FILE)) )     {
1234                 node_error(expp, "\"^\": illegal operand");
1235                 return 0;
1236         }
1237
1238         expp->nd_type = PointedtoType(tp);
1239         return 1;
1240 }
1241
1242 STATIC int
1243 ChkArr(expp)
1244         register struct node *expp;
1245 {
1246         /*      Check an array selection.
1247                 The left hand side must be a variable of an array type,
1248                 and the right hand side must be an expression that is
1249                 assignment compatible with the array-index.
1250         */
1251
1252         register struct type *tpl, *tpr;
1253         int retval;
1254
1255         assert(expp->nd_class == Arrsel);
1256         assert(expp->nd_symb == '[');
1257
1258         expp->nd_type = error_type;
1259
1260         /* Check the index first, so a[a[j]] is checked in order of
1261          * evaluation. This to make sure that warnings are generated
1262          * in the right order.
1263          */
1264         retval = ChkExpression(expp->nd_right);
1265         MarkUsed(expp->nd_right);
1266         retval &= ChkVariable(expp->nd_left);
1267
1268         tpl = expp->nd_left->nd_type;
1269         tpr = expp->nd_right->nd_type;
1270         if( tpl == error_type || tpr == error_type ) return 0;
1271
1272         if( tpl->tp_fund != T_ARRAY )   {
1273                 node_error(expp, "not indexing an ARRAY type");
1274                 return 0;
1275         }
1276
1277         /* Type of the index must be assignment compatible with
1278            the index type of the array.
1279         */
1280         if( !TstCompat(IndexType(tpl), tpr) )   {
1281                 node_error(expp, "incompatible index type");
1282                 return 0;
1283         }
1284
1285         if( tpr == long_type ) {
1286                 expp->nd_right = MkNode(IntReduc, NULLNODE, expp->nd_right, &dot);
1287                 expp->nd_right->nd_type = int_type;
1288         }
1289
1290         expp->nd_type = tpl->arr_elem;
1291         return retval;
1292 }
1293
1294 STATIC int
1295 done_before()
1296 {
1297         return 1;
1298 }
1299
1300 STATIC int
1301 no_var_access(expp)
1302         struct node *expp;
1303 {
1304         node_error(expp, "variable-access expected");
1305         return 0;
1306 }
1307
1308 extern int      NodeCrash();
1309
1310 int (*ExprChkTable[])() = {
1311 #ifdef DEBUG
1312         ChkValue,
1313 #else
1314         done_before,
1315 #endif
1316         ChkExLinkOrName,
1317         ChkUnOper,
1318         ChkBinOper,
1319         ChkSet,
1320         NodeCrash,
1321         ChkExCall,
1322         ChkNameOrCall,
1323         ChkArrow,
1324         ChkArr,
1325         NodeCrash,
1326         ChkExLinkOrName,
1327         NodeCrash,
1328         NodeCrash,
1329         NodeCrash,
1330         NodeCrash
1331 };
1332
1333 int (*VarAccChkTable[])() = {
1334         no_var_access,
1335         ChkLinkOrName,
1336         no_var_access,
1337         no_var_access,
1338         no_var_access,
1339         NodeCrash,
1340         no_var_access,
1341         no_var_access,
1342         ChkArrow,
1343         ChkArr,
1344         done_before,
1345         ChkLinkOrName,
1346         done_before,
1347         no_var_access,
1348         no_var_access,
1349         no_var_access
1350 };