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