src/bin/embryo_cc_sc3.c

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