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 <limits.h>             /* for PATH_MAX */
  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         *val = 0;
 780      }                          /* if */
 781    if (tag != NULL)
 782       *tag = lval.tag;
 783    if (chkfuncresult)
 784       checkfunction(&lval);
 785    return lval.ident;
 786 }
 787
 788 static cell
 789 array_totalsize(symbol * sym)
 790 {
 791    cell                length;
 792
 793    assert(sym != NULL);
 794    assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
 795    length = sym->dim.array.length;
 796    if (sym->dim.array.level > 0)
 797      {
 798         cell                sublength = array_totalsize(finddepend(sym));
 799
 800         if (sublength > 0)
 801            length = length + length * sublength;
 802         else
 803            length = 0;
 804      }                          /* if */
 805    return length;
 806 }
 807
 808 static cell
 809 array_levelsize(symbol * sym, int level)
 810 {
 811    assert(sym != NULL);
 812    assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
 813    assert(level <= sym->dim.array.level);
 814    while (level-- > 0)
 815      {
 816         sym = finddepend(sym);
 817         assert(sym != NULL);
 818      }                          /* if */
 819    return sym->dim.array.length;
 820 }
 821
 822 /*  hier14
 823  *
 824  *  Lowest hierarchy level (except for the , operator).
 825  *
 826  *  Global references: intest   (reffered to only)
 827  */
 828 int
 829 hier14(value * lval1)
 830 {
 831    int                 lvalue;
 832    value               lval2 = { NULL, 0, 0, 0, 0, NULL };
 833    value               lval3 = { NULL, 0, 0, 0, 0, NULL };
 834    void                (*oper) (void);
 835    int                 tok, level, i;
 836    cell                val;
 837    char               *st;
 838    int                 bwcount;
 839    cell                arrayidx1[sDIMEN_MAX], arrayidx2[sDIMEN_MAX];    /* last used array indices */
 840    cell               *org_arrayidx;
 841
 842    bwcount = bitwise_opercount;
 843    bitwise_opercount = 0;
 844    for (i = 0; i < sDIMEN_MAX; i++)
 845       arrayidx1[i] = arrayidx2[i] = 0;
 846    org_arrayidx = lval1->arrayidx;      /* save current pointer, to reset later */
 847    if (lval1->arrayidx == NULL)
 848       lval1->arrayidx = arrayidx1;
 849    lvalue = plnge1(hier13, lval1);
 850    if (lval1->ident != iARRAYCELL && lval1->ident != iARRAYCHAR)
 851       lval1->arrayidx = NULL;
 852    if (lval1->ident == iCONSTEXPR)      /* load constant here */
 853       const1(lval1->constval);
 854    tok = lex(&val, &st);
 855    switch (tok)
 856      {
 857      case taOR:
 858         oper = ob_or;
 859         break;
 860      case taXOR:
 861         oper = ob_xor;
 862         break;
 863      case taAND:
 864         oper = ob_and;
 865         break;
 866      case taADD:
 867         oper = ob_add;
 868         break;
 869      case taSUB:
 870         oper = ob_sub;
 871         break;
 872      case taMULT:
 873         oper = os_mult;
 874         break;
 875      case taDIV:
 876         oper = os_div;
 877         break;
 878      case taMOD:
 879         oper = os_mod;
 880         break;
 881      case taSHRU:
 882         oper = ou_sar;
 883         break;
 884      case taSHR:
 885         oper = os_sar;
 886         break;
 887      case taSHL:
 888         oper = ob_sal;
 889         break;
 890      case '=':                  /* simple assignment */
 891         oper = NULL;
 892         if (intest)
 893            error(211);          /* possibly unintended assignment */
 894         break;
 895      default:
 896         lexpush();
 897         bitwise_opercount = bwcount;
 898         lval1->arrayidx = org_arrayidx; /* restore array index pointer */
 899         return lvalue;
 900      }                          /* switch */
 901
 902    /* if we get here, it was an assignment; first check a few special cases
 903     * and then the general */
 904    if (lval1->ident == iARRAYCHAR)
 905      {
 906         /* special case, assignment to packed character in a cell is permitted */
 907         lvalue = TRUE;
 908      }
 909    else if (lval1->ident == iARRAY || lval1->ident == iREFARRAY)
 910      {
 911         /* array assignment is permitted too (with restrictions) */
 912         if (oper)
 913            return error(23);    /* array assignment must be simple assigment */
 914         assert(lval1->sym != NULL);
 915         if (array_totalsize(lval1->sym) == 0)
 916            return error(46, lval1->sym->name);  /* unknown array size */
 917         lvalue = TRUE;
 918      }                          /* if */
 919
 920    /* operand on left side of assignment must be lvalue */
 921    if (!lvalue)
 922       return error(22);         /* must be lvalue */
 923    /* may not change "constant" parameters */
 924    assert(lval1->sym != NULL);
 925    if ((lval1->sym->usage & uCONST) != 0)
 926       return error(22);         /* assignment to const argument */
 927    lval3 = *lval1;              /* save symbol to enable storage of expresion result */
 928    lval1->arrayidx = org_arrayidx;      /* restore array index pointer */
 929    if (lval1->ident == iARRAYCELL || lval1->ident == iARRAYCHAR
 930        || lval1->ident == iARRAY || lval1->ident == iREFARRAY)
 931      {
 932         /* if indirect fetch: save PRI (cell address) */
 933         if (oper)
 934           {
 935              push1();
 936              rvalue(lval1);
 937           }                     /* if */
 938         lval2.arrayidx = arrayidx2;
 939         plnge2(oper, hier14, lval1, &lval2);
 940         if (lval2.ident != iARRAYCELL && lval2.ident != iARRAYCHAR)
 941            lval2.arrayidx = NULL;
 942         if (oper)
 943            pop2();
 944         if (!oper && lval3.arrayidx != NULL && lval2.arrayidx != NULL
 945             && lval3.ident == lval2.ident && lval3.sym == lval2.sym)
 946           {
 947              int                 same = TRUE;
 948
 949              assert(lval3.arrayidx == arrayidx1);
 950              assert(lval2.arrayidx == arrayidx2);
 951              for (i = 0; i < sDIMEN_MAX; i++)
 952                 same = same && (lval3.arrayidx[i] == lval2.arrayidx[i]);
 953              if (same)
 954                 error(226, lval3.sym->name);    /* self-assignment */
 955           }                     /* if */
 956      }
 957    else
 958      {
 959         if (oper)
 960           {
 961              rvalue(lval1);
 962              plnge2(oper, hier14, lval1, &lval2);
 963           }
 964         else
 965           {
 966              /* if direct fetch and simple assignment: no "push"
 967               * and "pop" needed -> call hier14() directly, */
 968              if (hier14(&lval2))
 969                 rvalue(&lval2); /* instead of plnge2(). */
 970              checkfunction(&lval2);
 971              /* check whether lval2 and lval3 (old lval1) refer to the same variable */
 972              if (lval2.ident == iVARIABLE && lval3.ident == lval2.ident
 973                  && lval3.sym == lval2.sym)
 974                {
 975                   assert(lval3.sym != NULL);
 976                   error(226, lval3.sym->name);  /* self-assignment */
 977                }                /* if */
 978           }                     /* if */
 979      }                          /* if */
 980    if (lval3.ident == iARRAY || lval3.ident == iREFARRAY)
 981      {
 982         /* left operand is an array, right operand should be an array variable
 983          * of the same size and the same dimension, an array literal (of the
 984          * same size) or a literal string.
 985          */
 986         int                 exactmatch = TRUE;
 987
 988         if (lval2.ident != iARRAY && lval2.ident != iREFARRAY)
 989            error(33, lval3.sym->name);  /* array must be indexed */
 990         if (lval2.sym != NULL)
 991           {
 992              val = lval2.sym->dim.array.length; /* array variable */
 993              level = lval2.sym->dim.array.level;
 994           }
 995         else
 996           {
 997              val = lval2.constval;      /* literal array */
 998              level = 0;
 999              /* If val is negative, it means that lval2 is a
1000               * literal string. The string array size may be
1001               * smaller than the destination array.
1002               */
1003              if (val < 0)
1004                {
1005                   val = -val;
1006                   exactmatch = FALSE;
1007                }                /* if */
1008           }                     /* if */
1009         if (lval3.sym->dim.array.level != level)
1010            return error(48);    /* array dimensions must match */
1011         else if (lval3.sym->dim.array.length < val
1012                  || (exactmatch && lval3.sym->dim.array.length > val))
1013            return error(47);    /* array sizes must match */
1014         if (level > 0)
1015           {
1016              /* check the sizes of all sublevels too */
1017              symbol             *sym1 = lval3.sym;
1018              symbol             *sym2 = lval2.sym;
1019              int                 i;
1020
1021              assert(sym1 != NULL && sym2 != NULL);
1022              /* ^^^ sym2 must be valid, because only variables can be
1023               *     multi-dimensional (there are no multi-dimensional arrays),
1024               *     sym1 must be valid because it must be an lvalue
1025               */
1026              assert(exactmatch);
1027              for (i = 0; i < level; i++)
1028                {
1029                   sym1 = finddepend(sym1);
1030                   sym2 = finddepend(sym2);
1031                   assert(sym1 != NULL && sym2 != NULL);
1032                   /* ^^^ both arrays have the same dimensions (this was checked
1033                    *     earlier) so the dependend should always be found
1034                    */
1035                   if (sym1->dim.array.length != sym2->dim.array.length)
1036                      error(47); /* array sizes must match */
1037                }                /* for */
1038              /* get the total size in cells of the multi-dimensional array */
1039              val = array_totalsize(lval3.sym);
1040              assert(val > 0);   /* already checked */
1041           }                     /* if */
1042      }
1043    else
1044      {
1045         /* left operand is not an array, right operand should then not be either */
1046         if (lval2.ident == iARRAY || lval2.ident == iREFARRAY)
1047            error(6);            /* must be assigned to an array */
1048      }                          /* if */
1049    if (lval3.ident == iARRAY || lval3.ident == iREFARRAY)
1050      {
1051         memcopy(val * sizeof(cell));
1052      }
1053    else
1054      {
1055         check_userop(NULL, lval2.tag, lval3.tag, 2, &lval3, &lval2.tag);
1056         store(&lval3);          /* now, store the expression result */
1057      }                          /* if */
1058    if (!oper && !matchtag(lval3.tag, lval2.tag, TRUE))
1059       error(213);               /* tagname mismatch (if "oper", warning already given in plunge2()) */
1060    if (lval3.sym)
1061       markusage(lval3.sym, uWRITTEN);
1062    sideeffect = TRUE;
1063    bitwise_opercount = bwcount;
1064    return FALSE;                /* expression result is never an lvalue */
1065 }
1066
1067 static int
1068 hier13(value * lval)
1069 {
1070    int                 lvalue, flab1, flab2;
1071    value               lval2 = { NULL, 0, 0, 0, 0, NULL };
1072    int                 array1, array2;
1073
1074    lvalue = plnge1(hier12, lval);
1075    if (matchtoken('?'))
1076      {
1077         flab1 = getlabel();
1078         flab2 = getlabel();
1079         if (lvalue)
1080           {
1081              rvalue(lval);
1082           }
1083         else if (lval->ident == iCONSTEXPR)
1084           {
1085              const1(lval->constval);
1086              error(lval->constval ? 206 : 205); /* redundant test */
1087           }                     /* if */
1088         jmp_eq0(flab1);         /* go to second expression if primary register==0 */
1089         if (hier14(lval))
1090            rvalue(lval);
1091         jumplabel(flab2);
1092         setlabel(flab1);
1093         needtoken(':');
1094         if (hier14(&lval2))
1095            rvalue(&lval2);
1096         array1 = (lval->ident == iARRAY || lval->ident == iREFARRAY);
1097         array2 = (lval2.ident == iARRAY || lval2.ident == iREFARRAY);
1098         if (array1 && !array2)
1099           {
1100              char               *ptr =
1101                 (lval->sym->name != NULL) ? lval->sym->name : "-unknown-";
1102              error(33, ptr);    /* array must be indexed */
1103           }
1104         else if (!array1 && array2)
1105           {
1106              char               *ptr =
1107                 (lval2.sym->name != NULL) ? lval2.sym->name : "-unknown-";
1108              error(33, ptr);    /* array must be indexed */
1109           }                     /* if */
1110         /* ??? if both are arrays, should check dimensions */
1111         if (!matchtag(lval->tag, lval2.tag, FALSE))
1112            error(213);          /* tagname mismatch ('true' and 'false' expressions) */
1113         setlabel(flab2);
1114         if (lval->ident == iARRAY)
1115            lval->ident = iREFARRAY;     /* iARRAY becomes iREFARRAY */
1116         else if (lval->ident != iREFARRAY)
1117            lval->ident = iEXPRESSION;   /* iREFARRAY stays iREFARRAY, rest becomes iEXPRESSION */
1118         return FALSE;           /* conditional expression is no lvalue */
1119      }
1120    else
1121      {
1122         return lvalue;
1123      }                          /* endif */
1124 }
1125
1126 /* the order of the operators in these lists is important and must cohere */
1127 /* with the order of the operators in the array "op1" */
1128 static int          list3[] = { '*', '/', '%', 0 };
1129 static int          list4[] = { '+', '-', 0 };
1130 static int          list5[] = { tSHL, tSHR, tSHRU, 0 };
1131 static int          list6[] = { '&', 0 };
1132 static int          list7[] = { '^', 0 };
1133 static int          list8[] = { '|', 0 };
1134 static int          list9[] = { tlLE, tlGE, '<', '>', 0 };
1135 static int          list10[] = { tlEQ, tlNE, 0 };
1136 static int          list11[] = { tlAND, 0 };
1137 static int          list12[] = { tlOR, 0 };
1138
1139 static int
1140 hier12(value * lval)
1141 {
1142    return skim(list12, jmp_ne0, 1, 0, hier11, lval);
1143 }
1144
1145 static int
1146 hier11(value * lval)
1147 {
1148    return skim(list11, jmp_eq0, 0, 1, hier10, lval);
1149 }
1150
1151 static int
1152 hier10(value * lval)
1153 {                               /* ==, != */
1154    return plnge(list10, 15, hier9, lval, "bool", TRUE);
1155 }                               /* ^ this variable is the starting index in the op1[]
1156                                  *   array of the operators of this hierarchy level */
1157
1158 static int
1159 hier9(value * lval)
1160 {                               /* <=, >=, <, > */
1161    return plnge_rel(list9, 11, hier8, lval);
1162 }
1163
1164 static int
1165 hier8(value * lval)
1166 {                               /* | */
1167    return plnge(list8, 10, hier7, lval, NULL, FALSE);
1168 }
1169
1170 static int
1171 hier7(value * lval)
1172 {                               /* ^ */
1173    return plnge(list7, 9, hier6, lval, NULL, FALSE);
1174 }
1175
1176 static int
1177 hier6(value * lval)
1178 {                               /* & */
1179    return plnge(list6, 8, hier5, lval, NULL, FALSE);
1180 }
1181
1182 static int
1183 hier5(value * lval)
1184 {                               /* <<, >>, >>> */
1185    return plnge(list5, 5, hier4, lval, NULL, FALSE);
1186 }
1187
1188 static int
1189 hier4(value * lval)
1190 {                               /* +, - */
1191    return plnge(list4, 3, hier3, lval, NULL, FALSE);
1192 }
1193
1194 static int
1195 hier3(value * lval)
1196 {                               /* *, /, % */
1197    return plnge(list3, 0, hier2, lval, NULL, FALSE);
1198 }
1199
1200 static int
1201 hier2(value * lval)
1202 {
1203    int                 lvalue, tok;
1204    int                 tag, paranthese;
1205    cell                val;
1206    char               *st;
1207    symbol             *sym;
1208    int                 saveresult;
1209
1210    tok = lex(&val, &st);
1211    switch (tok)
1212      {
1213      case tINC:         /* ++lval */
1214         if (!hier2(lval))
1215            return error(22);    /* must be lvalue */
1216         assert(lval->sym != NULL);
1217         if ((lval->sym->usage & uCONST) != 0)
1218            return error(22);    /* assignment to const argument */
1219         if (!check_userop(user_inc, lval->tag, 0, 1, lval, &lval->tag))
1220            inc(lval);           /* increase variable first */
1221         rvalue(lval);           /* and read the result into PRI */
1222         sideeffect = TRUE;
1223         return FALSE;           /* result is no longer lvalue */
1224      case tDEC:         /* --lval */
1225         if (!hier2(lval))
1226            return error(22);    /* must be lvalue */
1227         assert(lval->sym != NULL);
1228         if ((lval->sym->usage & uCONST) != 0)
1229            return error(22);    /* assignment to const argument */
1230         if (!check_userop(user_dec, lval->tag, 0, 1, lval, &lval->tag))
1231            dec(lval);           /* decrease variable first */
1232         rvalue(lval);           /* and read the result into PRI */
1233         sideeffect = TRUE;
1234         return FALSE;           /* result is no longer lvalue */
1235      case '~':                  /* ~ (one's complement) */
1236         if (hier2(lval))
1237            rvalue(lval);
1238         invert();               /* bitwise NOT */
1239         lval->constval = ~lval->constval;
1240         return FALSE;
1241      case '!':                  /* ! (logical negate) */
1242         if (hier2(lval))
1243            rvalue(lval);
1244         if (check_userop(lneg, lval->tag, 0, 1, NULL, &lval->tag))
1245           {
1246              lval->ident = iEXPRESSION;
1247              lval->constval = 0;
1248           }
1249         else
1250           {
1251              lneg();            /* 0 -> 1,  !0 -> 0 */
1252              lval->constval = !lval->constval;
1253              lval->tag = sc_addtag("bool");
1254           }                     /* if */
1255         return FALSE;
1256      case '-':                  /* unary - (two's complement) */
1257         if (hier2(lval))
1258            rvalue(lval);
1259         /* make a special check for a constant expression with the tag of a
1260          * rational number, so that we can simple swap the sign of that constant.
1261          */
1262         if (lval->ident == iCONSTEXPR && lval->tag == sc_rationaltag
1263             && sc_rationaltag != 0)
1264           {
1265              if (rational_digits == 0)
1266                {
1267                   float              *f = (float *)&lval->constval;
1268
1269                   *f = -*f;     /* this modifies lval->constval */
1270                }
1271              else
1272                {
1273                   /* the negation of a fixed point number is just an integer negation */
1274                   lval->constval = -lval->constval;
1275                }                /* if */
1276           }
1277         else if (check_userop(neg, lval->tag, 0, 1, NULL, &lval->tag))
1278           {
1279              lval->ident = iEXPRESSION;
1280              lval->constval = 0;
1281           }
1282         else
1283           {
1284              neg();             /* arithmic negation */
1285              lval->constval = -lval->constval;
1286           }                     /* if */
1287         return FALSE;
1288      case tLABEL:               /* tagname override */
1289         tag = sc_addtag(st);
1290         lvalue = hier2(lval);
1291         lval->tag = tag;
1292         return lvalue;
1293      case tDEFINED:
1294         paranthese = 0;
1295         while (matchtoken('('))
1296            paranthese++;
1297         tok = lex(&val, &st);
1298         if (tok != tSYMBOL)
1299            return error(20, st);        /* illegal symbol name */
1300         sym = findloc(st);
1301         if (sym == NULL)
1302            sym = findglb(st);
1303         if (sym != NULL && sym->ident != iFUNCTN && sym->ident != iREFFUNC
1304             && (sym->usage & uDEFINE) == 0)
1305            sym = NULL;          /* symbol is not a function, it is in the table, but not "defined" */
1306         val = (sym != NULL);
1307         if (!val && find_subst(st, strlen(st)) != NULL)
1308            val = 1;
1309         clear_value(lval);
1310         lval->ident = iCONSTEXPR;
1311         lval->constval = val;
1312         const1(lval->constval);
1313         while (paranthese--)
1314            needtoken(')');
1315         return FALSE;
1316      case tSIZEOF:
1317         paranthese = 0;
1318         while (matchtoken('('))
1319            paranthese++;
1320         tok = lex(&val, &st);
1321         if (tok != tSYMBOL)
1322            return error(20, st);        /* illegal symbol name */
1323         sym = findloc(st);
1324         if (sym == NULL)
1325            sym = findglb(st);
1326         if (sym == NULL)
1327            return error(17, st);        /* undefined symbol */
1328         if (sym->ident == iCONSTEXPR)
1329            error(39);           /* constant symbol has no size */
1330         else if (sym->ident == iFUNCTN || sym->ident == iREFFUNC)
1331            error(72);           /* "function" symbol has no size */
1332         else if ((sym->usage & uDEFINE) == 0)
1333            return error(17, st);        /* undefined symbol (symbol is in the table, but it is "used" only) */
1334         clear_value(lval);
1335         lval->ident = iCONSTEXPR;
1336         lval->constval = 1;     /* preset */
1337         if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1338           {
1339              int                 level;
1340
1341              for (level = 0; matchtoken('['); level++)
1342                 needtoken(']');
1343              if (level > sym->dim.array.level)
1344                 error(28);      /* invalid subscript */
1345              else
1346                 lval->constval = array_levelsize(sym, level);
1347              if (lval->constval == 0 && strchr(lptr, PREPROC_TERM) == NULL)
1348                 error(224, st); /* indeterminate array size in "sizeof" expression */
1349           }                     /* if */
1350         const1(lval->constval);
1351         while (paranthese--)
1352            needtoken(')');
1353         return FALSE;
1354      case tTAGOF:
1355         paranthese = 0;
1356         while (matchtoken('('))
1357            paranthese++;
1358         tok = lex(&val, &st);
1359         if (tok != tSYMBOL && tok != tLABEL)
1360            return error(20, st);        /* illegal symbol name */
1361         if (tok == tLABEL)
1362           {
1363              tag = sc_addtag(st);
1364           }
1365         else
1366           {
1367              sym = findloc(st);
1368              if (sym == NULL)
1369                 sym = findglb(st);
1370              if (sym == NULL)
1371                 return error(17, st);   /* undefined symbol */
1372              if ((sym->usage & uDEFINE) == 0)
1373                 return error(17, st);   /* undefined symbol (symbol is in the table, but it is "used" only) */
1374              tag = sym->tag;
1375           }                     /* if */
1376         exporttag(tag);
1377         clear_value(lval);
1378         lval->ident = iCONSTEXPR;
1379         lval->constval = tag;
1380         const1(lval->constval);
1381         while (paranthese--)
1382            needtoken(')');
1383         return FALSE;
1384      default:
1385         lexpush();
1386         lvalue = hier1(lval);
1387         /* check for postfix operators */
1388         if (matchtoken(';'))
1389           {
1390              /* Found a ';', do not look further for postfix operators */
1391              lexpush();         /* push ';' back after successful match */
1392              return lvalue;
1393           }
1394         else if (matchtoken(tTERM))
1395           {
1396              /* Found a newline that ends a statement (this is the case when
1397               * semicolons are optional). Note that an explicit semicolon was
1398               * handled above. This case is similar, except that the token must
1399               * not be pushed back.
1400               */
1401              return lvalue;
1402           }
1403         else
1404           {
1405              tok = lex(&val, &st);
1406              switch (tok)
1407                {
1408                case tINC:       /* lval++ */
1409                   if (!lvalue)
1410                      return error(22);  /* must be lvalue */
1411                   assert(lval->sym != NULL);
1412                   if ((lval->sym->usage & uCONST) != 0)
1413                      return error(22);  /* assignment to const argument */
1414                   /* on incrementing array cells, the address in PRI must be saved for
1415                    * incremening the value, whereas the current value must be in PRI
1416                    * on exit.
1417                    */
1418                   saveresult = (lval->ident == iARRAYCELL
1419                                 || lval->ident == iARRAYCHAR);
1420                   if (saveresult)
1421                      push1();   /* save address in PRI */
1422                   rvalue(lval); /* read current value into PRI */
1423                   if (saveresult)
1424                      swap1();   /* save PRI on the stack, restore address in PRI */
1425                   if (!check_userop
1426                       (user_inc, lval->tag, 0, 1, lval, &lval->tag))
1427                      inc(lval); /* increase variable afterwards */
1428                   if (saveresult)
1429                      pop1();    /* restore PRI (result of rvalue()) */
1430                   sideeffect = TRUE;
1431                   return FALSE; /* result is no longer lvalue */
1432                case tDEC:       /* lval-- */
1433                   if (!lvalue)
1434                      return error(22);  /* must be lvalue */
1435                   assert(lval->sym != NULL);
1436                   if ((lval->sym->usage & uCONST) != 0)
1437                      return error(22);  /* assignment to const argument */
1438                   saveresult = (lval->ident == iARRAYCELL
1439                                 || lval->ident == iARRAYCHAR);
1440                   if (saveresult)
1441                      push1();   /* save address in PRI */
1442                   rvalue(lval); /* read current value into PRI */
1443                   if (saveresult)
1444                      swap1();   /* save PRI on the stack, restore address in PRI */
1445                   if (!check_userop
1446                       (user_dec, lval->tag, 0, 1, lval, &lval->tag))
1447                      dec(lval); /* decrease variable afterwards */
1448                   if (saveresult)
1449                      pop1();    /* restore PRI (result of rvalue()) */
1450                   sideeffect = TRUE;
1451                   return FALSE;
1452                case tCHAR:      /* char (compute required # of cells */
1453                   if (lval->ident == iCONSTEXPR)
1454                     {
1455                        lval->constval *= charbits / 8;  /* from char to bytes */
1456                        lval->constval =
1457                           (lval->constval + sizeof(cell) - 1) / sizeof(cell);
1458                     }
1459                   else
1460                     {
1461                        if (lvalue)
1462                           rvalue(lval); /* fetch value if not already in PRI */
1463                        char2addr();     /* from characters to bytes */
1464                        addconst(sizeof(cell) - 1);      /* make sure the value is rounded up */
1465                        addr2cell();     /* truncate to number of cells */
1466                     }           /* if */
1467                   return FALSE;
1468                default:
1469                   lexpush();
1470                   return lvalue;
1471                }                /* switch */
1472           }                     /* if */
1473      }                          /* switch */
1474 }
1475
1476 /*  hier1
1477  *
1478  *  The highest hierarchy level: it looks for pointer and array indices
1479  *  and function calls.
1480  *  Generates code to fetch a pointer value if it is indexed and code to
1481  *  add to the pointer value or the array address (the address is already
1482  *  read at primary()). It also generates code to fetch a function address
1483  *  if that hasn't already been done at primary() (check lval[4]) and calls
1484  *  callfunction() to call the function.
1485  */
1486 static int
1487 hier1(value * lval1)
1488 {
1489    int                 lvalue, index, tok, symtok;
1490    cell                val, cidx;
1491    value               lval2 = { NULL, 0, 0, 0, 0, NULL };
1492    char               *st;
1493    char                close;
1494    symbol             *sym;
1495
1496    lvalue = primary(lval1);
1497    symtok = tokeninfo(&val, &st);       /* get token read by primary() */
1498  restart:
1499    sym = lval1->sym;
1500    if (matchtoken('[') || matchtoken('{') || matchtoken('('))
1501      {
1502         tok = tokeninfo(&val, &st);     /* get token read by matchtoken() */
1503         if (sym == NULL && symtok != tSYMBOL)
1504           {
1505              /* we do not have a valid symbol and we appear not to have read a valid
1506               * symbol name (so it is unlikely that we would have read a name of an
1507               * undefined symbol) */
1508              error(29);         /* expression error, assumed 0 */
1509              lexpush();         /* analyse '(', '{' or '[' again later */
1510              return FALSE;
1511           }                     /* if */
1512         if (tok == '[' || tok == '{')
1513           {                     /* subscript */
1514              close = (char)((tok == '[') ? ']' : '}');
1515              if (sym == NULL)
1516                {                /* sym==NULL if lval is a constant or a literal */
1517                   error(28);    /* cannot subscript */
1518                   needtoken(close);
1519                   return FALSE;
1520                }
1521              else if (sym->ident != iARRAY && sym->ident != iREFARRAY)
1522                {
1523                   error(28);    /* cannot subscript, variable is not an array */
1524                   needtoken(close);
1525                   return FALSE;
1526                }
1527              else if (sym->dim.array.level > 0 && close != ']')
1528                {
1529                   error(51);    /* invalid subscript, must use [ ] */
1530                   needtoken(close);
1531                   return FALSE;
1532                }                /* if */
1533              stgget(&index, &cidx);     /* mark position in code generator */
1534              push1();           /* save base address of the array */
1535              if (hier14(&lval2))        /* create expression for the array index */
1536                 rvalue(&lval2);
1537              if (lval2.ident == iARRAY || lval2.ident == iREFARRAY)
1538                 error(33, lval2.sym->name);     /* array must be indexed */
1539              needtoken(close);
1540              if (!matchtag(sym->x.idxtag, lval2.tag, TRUE))
1541                 error(213);
1542              if (lval2.ident == iCONSTEXPR)
1543                {                /* constant expression */
1544                   stgdel(index, cidx);  /* scratch generated code */
1545                   if (lval1->arrayidx != NULL)
1546                     {           /* keep constant index, for checking */
1547                        assert(sym->dim.array.level >= 0
1548                               && sym->dim.array.level < sDIMEN_MAX);
1549                        lval1->arrayidx[sym->dim.array.level] = lval2.constval;
1550                     }           /* if */
1551                   if (close == ']')
1552                     {
1553                        /* normal array index */
1554                        if (lval2.constval < 0 || (sym->dim.array.length != 0
1555                            && sym->dim.array.length <= lval2.constval))
1556                           error(32, sym->name); /* array index out of bounds */
1557                        if (lval2.constval != 0)
1558                          {
1559                             /* don't add offsets for zero subscripts */
1560 #if defined(BIT16)
1561                             const2(lval2.constval << 1);
1562 #else
1563                             const2(lval2.constval << 2);
1564 #endif
1565                             ob_add();
1566                          }      /* if */
1567                     }
1568                   else
1569                     {
1570                        /* character index */
1571                        if (lval2.constval < 0 || (sym->dim.array.length != 0
1572                            && sym->dim.array.length * ((8 * sizeof(cell)) /
1573                                                        charbits) <=
1574                            (ucell) lval2.constval))
1575                           error(32, sym->name); /* array index out of bounds */
1576                        if (lval2.constval != 0)
1577                          {
1578                             /* don't add offsets for zero subscripts */
1579                             if (charbits == 16)
1580                                const2(lval2.constval << 1);     /* 16-bit character */
1581                             else
1582                                const2(lval2.constval);  /* 8-bit character */
1583                             ob_add();
1584                          }      /* if */
1585                        charalign();     /* align character index into array */
1586                     }           /* if */
1587                }
1588              else
1589                {
1590                   /* array index is not constant */
1591                   lval1->arrayidx = NULL;       /* reset, so won't be checked */
1592                   if (close == ']')
1593                     {
1594                        if (sym->dim.array.length != 0)
1595                           ffbounds(sym->dim.array.length - 1);  /* run time check for array bounds */
1596                        cell2addr();     /* normal array index */
1597                     }
1598                   else
1599                     {
1600                        if (sym->dim.array.length != 0)
1601                           ffbounds(sym->dim.array.length * (32 / charbits) - 1);
1602                        char2addr();     /* character array index */
1603                     }           /* if */
1604                   pop2();
1605                   ob_add();     /* base address was popped into secondary register */
1606                   if (close != ']')
1607                      charalign();       /* align character index into array */
1608                }                /* if */
1609              /* the indexed item may be another array (multi-dimensional arrays) */
1610              assert(lval1->sym == sym && sym != NULL);  /* should still be set */
1611              if (sym->dim.array.level > 0)
1612                {
1613                   assert(close == ']'); /* checked earlier */
1614                   /* read the offset to the subarray and add it to the current address */
1615                   lval1->ident = iARRAYCELL;
1616                   push1();      /* the optimizer makes this to a MOVE.alt */
1617                   rvalue(lval1);
1618                   pop2();
1619                   ob_add();
1620                   /* adjust the "value" structure and find the referenced array */
1621                   lval1->ident = iREFARRAY;
1622                   lval1->sym = finddepend(sym);
1623                   assert(lval1->sym != NULL);
1624                   assert(lval1->sym->dim.array.level ==
1625                          sym->dim.array.level - 1);
1626                   /* try to parse subsequent array indices */
1627                   lvalue = FALSE;       /* for now, a iREFARRAY is no lvalue */
1628                   goto restart;
1629                }                /* if */
1630              assert(sym->dim.array.level == 0);
1631              /* set type to fetch... INDIRECTLY */
1632              lval1->ident = (char)((close == ']') ? iARRAYCELL : iARRAYCHAR);
1633              lval1->tag = sym->tag;
1634              /* a cell in an array is an lvalue, a character in an array is not
1635               * always a *valid* lvalue */
1636              return TRUE;
1637           }
1638         else
1639           {                     /* tok=='(' -> function(...) */
1640              if (sym == NULL
1641                  || (sym->ident != iFUNCTN && sym->ident != iREFFUNC))
1642                {
1643                   if (sym == NULL && sc_status == statFIRST)
1644                     {
1645                        /* could be a "use before declaration"; in that case, create a stub
1646                         * function so that the usage can be marked.
1647                         */
1648                        sym = fetchfunc(lastsymbol, 0);
1649                        if (sym != NULL)
1650                           markusage(sym, uREAD);
1651                     }           /* if */
1652                   return error(12);     /* invalid function call */
1653                }
1654              else if ((sym->usage & uMISSING) != 0)
1655                {
1656                   char                symname[2 * sNAMEMAX + 16];       /* allow space for user defined operators */
1657
1658                   funcdisplayname(symname, sym->name);
1659                   error(4, symname);    /* function not defined */
1660                }                /* if */
1661              callfunction(sym);
1662              lval1->ident = iEXPRESSION;
1663              lval1->constval = 0;
1664              lval1->tag = sym->tag;
1665              return FALSE;      /* result of function call is no lvalue */
1666           }                     /* if */
1667      }                          /* if */
1668    if (sym != NULL && lval1->ident == iFUNCTN)
1669      {
1670         assert(sym->ident == iFUNCTN);
1671         address(sym);
1672         lval1->sym = NULL;
1673         lval1->ident = iREFFUNC;
1674         /* ??? however... function pointers (or function references are not (yet) allowed */
1675         error(29);              /* expression error, assumed 0 */
1676         return FALSE;
1677      }                          /* if */
1678    return lvalue;
1679 }
1680
1681 /*  primary
1682  *
1683  *  Returns 1 if the operand is an lvalue (everything except arrays, functions
1684  *  constants and -of course- errors).
1685  *  Generates code to fetch the address of arrays. Code for constants is
1686  *  already generated by constant().
1687  *  This routine first clears the entire lval array (all fields are set to 0).
1688  *
1689  *  Global references: intest  (may be altered, but restored upon termination)
1690  */
1691 static int
1692 primary(value * lval)
1693 {
1694    char               *st;
1695    int                 lvalue, tok;
1696    cell                val;
1697    symbol             *sym;
1698
1699    if (matchtoken('('))
1700      {                          /* sub-expression - (expression,...) */
1701         pushstk((stkitem) intest);
1702         pushstk((stkitem) sc_allowtags);
1703
1704         intest = 0;             /* no longer in "test" expression */
1705         sc_allowtags = TRUE;    /* allow tagnames to be used in parenthised expressions */
1706         do
1707            lvalue = hier14(lval);
1708         while (matchtoken(','));
1709         needtoken(')');
1710         lexclr(FALSE);          /* clear lex() push-back, it should have been
1711                                  * cleared already by needtoken() */
1712         sc_allowtags = (int)(long)popstk();
1713         intest = (int)(long)popstk();
1714         return lvalue;
1715      }                          /* if */
1716
1717    clear_value(lval);           /* clear lval */
1718    tok = lex(&val, &st);
1719    if (tok == tSYMBOL)
1720      {
1721         /* lastsymbol is char[sNAMEMAX+1], lex() should have truncated any symbol
1722          * to sNAMEMAX significant characters */
1723         assert(strlen(st) < sizeof lastsymbol);
1724         strcpy(lastsymbol, st);
1725      }                          /* if */
1726    if (tok == tSYMBOL && !findconst(st))
1727      {
1728         /* first look for a local variable */
1729         if ((sym = findloc(st)) != 0)
1730           {
1731              if (sym->ident == iLABEL)
1732                {
1733                   error(29);    /* expression error, assumed 0 */
1734                   const1(0);    /* load 0 */
1735                   return FALSE; /* return 0 for labels (expression error) */
1736                }                /* if */
1737              lval->sym = sym;
1738              lval->ident = sym->ident;
1739              lval->tag = sym->tag;
1740              if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1741                {
1742                   address(sym); /* get starting address in primary register */
1743                   return FALSE; /* return 0 for array (not lvalue) */
1744                }
1745              else
1746                {
1747                   return TRUE;  /* return 1 if lvalue (not label or array) */
1748                }                /* if */
1749           }                     /* if */
1750         /* now try a global variable */
1751         if ((sym = findglb(st)) != 0)
1752           {
1753              if (sym->ident == iFUNCTN || sym->ident == iREFFUNC)
1754                {
1755                   /* if the function is only in the table because it was inserted as a
1756                    * stub in the first pass (i.e. it was "used" but never declared or
1757                    * implemented, issue an error
1758                    */
1759                   if ((sym->usage & uPROTOTYPED) == 0)
1760                      error(17, st);
1761                }
1762              else
1763                {
1764                   if ((sym->usage & uDEFINE) == 0)
1765                      error(17, st);
1766                   lval->sym = sym;
1767                   lval->ident = sym->ident;
1768                   lval->tag = sym->tag;
1769                   if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1770                     {
1771                        address(sym);    /* get starting address in primary register */
1772                        return FALSE;    /* return 0 for array (not lvalue) */
1773                     }
1774                   else
1775                     {
1776                        return TRUE;     /* return 1 if lvalue (not function or array) */
1777                     }           /* if */
1778                }                /* if */
1779           }
1780         else
1781           {
1782              return error(17, st);      /* undefined symbol */
1783           }                     /* endif */
1784         assert(sym != NULL);
1785         assert(sym->ident == iFUNCTN || sym->ident != iREFFUNC);
1786         lval->sym = sym;
1787         lval->ident = sym->ident;
1788         lval->tag = sym->tag;
1789         return FALSE;           /* return 0 for function (not an lvalue) */
1790      }                          /* if */
1791    lexpush();                   /* push the token, it is analyzed by constant() */
1792    if (constant(lval) == 0)
1793      {
1794         error(29);              /* expression error, assumed 0 */
1795         const1(0);              /* load 0 */
1796      }                          /* if */
1797    return FALSE;                /* return 0 for constants (or errors) */
1798 }
1799
1800 static void
1801 clear_value(value * lval)
1802 {
1803    lval->sym = NULL;
1804    lval->constval = 0L;
1805    lval->tag = 0;
1806    lval->ident = 0;
1807    lval->boolresult = FALSE;
1808    /* do not clear lval->arrayidx, it is preset in hier14() */
1809 }
1810
1811 static void
1812 setdefarray(cell * string, cell size, cell array_sz, cell * dataaddr,
1813             int fconst)
1814 {
1815    /* The routine must copy the default array data onto the heap, as to avoid
1816     * that a function can change the default value. An optimization is that
1817     * the default array data is "dumped" into the data segment only once (on the
1818     * first use).
1819     */
1820    assert(string != NULL);
1821    assert(size > 0);
1822    /* check whether to dump the default array */
1823    assert(dataaddr != NULL);
1824    if (sc_status == statWRITE && *dataaddr < 0)
1825      {
1826         int                 i;
1827
1828         *dataaddr = (litidx + glb_declared) * sizeof(cell);
1829         for (i = 0; i < size; i++)
1830            stowlit(*string++);
1831      }                          /* if */
1832
1833    /* if the function is known not to modify the array (meaning that it also
1834     * does not modify the default value), directly pass the address of the
1835     * array in the data segment.
1836     */
1837    if (fconst)
1838      {
1839         const1(*dataaddr);
1840      }
1841    else
1842      {
1843         /* Generate the code:
1844          *  CONST.pri dataaddr                ;address of the default array data
1845          *  HEAP      array_sz*sizeof(cell)   ;heap address in ALT
1846          *  MOVS      size*sizeof(cell)       ;copy data from PRI to ALT
1847          *  MOVE.PRI                          ;PRI = address on the heap
1848          */
1849         const1(*dataaddr);
1850         /* "array_sz" is the size of the argument (the value between the brackets
1851          * in the declaration), "size" is the size of the default array data.
1852          */
1853         assert(array_sz >= size);
1854         modheap((int)array_sz * sizeof(cell));
1855         /* ??? should perhaps fill with zeros first */
1856         memcopy(size * sizeof(cell));
1857         moveto1();
1858      }                          /* if */
1859 }
1860
1861 static int
1862 findnamedarg(arginfo * arg, char *name)
1863 {
1864    int                 i;
1865
1866    for (i = 0; arg[i].ident != 0 && arg[i].ident != iVARARGS; i++)
1867       if (strcmp(arg[i].name, name) == 0)
1868          return i;
1869    return -1;
1870 }
1871
1872 static int
1873 checktag(int tags[], int numtags, int exprtag)
1874 {
1875    int                 i;
1876
1877    assert(tags != 0);
1878    assert(numtags > 0);
1879    for (i = 0; i < numtags; i++)
1880       if (matchtag(tags[i], exprtag, TRUE))
1881          return TRUE;           /* matching tag */
1882    return FALSE;                /* no tag matched */
1883 }
1884
1885 enum
1886 {
1887    ARG_UNHANDLED,
1888    ARG_IGNORED,
1889    ARG_DONE,
1890 };
1891
1892 /*  callfunction
1893  *
1894  *  Generates code to call a function. This routine handles default arguments
1895  *  and positional as well as named parameters.
1896  */
1897 static void
1898 callfunction(symbol * sym)
1899 {
1900    int                 close, lvalue;
1901    int                 argpos;  /* index in the output stream (argpos==nargs if positional parameters) */
1902    int                 argidx = 0;      /* index in "arginfo" list */
1903    int                 nargs = 0;       /* number of arguments */
1904    int                 heapalloc = 0;
1905    int                 namedparams = FALSE;
1906    value               lval = { NULL, 0, 0, 0, 0, NULL };
1907    arginfo            *arg;
1908    char                arglist[sMAXARGS];
1909    constvalue          arrayszlst = { NULL, "", 0, 0 }; /* array size list starts empty */
1910    cell                lexval;
1911    char               *lexstr;
1912
1913    assert(sym != NULL);
1914    arg = sym->dim.arglist;
1915    assert(arg != NULL);
1916    stgmark(sSTARTREORDER);
1917    for (argpos = 0; argpos < sMAXARGS; argpos++)
1918       arglist[argpos] = ARG_UNHANDLED;
1919    if (!matchtoken(')'))
1920      {
1921         do
1922           {
1923              if (matchtoken('.'))
1924                {
1925                   namedparams = TRUE;
1926                   if (needtoken(tSYMBOL))
1927                      tokeninfo(&lexval, &lexstr);
1928                   else
1929                      lexstr = "";
1930                   argpos = findnamedarg(arg, lexstr);
1931                   if (argpos < 0)
1932                     {
1933                        error(17, lexstr);       /* undefined symbol */
1934                        break;   /* exit loop, argpos is invalid */
1935                     }           /* if */
1936                   needtoken('=');
1937                   argidx = argpos;
1938                }
1939              else
1940                {
1941                   if (namedparams)
1942                      error(44); /* positional parameters must precede named parameters */
1943                   argpos = nargs;
1944                }                /* if */
1945              stgmark((char)(sEXPRSTART + argpos));      /* mark beginning of new expression in stage */
1946              if (arglist[argpos] != ARG_UNHANDLED)
1947                 error(58);      /* argument already set */
1948              if (matchtoken('_'))
1949                {
1950                   arglist[argpos] = ARG_IGNORED;        /* flag argument as "present, but ignored" */
1951                   if (arg[argidx].ident == 0 || arg[argidx].ident == iVARARGS)
1952                     {
1953                        error(202);      /* argument count mismatch */
1954                     }
1955                   else if (!arg[argidx].hasdefault)
1956                     {
1957                        error(34, nargs + 1);    /* argument has no default value */
1958                     }           /* if */
1959                   if (arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS)
1960                      argidx++;
1961                   /* The rest of the code to handle default values is at the bottom
1962                    * of this routine where default values for unspecified parameters
1963                    * are (also) handled. Note that above, the argument is flagged as
1964                    * ARG_IGNORED.
1965                    */
1966                }
1967              else
1968                {
1969                   arglist[argpos] = ARG_DONE;   /* flag argument as "present" */
1970                   lvalue = hier14(&lval);
1971                   switch (arg[argidx].ident)
1972                     {
1973                     case 0:
1974                        error(202);      /* argument count mismatch */
1975                        break;
1976                     case iVARARGS:
1977                        /* always pass by reference */
1978                        if (lval.ident == iVARIABLE || lval.ident == iREFERENCE)
1979                          {
1980                             assert(lval.sym != NULL);
1981                             if ((lval.sym->usage & uCONST) != 0
1982                                 && (arg[argidx].usage & uCONST) == 0)
1983                               {
1984                                  /* treat a "const" variable passed to a function with a non-const
1985                                   * "variable argument list" as a constant here */
1986                                  assert(lvalue);
1987                                  rvalue(&lval); /* get value in PRI */
1988                                  setheap_pri(); /* address of the value on the heap in PRI */
1989                                  heapalloc++;
1990                               }
1991                             else if (lvalue)
1992                               {
1993                                  address(lval.sym);
1994                               }
1995                             else
1996                               {
1997                                  setheap_pri(); /* address of the value on the heap in PRI */
1998                                  heapalloc++;
1999                               } /* if */
2000                          }
2001                        else if (lval.ident == iCONSTEXPR
2002                                 || lval.ident == iEXPRESSION
2003                                 || lval.ident == iARRAYCHAR)
2004                          {
2005                             /* fetch value if needed */
2006                             if (lval.ident == iARRAYCHAR)
2007                                rvalue(&lval);
2008                             /* allocate a cell on the heap and store the
2009                              * value (already in PRI) there */
2010                             setheap_pri();      /* address of the value on the heap in PRI */
2011                             heapalloc++;
2012                          }      /* if */
2013                        /* ??? handle const array passed by reference */
2014                        /* otherwise, the address is already in PRI */
2015                        if (lval.sym != NULL)
2016                           markusage(lval.sym, uWRITTEN);
2017 /*
2018  * Dont need this warning - its varargs. there is no way of knowing the
2019  * required tag/type...
2020  *
2021           if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
2022             error(213);
2023  */
2024                        break;
2025                     case iVARIABLE:
2026                        if (lval.ident == iLABEL || lval.ident == iFUNCTN
2027                            || lval.ident == iREFFUNC || lval.ident == iARRAY
2028                            || lval.ident == iREFARRAY)
2029                           error(35, argidx + 1);        /* argument type mismatch */
2030                        if (lvalue)
2031                           rvalue(&lval);        /* get value (direct or indirect) */
2032                        /* otherwise, the expression result is already in PRI */
2033                        assert(arg[argidx].numtags > 0);
2034                        check_userop(NULL, lval.tag, arg[argidx].tags[0], 2,
2035                                     NULL, &lval.tag);
2036                        if (!checktag
2037                            (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2038                           error(213);
2039                        argidx++;        /* argument done */
2040                        break;
2041                     case iREFERENCE:
2042                        if (!lvalue || lval.ident == iARRAYCHAR)
2043                           error(35, argidx + 1);        /* argument type mismatch */
2044                        if (lval.sym != NULL && (lval.sym->usage & uCONST) != 0
2045                            && (arg[argidx].usage & uCONST) == 0)
2046                           error(35, argidx + 1);        /* argument type mismatch */
2047                        if (lval.ident == iVARIABLE || lval.ident == iREFERENCE)
2048                          {
2049                             if (lvalue)
2050                               {
2051                                  assert(lval.sym != NULL);
2052                                  address(lval.sym);
2053                               }
2054                             else
2055                               {
2056                                  setheap_pri(); /* address of the value on the heap in PRI */
2057                                  heapalloc++;
2058                               } /* if */
2059                          }      /* if */
2060                        /* otherwise, the address is already in PRI */
2061                        if (!checktag
2062                            (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2063                           error(213);
2064                        argidx++;        /* argument done */
2065                        if (lval.sym != NULL)
2066                           markusage(lval.sym, uWRITTEN);
2067                        break;
2068                     case iREFARRAY:
2069                        if (lval.ident != iARRAY && lval.ident != iREFARRAY
2070                            && lval.ident != iARRAYCELL)
2071                          {
2072                             error(35, argidx + 1);      /* argument type mismatch */
2073                             break;
2074                          }      /* if */
2075                        if (lval.sym != NULL && (lval.sym->usage & uCONST) != 0
2076                            && (arg[argidx].usage & uCONST) == 0)
2077                           error(35, argidx + 1);        /* argument type mismatch */
2078                        /* Verify that the dimensions match with those in arg[argidx].
2079                         * A literal array always has a single dimension.
2080                         * An iARRAYCELL parameter is also assumed to have a single dimension.
2081                         */
2082                        if (lval.sym == NULL || lval.ident == iARRAYCELL)
2083                          {
2084                             if (arg[argidx].numdim != 1)
2085                               {
2086                                  error(48);     /* array dimensions must match */
2087                               }
2088                             else if (arg[argidx].dim[0] != 0)
2089                               {
2090                                  assert(arg[argidx].dim[0] > 0);
2091                                  if (lval.ident == iARRAYCELL)
2092                                    {
2093                                       error(47);        /* array sizes must match */
2094                                    }
2095                                  else
2096                                    {
2097                                       assert(lval.constval != 0);       /* literal array must have a size */
2098                                       /* A literal array must have exactly the same size as the
2099                                        * function argument; a literal string may be smaller than
2100                                        * the function argument.
2101                                        */
2102                                       if ((lval.constval > 0
2103                                           && arg[argidx].dim[0] != lval.constval)
2104                                           || (lval.constval < 0
2105                                           && arg[argidx].dim[0] <
2106                                           -lval.constval))
2107                                          error(47);     /* array sizes must match */
2108                                    }    /* if */
2109                               } /* if */
2110                             if (lval.ident != iARRAYCELL)
2111                               {
2112                                  /* save array size, for default values with uSIZEOF flag */
2113                                  cell                array_sz = lval.constval;
2114
2115                                  assert(array_sz != 0); /* literal array must have a size */
2116                                  if (array_sz < 0)
2117                                     array_sz = -array_sz;
2118                                  append_constval(&arrayszlst, arg[argidx].name,
2119                                                  array_sz, 0);
2120                               } /* if */
2121                          }
2122                        else
2123                          {
2124                             symbol             *sym = lval.sym;
2125                             short               level = 0;
2126
2127                             assert(sym != NULL);
2128                             if (sym->dim.array.level + 1 != arg[argidx].numdim)
2129                                error(48);       /* array dimensions must match */
2130                             /* the lengths for all dimensions must match, unless the dimension
2131                              * length was defined at zero (which means "undefined")
2132                              */
2133                             while (sym->dim.array.level > 0)
2134                               {
2135                                  assert(level < sDIMEN_MAX);
2136                                  if (arg[argidx].dim[level] != 0
2137                                      && sym->dim.array.length !=
2138                                      arg[argidx].dim[level])
2139                                     error(47);  /* array sizes must match */
2140                                  append_constval(&arrayszlst, arg[argidx].name,
2141                                                  sym->dim.array.length, level);
2142                                  sym = finddepend(sym);
2143                                  assert(sym != NULL);
2144                                  level++;
2145                               } /* if */
2146                             /* the last dimension is checked too, again, unless it is zero */
2147                             assert(level < sDIMEN_MAX);
2148                             assert(sym != NULL);
2149                             if (arg[argidx].dim[level] != 0
2150                                 && sym->dim.array.length !=
2151                                 arg[argidx].dim[level])
2152                                error(47);       /* array sizes must match */
2153                             append_constval(&arrayszlst, arg[argidx].name,
2154                                             sym->dim.array.length, level);
2155                          }      /* if */
2156                        /* address already in PRI */
2157                        if (!checktag
2158                            (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2159                           error(213);
2160                        // ??? set uWRITTEN?
2161                        argidx++;        /* argument done */
2162                        break;
2163                     }           /* switch */
2164                   push1();      /* store the function argument on the stack */
2165                   endexpr(FALSE);       /* mark the end of a sub-expression */
2166                }                /* if */
2167              assert(arglist[argpos] != ARG_UNHANDLED);
2168              nargs++;
2169              close = matchtoken(')');
2170              if (!close)        /* if not paranthese... */
2171                 if (!needtoken(','))    /* ...should be comma... */
2172                    break;       /* ...but abort loop if neither */
2173           }
2174         while (!close && freading && !matchtoken(tENDEXPR));    /* do */
2175      }                          /* if */
2176    /* check remaining function arguments (they may have default values) */
2177    for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS;
2178         argidx++)
2179      {
2180         if (arglist[argidx] == ARG_DONE)
2181            continue;            /* already seen and handled this argument */
2182         /* in this first stage, we also skip the arguments with uSIZEOF and uTAGOF;
2183          * these are handled last
2184          */
2185         if ((arg[argidx].hasdefault & uSIZEOF) != 0
2186             || (arg[argidx].hasdefault & uTAGOF) != 0)
2187           {
2188              assert(arg[argidx].ident == iVARIABLE);
2189              continue;
2190           }                     /* if */
2191         stgmark((char)(sEXPRSTART + argidx));   /* mark beginning of new expression in stage */
2192         if (arg[argidx].hasdefault)
2193           {
2194              if (arg[argidx].ident == iREFARRAY)
2195                {
2196                   short               level;
2197
2198                   setdefarray(arg[argidx].defvalue.array.data,
2199                               arg[argidx].defvalue.array.size,
2200                               arg[argidx].defvalue.array.arraysize,
2201                               &arg[argidx].defvalue.array.addr,
2202                               (arg[argidx].usage & uCONST) != 0);
2203                   if ((arg[argidx].usage & uCONST) == 0)
2204                      heapalloc += arg[argidx].defvalue.array.arraysize;
2205                   /* keep the lengths of all dimensions of a multi-dimensional default array */
2206                   assert(arg[argidx].numdim > 0);
2207                   if (arg[argidx].numdim == 1)
2208                     {
2209                        append_constval(&arrayszlst, arg[argidx].name,
2210                                        arg[argidx].defvalue.array.arraysize, 0);
2211                     }
2212                   else
2213                     {
2214                        for (level = 0; level < arg[argidx].numdim; level++)
2215                          {
2216                             assert(level < sDIMEN_MAX);
2217                             append_constval(&arrayszlst, arg[argidx].name,
2218                                             arg[argidx].dim[level], level);
2219                          }      /* for */
2220                     }           /* if */
2221                }
2222              else if (arg[argidx].ident == iREFERENCE)
2223                {
2224                   setheap(arg[argidx].defvalue.val);
2225                   /* address of the value on the heap in PRI */
2226                   heapalloc++;
2227                }
2228              else
2229                {
2230                   int                 dummytag = arg[argidx].tags[0];
2231
2232                   const1(arg[argidx].defvalue.val);
2233                   assert(arg[argidx].numtags > 0);
2234                   check_userop(NULL, arg[argidx].defvalue_tag,
2235                                arg[argidx].tags[0], 2, NULL, &dummytag);
2236                   assert(dummytag == arg[argidx].tags[0]);
2237                }                /* if */
2238              push1();           /* store the function argument on the stack */
2239              endexpr(FALSE);    /* mark the end of a sub-expression */
2240           }
2241         else
2242           {
2243              error(202, argidx);        /* argument count mismatch */
2244           }                     /* if */
2245         if (arglist[argidx] == ARG_UNHANDLED)
2246            nargs++;
2247         arglist[argidx] = ARG_DONE;
2248      }                          /* for */
2249    /* now a second loop to catch the arguments with default values that are
2250     * the "sizeof" or "tagof" of other arguments
2251     */
2252    for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS;
2253         argidx++)
2254      {
2255         constvalue         *asz;
2256         cell                array_sz;
2257
2258         if (arglist[argidx] == ARG_DONE)
2259            continue;            /* already seen and handled this argument */
2260         stgmark((char)(sEXPRSTART + argidx));   /* mark beginning of new expression in stage */
2261         assert(arg[argidx].ident == iVARIABLE); /* if "sizeof", must be single cell */
2262         /* if unseen, must be "sizeof" or "tagof" */
2263         assert((arg[argidx].hasdefault & uSIZEOF) != 0
2264                || (arg[argidx].hasdefault & uTAGOF) != 0);
2265         if ((arg[argidx].hasdefault & uSIZEOF) != 0)
2266           {
2267              /* find the argument; if it isn't found, the argument's default value
2268               * was a "sizeof" of a non-array (a warning for this was already given
2269               * when declaring the function)
2270               */
2271              asz = find_constval(&arrayszlst, arg[argidx].defvalue.size.symname,
2272                                  arg[argidx].defvalue.size.level);
2273              if (asz != NULL)
2274                {
2275                   array_sz = asz->value;
2276                   if (array_sz == 0)
2277                      error(224, arg[argidx].name);      /* indeterminate array size in "sizeof" expression */
2278                }
2279              else
2280                {
2281                   array_sz = 1;
2282                }                /* if */
2283           }
2284         else
2285           {
2286              symbol             *sym;
2287
2288              assert((arg[argidx].hasdefault & uTAGOF) != 0);
2289              sym = findloc(arg[argidx].defvalue.size.symname);
2290              if (sym == NULL)
2291                 sym = findglb(arg[argidx].defvalue.size.symname);
2292              array_sz = (sym != NULL) ? sym->tag : 0;
2293              exporttag(array_sz);
2294           }                     /* if */
2295         const1(array_sz);
2296         push1();                /* store the function argument on the stack */
2297         endexpr(FALSE);
2298         if (arglist[argidx] == ARG_UNHANDLED)
2299            nargs++;
2300         arglist[argidx] = ARG_DONE;
2301      }                          /* for */
2302    stgmark(sENDREORDER);        /* mark end of reversed evaluation */
2303    pushval((cell) nargs * sizeof(cell));
2304    ffcall(sym, nargs);
2305    if (sc_status != statSKIP)
2306       markusage(sym, uREAD);    /* do not mark as "used" when this call itself is skipped */
2307    if (sym->x.lib != NULL)
2308       sym->x.lib->value += 1;   /* increment "usage count" of the library */
2309    modheap(-heapalloc * sizeof(cell));
2310    sideeffect = TRUE;           /* assume functions carry out a side-effect */
2311    delete_consttable(&arrayszlst);      /* clear list of array sizes */
2312 }
2313
2314 /*  dbltest
2315  *
2316  *  Returns a non-zero value if lval1 an array and lval2 is not an array and
2317  *  the operation is addition or subtraction.
2318  *
2319  *  Returns the "shift" count (1 for 16-bit, 2 for 32-bit) to align a cell
2320  *  to an array offset.
2321  */
2322 static int
2323 dbltest(void        (*oper) (), value * lval1, value * lval2)
2324 {
2325    if ((oper != ob_add) && (oper != ob_sub))
2326       return 0;
2327    if (lval1->ident != iARRAY)
2328       return 0;
2329    if (lval2->ident == iARRAY)
2330       return 0;
2331    return sizeof(cell) / 2;     /* 1 for 16-bit, 2 for 32-bit */
2332 }
2333
2334 /*  commutative
2335  *
2336  *  Test whether an operator is commutative, i.e. x oper y == y oper x.
2337  *  Commutative operators are: +  (addition)
2338  *                             *  (multiplication)
2339  *                             == (equality)
2340  *                             != (inequality)
2341  *                             &  (bitwise and)
2342  *                             ^  (bitwise xor)
2343  *                             |  (bitwise or)
2344  *
2345  *  If in an expression, code for the left operand has been generated and
2346  *  the right operand is a constant and the operator is commutative, the
2347  *  precautionary "push" of the primary register is scrapped and the constant
2348  *  is read into the secondary register immediately.
2349  */
2350 static int
2351 commutative(void    (*oper) ())
2352 {
2353    return oper == ob_add || oper == os_mult
2354       || oper == ob_eq || oper == ob_ne
2355       || oper == ob_and || oper == ob_xor || oper == ob_or;
2356 }
2357
2358 /*  constant
2359  *
2360  *  Generates code to fetch a number, a literal character (which is returned
2361  *  by lex() as a number as well) or a literal string (lex() stores the
2362  *  strings in the literal queue). If the operand was a number, it is stored
2363  *  in lval->constval.
2364  *
2365  *  The function returns 1 if the token was a constant or a string, 0
2366  *  otherwise.
2367  */
2368 static int
2369 constant(value * lval)
2370 {
2371    int                 tok, index, constant;
2372    cell                val, item, cidx;
2373    char               *st;
2374    symbol             *sym;
2375
2376    tok = lex(&val, &st);
2377    if (tok == tSYMBOL && (sym = findconst(st)) != 0)
2378      {
2379         lval->constval = sym->addr;
2380         const1(lval->constval);
2381         lval->ident = iCONSTEXPR;
2382         lval->tag = sym->tag;
2383         markusage(sym, uREAD);
2384      }
2385    else if (tok == tNUMBER)
2386      {
2387         lval->constval = val;
2388         const1(lval->constval);
2389         lval->ident = iCONSTEXPR;
2390      }
2391    else if (tok == tRATIONAL)
2392      {
2393         lval->constval = val;
2394         const1(lval->constval);
2395         lval->ident = iCONSTEXPR;
2396         lval->tag = sc_rationaltag;
2397      }
2398    else if (tok == tSTRING)
2399      {
2400         /* lex() stores starting index of string in the literal table in 'val' */
2401         const1((val + glb_declared) * sizeof(cell));
2402         lval->ident = iARRAY;   /* pretend this is a global array */
2403         lval->constval = val - litidx;  /* constval == the negative value of the
2404                                          * size of the literal array; using a negative
2405                                          * value distinguishes between literal arrays
2406                                          * and literal strings (this was done for
2407                                          * array assignment). */
2408      }
2409    else if (tok == '{')
2410      {
2411         int                 tag, lasttag = -1;
2412
2413         val = litidx;
2414         do
2415           {
2416              /* cannot call constexpr() here, because "staging" is already turned
2417               * on at this point */
2418              assert(staging);
2419              stgget(&index, &cidx);     /* mark position in code generator */
2420              expression(&constant, &item, &tag, FALSE);
2421              stgdel(index, cidx);       /* scratch generated code */
2422              if (constant == 0)
2423                 error(8);       /* must be constant expression */
2424              if (lasttag < 0)
2425                 lasttag = tag;
2426              else if (!matchtag(lasttag, tag, FALSE))
2427                 error(213);     /* tagname mismatch */
2428              stowlit(item);     /* store expression result in literal table */
2429           }
2430         while (matchtoken(','));
2431         needtoken('}');
2432         const1((val + glb_declared) * sizeof(cell));
2433         lval->ident = iARRAY;   /* pretend this is a global array */
2434         lval->constval = litidx - val;  /* constval == the size of the literal array */
2435      }
2436    else
2437      {
2438         return FALSE;           /* no, it cannot be interpreted as a constant */
2439      }                          /* if */
2440    return TRUE;                 /* yes, it was a constant value */
2441 }