src/bin/embryo_cc_sc3.c

   1 /*  Small compiler - Recursive descend expresion parser
   2  *
   3  *  Copyright (c) ITB CompuPhase, 1997-2003
   4  *
   5  *  This software is provided "as-is", without any express or implied warranty.
   6  *  In no event will the authors be held liable for any damages arising from
   7  *  the use of this software.
   8  *
   9  *  Permission is granted to anyone to use this software for any purpose,
  10  *  including commercial applications, and to alter it and redistribute it
  11  *  freely, subject to the following restrictions:
  12  *
  13  *  1.  The origin of this software must not be misrepresented; you must not
  14  *      claim that you wrote the original software. If you use this software in
  15  *      a product, an acknowledgment in the product documentation would be
  16  *      appreciated but is not required.
  17  *  2.  Altered source versions must be plainly marked as such, and must not be
  18  *      misrepresented as being the original software.
  19  *  3.  This notice may not be removed or altered from any source distribution.
  20  *
  21  *  Version: $Id$
  22  */
  23
  24
  25 #ifdef HAVE_CONFIG_H
  26 # include <config.h>
  27 #endif
  28
  29 #include <assert.h>
  30 #include <stdio.h>
  31 #include <limits.h>             /* for PATH_MAX */
  32 #include <string.h>
  33
  34 #include "embryo_cc_sc.h"
  35
  36 static int          skim(int *opstr, void (*testfunc) (int), int dropval,
  37                          int endval, int (*hier) (value *), value * lval);
  38 static void         dropout(int lvalue, void (*testfunc) (int val), int exit1,
  39                             value * lval);
  40 static int          plnge(int *opstr, int opoff, int (*hier) (value * lval),
  41                           value * lval, char *forcetag, int chkbitwise);
  42 static int          plnge1(int (*hier) (value * lval), value * lval);
  43 static void         plnge2(void (*oper) (void),
  44                            int (*hier) (value * lval),
  45                            value * lval1, value * lval2);
  46 static cell         calc(cell left, void (*oper) (), cell right,
  47                          char *boolresult);
  48 static int          hier13(value * lval);
  49 static int          hier12(value * lval);
  50 static int          hier11(value * lval);
  51 static int          hier10(value * lval);
  52 static int          hier9(value * lval);
  53 static int          hier8(value * lval);
  54 static int          hier7(value * lval);
  55 static int          hier6(value * lval);
  56 static int          hier5(value * lval);
  57 static int          hier4(value * lval);
  58 static int          hier3(value * lval);
  59 static int          hier2(value * lval);
  60 static int          hier1(value * lval1);
  61 static int          primary(value * lval);
  62 static void         clear_value(value * lval);
  63 static void         callfunction(symbol * sym);
  64 static int          dbltest(void (*oper) (), value * lval1, value * lval2);
  65 static int          commutative(void (*oper) ());
  66 static int          constant(value * lval);
  67
  68 static char         lastsymbol[sNAMEMAX + 1];   /* name of last function/variable */
  69 static int          bitwise_opercount;  /* count of bitwise operators in an expression */
  70
  71 /* Function addresses of binary operators for signed operations */
  72 static void         (*op1[17]) (void) =
  73 {
  74    os_mult, os_div, os_mod,     /* hier3, index 0 */
  75       ob_add, ob_sub,           /* hier4, index 3 */
  76       ob_sal, os_sar, ou_sar,   /* hier5, index 5 */
  77       ob_and,                   /* hier6, index 8 */
  78       ob_xor,                   /* hier7, index 9 */
  79       ob_or,                    /* hier8, index 10 */
  80       os_le, os_ge, os_lt, os_gt,       /* hier9, index 11 */
  81       ob_eq, ob_ne,             /* hier10, index 15 */
  82 };
  83 /* These two functions are defined because the functions inc() and dec() in
  84  * SC4.C have a different prototype than the other code generation functions.
  85  * The arrays for user-defined functions use the function pointers for
  86  * identifying what kind of operation is requested; these functions must all
  87  * have the same prototype. As inc() and dec() are special cases already, it
  88  * is simplest to add two "do-nothing" functions.
  89  */
  90 static void
  91 user_inc(void)
  92 {
  93 }
  94 static void
  95 user_dec(void)
  96 {
  97 }
  98
  99 /*
 100  *  Searches for a binary operator a list of operators. The list is stored in
 101  *  the array "list". The last entry in the list should be set to 0.
 102  *
 103  *  The index of an operator in "list" (if found) is returned in "opidx". If
 104  *  no operator is found, nextop() returns 0.
 105  */
 106 static int
 107 nextop(int *opidx, int *list)
 108 {
 109    *opidx = 0;
 110    while (*list)
 111      {
 112         if (matchtoken(*list))
 113           {
 114              return TRUE;       /* found! */
 115           }
 116         else
 117           {
 118              list += 1;
 119              *opidx += 1;
 120           }                     /* if */
 121      }                          /* while */
 122    return FALSE;                /* entire list scanned, nothing found */
 123 }
 124
 125 int
 126 check_userop(void   (*oper) (void), int tag1, int tag2, int numparam,
 127              value * lval, int *resulttag)
 128 {
 129    static char        *binoperstr[] = { "*", "/", "%", "+", "-", "", "", "",
 130       "", "", "", "<=", ">=", "<", ">", "==", "!="
 131    };
 132    static int          binoper_savepri[] =
 133       { FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
 134       FALSE, FALSE, FALSE, FALSE, FALSE,
 135       TRUE, TRUE, TRUE, TRUE, FALSE, FALSE
 136    };
 137    static char        *unoperstr[] = { "!", "-", "++", "--" };
 138    static void         (*unopers[]) (void) =
 139    {
 140    lneg, neg, user_inc, user_dec};
 141    char                opername[4] = "", symbolname[sNAMEMAX + 1];
 142    int                 i, swapparams, savepri, savealt;
 143    int                 paramspassed;
 144    symbol             *sym;
 145
 146    /* since user-defined operators on untagged operands are forbidden, we have
 147     * a quick exit.
 148     */
 149    assert(numparam == 1 || numparam == 2);
 150    if (tag1 == 0 && (numparam == 1 || tag2 == 0))
 151       return FALSE;
 152
 153    savepri = savealt = FALSE;
 154    /* find the name with the operator */
 155    if (numparam == 2)
 156      {
 157         if (!oper)
 158           {
 159              /* assignment operator: a special case */
 160              strcpy(opername, "=");
 161              if (lval
 162                  && (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR))
 163                 savealt = TRUE;
 164           }
 165         else
 166           {
 167              assert((sizeof binoperstr / sizeof binoperstr[0]) ==
 168                     (sizeof op1 / sizeof op1[0]));
 169              for (i = 0; i < sizeof op1 / sizeof op1[0]; i++)
 170                {
 171                   if (oper == op1[i])
 172                     {
 173                        strcpy(opername, binoperstr[i]);
 174                        savepri = binoper_savepri[i];
 175                        break;
 176                     }           /* if */
 177                }                /* for */
 178           }                     /* if */
 179      }
 180    else
 181      {
 182         assert(oper != NULL);
 183         assert(numparam == 1);
 184         /* try a select group of unary operators */
 185         assert((sizeof unoperstr / sizeof unoperstr[0]) ==
 186                (sizeof unopers / sizeof unopers[0]));
 187         if (opername[0] == '\0')
 188           {
 189              for (i = 0; i < sizeof unopers / sizeof unopers[0]; i++)
 190                {
 191                   if (oper == unopers[i])
 192                     {
 193                        strcpy(opername, unoperstr[i]);
 194                        break;
 195                     }           /* if */
 196                }                /* for */
 197           }                     /* if */
 198      }                          /* if */
 199    /* if not found, quit */
 200    if (opername[0] == '\0')
 201       return FALSE;
 202
 203    /* create a symbol name from the tags and the operator name */
 204    assert(numparam == 1 || numparam == 2);
 205    operator_symname(symbolname, opername, tag1, tag2, numparam, tag2);
 206    swapparams = FALSE;
 207    sym = findglb(symbolname);
 208    if (!sym /*|| (sym->usage & uDEFINE)==0 */ )
 209      {                          /* ??? should not check uDEFINE; first pass clears these bits */
 210         /* check for commutative operators */
 211         if (tag1 == tag2 || !oper || !commutative(oper))
 212            return FALSE;        /* not commutative, cannot swap operands */
 213         /* if arrived here, the operator is commutative and the tags are different,
 214          * swap tags and try again
 215          */
 216         assert(numparam == 2);  /* commutative operator must be a binary operator */
 217         operator_symname(symbolname, opername, tag2, tag1, numparam, tag1);
 218         swapparams = TRUE;
 219         sym = findglb(symbolname);
 220         if (!sym /*|| (sym->usage & uDEFINE)==0 */ )
 221            return FALSE;
 222      }                          /* if */
 223
 224    /* check existance and the proper declaration of this function */
 225    if ((sym->usage & uMISSING) != 0 || (sym->usage & uPROTOTYPED) == 0)
 226      {
 227         char                symname[2 * sNAMEMAX + 16]; /* allow space for user defined operators */
 228
 229         funcdisplayname(symname, sym->name);
 230         if ((sym->usage & uMISSING) != 0)
 231            error(4, symname);   /* function not defined */
 232         if ((sym->usage & uPROTOTYPED) == 0)
 233            error(71, symname);  /* operator must be declared before use */
 234      }                          /* if */
 235
 236    /* we don't want to use the redefined operator in the function that
 237     * redefines the operator itself, otherwise the snippet below gives
 238     * an unexpected recursion:
 239     *    fixed:operator+(fixed:a, fixed:b)
 240     *        return a + b
 241     */
 242    if (sym == curfunc)
 243       return FALSE;
 244
 245    /* for increment and decrement operators, the symbol must first be loaded
 246     * (and stored back afterwards)
 247     */
 248    if (oper == user_inc || oper == user_dec)
 249      {
 250         assert(!savepri);
 251         assert(lval != NULL);
 252         if (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR)
 253            push1();             /* save current address in PRI */
 254         rvalue(lval);           /* get the symbol's value in PRI */
 255      }                          /* if */
 256
 257    assert(!savepri || !savealt);        /* either one MAY be set, but not both */
 258    if (savepri)
 259      {
 260         /* the chained comparison operators require that the ALT register is
 261          * unmodified, so we save it here; actually, we save PRI because the normal
 262          * instruction sequence (without user operator) swaps PRI and ALT
 263          */
 264         push1();                /* right-hand operand is in PRI */
 265      }
 266    else if (savealt)
 267      {
 268         /* for the assignment operator, ALT may contain an address at which the
 269          * result must be stored; this address must be preserved accross the
 270          * call
 271          */
 272         assert(lval != NULL);   /* this was checked earlier */
 273         assert(lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR); /* checked earlier */
 274         push2();
 275      }                          /* if */
 276
 277    /* push parameters, call the function */
 278    paramspassed = (!oper) ? 1 : numparam;
 279    switch (paramspassed)
 280      {
 281      case 1:
 282         push1();
 283         break;
 284      case 2:
 285         /* note that 1) a function expects that the parameters are pushed
 286          * in reversed order, and 2) the left operand is in the secondary register
 287          * and the right operand is in the primary register */
 288         if (swapparams)
 289           {
 290              push2();
 291              push1();
 292           }
 293         else
 294           {
 295              push1();
 296              push2();
 297           }                     /* if */
 298         break;
 299      default:
 300         assert(0);
 301      }                          /* switch */
 302    endexpr(FALSE);              /* mark the end of a sub-expression */
 303    pushval((cell) paramspassed * sizeof(cell));
 304    assert(sym->ident == iFUNCTN);
 305    ffcall(sym, paramspassed);
 306    if (sc_status != statSKIP)
 307       markusage(sym, uREAD);    /* do not mark as "used" when this call itself is skipped */
 308    if (sym->x.lib)
 309       sym->x.lib->value += 1;   /* increment "usage count" of the library */
 310    sideeffect = TRUE;           /* assume functions carry out a side-effect */
 311    assert(resulttag != NULL);
 312    *resulttag = sym->tag;       /* save tag of the called function */
 313
 314    if (savepri || savealt)
 315       pop2();                   /* restore the saved PRI/ALT that into ALT */
 316    if (oper == user_inc || oper == user_dec)
 317      {
 318         assert(lval != NULL);
 319         if (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR)
 320            pop2();              /* restore address (in ALT) */
 321         store(lval);            /* store PRI in the symbol */
 322         moveto1();              /* make sure PRI is restored on exit */
 323      }                          /* if */
 324    return TRUE;
 325 }
 326
 327 int
 328 matchtag(int formaltag, int actualtag, int allowcoerce)
 329 {
 330    if (formaltag != actualtag)
 331      {
 332         /* if the formal tag is zero and the actual tag is not "fixed", the actual
 333          * tag is "coerced" to zero
 334          */
 335         if (!allowcoerce || formaltag != 0 || (actualtag & FIXEDTAG) != 0)
 336            return FALSE;
 337      }                          /* if */
 338    return TRUE;
 339 }
 340
 341 /*
 342  *  The AMX pseudo-processor has no direct support for logical (boolean)
 343  *  operations. These have to be done via comparing and jumping. Since we are
 344  *  already jumping through the code, we might as well implement an "early
 345  *  drop-out" evaluation (also called "short-circuit"). This conforms to
 346  *  standard C:
 347  *
 348  *  expr1 || expr2           expr2 will only be evaluated if expr1 is false.
 349  *  expr1 && expr2           expr2 will only be evaluated if expr1 is true.
 350  *
 351  *  expr1 || expr2 && expr3  expr2 will only be evaluated if expr1 is false
 352  *                           and expr3 will only be evaluated if expr1 is
 353  *                           false and expr2 is true.
 354  *
 355  *  Code generation for the last example proceeds thus:
 356  *
 357  *      evaluate expr1
 358  *      operator || found
 359  *      jump to "l1" if result of expr1 not equal to 0
 360  *      evaluate expr2
 361  *      ->  operator && found; skip to higher level in hierarchy diagram
 362  *          jump to "l2" if result of expr2 equal to 0
 363  *          evaluate expr3
 364  *          jump to "l2" if result of expr3 equal to 0
 365  *          set expression result to 1 (true)
 366  *          jump to "l3"
 367  *      l2: set expression result to 0 (false)
 368  *      l3:
 369  *      <-  drop back to previous hierarchy level
 370  *      jump to "l1" if result of expr2 && expr3 not equal to 0
 371  *      set expression result to 0 (false)
 372  *      jump to "l4"
 373  *  l1: set expression result to 1 (true)
 374  *  l4:
 375  *
 376  */
 377
 378 /*  Skim over terms adjoining || and && operators
 379  *  dropval   The value of the expression after "dropping out". An "or" drops
 380  *            out when the left hand is TRUE, so dropval must be 1 on "or"
 381  *            expressions.
 382  *  endval    The value of the expression when no expression drops out. In an
 383  *            "or" expression, this happens when both the left hand and the
 384  *            right hand are FALSE, so endval must be 0 for "or" expressions.
 385  */
 386 static int
 387 skim(int *opstr, void (*testfunc) (int), int dropval, int endval,
 388      int (*hier) (value *), value * lval)
 389 {
 390    int                 lvalue, hits, droplab, endlab, opidx;
 391    int                 allconst;
 392    cell                constval;
 393    int                 index;
 394    cell                cidx;
 395
 396    stgget(&index, &cidx);       /* mark position in code generator */
 397    hits = FALSE;                /* no logical operators "hit" yet */
 398    allconst = TRUE;             /* assume all values "const" */
 399    constval = 0;
 400    droplab = 0;                 /* to avoid a compiler warning */
 401    for (;;)
 402      {
 403         lvalue = plnge1(hier, lval);    /* evaluate left expression */
 404
 405         allconst = allconst && (lval->ident == iCONSTEXPR);
 406         if (allconst)
 407           {
 408              if (hits)
 409                {
 410                   /* one operator was already found */
 411                   if (testfunc == jmp_ne0)
 412                      lval->constval = lval->constval || constval;
 413                   else
 414                      lval->constval = lval->constval && constval;
 415                }                /* if */
 416              constval = lval->constval; /* save result accumulated so far */
 417           }                     /* if */
 418
 419         if (nextop(&opidx, opstr))
 420           {
 421              if (!hits)
 422                {
 423                   /* this is the first operator in the list */
 424                   hits = TRUE;
 425                   droplab = getlabel();
 426                }                /* if */
 427              dropout(lvalue, testfunc, droplab, lval);
 428           }
 429         else if (hits)
 430           {                     /* no (more) identical operators */
 431              dropout(lvalue, testfunc, droplab, lval);  /* found at least one operator! */
 432              const1(endval);
 433              jumplabel(endlab = getlabel());
 434              setlabel(droplab);
 435              const1(dropval);
 436              setlabel(endlab);
 437              lval->sym = NULL;
 438              lval->tag = 0;
 439              if (allconst)
 440                {
 441                   lval->ident = iCONSTEXPR;
 442                   lval->constval = constval;
 443                   stgdel(index, cidx);  /* scratch generated code and calculate */
 444                }
 445              else
 446                {
 447                   lval->ident = iEXPRESSION;
 448                   lval->constval = 0;
 449                }                /* if */
 450              return FALSE;
 451           }
 452         else
 453           {
 454              return lvalue;     /* none of the operators in "opstr" were found */
 455           }                     /* if */
 456
 457      }                          /* while */
 458 }
 459
 460 /*
 461  *  Reads into the primary register the variable pointed to by lval if
 462  *  plunging through the hierarchy levels detected an lvalue. Otherwise
 463  *  if a constant was detected, it is loaded. If there is no constant and
 464  *  no lvalue, the primary register must already contain the expression
 465  *  result.
 466  *
 467  *  After that, the compare routines "jmp_ne0" or "jmp_eq0" are called, which
 468  *  compare the primary register against 0, and jump to the "early drop-out"
 469  *  label "exit1" if the condition is true.
 470  */
 471 static void
 472 dropout(int lvalue, void (*testfunc) (int val), int exit1, value * lval)
 473 {
 474    if (lvalue)
 475       rvalue(lval);
 476    else if (lval->ident == iCONSTEXPR)
 477       const1(lval->constval);
 478    (*testfunc) (exit1);
 479 }
 480
 481 static void
 482 checkfunction(value * lval)
 483 {
 484    symbol             *sym = lval->sym;
 485
 486    if (!sym || (sym->ident != iFUNCTN && sym->ident != iREFFUNC))
 487       return;                   /* no known symbol, or not a function result */
 488
 489    if ((sym->usage & uDEFINE) != 0)
 490      {
 491         /* function is defined, can now check the return value (but make an
 492          * exception for directly recursive functions)
 493          */
 494         if (sym != curfunc && (sym->usage & uRETVALUE) == 0)
 495           {
 496              char                symname[2 * sNAMEMAX + 16];    /* allow space for user defined operators */
 497
 498              funcdisplayname(symname, sym->name);
 499              error(209, symname);       /* function should return a value */
 500           }                     /* if */
 501      }
 502    else
 503      {
 504         /* function not yet defined, set */
 505         sym->usage |= uRETVALUE;        /* make sure that a future implementation of
 506                                          * the function uses "return <value>" */
 507      }                          /* if */
 508 }
 509
 510 /*
 511  *  Plunge to a lower level
 512  */
 513 static int
 514 plnge(int *opstr, int opoff, int (*hier) (value * lval), value * lval,
 515       char *forcetag, int chkbitwise)
 516 {
 517    int                 lvalue, opidx;
 518    int                 count;
 519    value               lval2 = { NULL, 0, 0, 0, 0, NULL };
 520
 521    lvalue = plnge1(hier, lval);
 522    if (nextop(&opidx, opstr) == 0)
 523       return lvalue;            /* no operator in "opstr" found */
 524    if (lvalue)
 525       rvalue(lval);
 526    count = 0;
 527    do
 528      {
 529         if (chkbitwise && count++ > 0 && bitwise_opercount != 0)
 530            error(212);
 531         opidx += opoff;         /* add offset to index returned by nextop() */
 532         plnge2(op1[opidx], hier, lval, &lval2);
 533         if (op1[opidx] == ob_and || op1[opidx] == ob_or)
 534            bitwise_opercount++;
 535         if (forcetag)
 536            lval->tag = sc_addtag(forcetag);
 537      }
 538    while (nextop(&opidx, opstr));       /* do */
 539    return FALSE;                /* result of expression is not an lvalue */
 540 }
 541
 542 /*  plnge_rel
 543  *
 544  *  Binary plunge to lower level; this is very simular to plnge, but
 545  *  it has special code generation sequences for chained operations.
 546  */
 547 static int
 548 plnge_rel(int *opstr, int opoff, int (*hier) (value * lval), value * lval)
 549 {
 550    int                 lvalue, opidx;
 551    value               lval2 = { NULL, 0, 0, 0, 0, NULL };
 552    int                 count;
 553
 554    /* this function should only be called for relational operators */
 555    assert(op1[opoff] == os_le);
 556    lvalue = plnge1(hier, lval);
 557    if (nextop(&opidx, opstr) == 0)
 558       return lvalue;            /* no operator in "opstr" found */
 559    if (lvalue)
 560       rvalue(lval);
 561    count = 0;
 562    lval->boolresult = TRUE;
 563    do
 564      {
 565         /* same check as in plnge(), but "chkbitwise" is always TRUE */
 566         if (count > 0 && bitwise_opercount != 0)
 567            error(212);
 568         if (count > 0)
 569           {
 570              relop_prefix();
 571              *lval = lval2;     /* copy right hand expression of the previous iteration */
 572           }                     /* if */
 573         opidx += opoff;
 574         plnge2(op1[opidx], hier, lval, &lval2);
 575         if (count++ > 0)
 576            relop_suffix();
 577      }
 578    while (nextop(&opidx, opstr));       /* enddo */
 579    lval->constval = lval->boolresult;
 580    lval->tag = sc_addtag("bool");       /* force tag to be "bool" */
 581    return FALSE;                /* result of expression is not an lvalue */
 582 }
 583
 584 /*  plnge1
 585  *
 586  *  Unary plunge to lower level
 587  *  Called by: skim(), plnge(), plnge2(), plnge_rel(), hier14() and hier13()
 588  */
 589 static int
 590 plnge1(int          (*hier) (value * lval), value * lval)
 591 {
 592    int                 lvalue, index;
 593    cell                cidx;
 594
 595    stgget(&index, &cidx);       /* mark position in code generator */
 596    lvalue = (*hier) (lval);
 597    if (lval->ident == iCONSTEXPR)
 598       stgdel(index, cidx);      /* load constant later */
 599    return lvalue;
 600 }
 601
 602 /*  plnge2
 603  *
 604  *  Binary plunge to lower level
 605  *  Called by: plnge(), plnge_rel(), hier14() and hier1()
 606  */
 607 static void
 608 plnge2(void         (*oper) (void),
 609        int (*hier) (value * lval), value * lval1, value * lval2)
 610 {
 611    int                 index;
 612    cell                cidx;
 613
 614    stgget(&index, &cidx);       /* mark position in code generator */
 615    if (lval1->ident == iCONSTEXPR)
 616      {                          /* constant on left side; it is not yet loaded */
 617         if (plnge1(hier, lval2))
 618            rvalue(lval2);       /* load lvalue now */
 619         else if (lval2->ident == iCONSTEXPR)
 620            const1(lval2->constval << dbltest(oper, lval2, lval1));
 621         const2(lval1->constval << dbltest(oper, lval2, lval1));
 622         /* ^ doubling of constants operating on integer addresses */
 623         /*   is restricted to "add" and "subtract" operators */
 624      }
 625    else
 626      {                          /* non-constant on left side */
 627         push1();
 628         if (plnge1(hier, lval2))
 629            rvalue(lval2);
 630         if (lval2->ident == iCONSTEXPR)
 631           {                     /* constant on right side */
 632              if (commutative(oper))
 633                {                /* test for commutative operators */
 634                   value               lvaltmp = { NULL, 0, 0, 0, 0, NULL };
 635                   stgdel(index, cidx);  /* scratch push1() and constant fetch (then
 636                                          * fetch the constant again */
 637                   const2(lval2->constval << dbltest(oper, lval1, lval2));
 638                   /* now, the primary register has the left operand and the secondary
 639                    * register the right operand; swap the "lval" variables so that lval1
 640                    * is associated with the secondary register and lval2 with the
 641                    * primary register, as is the "normal" case.
 642                    */
 643                   lvaltmp = *lval1;
 644                   *lval1 = *lval2;
 645                   *lval2 = lvaltmp;
 646                }
 647              else
 648                {
 649                   const1(lval2->constval << dbltest(oper, lval1, lval2));
 650                   pop2();       /* pop result of left operand into secondary register */
 651                }                /* if */
 652           }
 653         else
 654           {                     /* non-constants on both sides */
 655              pop2();
 656              if (dbltest(oper, lval1, lval2))
 657                 cell2addr();    /* double primary register */
 658              if (dbltest(oper, lval2, lval1))
 659                 cell2addr_alt();        /* double secondary register */
 660           }                     /* if */
 661      }                          /* if */
 662    if (oper)
 663      {
 664         /* If used in an expression, a function should return a value.
 665          * If the function has been defined, we can check this. If the
 666          * function was not defined, we can set this requirement (so that
 667          * a future function definition can check this bit.
 668          */
 669         checkfunction(lval1);
 670         checkfunction(lval2);
 671         if (lval1->ident == iARRAY || lval1->ident == iREFARRAY)
 672           {
 673              char               *ptr =
 674                 (lval1->sym) ? lval1->sym->name : "-unknown-";
 675              error(33, ptr);    /* array must be indexed */
 676           }
 677         else if (lval2->ident == iARRAY || lval2->ident == iREFARRAY)
 678           {
 679              char               *ptr =
 680                 (lval2->sym) ? lval2->sym->name : "-unknown-";
 681              error(33, ptr);    /* array must be indexed */
 682           }                     /* if */
 683         /* ??? ^^^ should do same kind of error checking with functions */
 684
 685         /* check whether an "operator" function is defined for the tag names
 686          * (a constant expression cannot be optimized in that case)
 687          */
 688         if (check_userop(oper, lval1->tag, lval2->tag, 2, NULL, &lval1->tag))
 689           {
 690              lval1->ident = iEXPRESSION;
 691              lval1->constval = 0;
 692           }
 693         else if (lval1->ident == iCONSTEXPR && lval2->ident == iCONSTEXPR)
 694           {
 695              /* only constant expression if both constant */
 696              stgdel(index, cidx);       /* scratch generated code and calculate */
 697              if (!matchtag(lval1->tag, lval2->tag, FALSE))
 698                 error(213);     /* tagname mismatch */
 699              lval1->constval =
 700                 calc(lval1->constval, oper, lval2->constval,
 701                      &lval1->boolresult);
 702           }
 703         else
 704           {
 705              if (!matchtag(lval1->tag, lval2->tag, FALSE))
 706                 error(213);     /* tagname mismatch */
 707              (*oper) ();        /* do the (signed) operation */
 708              lval1->ident = iEXPRESSION;
 709           }                     /* if */
 710      }                          /* if */
 711 }
 712
 713 static cell
 714 truemodulus(cell a, cell b)
 715 {
 716    return (a % b + b) % b;
 717 }
 718
 719 static cell
 720 calc(cell left, void (*oper) (), cell right, char *boolresult)
 721 {
 722    if (oper == ob_or)
 723       return (left | right);
 724    else if (oper == ob_xor)
 725       return (left ^ right);
 726    else if (oper == ob_and)
 727       return (left & right);
 728    else if (oper == ob_eq)
 729       return (left == right);
 730    else if (oper == ob_ne)
 731       return (left != right);
 732    else if (oper == os_le)
 733       return *boolresult &= (char)(left <= right), right;
 734    else if (oper == os_ge)
 735       return *boolresult &= (char)(left >= right), right;
 736    else if (oper == os_lt)
 737       return *boolresult &= (char)(left < right), right;
 738    else if (oper == os_gt)
 739       return *boolresult &= (char)(left > right), right;
 740    else if (oper == os_sar)
 741       return (left >> (int)right);
 742    else if (oper == ou_sar)
 743       return ((ucell) left >> (ucell) right);
 744    else if (oper == ob_sal)
 745       return ((ucell) left << (int)right);
 746    else if (oper == ob_add)
 747       return (left + right);
 748    else if (oper == ob_sub)
 749       return (left - right);
 750    else if (oper == os_mult)
 751       return (left * right);
 752    else if (oper == os_div)
 753       return (left - truemodulus(left, right)) / right;
 754    else if (oper == os_mod)
 755       return truemodulus(left, right);
 756    else
 757       error(29);                /* invalid expression, assumed 0 (this should never occur) */
 758    return 0;
 759 }
 760
 761 int
 762 expression(int *constant, cell * val, int *tag, int chkfuncresult)
 763 {
 764    value               lval = { NULL, 0, 0, 0, 0, NULL };
 765
 766    if (hier14(&lval))
 767       rvalue(&lval);
 768    if (lval.ident == iCONSTEXPR)
 769      {                          /* constant expression */
 770         *constant = TRUE;
 771         *val = lval.constval;
 772      }
 773    else
 774      {
 775         *constant = FALSE;
 776         *val = 0;
 777      }                          /* if */
 778    if (tag)
 779       *tag = lval.tag;
 780    if (chkfuncresult)
 781       checkfunction(&lval);
 782    return lval.ident;
 783 }
 784
 785 static cell
 786 array_totalsize(symbol * sym)
 787 {
 788    cell                length;
 789
 790    assert(sym != NULL);
 791    assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
 792    length = sym->dim.array.length;
 793    if (sym->dim.array.level > 0)
 794      {
 795         cell                sublength = array_totalsize(finddepend(sym));
 796
 797         if (sublength > 0)
 798            length = length + length * sublength;
 799         else
 800            length = 0;
 801      }                          /* if */
 802    return length;
 803 }
 804
 805 static cell
 806 array_levelsize(symbol * sym, int level)
 807 {
 808    assert(sym != NULL);
 809    assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
 810    assert(level <= sym->dim.array.level);
 811    while (level-- > 0)
 812      {
 813         sym = finddepend(sym);
 814         assert(sym != NULL);
 815      }                          /* if */
 816    return sym->dim.array.length;
 817 }
 818
 819 /*  hier14
 820  *
 821  *  Lowest hierarchy level (except for the , operator).
 822  *
 823  *  Global references: intest   (reffered to only)
 824  */
 825 int
 826 hier14(value * lval1)
 827 {
 828    int                 lvalue;
 829    value               lval2 = { NULL, 0, 0, 0, 0, NULL };
 830    value               lval3 = { NULL, 0, 0, 0, 0, NULL };
 831    void                (*oper) (void);
 832    int                 tok, level, i;
 833    cell                val;
 834    char               *st;
 835    int                 bwcount;
 836    cell                arrayidx1[sDIMEN_MAX], arrayidx2[sDIMEN_MAX];    /* last used array indices */
 837    cell               *org_arrayidx;
 838
 839    bwcount = bitwise_opercount;
 840    bitwise_opercount = 0;
 841    for (i = 0; i < sDIMEN_MAX; i++)
 842       arrayidx1[i] = arrayidx2[i] = 0;
 843    org_arrayidx = lval1->arrayidx;      /* save current pointer, to reset later */
 844    if (!lval1->arrayidx)
 845       lval1->arrayidx = arrayidx1;
 846    lvalue = plnge1(hier13, lval1);
 847    if (lval1->ident != iARRAYCELL && lval1->ident != iARRAYCHAR)
 848       lval1->arrayidx = NULL;
 849    if (lval1->ident == iCONSTEXPR)      /* load constant here */
 850       const1(lval1->constval);
 851    tok = lex(&val, &st);
 852    switch (tok)
 853      {
 854      case taOR:
 855         oper = ob_or;
 856         break;
 857      case taXOR:
 858         oper = ob_xor;
 859         break;
 860      case taAND:
 861         oper = ob_and;
 862         break;
 863      case taADD:
 864         oper = ob_add;
 865         break;
 866      case taSUB:
 867         oper = ob_sub;
 868         break;
 869      case taMULT:
 870         oper = os_mult;
 871         break;
 872      case taDIV:
 873         oper = os_div;
 874         break;
 875      case taMOD:
 876         oper = os_mod;
 877         break;
 878      case taSHRU:
 879         oper = ou_sar;
 880         break;
 881      case taSHR:
 882         oper = os_sar;
 883         break;
 884      case taSHL:
 885         oper = ob_sal;
 886         break;
 887      case '=':                  /* simple assignment */
 888         oper = NULL;
 889         if (intest)
 890            error(211);          /* possibly unintended assignment */
 891         break;
 892      default:
 893         lexpush();
 894         bitwise_opercount = bwcount;
 895         lval1->arrayidx = org_arrayidx; /* restore array index pointer */
 896         return lvalue;
 897      }                          /* switch */
 898
 899    /* if we get here, it was an assignment; first check a few special cases
 900     * and then the general */
 901    if (lval1->ident == iARRAYCHAR)
 902      {
 903         /* special case, assignment to packed character in a cell is permitted */
 904         lvalue = TRUE;
 905      }
 906    else if (lval1->ident == iARRAY || lval1->ident == iREFARRAY)
 907      {
 908         /* array assignment is permitted too (with restrictions) */
 909         if (oper)
 910            return error(23);    /* array assignment must be simple assigment */
 911         assert(lval1->sym != NULL);
 912         if (array_totalsize(lval1->sym) == 0)
 913            return error(46, lval1->sym->name);  /* unknown array size */
 914         lvalue = TRUE;
 915      }                          /* if */
 916
 917    /* operand on left side of assignment must be lvalue */
 918    if (!lvalue)
 919       return error(22);         /* must be lvalue */
 920    /* may not change "constant" parameters */
 921    assert(lval1->sym != NULL);
 922    if ((lval1->sym->usage & uCONST) != 0)
 923       return error(22);         /* assignment to const argument */
 924    lval3 = *lval1;              /* save symbol to enable storage of expresion result */
 925    lval1->arrayidx = org_arrayidx;      /* restore array index pointer */
 926    if (lval1->ident == iARRAYCELL || lval1->ident == iARRAYCHAR
 927        || lval1->ident == iARRAY || lval1->ident == iREFARRAY)
 928      {
 929         /* if indirect fetch: save PRI (cell address) */
 930         if (oper)
 931           {
 932              push1();
 933              rvalue(lval1);
 934           }                     /* if */
 935         lval2.arrayidx = arrayidx2;
 936         plnge2(oper, hier14, lval1, &lval2);
 937         if (lval2.ident != iARRAYCELL && lval2.ident != iARRAYCHAR)
 938            lval2.arrayidx = NULL;
 939         if (oper)
 940            pop2();
 941         if (!oper && lval3.arrayidx && lval2.arrayidx
 942             && lval3.ident == lval2.ident && lval3.sym == lval2.sym)
 943           {
 944              int                 same = TRUE;
 945
 946              assert(lval3.arrayidx == arrayidx1);
 947              assert(lval2.arrayidx == arrayidx2);
 948              for (i = 0; i < sDIMEN_MAX; i++)
 949                 same = same && (lval3.arrayidx[i] == lval2.arrayidx[i]);
 950              if (same)
 951                 error(226, lval3.sym->name);    /* self-assignment */
 952           }                     /* if */
 953      }
 954    else
 955      {
 956         if (oper)
 957           {
 958              rvalue(lval1);
 959              plnge2(oper, hier14, lval1, &lval2);
 960           }
 961         else
 962           {
 963              /* if direct fetch and simple assignment: no "push"
 964               * and "pop" needed -> call hier14() directly, */
 965              if (hier14(&lval2))
 966                 rvalue(&lval2); /* instead of plnge2(). */
 967              checkfunction(&lval2);
 968              /* check whether lval2 and lval3 (old lval1) refer to the same variable */
 969              if (lval2.ident == iVARIABLE && lval3.ident == lval2.ident
 970                  && lval3.sym == lval2.sym)
 971                {
 972                   assert(lval3.sym != NULL);
 973                   error(226, lval3.sym->name);  /* self-assignment */
 974                }                /* if */
 975           }                     /* if */
 976      }                          /* if */
 977    if (lval3.ident == iARRAY || lval3.ident == iREFARRAY)
 978      {
 979         /* left operand is an array, right operand should be an array variable
 980          * of the same size and the same dimension, an array literal (of the
 981          * same size) or a literal string.
 982          */
 983         int                 exactmatch = TRUE;
 984
 985         if (lval2.ident != iARRAY && lval2.ident != iREFARRAY)
 986            error(33, lval3.sym->name);  /* array must be indexed */
 987         if (lval2.sym)
 988           {
 989              val = lval2.sym->dim.array.length; /* array variable */
 990              level = lval2.sym->dim.array.level;
 991           }
 992         else
 993           {
 994              val = lval2.constval;      /* literal array */
 995              level = 0;
 996              /* If val is negative, it means that lval2 is a
 997               * literal string. The string array size may be
 998               * smaller than the destination array.
 999               */
1000              if (val < 0)
1001                {
1002                   val = -val;
1003                   exactmatch = FALSE;
1004                }                /* if */
1005           }                     /* if */
1006         if (lval3.sym->dim.array.level != level)
1007            return error(48);    /* array dimensions must match */
1008         else if (lval3.sym->dim.array.length < val
1009                  || (exactmatch && lval3.sym->dim.array.length > val))
1010            return error(47);    /* array sizes must match */
1011         if (level > 0)
1012           {
1013              /* check the sizes of all sublevels too */
1014              symbol             *sym1 = lval3.sym;
1015              symbol             *sym2 = lval2.sym;
1016              int                 i;
1017
1018              assert(sym1 != NULL && sym2 != NULL);
1019              /* ^^^ sym2 must be valid, because only variables can be
1020               *     multi-dimensional (there are no multi-dimensional arrays),
1021               *     sym1 must be valid because it must be an lvalue
1022               */
1023              assert(exactmatch);
1024              for (i = 0; i < level; i++)
1025                {
1026                   sym1 = finddepend(sym1);
1027                   sym2 = finddepend(sym2);
1028                   assert(sym1 != NULL && sym2 != NULL);
1029                   /* ^^^ both arrays have the same dimensions (this was checked
1030                    *     earlier) so the dependend should always be found
1031                    */
1032                   if (sym1->dim.array.length != sym2->dim.array.length)
1033                      error(47); /* array sizes must match */
1034                }                /* for */
1035              /* get the total size in cells of the multi-dimensional array */
1036              val = array_totalsize(lval3.sym);
1037              assert(val > 0);   /* already checked */
1038           }                     /* if */
1039      }
1040    else
1041      {
1042         /* left operand is not an array, right operand should then not be either */
1043         if (lval2.ident == iARRAY || lval2.ident == iREFARRAY)
1044            error(6);            /* must be assigned to an array */
1045      }                          /* if */
1046    if (lval3.ident == iARRAY || lval3.ident == iREFARRAY)
1047      {
1048         memcopy(val * sizeof(cell));
1049      }
1050    else
1051      {
1052         check_userop(NULL, lval2.tag, lval3.tag, 2, &lval3, &lval2.tag);
1053         store(&lval3);          /* now, store the expression result */
1054      }                          /* if */
1055    if (!oper && !matchtag(lval3.tag, lval2.tag, TRUE))
1056       error(213);               /* tagname mismatch (if "oper", warning already given in plunge2()) */
1057    if (lval3.sym)
1058       markusage(lval3.sym, uWRITTEN);
1059    sideeffect = TRUE;
1060    bitwise_opercount = bwcount;
1061    return FALSE;                /* expression result is never an lvalue */
1062 }
1063
1064 static int
1065 hier13(value * lval)
1066 {
1067    int                 lvalue, flab1, flab2;
1068    value               lval2 = { NULL, 0, 0, 0, 0, NULL };
1069    int                 array1, array2;
1070
1071    lvalue = plnge1(hier12, lval);
1072    if (matchtoken('?'))
1073      {
1074         flab1 = getlabel();
1075         flab2 = getlabel();
1076         if (lvalue)
1077           {
1078              rvalue(lval);
1079           }
1080         else if (lval->ident == iCONSTEXPR)
1081           {
1082              const1(lval->constval);
1083              error(lval->constval ? 206 : 205); /* redundant test */
1084           }                     /* if */
1085         jmp_eq0(flab1);         /* go to second expression if primary register==0 */
1086         if (hier14(lval))
1087            rvalue(lval);
1088         jumplabel(flab2);
1089         setlabel(flab1);
1090         needtoken(':');
1091         if (hier14(&lval2))
1092            rvalue(&lval2);
1093         array1 = (lval->ident == iARRAY || lval->ident == iREFARRAY);
1094         array2 = (lval2.ident == iARRAY || lval2.ident == iREFARRAY);
1095         if (array1 && !array2)
1096           {
1097              char               *ptr =
1098                 (lval->sym->name) ? lval->sym->name : "-unknown-";
1099              error(33, ptr);    /* array must be indexed */
1100           }
1101         else if (!array1 && array2)
1102           {
1103              char               *ptr =
1104                 (lval2.sym->name) ? lval2.sym->name : "-unknown-";
1105              error(33, ptr);    /* array must be indexed */
1106           }                     /* if */
1107         /* ??? if both are arrays, should check dimensions */
1108         if (!matchtag(lval->tag, lval2.tag, FALSE))
1109            error(213);          /* tagname mismatch ('true' and 'false' expressions) */
1110         setlabel(flab2);
1111         if (lval->ident == iARRAY)
1112            lval->ident = iREFARRAY;     /* iARRAY becomes iREFARRAY */
1113         else if (lval->ident != iREFARRAY)
1114            lval->ident = iEXPRESSION;   /* iREFARRAY stays iREFARRAY, rest becomes iEXPRESSION */
1115         return FALSE;           /* conditional expression is no lvalue */
1116      }
1117    else
1118      {
1119         return lvalue;
1120      }                          /* endif */
1121 }
1122
1123 /* the order of the operators in these lists is important and must cohere */
1124 /* with the order of the operators in the array "op1" */
1125 static int          list3[] = { '*', '/', '%', 0 };
1126 static int          list4[] = { '+', '-', 0 };
1127 static int          list5[] = { tSHL, tSHR, tSHRU, 0 };
1128 static int          list6[] = { '&', 0 };
1129 static int          list7[] = { '^', 0 };
1130 static int          list8[] = { '|', 0 };
1131 static int          list9[] = { tlLE, tlGE, '<', '>', 0 };
1132 static int          list10[] = { tlEQ, tlNE, 0 };
1133 static int          list11[] = { tlAND, 0 };
1134 static int          list12[] = { tlOR, 0 };
1135
1136 static int
1137 hier12(value * lval)
1138 {
1139    return skim(list12, jmp_ne0, 1, 0, hier11, lval);
1140 }
1141
1142 static int
1143 hier11(value * lval)
1144 {
1145    return skim(list11, jmp_eq0, 0, 1, hier10, lval);
1146 }
1147
1148 static int
1149 hier10(value * lval)
1150 {                               /* ==, != */
1151    return plnge(list10, 15, hier9, lval, "bool", TRUE);
1152 }                               /* ^ this variable is the starting index in the op1[]
1153                                  *   array of the operators of this hierarchy level */
1154
1155 static int
1156 hier9(value * lval)
1157 {                               /* <=, >=, <, > */
1158    return plnge_rel(list9, 11, hier8, lval);
1159 }
1160
1161 static int
1162 hier8(value * lval)
1163 {                               /* | */
1164    return plnge(list8, 10, hier7, lval, NULL, FALSE);
1165 }
1166
1167 static int
1168 hier7(value * lval)
1169 {                               /* ^ */
1170    return plnge(list7, 9, hier6, lval, NULL, FALSE);
1171 }
1172
1173 static int
1174 hier6(value * lval)
1175 {                               /* & */
1176    return plnge(list6, 8, hier5, lval, NULL, FALSE);
1177 }
1178
1179 static int
1180 hier5(value * lval)
1181 {                               /* <<, >>, >>> */
1182    return plnge(list5, 5, hier4, lval, NULL, FALSE);
1183 }
1184
1185 static int
1186 hier4(value * lval)
1187 {                               /* +, - */
1188    return plnge(list4, 3, hier3, lval, NULL, FALSE);
1189 }
1190
1191 static int
1192 hier3(value * lval)
1193 {                               /* *, /, % */
1194    return plnge(list3, 0, hier2, lval, NULL, FALSE);
1195 }
1196
1197 static int
1198 hier2(value * lval)
1199 {
1200    int                 lvalue, tok;
1201    int                 tag, paranthese;
1202    cell                val;
1203    char               *st;
1204    symbol             *sym;
1205    int                 saveresult;
1206
1207    tok = lex(&val, &st);
1208    switch (tok)
1209      {
1210      case tINC:         /* ++lval */
1211         if (!hier2(lval))
1212            return error(22);    /* must be lvalue */
1213         assert(lval->sym != NULL);
1214         if ((lval->sym->usage & uCONST) != 0)
1215            return error(22);    /* assignment to const argument */
1216         if (!check_userop(user_inc, lval->tag, 0, 1, lval, &lval->tag))
1217            inc(lval);           /* increase variable first */
1218         rvalue(lval);           /* and read the result into PRI */
1219         sideeffect = TRUE;
1220         return FALSE;           /* result is no longer lvalue */
1221      case tDEC:         /* --lval */
1222         if (!hier2(lval))
1223            return error(22);    /* must be lvalue */
1224         assert(lval->sym != NULL);
1225         if ((lval->sym->usage & uCONST) != 0)
1226            return error(22);    /* assignment to const argument */
1227         if (!check_userop(user_dec, lval->tag, 0, 1, lval, &lval->tag))
1228            dec(lval);           /* decrease variable first */
1229         rvalue(lval);           /* and read the result into PRI */
1230         sideeffect = TRUE;
1231         return FALSE;           /* result is no longer lvalue */
1232      case '~':                  /* ~ (one's complement) */
1233         if (hier2(lval))
1234            rvalue(lval);
1235         invert();               /* bitwise NOT */
1236         lval->constval = ~lval->constval;
1237         return FALSE;
1238      case '!':                  /* ! (logical negate) */
1239         if (hier2(lval))
1240            rvalue(lval);
1241         if (check_userop(lneg, lval->tag, 0, 1, NULL, &lval->tag))
1242           {
1243              lval->ident = iEXPRESSION;
1244              lval->constval = 0;
1245           }
1246         else
1247           {
1248              lneg();            /* 0 -> 1,  !0 -> 0 */
1249              lval->constval = !lval->constval;
1250              lval->tag = sc_addtag("bool");
1251           }                     /* if */
1252         return FALSE;
1253      case '-':                  /* unary - (two's complement) */
1254         if (hier2(lval))
1255            rvalue(lval);
1256         /* make a special check for a constant expression with the tag of a
1257          * rational number, so that we can simple swap the sign of that constant.
1258          */
1259         if (lval->ident == iCONSTEXPR && lval->tag == sc_rationaltag
1260             && sc_rationaltag != 0)
1261           {
1262              if (rational_digits == 0)
1263                {
1264                   float              *f = (float *)&lval->constval;
1265
1266                   *f = -*f;     /* this modifies lval->constval */
1267                }
1268              else
1269                {
1270                   /* the negation of a fixed point number is just an integer negation */
1271                   lval->constval = -lval->constval;
1272                }                /* if */
1273           }
1274         else if (check_userop(neg, lval->tag, 0, 1, NULL, &lval->tag))
1275           {
1276              lval->ident = iEXPRESSION;
1277              lval->constval = 0;
1278           }
1279         else
1280           {
1281              neg();             /* arithmic negation */
1282              lval->constval = -lval->constval;
1283           }                     /* if */
1284         return FALSE;
1285      case tLABEL:               /* tagname override */
1286         tag = sc_addtag(st);
1287         lvalue = hier2(lval);
1288         lval->tag = tag;
1289         return lvalue;
1290      case tDEFINED:
1291         paranthese = 0;
1292         while (matchtoken('('))
1293            paranthese++;
1294         tok = lex(&val, &st);
1295         if (tok != tSYMBOL)
1296            return error(20, st);        /* illegal symbol name */
1297         sym = findloc(st);
1298         if (!sym)
1299            sym = findglb(st);
1300         if (sym && sym->ident != iFUNCTN && sym->ident != iREFFUNC
1301             && (sym->usage & uDEFINE) == 0)
1302            sym = NULL;          /* symbol is not a function, it is in the table, but not "defined" */
1303         val = !!sym;
1304         if (!val && find_subst(st, strlen(st)))
1305            val = 1;
1306         clear_value(lval);
1307         lval->ident = iCONSTEXPR;
1308         lval->constval = val;
1309         const1(lval->constval);
1310         while (paranthese--)
1311            needtoken(')');
1312         return FALSE;
1313      case tSIZEOF:
1314         paranthese = 0;
1315         while (matchtoken('('))
1316            paranthese++;
1317         tok = lex(&val, &st);
1318         if (tok != tSYMBOL)
1319            return error(20, st);        /* illegal symbol name */
1320         sym = findloc(st);
1321         if (!sym)
1322            sym = findglb(st);
1323         if (!sym)
1324            return error(17, st);        /* undefined symbol */
1325         if (sym->ident == iCONSTEXPR)
1326            error(39);           /* constant symbol has no size */
1327         else if (sym->ident == iFUNCTN || sym->ident == iREFFUNC)
1328            error(72);           /* "function" symbol has no size */
1329         else if ((sym->usage & uDEFINE) == 0)
1330            return error(17, st);        /* undefined symbol (symbol is in the table, but it is "used" only) */
1331         clear_value(lval);
1332         lval->ident = iCONSTEXPR;
1333         lval->constval = 1;     /* preset */
1334         if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1335           {
1336              int                 level;
1337
1338              for (level = 0; matchtoken('['); level++)
1339                 needtoken(']');
1340              if (level > sym->dim.array.level)
1341                 error(28);      /* invalid subscript */
1342              else
1343                 lval->constval = array_levelsize(sym, level);
1344              if (lval->constval == 0 && !strchr(lptr, PREPROC_TERM))
1345                 error(224, st); /* indeterminate array size in "sizeof" expression */
1346           }                     /* if */
1347         const1(lval->constval);
1348         while (paranthese--)
1349            needtoken(')');
1350         return FALSE;
1351      case tTAGOF:
1352         paranthese = 0;
1353         while (matchtoken('('))
1354            paranthese++;
1355         tok = lex(&val, &st);
1356         if (tok != tSYMBOL && tok != tLABEL)
1357            return error(20, st);        /* illegal symbol name */
1358         if (tok == tLABEL)
1359           {
1360              tag = sc_addtag(st);
1361           }
1362         else
1363           {
1364              sym = findloc(st);
1365              if (!sym)
1366                 sym = findglb(st);
1367              if (!sym)
1368                 return error(17, st);   /* undefined symbol */
1369              if ((sym->usage & uDEFINE) == 0)
1370                 return error(17, st);   /* undefined symbol (symbol is in the table, but it is "used" only) */
1371              tag = sym->tag;
1372           }                     /* if */
1373         exporttag(tag);
1374         clear_value(lval);
1375         lval->ident = iCONSTEXPR;
1376         lval->constval = tag;
1377         const1(lval->constval);
1378         while (paranthese--)
1379            needtoken(')');
1380         return FALSE;
1381      default:
1382         lexpush();
1383         lvalue = hier1(lval);
1384         /* check for postfix operators */
1385         if (matchtoken(';'))
1386           {
1387              /* Found a ';', do not look further for postfix operators */
1388              lexpush();         /* push ';' back after successful match */
1389              return lvalue;
1390           }
1391         else if (matchtoken(tTERM))
1392           {
1393              /* Found a newline that ends a statement (this is the case when
1394               * semicolons are optional). Note that an explicit semicolon was
1395               * handled above. This case is similar, except that the token must
1396               * not be pushed back.
1397               */
1398              return lvalue;
1399           }
1400         else
1401           {
1402              tok = lex(&val, &st);
1403              switch (tok)
1404                {
1405                case tINC:       /* lval++ */
1406                   if (!lvalue)
1407                      return error(22);  /* must be lvalue */
1408                   assert(lval->sym != NULL);
1409                   if ((lval->sym->usage & uCONST) != 0)
1410                      return error(22);  /* assignment to const argument */
1411                   /* on incrementing array cells, the address in PRI must be saved for
1412                    * incremening the value, whereas the current value must be in PRI
1413                    * on exit.
1414                    */
1415                   saveresult = (lval->ident == iARRAYCELL
1416                                 || lval->ident == iARRAYCHAR);
1417                   if (saveresult)
1418                      push1();   /* save address in PRI */
1419                   rvalue(lval); /* read current value into PRI */
1420                   if (saveresult)
1421                      swap1();   /* save PRI on the stack, restore address in PRI */
1422                   if (!check_userop
1423                       (user_inc, lval->tag, 0, 1, lval, &lval->tag))
1424                      inc(lval); /* increase variable afterwards */
1425                   if (saveresult)
1426                      pop1();    /* restore PRI (result of rvalue()) */
1427                   sideeffect = TRUE;
1428                   return FALSE; /* result is no longer lvalue */
1429                case tDEC:       /* lval-- */
1430                   if (!lvalue)
1431                      return error(22);  /* must be lvalue */
1432                   assert(lval->sym != NULL);
1433                   if ((lval->sym->usage & uCONST) != 0)
1434                      return error(22);  /* assignment to const argument */
1435                   saveresult = (lval->ident == iARRAYCELL
1436                                 || lval->ident == iARRAYCHAR);
1437                   if (saveresult)
1438                      push1();   /* save address in PRI */
1439                   rvalue(lval); /* read current value into PRI */
1440                   if (saveresult)
1441                      swap1();   /* save PRI on the stack, restore address in PRI */
1442                   if (!check_userop
1443                       (user_dec, lval->tag, 0, 1, lval, &lval->tag))
1444                      dec(lval); /* decrease variable afterwards */
1445                   if (saveresult)
1446                      pop1();    /* restore PRI (result of rvalue()) */
1447                   sideeffect = TRUE;
1448                   return FALSE;
1449                case tCHAR:      /* char (compute required # of cells */
1450                   if (lval->ident == iCONSTEXPR)
1451                     {
1452                        lval->constval *= charbits / 8;  /* from char to bytes */
1453                        lval->constval =
1454                           (lval->constval + sizeof(cell) - 1) / sizeof(cell);
1455                     }
1456                   else
1457                     {
1458                        if (lvalue)
1459                           rvalue(lval); /* fetch value if not already in PRI */
1460                        char2addr();     /* from characters to bytes */
1461                        addconst(sizeof(cell) - 1);      /* make sure the value is rounded up */
1462                        addr2cell();     /* truncate to number of cells */
1463                     }           /* if */
1464                   return FALSE;
1465                default:
1466                   lexpush();
1467                   return lvalue;
1468                }                /* switch */
1469           }                     /* if */
1470      }                          /* switch */
1471 }
1472
1473 /*  hier1
1474  *
1475  *  The highest hierarchy level: it looks for pointer and array indices
1476  *  and function calls.
1477  *  Generates code to fetch a pointer value if it is indexed and code to
1478  *  add to the pointer value or the array address (the address is already
1479  *  read at primary()). It also generates code to fetch a function address
1480  *  if that hasn't already been done at primary() (check lval[4]) and calls
1481  *  callfunction() to call the function.
1482  */
1483 static int
1484 hier1(value * lval1)
1485 {
1486    int                 lvalue, index, tok, symtok;
1487    cell                val, cidx;
1488    value               lval2 = { NULL, 0, 0, 0, 0, NULL };
1489    char               *st;
1490    char                close;
1491    symbol             *sym;
1492
1493    lvalue = primary(lval1);
1494    symtok = tokeninfo(&val, &st);       /* get token read by primary() */
1495  restart:
1496    sym = lval1->sym;
1497    if (matchtoken('[') || matchtoken('{') || matchtoken('('))
1498      {
1499         tok = tokeninfo(&val, &st);     /* get token read by matchtoken() */
1500         if (!sym && symtok != tSYMBOL)
1501           {
1502              /* we do not have a valid symbol and we appear not to have read a valid
1503               * symbol name (so it is unlikely that we would have read a name of an
1504               * undefined symbol) */
1505              error(29);         /* expression error, assumed 0 */
1506              lexpush();         /* analyse '(', '{' or '[' again later */
1507              return FALSE;
1508           }                     /* if */
1509         if (tok == '[' || tok == '{')
1510           {                     /* subscript */
1511              close = (char)((tok == '[') ? ']' : '}');
1512              if (!sym)
1513                {                /* sym==NULL if lval is a constant or a literal */
1514                   error(28);    /* cannot subscript */
1515                   needtoken(close);
1516                   return FALSE;
1517                }
1518              else if (sym->ident != iARRAY && sym->ident != iREFARRAY)
1519                {
1520                   error(28);    /* cannot subscript, variable is not an array */
1521                   needtoken(close);
1522                   return FALSE;
1523                }
1524              else if (sym->dim.array.level > 0 && close != ']')
1525                {
1526                   error(51);    /* invalid subscript, must use [ ] */
1527                   needtoken(close);
1528                   return FALSE;
1529                }                /* if */
1530              stgget(&index, &cidx);     /* mark position in code generator */
1531              push1();           /* save base address of the array */
1532              if (hier14(&lval2))        /* create expression for the array index */
1533                 rvalue(&lval2);
1534              if (lval2.ident == iARRAY || lval2.ident == iREFARRAY)
1535                 error(33, lval2.sym->name);     /* array must be indexed */
1536              needtoken(close);
1537              if (!matchtag(sym->x.idxtag, lval2.tag, TRUE))
1538                 error(213);
1539              if (lval2.ident == iCONSTEXPR)
1540                {                /* constant expression */
1541                   stgdel(index, cidx);  /* scratch generated code */
1542                   if (lval1->arrayidx)
1543                     {           /* keep constant index, for checking */
1544                        assert(sym->dim.array.level >= 0
1545                               && sym->dim.array.level < sDIMEN_MAX);
1546                        lval1->arrayidx[sym->dim.array.level] = lval2.constval;
1547                     }           /* if */
1548                   if (close == ']')
1549                     {
1550                        /* normal array index */
1551                        if (lval2.constval < 0 || (sym->dim.array.length != 0
1552                            && sym->dim.array.length <= lval2.constval))
1553                           error(32, sym->name); /* array index out of bounds */
1554                        if (lval2.constval != 0)
1555                          {
1556                             /* don't add offsets for zero subscripts */
1557 #if defined(BIT16)
1558                             const2(lval2.constval << 1);
1559 #else
1560                             const2(lval2.constval << 2);
1561 #endif
1562                             ob_add();
1563                          }      /* if */
1564                     }
1565                   else
1566                     {
1567                        /* character index */
1568                        if (lval2.constval < 0 || (sym->dim.array.length != 0
1569                            && sym->dim.array.length * ((8 * sizeof(cell)) /
1570                                                        charbits) <=
1571                            (ucell) lval2.constval))
1572                           error(32, sym->name); /* array index out of bounds */
1573                        if (lval2.constval != 0)
1574                          {
1575                             /* don't add offsets for zero subscripts */
1576                             if (charbits == 16)
1577                                const2(lval2.constval << 1);     /* 16-bit character */
1578                             else
1579                                const2(lval2.constval);  /* 8-bit character */
1580                             ob_add();
1581                          }      /* if */
1582                        charalign();     /* align character index into array */
1583                     }           /* if */
1584                }
1585              else
1586                {
1587                   /* array index is not constant */
1588                   lval1->arrayidx = NULL;       /* reset, so won't be checked */
1589                   if (close == ']')
1590                     {
1591                        if (sym->dim.array.length != 0)
1592                           ffbounds(sym->dim.array.length - 1);  /* run time check for array bounds */
1593                        cell2addr();     /* normal array index */
1594                     }
1595                   else
1596                     {
1597                        if (sym->dim.array.length != 0)
1598                           ffbounds(sym->dim.array.length * (32 / charbits) - 1);
1599                        char2addr();     /* character array index */
1600                     }           /* if */
1601                   pop2();
1602                   ob_add();     /* base address was popped into secondary register */
1603                   if (close != ']')
1604                      charalign();       /* align character index into array */
1605                }                /* if */
1606              /* the indexed item may be another array (multi-dimensional arrays) */
1607              assert(lval1->sym == sym && sym != NULL);  /* should still be set */
1608              if (sym->dim.array.level > 0)
1609                {
1610                   assert(close == ']'); /* checked earlier */
1611                   /* read the offset to the subarray and add it to the current address */
1612                   lval1->ident = iARRAYCELL;
1613                   push1();      /* the optimizer makes this to a MOVE.alt */
1614                   rvalue(lval1);
1615                   pop2();
1616                   ob_add();
1617                   /* adjust the "value" structure and find the referenced array */
1618                   lval1->ident = iREFARRAY;
1619                   lval1->sym = finddepend(sym);
1620                   assert(lval1->sym != NULL);
1621                   assert(lval1->sym->dim.array.level ==
1622                          sym->dim.array.level - 1);
1623                   /* try to parse subsequent array indices */
1624                   lvalue = FALSE;       /* for now, a iREFARRAY is no lvalue */
1625                   goto restart;
1626                }                /* if */
1627              assert(sym->dim.array.level == 0);
1628              /* set type to fetch... INDIRECTLY */
1629              lval1->ident = (char)((close == ']') ? iARRAYCELL : iARRAYCHAR);
1630              lval1->tag = sym->tag;
1631              /* a cell in an array is an lvalue, a character in an array is not
1632               * always a *valid* lvalue */
1633              return TRUE;
1634           }
1635         else
1636           {                     /* tok=='(' -> function(...) */
1637              if (!sym
1638                  || (sym->ident != iFUNCTN && sym->ident != iREFFUNC))
1639                {
1640                   if (!sym && sc_status == statFIRST)
1641                     {
1642                        /* could be a "use before declaration"; in that case, create a stub
1643                         * function so that the usage can be marked.
1644                         */
1645                        sym = fetchfunc(lastsymbol, 0);
1646                        if (sym)
1647                           markusage(sym, uREAD);
1648                     }           /* if */
1649                   return error(12);     /* invalid function call */
1650                }
1651              else if ((sym->usage & uMISSING) != 0)
1652                {
1653                   char                symname[2 * sNAMEMAX + 16];       /* allow space for user defined operators */
1654
1655                   funcdisplayname(symname, sym->name);
1656                   error(4, symname);    /* function not defined */
1657                }                /* if */
1658              callfunction(sym);
1659              lval1->ident = iEXPRESSION;
1660              lval1->constval = 0;
1661              lval1->tag = sym->tag;
1662              return FALSE;      /* result of function call is no lvalue */
1663           }                     /* if */
1664      }                          /* if */
1665    if (sym && lval1->ident == iFUNCTN)
1666      {
1667         assert(sym->ident == iFUNCTN);
1668         address(sym);
1669         lval1->sym = NULL;
1670         lval1->ident = iREFFUNC;
1671         /* ??? however... function pointers (or function references are not (yet) allowed */
1672         error(29);              /* expression error, assumed 0 */
1673         return FALSE;
1674      }                          /* if */
1675    return lvalue;
1676 }
1677
1678 /*  primary
1679  *
1680  *  Returns 1 if the operand is an lvalue (everything except arrays, functions
1681  *  constants and -of course- errors).
1682  *  Generates code to fetch the address of arrays. Code for constants is
1683  *  already generated by constant().
1684  *  This routine first clears the entire lval array (all fields are set to 0).
1685  *
1686  *  Global references: intest  (may be altered, but restored upon termination)
1687  */
1688 static int
1689 primary(value * lval)
1690 {
1691    char               *st;
1692    int                 lvalue, tok;
1693    cell                val;
1694    symbol             *sym;
1695
1696    if (matchtoken('('))
1697      {                          /* sub-expression - (expression,...) */
1698         pushstk((stkitem) intest);
1699         pushstk((stkitem) sc_allowtags);
1700
1701         intest = 0;             /* no longer in "test" expression */
1702         sc_allowtags = TRUE;    /* allow tagnames to be used in parenthised expressions */
1703         do
1704            lvalue = hier14(lval);
1705         while (matchtoken(','));
1706         needtoken(')');
1707         lexclr(FALSE);          /* clear lex() push-back, it should have been
1708                                  * cleared already by needtoken() */
1709         sc_allowtags = (int)(long)popstk();
1710         intest = (int)(long)popstk();
1711         return lvalue;
1712      }                          /* if */
1713
1714    clear_value(lval);           /* clear lval */
1715    tok = lex(&val, &st);
1716    if (tok == tSYMBOL)
1717      {
1718         /* lastsymbol is char[sNAMEMAX+1], lex() should have truncated any symbol
1719          * to sNAMEMAX significant characters */
1720         assert(strlen(st) < sizeof lastsymbol);
1721         strcpy(lastsymbol, st);
1722      }                          /* if */
1723    if (tok == tSYMBOL && !findconst(st))
1724      {
1725         /* first look for a local variable */
1726         if ((sym = findloc(st)))
1727           {
1728              if (sym->ident == iLABEL)
1729                {
1730                   error(29);    /* expression error, assumed 0 */
1731                   const1(0);    /* load 0 */
1732                   return FALSE; /* return 0 for labels (expression error) */
1733                }                /* if */
1734              lval->sym = sym;
1735              lval->ident = sym->ident;
1736              lval->tag = sym->tag;
1737              if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1738                {
1739                   address(sym); /* get starting address in primary register */
1740                   return FALSE; /* return 0 for array (not lvalue) */
1741                }
1742              else
1743                {
1744                   return TRUE;  /* return 1 if lvalue (not label or array) */
1745                }                /* if */
1746           }                     /* if */
1747         /* now try a global variable */
1748         if ((sym = findglb(st)))
1749           {
1750              if (sym->ident == iFUNCTN || sym->ident == iREFFUNC)
1751                {
1752                   /* if the function is only in the table because it was inserted as a
1753                    * stub in the first pass (i.e. it was "used" but never declared or
1754                    * implemented, issue an error
1755                    */
1756                   if ((sym->usage & uPROTOTYPED) == 0)
1757                      error(17, st);
1758                }
1759              else
1760                {
1761                   if ((sym->usage & uDEFINE) == 0)
1762                      error(17, st);
1763                   lval->sym = sym;
1764                   lval->ident = sym->ident;
1765                   lval->tag = sym->tag;
1766                   if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1767                     {
1768                        address(sym);    /* get starting address in primary register */
1769                        return FALSE;    /* return 0 for array (not lvalue) */
1770                     }
1771                   else
1772                     {
1773                        return TRUE;     /* return 1 if lvalue (not function or array) */
1774                     }           /* if */
1775                }                /* if */
1776           }
1777         else
1778           {
1779              return error(17, st);      /* undefined symbol */
1780           }                     /* endif */
1781         assert(sym != NULL);
1782         assert(sym->ident == iFUNCTN || sym->ident != iREFFUNC);
1783         lval->sym = sym;
1784         lval->ident = sym->ident;
1785         lval->tag = sym->tag;
1786         return FALSE;           /* return 0 for function (not an lvalue) */
1787      }                          /* if */
1788    lexpush();                   /* push the token, it is analyzed by constant() */
1789    if (constant(lval) == 0)
1790      {
1791         error(29);              /* expression error, assumed 0 */
1792         const1(0);              /* load 0 */
1793      }                          /* if */
1794    return FALSE;                /* return 0 for constants (or errors) */
1795 }
1796
1797 static void
1798 clear_value(value * lval)
1799 {
1800    lval->sym = NULL;
1801    lval->constval = 0L;
1802    lval->tag = 0;
1803    lval->ident = 0;
1804    lval->boolresult = FALSE;
1805    /* do not clear lval->arrayidx, it is preset in hier14() */
1806 }
1807
1808 static void
1809 setdefarray(cell * string, cell size, cell array_sz, cell * dataaddr,
1810             int fconst)
1811 {
1812    /* The routine must copy the default array data onto the heap, as to avoid
1813     * that a function can change the default value. An optimization is that
1814     * the default array data is "dumped" into the data segment only once (on the
1815     * first use).
1816     */
1817    assert(string != NULL);
1818    assert(size > 0);
1819    /* check whether to dump the default array */
1820    assert(dataaddr != NULL);
1821    if (sc_status == statWRITE && *dataaddr < 0)
1822      {
1823         int                 i;
1824
1825         *dataaddr = (litidx + glb_declared) * sizeof(cell);
1826         for (i = 0; i < size; i++)
1827            stowlit(*string++);
1828      }                          /* if */
1829
1830    /* if the function is known not to modify the array (meaning that it also
1831     * does not modify the default value), directly pass the address of the
1832     * array in the data segment.
1833     */
1834    if (fconst)
1835      {
1836         const1(*dataaddr);
1837      }
1838    else
1839      {
1840         /* Generate the code:
1841          *  CONST.pri dataaddr                ;address of the default array data
1842          *  HEAP      array_sz*sizeof(cell)   ;heap address in ALT
1843          *  MOVS      size*sizeof(cell)       ;copy data from PRI to ALT
1844          *  MOVE.PRI                          ;PRI = address on the heap
1845          */
1846         const1(*dataaddr);
1847         /* "array_sz" is the size of the argument (the value between the brackets
1848          * in the declaration), "size" is the size of the default array data.
1849          */
1850         assert(array_sz >= size);
1851         modheap((int)array_sz * sizeof(cell));
1852         /* ??? should perhaps fill with zeros first */
1853         memcopy(size * sizeof(cell));
1854         moveto1();
1855      }                          /* if */
1856 }
1857
1858 static int
1859 findnamedarg(arginfo * arg, char *name)
1860 {
1861    int                 i;
1862
1863    for (i = 0; arg[i].ident != 0 && arg[i].ident != iVARARGS; i++)
1864       if (strcmp(arg[i].name, name) == 0)
1865          return i;
1866    return -1;
1867 }
1868
1869 static int
1870 checktag(int tags[], int numtags, int exprtag)
1871 {
1872    int                 i;
1873
1874    assert(tags != 0);
1875    assert(numtags > 0);
1876    for (i = 0; i < numtags; i++)
1877       if (matchtag(tags[i], exprtag, TRUE))
1878          return TRUE;           /* matching tag */
1879    return FALSE;                /* no tag matched */
1880 }
1881
1882 enum
1883 {
1884    ARG_UNHANDLED,
1885    ARG_IGNORED,
1886    ARG_DONE,
1887 };
1888
1889 /*  callfunction
1890  *
1891  *  Generates code to call a function. This routine handles default arguments
1892  *  and positional as well as named parameters.
1893  */
1894 static void
1895 callfunction(symbol * sym)
1896 {
1897    int                 close, lvalue;
1898    int                 argpos;  /* index in the output stream (argpos==nargs if positional parameters) */
1899    int                 argidx = 0;      /* index in "arginfo" list */
1900    int                 nargs = 0;       /* number of arguments */
1901    int                 heapalloc = 0;
1902    int                 namedparams = FALSE;
1903    value               lval = { NULL, 0, 0, 0, 0, NULL };
1904    arginfo            *arg;
1905    char                arglist[sMAXARGS];
1906    constvalue          arrayszlst = { NULL, "", 0, 0 }; /* array size list starts empty */
1907    cell                lexval;
1908    char               *lexstr;
1909
1910    assert(sym != NULL);
1911    arg = sym->dim.arglist;
1912    assert(arg != NULL);
1913    stgmark(sSTARTREORDER);
1914    for (argpos = 0; argpos < sMAXARGS; argpos++)
1915       arglist[argpos] = ARG_UNHANDLED;
1916    if (!matchtoken(')'))
1917      {
1918         do
1919           {
1920              if (matchtoken('.'))
1921                {
1922                   namedparams = TRUE;
1923                   if (needtoken(tSYMBOL))
1924                      tokeninfo(&lexval, &lexstr);
1925                   else
1926                      lexstr = "";
1927                   argpos = findnamedarg(arg, lexstr);
1928                   if (argpos < 0)
1929                     {
1930                        error(17, lexstr);       /* undefined symbol */
1931                        break;   /* exit loop, argpos is invalid */
1932                     }           /* if */
1933                   needtoken('=');
1934                   argidx = argpos;
1935                }
1936              else
1937                {
1938                   if (namedparams)
1939                      error(44); /* positional parameters must precede named parameters */
1940                   argpos = nargs;
1941                }                /* if */
1942              stgmark((char)(sEXPRSTART + argpos));      /* mark beginning of new expression in stage */
1943              if (arglist[argpos] != ARG_UNHANDLED)
1944                 error(58);      /* argument already set */
1945              if (matchtoken('_'))
1946                {
1947                   arglist[argpos] = ARG_IGNORED;        /* flag argument as "present, but ignored" */
1948                   if (arg[argidx].ident == 0 || arg[argidx].ident == iVARARGS)
1949                     {
1950                        error(202);      /* argument count mismatch */
1951                     }
1952                   else if (!arg[argidx].hasdefault)
1953                     {
1954                        error(34, nargs + 1);    /* argument has no default value */
1955                     }           /* if */
1956                   if (arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS)
1957                      argidx++;
1958                   /* The rest of the code to handle default values is at the bottom
1959                    * of this routine where default values for unspecified parameters
1960                    * are (also) handled. Note that above, the argument is flagged as
1961                    * ARG_IGNORED.
1962                    */
1963                }
1964              else
1965                {
1966                   arglist[argpos] = ARG_DONE;   /* flag argument as "present" */
1967                   lvalue = hier14(&lval);
1968                   switch (arg[argidx].ident)
1969                     {
1970                     case 0:
1971                        error(202);      /* argument count mismatch */
1972                        break;
1973                     case iVARARGS:
1974                        /* always pass by reference */
1975                        if (lval.ident == iVARIABLE || lval.ident == iREFERENCE)
1976                          {
1977                             assert(lval.sym != NULL);
1978                             if ((lval.sym->usage & uCONST) != 0
1979                                 && (arg[argidx].usage & uCONST) == 0)
1980                               {
1981                                  /* treat a "const" variable passed to a function with a non-const
1982                                   * "variable argument list" as a constant here */
1983                                  assert(lvalue);
1984                                  rvalue(&lval); /* get value in PRI */
1985                                  setheap_pri(); /* address of the value on the heap in PRI */
1986                                  heapalloc++;
1987                               }
1988                             else if (lvalue)
1989                               {
1990                                  address(lval.sym);
1991                               }
1992                             else
1993                               {
1994                                  setheap_pri(); /* address of the value on the heap in PRI */
1995                                  heapalloc++;
1996                               } /* if */
1997                          }
1998                        else if (lval.ident == iCONSTEXPR
1999                                 || lval.ident == iEXPRESSION
2000                                 || lval.ident == iARRAYCHAR)
2001                          {
2002                             /* fetch value if needed */
2003                             if (lval.ident == iARRAYCHAR)
2004                                rvalue(&lval);
2005                             /* allocate a cell on the heap and store the
2006                              * value (already in PRI) there */
2007                             setheap_pri();      /* address of the value on the heap in PRI */
2008                             heapalloc++;
2009                          }      /* if */
2010                        /* ??? handle const array passed by reference */
2011                        /* otherwise, the address is already in PRI */
2012                        if (lval.sym)
2013                           markusage(lval.sym, uWRITTEN);
2014 /*
2015  * Dont need this warning - its varargs. there is no way of knowing the
2016  * required tag/type...
2017  *
2018           if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
2019             error(213);
2020  */
2021                        break;
2022                     case iVARIABLE:
2023                        if (lval.ident == iLABEL || lval.ident == iFUNCTN
2024                            || lval.ident == iREFFUNC || lval.ident == iARRAY
2025                            || lval.ident == iREFARRAY)
2026                           error(35, argidx + 1);        /* argument type mismatch */
2027                        if (lvalue)
2028                           rvalue(&lval);        /* get value (direct or indirect) */
2029                        /* otherwise, the expression result is already in PRI */
2030                        assert(arg[argidx].numtags > 0);
2031                        check_userop(NULL, lval.tag, arg[argidx].tags[0], 2,
2032                                     NULL, &lval.tag);
2033                        if (!checktag
2034                            (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2035                           error(213);
2036                        argidx++;        /* argument done */
2037                        break;
2038                     case iREFERENCE:
2039                        if (!lvalue || lval.ident == iARRAYCHAR)
2040                           error(35, argidx + 1);        /* argument type mismatch */
2041                        if (lval.sym && (lval.sym->usage & uCONST) != 0
2042                            && (arg[argidx].usage & uCONST) == 0)
2043                           error(35, argidx + 1);        /* argument type mismatch */
2044                        if (lval.ident == iVARIABLE || lval.ident == iREFERENCE)
2045                          {
2046                             if (lvalue)
2047                               {
2048                                  assert(lval.sym != NULL);
2049                                  address(lval.sym);
2050                               }
2051                             else
2052                               {
2053                                  setheap_pri(); /* address of the value on the heap in PRI */
2054                                  heapalloc++;
2055                               } /* if */
2056                          }      /* if */
2057                        /* otherwise, the address is already in PRI */
2058                        if (!checktag
2059                            (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2060                           error(213);
2061                        argidx++;        /* argument done */
2062                        if (lval.sym)
2063                           markusage(lval.sym, uWRITTEN);
2064                        break;
2065                     case iREFARRAY:
2066                        if (lval.ident != iARRAY && lval.ident != iREFARRAY
2067                            && lval.ident != iARRAYCELL)
2068                          {
2069                             error(35, argidx + 1);      /* argument type mismatch */
2070                             break;
2071                          }      /* if */
2072                        if (lval.sym && (lval.sym->usage & uCONST) != 0
2073                            && (arg[argidx].usage & uCONST) == 0)
2074                           error(35, argidx + 1);        /* argument type mismatch */
2075                        /* Verify that the dimensions match with those in arg[argidx].
2076                         * A literal array always has a single dimension.
2077                         * An iARRAYCELL parameter is also assumed to have a single dimension.
2078                         */
2079                        if (!lval.sym || lval.ident == iARRAYCELL)
2080                          {
2081                             if (arg[argidx].numdim != 1)
2082                               {
2083                                  error(48);     /* array dimensions must match */
2084                               }
2085                             else if (arg[argidx].dim[0] != 0)
2086                               {
2087                                  assert(arg[argidx].dim[0] > 0);
2088                                  if (lval.ident == iARRAYCELL)
2089                                    {
2090                                       error(47);        /* array sizes must match */
2091                                    }
2092                                  else
2093                                    {
2094                                       assert(lval.constval != 0);       /* literal array must have a size */
2095                                       /* A literal array must have exactly the same size as the
2096                                        * function argument; a literal string may be smaller than
2097                                        * the function argument.
2098                                        */
2099                                       if ((lval.constval > 0
2100                                           && arg[argidx].dim[0] != lval.constval)
2101                                           || (lval.constval < 0
2102                                           && arg[argidx].dim[0] <
2103                                           -lval.constval))
2104                                          error(47);     /* array sizes must match */
2105                                    }    /* if */
2106                               } /* if */
2107                             if (lval.ident != iARRAYCELL)
2108                               {
2109                                  /* save array size, for default values with uSIZEOF flag */
2110                                  cell                array_sz = lval.constval;
2111
2112                                  assert(array_sz != 0); /* literal array must have a size */
2113                                  if (array_sz < 0)
2114                                     array_sz = -array_sz;
2115                                  append_constval(&arrayszlst, arg[argidx].name,
2116                                                  array_sz, 0);
2117                               } /* if */
2118                          }
2119                        else
2120                          {
2121                             symbol             *sym = lval.sym;
2122                             short               level = 0;
2123
2124                             assert(sym != NULL);
2125                             if (sym->dim.array.level + 1 != arg[argidx].numdim)
2126                                error(48);       /* array dimensions must match */
2127                             /* the lengths for all dimensions must match, unless the dimension
2128                              * length was defined at zero (which means "undefined")
2129                              */
2130                             while (sym->dim.array.level > 0)
2131                               {
2132                                  assert(level < sDIMEN_MAX);
2133                                  if (arg[argidx].dim[level] != 0
2134                                      && sym->dim.array.length !=
2135                                      arg[argidx].dim[level])
2136                                     error(47);  /* array sizes must match */
2137                                  append_constval(&arrayszlst, arg[argidx].name,
2138                                                  sym->dim.array.length, level);
2139                                  sym = finddepend(sym);
2140                                  assert(sym != NULL);
2141                                  level++;
2142                               } /* if */
2143                             /* the last dimension is checked too, again, unless it is zero */
2144                             assert(level < sDIMEN_MAX);
2145                             assert(sym != NULL);
2146                             if (arg[argidx].dim[level] != 0
2147                                 && sym->dim.array.length !=
2148                                 arg[argidx].dim[level])
2149                                error(47);       /* array sizes must match */
2150                             append_constval(&arrayszlst, arg[argidx].name,
2151                                             sym->dim.array.length, level);
2152                          }      /* if */
2153                        /* address already in PRI */
2154                        if (!checktag
2155                            (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2156                           error(213);
2157                        // ??? set uWRITTEN?
2158                        argidx++;        /* argument done */
2159                        break;
2160                     }           /* switch */
2161                   push1();      /* store the function argument on the stack */
2162                   endexpr(FALSE);       /* mark the end of a sub-expression */
2163                }                /* if */
2164              assert(arglist[argpos] != ARG_UNHANDLED);
2165              nargs++;
2166              close = matchtoken(')');
2167              if (!close)        /* if not paranthese... */
2168                 if (!needtoken(','))    /* ...should be comma... */
2169                    break;       /* ...but abort loop if neither */
2170           }
2171         while (!close && freading && !matchtoken(tENDEXPR));    /* do */
2172      }                          /* if */
2173    /* check remaining function arguments (they may have default values) */
2174    for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS;
2175         argidx++)
2176      {
2177         if (arglist[argidx] == ARG_DONE)
2178            continue;            /* already seen and handled this argument */
2179         /* in this first stage, we also skip the arguments with uSIZEOF and uTAGOF;
2180          * these are handled last
2181          */
2182         if ((arg[argidx].hasdefault & uSIZEOF) != 0
2183             || (arg[argidx].hasdefault & uTAGOF) != 0)
2184           {
2185              assert(arg[argidx].ident == iVARIABLE);
2186              continue;
2187           }                     /* if */
2188         stgmark((char)(sEXPRSTART + argidx));   /* mark beginning of new expression in stage */
2189         if (arg[argidx].hasdefault)
2190           {
2191              if (arg[argidx].ident == iREFARRAY)
2192                {
2193                   short               level;
2194
2195                   setdefarray(arg[argidx].defvalue.array.data,
2196                               arg[argidx].defvalue.array.size,
2197                               arg[argidx].defvalue.array.arraysize,
2198                               &arg[argidx].defvalue.array.addr,
2199                               (arg[argidx].usage & uCONST) != 0);
2200                   if ((arg[argidx].usage & uCONST) == 0)
2201                      heapalloc += arg[argidx].defvalue.array.arraysize;
2202                   /* keep the lengths of all dimensions of a multi-dimensional default array */
2203                   assert(arg[argidx].numdim > 0);
2204                   if (arg[argidx].numdim == 1)
2205                     {
2206                        append_constval(&arrayszlst, arg[argidx].name,
2207                                        arg[argidx].defvalue.array.arraysize, 0);
2208                     }
2209                   else
2210                     {
2211                        for (level = 0; level < arg[argidx].numdim; level++)
2212                          {
2213                             assert(level < sDIMEN_MAX);
2214                             append_constval(&arrayszlst, arg[argidx].name,
2215                                             arg[argidx].dim[level], level);
2216                          }      /* for */
2217                     }           /* if */
2218                }
2219              else if (arg[argidx].ident == iREFERENCE)
2220                {
2221                   setheap(arg[argidx].defvalue.val);
2222                   /* address of the value on the heap in PRI */
2223                   heapalloc++;
2224                }
2225              else
2226                {
2227                   int                 dummytag = arg[argidx].tags[0];
2228
2229                   const1(arg[argidx].defvalue.val);
2230                   assert(arg[argidx].numtags > 0);
2231                   check_userop(NULL, arg[argidx].defvalue_tag,
2232                                arg[argidx].tags[0], 2, NULL, &dummytag);
2233                   assert(dummytag == arg[argidx].tags[0]);
2234                }                /* if */
2235              push1();           /* store the function argument on the stack */
2236              endexpr(FALSE);    /* mark the end of a sub-expression */
2237           }
2238         else
2239           {
2240              error(202, argidx);        /* argument count mismatch */
2241           }                     /* if */
2242         if (arglist[argidx] == ARG_UNHANDLED)
2243            nargs++;
2244         arglist[argidx] = ARG_DONE;
2245      }                          /* for */
2246    /* now a second loop to catch the arguments with default values that are
2247     * the "sizeof" or "tagof" of other arguments
2248     */
2249    for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS;
2250         argidx++)
2251      {
2252         constvalue         *asz;
2253         cell                array_sz;
2254
2255         if (arglist[argidx] == ARG_DONE)
2256            continue;            /* already seen and handled this argument */
2257         stgmark((char)(sEXPRSTART + argidx));   /* mark beginning of new expression in stage */
2258         assert(arg[argidx].ident == iVARIABLE); /* if "sizeof", must be single cell */
2259         /* if unseen, must be "sizeof" or "tagof" */
2260         assert((arg[argidx].hasdefault & uSIZEOF) != 0
2261                || (arg[argidx].hasdefault & uTAGOF) != 0);
2262         if ((arg[argidx].hasdefault & uSIZEOF) != 0)
2263           {
2264              /* find the argument; if it isn't found, the argument's default value
2265               * was a "sizeof" of a non-array (a warning for this was already given
2266               * when declaring the function)
2267               */
2268              asz = find_constval(&arrayszlst, arg[argidx].defvalue.size.symname,
2269                                  arg[argidx].defvalue.size.level);
2270              if (asz)
2271                {
2272                   array_sz = asz->value;
2273                   if (array_sz == 0)
2274                      error(224, arg[argidx].name);      /* indeterminate array size in "sizeof" expression */
2275                }
2276              else
2277                {
2278                   array_sz = 1;
2279                }                /* if */
2280           }
2281         else
2282           {
2283              symbol             *sym;
2284
2285              assert((arg[argidx].hasdefault & uTAGOF) != 0);
2286              sym = findloc(arg[argidx].defvalue.size.symname);
2287              if (!sym)
2288                 sym = findglb(arg[argidx].defvalue.size.symname);
2289              array_sz = (sym) ? sym->tag : 0;
2290              exporttag(array_sz);
2291           }                     /* if */
2292         const1(array_sz);
2293         push1();                /* store the function argument on the stack */
2294         endexpr(FALSE);
2295         if (arglist[argidx] == ARG_UNHANDLED)
2296            nargs++;
2297         arglist[argidx] = ARG_DONE;
2298      }                          /* for */
2299    stgmark(sENDREORDER);        /* mark end of reversed evaluation */
2300    pushval((cell) nargs * sizeof(cell));
2301    ffcall(sym, nargs);
2302    if (sc_status != statSKIP)
2303       markusage(sym, uREAD);    /* do not mark as "used" when this call itself is skipped */
2304    if (sym->x.lib)
2305       sym->x.lib->value += 1;   /* increment "usage count" of the library */
2306    modheap(-heapalloc * sizeof(cell));
2307    sideeffect = TRUE;           /* assume functions carry out a side-effect */
2308    delete_consttable(&arrayszlst);      /* clear list of array sizes */
2309 }
2310
2311 /*  dbltest
2312  *
2313  *  Returns a non-zero value if lval1 an array and lval2 is not an array and
2314  *  the operation is addition or subtraction.
2315  *
2316  *  Returns the "shift" count (1 for 16-bit, 2 for 32-bit) to align a cell
2317  *  to an array offset.
2318  */
2319 static int
2320 dbltest(void        (*oper) (), value * lval1, value * lval2)
2321 {
2322    if ((oper != ob_add) && (oper != ob_sub))
2323       return 0;
2324    if (lval1->ident != iARRAY)
2325       return 0;
2326    if (lval2->ident == iARRAY)
2327       return 0;
2328    return sizeof(cell) / 2;     /* 1 for 16-bit, 2 for 32-bit */
2329 }
2330
2331 /*  commutative
2332  *
2333  *  Test whether an operator is commutative, i.e. x oper y == y oper x.
2334  *  Commutative operators are: +  (addition)
2335  *                             *  (multiplication)
2336  *                             == (equality)
2337  *                             != (inequality)
2338  *                             &  (bitwise and)
2339  *                             ^  (bitwise xor)
2340  *                             |  (bitwise or)
2341  *
2342  *  If in an expression, code for the left operand has been generated and
2343  *  the right operand is a constant and the operator is commutative, the
2344  *  precautionary "push" of the primary register is scrapped and the constant
2345  *  is read into the secondary register immediately.
2346  */
2347 static int
2348 commutative(void    (*oper) ())
2349 {
2350    return oper == ob_add || oper == os_mult
2351       || oper == ob_eq || oper == ob_ne
2352       || oper == ob_and || oper == ob_xor || oper == ob_or;
2353 }
2354
2355 /*  constant
2356  *
2357  *  Generates code to fetch a number, a literal character (which is returned
2358  *  by lex() as a number as well) or a literal string (lex() stores the
2359  *  strings in the literal queue). If the operand was a number, it is stored
2360  *  in lval->constval.
2361  *
2362  *  The function returns 1 if the token was a constant or a string, 0
2363  *  otherwise.
2364  */
2365 static int
2366 constant(value * lval)
2367 {
2368    int                 tok, index, constant;
2369    cell                val, item, cidx;
2370    char               *st;
2371    symbol             *sym;
2372
2373    tok = lex(&val, &st);
2374    if (tok == tSYMBOL && (sym = findconst(st)))
2375      {
2376         lval->constval = sym->addr;
2377         const1(lval->constval);
2378         lval->ident = iCONSTEXPR;
2379         lval->tag = sym->tag;
2380         markusage(sym, uREAD);
2381      }
2382    else if (tok == tNUMBER)
2383      {
2384         lval->constval = val;
2385         const1(lval->constval);
2386         lval->ident = iCONSTEXPR;
2387      }
2388    else if (tok == tRATIONAL)
2389      {
2390         lval->constval = val;
2391         const1(lval->constval);
2392         lval->ident = iCONSTEXPR;
2393         lval->tag = sc_rationaltag;
2394      }
2395    else if (tok == tSTRING)
2396      {
2397         /* lex() stores starting index of string in the literal table in 'val' */
2398         const1((val + glb_declared) * sizeof(cell));
2399         lval->ident = iARRAY;   /* pretend this is a global array */
2400         lval->constval = val - litidx;  /* constval == the negative value of the
2401                                          * size of the literal array; using a negative
2402                                          * value distinguishes between literal arrays
2403                                          * and literal strings (this was done for
2404                                          * array assignment). */
2405      }
2406    else if (tok == '{')
2407      {
2408         int                 tag, lasttag = -1;
2409
2410         val = litidx;
2411         do
2412           {
2413              /* cannot call constexpr() here, because "staging" is already turned
2414               * on at this point */
2415              assert(staging);
2416              stgget(&index, &cidx);     /* mark position in code generator */
2417              expression(&constant, &item, &tag, FALSE);
2418              stgdel(index, cidx);       /* scratch generated code */
2419              if (constant == 0)
2420                 error(8);       /* must be constant expression */
2421              if (lasttag < 0)
2422                 lasttag = tag;
2423              else if (!matchtag(lasttag, tag, FALSE))
2424                 error(213);     /* tagname mismatch */
2425              stowlit(item);     /* store expression result in literal table */
2426           }
2427         while (matchtoken(','));
2428         needtoken('}');
2429         const1((val + glb_declared) * sizeof(cell));
2430         lval->ident = iARRAY;   /* pretend this is a global array */
2431         lval->constval = litidx - val;  /* constval == the size of the literal array */
2432      }
2433    else
2434      {
2435         return FALSE;           /* no, it cannot be interpreted as a constant */
2436      }                          /* if */
2437    return TRUE;                 /* yes, it was a constant value */
2438 }