/* Small compiler - Recursive descend expresion parser * * Copyright (c) ITB CompuPhase, 1997-2003 * * This software is provided "as-is", without any express or implied warranty. * In no event will the authors be held liable for any damages arising from * the use of this software. * * Permission is granted to anyone to use this software for any purpose, * including commercial applications, and to alter it and redistribute it * freely, subject to the following restrictions: * * 1. The origin of this software must not be misrepresented; you must not * claim that you wrote the original software. If you use this software in * a product, an acknowledgment in the product documentation would be * appreciated but is not required. * 2. Altered source versions must be plainly marked as such, and must not be * misrepresented as being the original software. * 3. This notice may not be removed or altered from any source distribution. * * Version: $Id$ */ #ifdef HAVE_CONFIG_H # include #endif #include #include #include /* for PATH_MAX */ #include #include "embryo_cc_sc.h" static int skim(int *opstr, void (*testfunc) (int), int dropval, int endval, int (*hier) (value *), value * lval); static void dropout(int lvalue, void (*testfunc) (int val), int exit1, value * lval); static int plnge(int *opstr, int opoff, int (*hier) (value * lval), value * lval, char *forcetag, int chkbitwise); static int plnge1(int (*hier) (value * lval), value * lval); static void plnge2(void (*oper) (void), int (*hier) (value * lval), value * lval1, value * lval2); static cell calc(cell left, void (*oper) (), cell right, char *boolresult); static int hier13(value * lval); static int hier12(value * lval); static int hier11(value * lval); static int hier10(value * lval); static int hier9(value * lval); static int hier8(value * lval); static int hier7(value * lval); static int hier6(value * lval); static int hier5(value * lval); static int hier4(value * lval); static int hier3(value * lval); static int hier2(value * lval); static int hier1(value * lval1); static int primary(value * lval); static void clear_value(value * lval); static void callfunction(symbol * sym); static int dbltest(void (*oper) (), value * lval1, value * lval2); static int commutative(void (*oper) ()); static int constant(value * lval); static char lastsymbol[sNAMEMAX + 1]; /* name of last function/variable */ static int bitwise_opercount; /* count of bitwise operators in an expression */ /* Function addresses of binary operators for signed operations */ static void (*op1[17]) (void) = { os_mult, os_div, os_mod, /* hier3, index 0 */ ob_add, ob_sub, /* hier4, index 3 */ ob_sal, os_sar, ou_sar, /* hier5, index 5 */ ob_and, /* hier6, index 8 */ ob_xor, /* hier7, index 9 */ ob_or, /* hier8, index 10 */ os_le, os_ge, os_lt, os_gt, /* hier9, index 11 */ ob_eq, ob_ne, /* hier10, index 15 */ }; /* These two functions are defined because the functions inc() and dec() in * SC4.C have a different prototype than the other code generation functions. * The arrays for user-defined functions use the function pointers for * identifying what kind of operation is requested; these functions must all * have the same prototype. As inc() and dec() are special cases already, it * is simplest to add two "do-nothing" functions. */ static void user_inc(void) { } static void user_dec(void) { } /* * Searches for a binary operator a list of operators. The list is stored in * the array "list". The last entry in the list should be set to 0. * * The index of an operator in "list" (if found) is returned in "opidx". If * no operator is found, nextop() returns 0. */ static int nextop(int *opidx, int *list) { *opidx = 0; while (*list) { if (matchtoken(*list)) { return TRUE; /* found! */ } else { list += 1; *opidx += 1; } /* if */ } /* while */ return FALSE; /* entire list scanned, nothing found */ } int check_userop(void (*oper) (void), int tag1, int tag2, int numparam, value * lval, int *resulttag) { static char *binoperstr[] = { "*", "/", "%", "+", "-", "", "", "", "", "", "", "<=", ">=", "<", ">", "==", "!=" }; static int binoper_savepri[] = { FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, FALSE, FALSE }; static char *unoperstr[] = { "!", "-", "++", "--" }; static void (*unopers[]) (void) = { lneg, neg, user_inc, user_dec}; char opername[4] = "", symbolname[sNAMEMAX + 1]; int i, swapparams, savepri, savealt; int paramspassed; symbol *sym; /* since user-defined operators on untagged operands are forbidden, we have * a quick exit. */ assert(numparam == 1 || numparam == 2); if (tag1 == 0 && (numparam == 1 || tag2 == 0)) return FALSE; savepri = savealt = FALSE; /* find the name with the operator */ if (numparam == 2) { if (!oper) { /* assignment operator: a special case */ strcpy(opername, "="); if (lval && (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR)) savealt = TRUE; } else { assert((sizeof binoperstr / sizeof binoperstr[0]) == (sizeof op1 / sizeof op1[0])); for (i = 0; i < (int)(sizeof op1 / sizeof op1[0]); i++) { if (oper == op1[i]) { strcpy(opername, binoperstr[i]); savepri = binoper_savepri[i]; break; } /* if */ } /* for */ } /* if */ } else { assert(oper != NULL); assert(numparam == 1); /* try a select group of unary operators */ assert((sizeof unoperstr / sizeof unoperstr[0]) == (sizeof unopers / sizeof unopers[0])); if (opername[0] == '\0') { for (i = 0; i < (int)(sizeof unopers / sizeof unopers[0]); i++) { if (oper == unopers[i]) { strcpy(opername, unoperstr[i]); break; } /* if */ } /* for */ } /* if */ } /* if */ /* if not found, quit */ if (opername[0] == '\0') return FALSE; /* create a symbol name from the tags and the operator name */ assert(numparam == 1 || numparam == 2); operator_symname(symbolname, opername, tag1, tag2, numparam, tag2); swapparams = FALSE; sym = findglb(symbolname); if (!sym /*|| (sym->usage & uDEFINE)==0 */ ) { /* ??? should not check uDEFINE; first pass clears these bits */ /* check for commutative operators */ if (tag1 == tag2 || !oper || !commutative(oper)) return FALSE; /* not commutative, cannot swap operands */ /* if arrived here, the operator is commutative and the tags are different, * swap tags and try again */ assert(numparam == 2); /* commutative operator must be a binary operator */ operator_symname(symbolname, opername, tag2, tag1, numparam, tag1); swapparams = TRUE; sym = findglb(symbolname); if (!sym /*|| (sym->usage & uDEFINE)==0 */ ) return FALSE; } /* if */ /* check existence and the proper declaration of this function */ if ((sym->usage & uMISSING) != 0 || (sym->usage & uPROTOTYPED) == 0) { char symname[2 * sNAMEMAX + 16]; /* allow space for user defined operators */ funcdisplayname(symname, sym->name); if ((sym->usage & uMISSING) != 0) error(4, symname); /* function not defined */ if ((sym->usage & uPROTOTYPED) == 0) error(71, symname); /* operator must be declared before use */ } /* if */ /* we don't want to use the redefined operator in the function that * redefines the operator itself, otherwise the snippet below gives * an unexpected recursion: * fixed:operator+(fixed:a, fixed:b) * return a + b */ if (sym == curfunc) return FALSE; /* for increment and decrement operators, the symbol must first be loaded * (and stored back afterwards) */ if (oper == user_inc || oper == user_dec) { assert(!savepri); assert(lval != NULL); if (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR) push1(); /* save current address in PRI */ rvalue(lval); /* get the symbol's value in PRI */ } /* if */ assert(!savepri || !savealt); /* either one MAY be set, but not both */ if (savepri) { /* the chained comparison operators require that the ALT register is * unmodified, so we save it here; actually, we save PRI because the normal * instruction sequence (without user operator) swaps PRI and ALT */ push1(); /* right-hand operand is in PRI */ } else if (savealt) { /* for the assignment operator, ALT may contain an address at which the * result must be stored; this address must be preserved across the * call */ assert(lval != NULL); /* this was checked earlier */ assert(lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR); /* checked earlier */ push2(); } /* if */ /* push parameters, call the function */ paramspassed = (!oper) ? 1 : numparam; switch (paramspassed) { case 1: push1(); break; case 2: /* note that 1) a function expects that the parameters are pushed * in reversed order, and 2) the left operand is in the secondary register * and the right operand is in the primary register */ if (swapparams) { push2(); push1(); } else { push1(); push2(); } /* if */ break; default: assert(0); } /* switch */ endexpr(FALSE); /* mark the end of a sub-expression */ pushval((cell) paramspassed * sizeof(cell)); assert(sym->ident == iFUNCTN); ffcall(sym, paramspassed); if (sc_status != statSKIP) markusage(sym, uREAD); /* do not mark as "used" when this call itself is skipped */ if (sym->x.lib) sym->x.lib->value += 1; /* increment "usage count" of the library */ sideeffect = TRUE; /* assume functions carry out a side-effect */ assert(resulttag != NULL); *resulttag = sym->tag; /* save tag of the called function */ if (savepri || savealt) pop2(); /* restore the saved PRI/ALT that into ALT */ if (oper == user_inc || oper == user_dec) { assert(lval != NULL); if (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR) pop2(); /* restore address (in ALT) */ store(lval); /* store PRI in the symbol */ moveto1(); /* make sure PRI is restored on exit */ } /* if */ return TRUE; } int matchtag(int formaltag, int actualtag, int allowcoerce) { if (formaltag != actualtag) { /* if the formal tag is zero and the actual tag is not "fixed", the actual * tag is "coerced" to zero */ if (!allowcoerce || formaltag != 0 || (actualtag & FIXEDTAG) != 0) return FALSE; } /* if */ return TRUE; } /* * The AMX pseudo-processor has no direct support for logical (boolean) * operations. These have to be done via comparing and jumping. Since we are * already jumping through the code, we might as well implement an "early * drop-out" evaluation (also called "short-circuit"). This conforms to * standard C: * * expr1 || expr2 expr2 will only be evaluated if expr1 is false. * expr1 && expr2 expr2 will only be evaluated if expr1 is true. * * expr1 || expr2 && expr3 expr2 will only be evaluated if expr1 is false * and expr3 will only be evaluated if expr1 is * false and expr2 is true. * * Code generation for the last example proceeds thus: * * evaluate expr1 * operator || found * jump to "l1" if result of expr1 not equal to 0 * evaluate expr2 * -> operator && found; skip to higher level in hierarchy diagram * jump to "l2" if result of expr2 equal to 0 * evaluate expr3 * jump to "l2" if result of expr3 equal to 0 * set expression result to 1 (true) * jump to "l3" * l2: set expression result to 0 (false) * l3: * <- drop back to previous hierarchy level * jump to "l1" if result of expr2 && expr3 not equal to 0 * set expression result to 0 (false) * jump to "l4" * l1: set expression result to 1 (true) * l4: * */ /* Skim over terms adjoining || and && operators * dropval The value of the expression after "dropping out". An "or" drops * out when the left hand is TRUE, so dropval must be 1 on "or" * expressions. * endval The value of the expression when no expression drops out. In an * "or" expression, this happens when both the left hand and the * right hand are FALSE, so endval must be 0 for "or" expressions. */ static int skim(int *opstr, void (*testfunc) (int), int dropval, int endval, int (*hier) (value *), value * lval) { int lvalue, hits, droplab, endlab, opidx; int allconst; cell constval; int index; cell cidx; stgget(&index, &cidx); /* mark position in code generator */ hits = FALSE; /* no logical operators "hit" yet */ allconst = TRUE; /* assume all values "const" */ constval = 0; droplab = 0; /* to avoid a compiler warning */ for (;;) { lvalue = plnge1(hier, lval); /* evaluate left expression */ allconst = allconst && (lval->ident == iCONSTEXPR); if (allconst) { if (hits) { /* one operator was already found */ if (testfunc == jmp_ne0) lval->constval = lval->constval || constval; else lval->constval = lval->constval && constval; } /* if */ constval = lval->constval; /* save result accumulated so far */ } /* if */ if (nextop(&opidx, opstr)) { if (!hits) { /* this is the first operator in the list */ hits = TRUE; droplab = getlabel(); } /* if */ dropout(lvalue, testfunc, droplab, lval); } else if (hits) { /* no (more) identical operators */ dropout(lvalue, testfunc, droplab, lval); /* found at least one operator! */ const1(endval); jumplabel(endlab = getlabel()); setlabel(droplab); const1(dropval); setlabel(endlab); lval->sym = NULL; lval->tag = 0; if (allconst) { lval->ident = iCONSTEXPR; lval->constval = constval; stgdel(index, cidx); /* scratch generated code and calculate */ } else { lval->ident = iEXPRESSION; lval->constval = 0; } /* if */ return FALSE; } else { return lvalue; /* none of the operators in "opstr" were found */ } /* if */ } /* while */ } /* * Reads into the primary register the variable pointed to by lval if * plunging through the hierarchy levels detected an lvalue. Otherwise * if a constant was detected, it is loaded. If there is no constant and * no lvalue, the primary register must already contain the expression * result. * * After that, the compare routines "jmp_ne0" or "jmp_eq0" are called, which * compare the primary register against 0, and jump to the "early drop-out" * label "exit1" if the condition is true. */ static void dropout(int lvalue, void (*testfunc) (int val), int exit1, value * lval) { if (lvalue) rvalue(lval); else if (lval->ident == iCONSTEXPR) const1(lval->constval); (*testfunc) (exit1); } static void checkfunction(value * lval) { symbol *sym = lval->sym; if (!sym || (sym->ident != iFUNCTN && sym->ident != iREFFUNC)) return; /* no known symbol, or not a function result */ if ((sym->usage & uDEFINE) != 0) { /* function is defined, can now check the return value (but make an * exception for directly recursive functions) */ if (sym != curfunc && (sym->usage & uRETVALUE) == 0) { char symname[2 * sNAMEMAX + 16]; /* allow space for user defined operators */ funcdisplayname(symname, sym->name); error(209, symname); /* function should return a value */ } /* if */ } else { /* function not yet defined, set */ sym->usage |= uRETVALUE; /* make sure that a future implementation of * the function uses "return " */ } /* if */ } /* * Plunge to a lower level */ static int plnge(int *opstr, int opoff, int (*hier) (value * lval), value * lval, char *forcetag, int chkbitwise) { int lvalue, opidx; int count; value lval2 = { NULL, 0, 0, 0, 0, NULL }; lvalue = plnge1(hier, lval); if (nextop(&opidx, opstr) == 0) return lvalue; /* no operator in "opstr" found */ if (lvalue) rvalue(lval); count = 0; do { if (chkbitwise && count++ > 0 && bitwise_opercount != 0) error(212); opidx += opoff; /* add offset to index returned by nextop() */ plnge2(op1[opidx], hier, lval, &lval2); if (op1[opidx] == ob_and || op1[opidx] == ob_or) bitwise_opercount++; if (forcetag) lval->tag = sc_addtag(forcetag); } while (nextop(&opidx, opstr)); /* do */ return FALSE; /* result of expression is not an lvalue */ } /* plnge_rel * * Binary plunge to lower level; this is very simular to plnge, but * it has special code generation sequences for chained operations. */ static int plnge_rel(int *opstr, int opoff, int (*hier) (value * lval), value * lval) { int lvalue, opidx; value lval2 = { NULL, 0, 0, 0, 0, NULL }; int count; /* this function should only be called for relational operators */ assert(op1[opoff] == os_le); lvalue = plnge1(hier, lval); if (nextop(&opidx, opstr) == 0) return lvalue; /* no operator in "opstr" found */ if (lvalue) rvalue(lval); count = 0; lval->boolresult = TRUE; do { /* same check as in plnge(), but "chkbitwise" is always TRUE */ if (count > 0 && bitwise_opercount != 0) error(212); if (count > 0) { relop_prefix(); *lval = lval2; /* copy right hand expression of the previous iteration */ } /* if */ opidx += opoff; plnge2(op1[opidx], hier, lval, &lval2); if (count++ > 0) relop_suffix(); } while (nextop(&opidx, opstr)); /* enddo */ lval->constval = lval->boolresult; lval->tag = sc_addtag("bool"); /* force tag to be "bool" */ return FALSE; /* result of expression is not an lvalue */ } /* plnge1 * * Unary plunge to lower level * Called by: skim(), plnge(), plnge2(), plnge_rel(), hier14() and hier13() */ static int plnge1(int (*hier) (value * lval), value * lval) { int lvalue, index; cell cidx; stgget(&index, &cidx); /* mark position in code generator */ lvalue = (*hier) (lval); if (lval->ident == iCONSTEXPR) stgdel(index, cidx); /* load constant later */ return lvalue; } /* plnge2 * * Binary plunge to lower level * Called by: plnge(), plnge_rel(), hier14() and hier1() */ static void plnge2(void (*oper) (void), int (*hier) (value * lval), value * lval1, value * lval2) { int index; cell cidx; stgget(&index, &cidx); /* mark position in code generator */ if (lval1->ident == iCONSTEXPR) { /* constant on left side; it is not yet loaded */ if (plnge1(hier, lval2)) rvalue(lval2); /* load lvalue now */ else if (lval2->ident == iCONSTEXPR) const1(lval2->constval << dbltest(oper, lval2, lval1)); const2(lval1->constval << dbltest(oper, lval2, lval1)); /* ^ doubling of constants operating on integer addresses */ /* is restricted to "add" and "subtract" operators */ } else { /* non-constant on left side */ push1(); if (plnge1(hier, lval2)) rvalue(lval2); if (lval2->ident == iCONSTEXPR) { /* constant on right side */ if (commutative(oper)) { /* test for commutative operators */ value lvaltmp = { NULL, 0, 0, 0, 0, NULL }; stgdel(index, cidx); /* scratch push1() and constant fetch (then * fetch the constant again */ const2(lval2->constval << dbltest(oper, lval1, lval2)); /* now, the primary register has the left operand and the secondary * register the right operand; swap the "lval" variables so that lval1 * is associated with the secondary register and lval2 with the * primary register, as is the "normal" case. */ lvaltmp = *lval1; *lval1 = *lval2; *lval2 = lvaltmp; } else { const1(lval2->constval << dbltest(oper, lval1, lval2)); pop2(); /* pop result of left operand into secondary register */ } /* if */ } else { /* non-constants on both sides */ pop2(); if (dbltest(oper, lval1, lval2)) cell2addr(); /* double primary register */ if (dbltest(oper, lval2, lval1)) cell2addr_alt(); /* double secondary register */ } /* if */ } /* if */ if (oper) { /* If used in an expression, a function should return a value. * If the function has been defined, we can check this. If the * function was not defined, we can set this requirement (so that * a future function definition can check this bit. */ checkfunction(lval1); checkfunction(lval2); if (lval1->ident == iARRAY || lval1->ident == iREFARRAY) { char *ptr = (lval1->sym) ? lval1->sym->name : "-unknown-"; error(33, ptr); /* array must be indexed */ } else if (lval2->ident == iARRAY || lval2->ident == iREFARRAY) { char *ptr = (lval2->sym) ? lval2->sym->name : "-unknown-"; error(33, ptr); /* array must be indexed */ } /* if */ /* ??? ^^^ should do same kind of error checking with functions */ /* check whether an "operator" function is defined for the tag names * (a constant expression cannot be optimized in that case) */ if (check_userop(oper, lval1->tag, lval2->tag, 2, NULL, &lval1->tag)) { lval1->ident = iEXPRESSION; lval1->constval = 0; } else if (lval1->ident == iCONSTEXPR && lval2->ident == iCONSTEXPR) { /* only constant expression if both constant */ stgdel(index, cidx); /* scratch generated code and calculate */ if (!matchtag(lval1->tag, lval2->tag, FALSE)) error(213); /* tagname mismatch */ lval1->constval = calc(lval1->constval, oper, lval2->constval, &lval1->boolresult); } else { if (!matchtag(lval1->tag, lval2->tag, FALSE)) error(213); /* tagname mismatch */ (*oper) (); /* do the (signed) operation */ lval1->ident = iEXPRESSION; } /* if */ } /* if */ } static cell truemodulus(cell a, cell b) { return (a % b + b) % b; } static cell calc(cell left, void (*oper) (), cell right, char *boolresult) { if (oper == ob_or) return (left | right); else if (oper == ob_xor) return (left ^ right); else if (oper == ob_and) return (left & right); else if (oper == ob_eq) return (left == right); else if (oper == ob_ne) return (left != right); else if (oper == os_le) return *boolresult &= (char)(left <= right), right; else if (oper == os_ge) return *boolresult &= (char)(left >= right), right; else if (oper == os_lt) return *boolresult &= (char)(left < right), right; else if (oper == os_gt) return *boolresult &= (char)(left > right), right; else if (oper == os_sar) return (left >> (int)right); else if (oper == ou_sar) return ((ucell) left >> (ucell) right); else if (oper == ob_sal) return ((ucell) left << (int)right); else if (oper == ob_add) return (left + right); else if (oper == ob_sub) return (left - right); else if (oper == os_mult) return (left * right); else if (oper == os_div) return (left - truemodulus(left, right)) / right; else if (oper == os_mod) return truemodulus(left, right); else error(29); /* invalid expression, assumed 0 (this should never occur) */ return 0; } int expression(int *constant, cell * val, int *tag, int chkfuncresult) { value lval = { NULL, 0, 0, 0, 0, NULL }; if (hier14(&lval)) rvalue(&lval); if (lval.ident == iCONSTEXPR) { /* constant expression */ *constant = TRUE; *val = lval.constval; } else { *constant = FALSE; *val = 0; } /* if */ if (tag) *tag = lval.tag; if (chkfuncresult) checkfunction(&lval); return lval.ident; } static cell array_totalsize(symbol * sym) { cell length; assert(sym != NULL); assert(sym->ident == iARRAY || sym->ident == iREFARRAY); length = sym->dim.array.length; if (sym->dim.array.level > 0) { cell sublength = array_totalsize(finddepend(sym)); if (sublength > 0) length = length + length * sublength; else length = 0; } /* if */ return length; } static cell array_levelsize(symbol * sym, int level) { assert(sym != NULL); assert(sym->ident == iARRAY || sym->ident == iREFARRAY); assert(level <= sym->dim.array.level); while (level-- > 0) { sym = finddepend(sym); assert(sym != NULL); } /* if */ return sym->dim.array.length; } /* hier14 * * Lowest hierarchy level (except for the , operator). * * Global references: intest (referred to only) */ int hier14(value * lval1) { int lvalue; value lval2 = { NULL, 0, 0, 0, 0, NULL }; value lval3 = { NULL, 0, 0, 0, 0, NULL }; void (*oper) (void); int tok, level, i; cell val; char *st; int bwcount; cell arrayidx1[sDIMEN_MAX], arrayidx2[sDIMEN_MAX]; /* last used array indices */ cell *org_arrayidx; bwcount = bitwise_opercount; bitwise_opercount = 0; for (i = 0; i < sDIMEN_MAX; i++) arrayidx1[i] = arrayidx2[i] = 0; org_arrayidx = lval1->arrayidx; /* save current pointer, to reset later */ if (!lval1->arrayidx) lval1->arrayidx = arrayidx1; lvalue = plnge1(hier13, lval1); if (lval1->ident != iARRAYCELL && lval1->ident != iARRAYCHAR) lval1->arrayidx = NULL; if (lval1->ident == iCONSTEXPR) /* load constant here */ const1(lval1->constval); tok = lex(&val, &st); switch (tok) { case taOR: oper = ob_or; break; case taXOR: oper = ob_xor; break; case taAND: oper = ob_and; break; case taADD: oper = ob_add; break; case taSUB: oper = ob_sub; break; case taMULT: oper = os_mult; break; case taDIV: oper = os_div; break; case taMOD: oper = os_mod; break; case taSHRU: oper = ou_sar; break; case taSHR: oper = os_sar; break; case taSHL: oper = ob_sal; break; case '=': /* simple assignment */ oper = NULL; if (intest) error(211); /* possibly unintended assignment */ break; default: lexpush(); bitwise_opercount = bwcount; lval1->arrayidx = org_arrayidx; /* restore array index pointer */ return lvalue; } /* switch */ /* if we get here, it was an assignment; first check a few special cases * and then the general */ if (lval1->ident == iARRAYCHAR) { /* special case, assignment to packed character in a cell is permitted */ lvalue = TRUE; } else if (lval1->ident == iARRAY || lval1->ident == iREFARRAY) { /* array assignment is permitted too (with restrictions) */ if (oper) return error(23); /* array assignment must be simple assigment */ assert(lval1->sym != NULL); if (array_totalsize(lval1->sym) == 0) return error(46, lval1->sym->name); /* unknown array size */ lvalue = TRUE; } /* if */ /* operand on left side of assignment must be lvalue */ if (!lvalue) return error(22); /* must be lvalue */ /* may not change "constant" parameters */ assert(lval1->sym != NULL); if ((lval1->sym->usage & uCONST) != 0) return error(22); /* assignment to const argument */ lval3 = *lval1; /* save symbol to enable storage of expresion result */ lval1->arrayidx = org_arrayidx; /* restore array index pointer */ if (lval1->ident == iARRAYCELL || lval1->ident == iARRAYCHAR || lval1->ident == iARRAY || lval1->ident == iREFARRAY) { /* if indirect fetch: save PRI (cell address) */ if (oper) { push1(); rvalue(lval1); } /* if */ lval2.arrayidx = arrayidx2; plnge2(oper, hier14, lval1, &lval2); if (lval2.ident != iARRAYCELL && lval2.ident != iARRAYCHAR) lval2.arrayidx = NULL; if (oper) pop2(); if (!oper && lval3.arrayidx && lval2.arrayidx && lval3.ident == lval2.ident && lval3.sym == lval2.sym) { int same = TRUE; assert(lval3.arrayidx == arrayidx1); assert(lval2.arrayidx == arrayidx2); for (i = 0; i < sDIMEN_MAX; i++) same = same && (lval3.arrayidx[i] == lval2.arrayidx[i]); if (same) error(226, lval3.sym->name); /* self-assignment */ } /* if */ } else { if (oper) { rvalue(lval1); plnge2(oper, hier14, lval1, &lval2); } else { /* if direct fetch and simple assignment: no "push" * and "pop" needed -> call hier14() directly, */ if (hier14(&lval2)) rvalue(&lval2); /* instead of plnge2(). */ checkfunction(&lval2); /* check whether lval2 and lval3 (old lval1) refer to the same variable */ if (lval2.ident == iVARIABLE && lval3.ident == lval2.ident && lval3.sym == lval2.sym) { assert(lval3.sym != NULL); error(226, lval3.sym->name); /* self-assignment */ } /* if */ } /* if */ } /* if */ if (lval3.ident == iARRAY || lval3.ident == iREFARRAY) { /* left operand is an array, right operand should be an array variable * of the same size and the same dimension, an array literal (of the * same size) or a literal string. */ int exactmatch = TRUE; if (lval2.ident != iARRAY && lval2.ident != iREFARRAY) error(33, lval3.sym->name); /* array must be indexed */ if (lval2.sym) { val = lval2.sym->dim.array.length; /* array variable */ level = lval2.sym->dim.array.level; } else { val = lval2.constval; /* literal array */ level = 0; /* If val is negative, it means that lval2 is a * literal string. The string array size may be * smaller than the destination array. */ if (val < 0) { val = -val; exactmatch = FALSE; } /* if */ } /* if */ if (lval3.sym->dim.array.level != level) return error(48); /* array dimensions must match */ else if (lval3.sym->dim.array.length < val || (exactmatch && lval3.sym->dim.array.length > val)) return error(47); /* array sizes must match */ if (level > 0) { /* check the sizes of all sublevels too */ symbol *sym1 = lval3.sym; symbol *sym2 = lval2.sym; int i; assert(sym1 != NULL && sym2 != NULL); /* ^^^ sym2 must be valid, because only variables can be * multi-dimensional (there are no multi-dimensional arrays), * sym1 must be valid because it must be an lvalue */ assert(exactmatch); for (i = 0; i < level; i++) { sym1 = finddepend(sym1); sym2 = finddepend(sym2); assert(sym1 != NULL && sym2 != NULL); /* ^^^ both arrays have the same dimensions (this was checked * earlier) so the dependend should always be found */ if (sym1->dim.array.length != sym2->dim.array.length) error(47); /* array sizes must match */ } /* for */ /* get the total size in cells of the multi-dimensional array */ val = array_totalsize(lval3.sym); assert(val > 0); /* already checked */ } /* if */ } else { /* left operand is not an array, right operand should then not be either */ if (lval2.ident == iARRAY || lval2.ident == iREFARRAY) error(6); /* must be assigned to an array */ } /* if */ if (lval3.ident == iARRAY || lval3.ident == iREFARRAY) { memcopy(val * sizeof(cell)); } else { check_userop(NULL, lval2.tag, lval3.tag, 2, &lval3, &lval2.tag); store(&lval3); /* now, store the expression result */ } /* if */ if (!oper && !matchtag(lval3.tag, lval2.tag, TRUE)) error(213); /* tagname mismatch (if "oper", warning already given in plunge2()) */ if (lval3.sym) markusage(lval3.sym, uWRITTEN); sideeffect = TRUE; bitwise_opercount = bwcount; return FALSE; /* expression result is never an lvalue */ } static int hier13(value * lval) { int lvalue, flab1, flab2; value lval2 = { NULL, 0, 0, 0, 0, NULL }; int array1, array2; lvalue = plnge1(hier12, lval); if (matchtoken('?')) { flab1 = getlabel(); flab2 = getlabel(); if (lvalue) { rvalue(lval); } else if (lval->ident == iCONSTEXPR) { const1(lval->constval); error(lval->constval ? 206 : 205); /* redundant test */ } /* if */ jmp_eq0(flab1); /* go to second expression if primary register==0 */ if (hier14(lval)) rvalue(lval); jumplabel(flab2); setlabel(flab1); needtoken(':'); if (hier14(&lval2)) rvalue(&lval2); array1 = (lval->ident == iARRAY || lval->ident == iREFARRAY); array2 = (lval2.ident == iARRAY || lval2.ident == iREFARRAY); if (array1 && !array2) { char *ptr = (lval->sym->name) ? lval->sym->name : "-unknown-"; error(33, ptr); /* array must be indexed */ } else if (!array1 && array2) { char *ptr = (lval2.sym->name) ? lval2.sym->name : "-unknown-"; error(33, ptr); /* array must be indexed */ } /* if */ /* ??? if both are arrays, should check dimensions */ if (!matchtag(lval->tag, lval2.tag, FALSE)) error(213); /* tagname mismatch ('true' and 'false' expressions) */ setlabel(flab2); if (lval->ident == iARRAY) lval->ident = iREFARRAY; /* iARRAY becomes iREFARRAY */ else if (lval->ident != iREFARRAY) lval->ident = iEXPRESSION; /* iREFARRAY stays iREFARRAY, rest becomes iEXPRESSION */ return FALSE; /* conditional expression is no lvalue */ } else { return lvalue; } /* endif */ } /* the order of the operators in these lists is important and must cohere */ /* with the order of the operators in the array "op1" */ static int list3[] = { '*', '/', '%', 0 }; static int list4[] = { '+', '-', 0 }; static int list5[] = { tSHL, tSHR, tSHRU, 0 }; static int list6[] = { '&', 0 }; static int list7[] = { '^', 0 }; static int list8[] = { '|', 0 }; static int list9[] = { tlLE, tlGE, '<', '>', 0 }; static int list10[] = { tlEQ, tlNE, 0 }; static int list11[] = { tlAND, 0 }; static int list12[] = { tlOR, 0 }; static int hier12(value * lval) { return skim(list12, jmp_ne0, 1, 0, hier11, lval); } static int hier11(value * lval) { return skim(list11, jmp_eq0, 0, 1, hier10, lval); } static int hier10(value * lval) { /* ==, != */ return plnge(list10, 15, hier9, lval, "bool", TRUE); } /* ^ this variable is the starting index in the op1[] * array of the operators of this hierarchy level */ static int hier9(value * lval) { /* <=, >=, <, > */ return plnge_rel(list9, 11, hier8, lval); } static int hier8(value * lval) { /* | */ return plnge(list8, 10, hier7, lval, NULL, FALSE); } static int hier7(value * lval) { /* ^ */ return plnge(list7, 9, hier6, lval, NULL, FALSE); } static int hier6(value * lval) { /* & */ return plnge(list6, 8, hier5, lval, NULL, FALSE); } static int hier5(value * lval) { /* <<, >>, >>> */ return plnge(list5, 5, hier4, lval, NULL, FALSE); } static int hier4(value * lval) { /* +, - */ return plnge(list4, 3, hier3, lval, NULL, FALSE); } static int hier3(value * lval) { /* *, /, % */ return plnge(list3, 0, hier2, lval, NULL, FALSE); } static int hier2(value * lval) { int lvalue, tok; int tag, paranthese; cell val; char *st; symbol *sym; int saveresult; tok = lex(&val, &st); switch (tok) { case tINC: /* ++lval */ if (!hier2(lval)) return error(22); /* must be lvalue */ assert(lval->sym != NULL); if ((lval->sym->usage & uCONST) != 0) return error(22); /* assignment to const argument */ if (!check_userop(user_inc, lval->tag, 0, 1, lval, &lval->tag)) inc(lval); /* increase variable first */ rvalue(lval); /* and read the result into PRI */ sideeffect = TRUE; return FALSE; /* result is no longer lvalue */ case tDEC: /* --lval */ if (!hier2(lval)) return error(22); /* must be lvalue */ assert(lval->sym != NULL); if ((lval->sym->usage & uCONST) != 0) return error(22); /* assignment to const argument */ if (!check_userop(user_dec, lval->tag, 0, 1, lval, &lval->tag)) dec(lval); /* decrease variable first */ rvalue(lval); /* and read the result into PRI */ sideeffect = TRUE; return FALSE; /* result is no longer lvalue */ case '~': /* ~ (one's complement) */ if (hier2(lval)) rvalue(lval); invert(); /* bitwise NOT */ lval->constval = ~lval->constval; return FALSE; case '!': /* ! (logical negate) */ if (hier2(lval)) rvalue(lval); if (check_userop(lneg, lval->tag, 0, 1, NULL, &lval->tag)) { lval->ident = iEXPRESSION; lval->constval = 0; } else { lneg(); /* 0 -> 1, !0 -> 0 */ lval->constval = !lval->constval; lval->tag = sc_addtag("bool"); } /* if */ return FALSE; case '-': /* unary - (two's complement) */ if (hier2(lval)) rvalue(lval); /* make a special check for a constant expression with the tag of a * rational number, so that we can simple swap the sign of that constant. */ if (lval->ident == iCONSTEXPR && lval->tag == sc_rationaltag && sc_rationaltag != 0) { if (rational_digits == 0) { float *f = (float *)&lval->constval; *f = -*f; /* this modifies lval->constval */ } else { /* the negation of a fixed point number is just an integer negation */ lval->constval = -lval->constval; } /* if */ } else if (check_userop(neg, lval->tag, 0, 1, NULL, &lval->tag)) { lval->ident = iEXPRESSION; lval->constval = 0; } else { neg(); /* arithmic negation */ lval->constval = -lval->constval; } /* if */ return FALSE; case tLABEL: /* tagname override */ tag = sc_addtag(st); lvalue = hier2(lval); lval->tag = tag; return lvalue; case tDEFINED: paranthese = 0; while (matchtoken('(')) paranthese++; tok = lex(&val, &st); if (tok != tSYMBOL) return error(20, st); /* illegal symbol name */ sym = findloc(st); if (!sym) sym = findglb(st); if (sym && sym->ident != iFUNCTN && sym->ident != iREFFUNC && (sym->usage & uDEFINE) == 0) sym = NULL; /* symbol is not a function, it is in the table, but not "defined" */ val = !!sym; if (!val && find_subst(st, strlen(st))) val = 1; clear_value(lval); lval->ident = iCONSTEXPR; lval->constval = val; const1(lval->constval); while (paranthese--) needtoken(')'); return FALSE; case tSIZEOF: paranthese = 0; while (matchtoken('(')) paranthese++; tok = lex(&val, &st); if (tok != tSYMBOL) return error(20, st); /* illegal symbol name */ sym = findloc(st); if (!sym) sym = findglb(st); if (!sym) return error(17, st); /* undefined symbol */ if (sym->ident == iCONSTEXPR) error(39); /* constant symbol has no size */ else if (sym->ident == iFUNCTN || sym->ident == iREFFUNC) error(72); /* "function" symbol has no size */ else if ((sym->usage & uDEFINE) == 0) return error(17, st); /* undefined symbol (symbol is in the table, but it is "used" only) */ clear_value(lval); lval->ident = iCONSTEXPR; lval->constval = 1; /* preset */ if (sym->ident == iARRAY || sym->ident == iREFARRAY) { int level; for (level = 0; matchtoken('['); level++) needtoken(']'); if (level > sym->dim.array.level) error(28); /* invalid subscript */ else lval->constval = array_levelsize(sym, level); if (lval->constval == 0 && !strchr(lptr, PREPROC_TERM)) error(224, st); /* indeterminate array size in "sizeof" expression */ } /* if */ const1(lval->constval); while (paranthese--) needtoken(')'); return FALSE; case tTAGOF: paranthese = 0; while (matchtoken('(')) paranthese++; tok = lex(&val, &st); if (tok != tSYMBOL && tok != tLABEL) return error(20, st); /* illegal symbol name */ if (tok == tLABEL) { tag = sc_addtag(st); } else { sym = findloc(st); if (!sym) sym = findglb(st); if (!sym) return error(17, st); /* undefined symbol */ if ((sym->usage & uDEFINE) == 0) return error(17, st); /* undefined symbol (symbol is in the table, but it is "used" only) */ tag = sym->tag; } /* if */ exporttag(tag); clear_value(lval); lval->ident = iCONSTEXPR; lval->constval = tag; const1(lval->constval); while (paranthese--) needtoken(')'); return FALSE; default: lexpush(); lvalue = hier1(lval); /* check for postfix operators */ if (matchtoken(';')) { /* Found a ';', do not look further for postfix operators */ lexpush(); /* push ';' back after successful match */ return lvalue; } else if (matchtoken(tTERM)) { /* Found a newline that ends a statement (this is the case when * semicolons are optional). Note that an explicit semicolon was * handled above. This case is similar, except that the token must * not be pushed back. */ return lvalue; } else { tok = lex(&val, &st); switch (tok) { case tINC: /* lval++ */ if (!lvalue) return error(22); /* must be lvalue */ assert(lval->sym != NULL); if ((lval->sym->usage & uCONST) != 0) return error(22); /* assignment to const argument */ /* on incrementing array cells, the address in PRI must be saved for * incremening the value, whereas the current value must be in PRI * on exit. */ saveresult = (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR); if (saveresult) push1(); /* save address in PRI */ rvalue(lval); /* read current value into PRI */ if (saveresult) swap1(); /* save PRI on the stack, restore address in PRI */ if (!check_userop (user_inc, lval->tag, 0, 1, lval, &lval->tag)) inc(lval); /* increase variable afterwards */ if (saveresult) pop1(); /* restore PRI (result of rvalue()) */ sideeffect = TRUE; return FALSE; /* result is no longer lvalue */ case tDEC: /* lval-- */ if (!lvalue) return error(22); /* must be lvalue */ assert(lval->sym != NULL); if ((lval->sym->usage & uCONST) != 0) return error(22); /* assignment to const argument */ saveresult = (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR); if (saveresult) push1(); /* save address in PRI */ rvalue(lval); /* read current value into PRI */ if (saveresult) swap1(); /* save PRI on the stack, restore address in PRI */ if (!check_userop (user_dec, lval->tag, 0, 1, lval, &lval->tag)) dec(lval); /* decrease variable afterwards */ if (saveresult) pop1(); /* restore PRI (result of rvalue()) */ sideeffect = TRUE; return FALSE; case tCHAR: /* char (compute required # of cells */ if (lval->ident == iCONSTEXPR) { lval->constval *= charbits / 8; /* from char to bytes */ lval->constval = (lval->constval + sizeof(cell) - 1) / sizeof(cell); } else { if (lvalue) rvalue(lval); /* fetch value if not already in PRI */ char2addr(); /* from characters to bytes */ addconst(sizeof(cell) - 1); /* make sure the value is rounded up */ addr2cell(); /* truncate to number of cells */ } /* if */ return FALSE; default: lexpush(); return lvalue; } /* switch */ } /* if */ } /* switch */ } /* hier1 * * The highest hierarchy level: it looks for pointer and array indices * and function calls. * Generates code to fetch a pointer value if it is indexed and code to * add to the pointer value or the array address (the address is already * read at primary()). It also generates code to fetch a function address * if that hasn't already been done at primary() (check lval[4]) and calls * callfunction() to call the function. */ static int hier1(value * lval1) { int lvalue, index, tok, symtok; cell val, cidx; value lval2 = { NULL, 0, 0, 0, 0, NULL }; char *st; char close; symbol *sym; lvalue = primary(lval1); symtok = tokeninfo(&val, &st); /* get token read by primary() */ restart: sym = lval1->sym; if (matchtoken('[') || matchtoken('{') || matchtoken('(')) { tok = tokeninfo(&val, &st); /* get token read by matchtoken() */ if (!sym && symtok != tSYMBOL) { /* we do not have a valid symbol and we appear not to have read a valid * symbol name (so it is unlikely that we would have read a name of an * undefined symbol) */ error(29); /* expression error, assumed 0 */ lexpush(); /* analyse '(', '{' or '[' again later */ return FALSE; } /* if */ if (tok == '[' || tok == '{') { /* subscript */ close = (char)((tok == '[') ? ']' : '}'); if (!sym) { /* sym==NULL if lval is a constant or a literal */ error(28); /* cannot subscript */ needtoken(close); return FALSE; } else if (sym->ident != iARRAY && sym->ident != iREFARRAY) { error(28); /* cannot subscript, variable is not an array */ needtoken(close); return FALSE; } else if (sym->dim.array.level > 0 && close != ']') { error(51); /* invalid subscript, must use [ ] */ needtoken(close); return FALSE; } /* if */ stgget(&index, &cidx); /* mark position in code generator */ push1(); /* save base address of the array */ if (hier14(&lval2)) /* create expression for the array index */ rvalue(&lval2); if (lval2.ident == iARRAY || lval2.ident == iREFARRAY) error(33, lval2.sym->name); /* array must be indexed */ needtoken(close); if (!matchtag(sym->x.idxtag, lval2.tag, TRUE)) error(213); if (lval2.ident == iCONSTEXPR) { /* constant expression */ stgdel(index, cidx); /* scratch generated code */ if (lval1->arrayidx) { /* keep constant index, for checking */ assert(sym->dim.array.level >= 0 && sym->dim.array.level < sDIMEN_MAX); lval1->arrayidx[sym->dim.array.level] = lval2.constval; } /* if */ if (close == ']') { /* normal array index */ if (lval2.constval < 0 || (sym->dim.array.length != 0 && sym->dim.array.length <= lval2.constval)) error(32, sym->name); /* array index out of bounds */ if (lval2.constval != 0) { /* don't add offsets for zero subscripts */ #if defined(BIT16) const2(lval2.constval << 1); #else const2(lval2.constval << 2); #endif ob_add(); } /* if */ } else { /* character index */ if (lval2.constval < 0 || (sym->dim.array.length != 0 && sym->dim.array.length * ((8 * sizeof(cell)) / charbits) <= (ucell) lval2.constval)) error(32, sym->name); /* array index out of bounds */ if (lval2.constval != 0) { /* don't add offsets for zero subscripts */ if (charbits == 16) const2(lval2.constval << 1); /* 16-bit character */ else const2(lval2.constval); /* 8-bit character */ ob_add(); } /* if */ charalign(); /* align character index into array */ } /* if */ } else { /* array index is not constant */ lval1->arrayidx = NULL; /* reset, so won't be checked */ if (close == ']') { if (sym->dim.array.length != 0) ffbounds(sym->dim.array.length - 1); /* run time check for array bounds */ cell2addr(); /* normal array index */ } else { if (sym->dim.array.length != 0) ffbounds(sym->dim.array.length * (32 / charbits) - 1); char2addr(); /* character array index */ } /* if */ pop2(); ob_add(); /* base address was popped into secondary register */ if (close != ']') charalign(); /* align character index into array */ } /* if */ /* the indexed item may be another array (multi-dimensional arrays) */ assert(lval1->sym == sym && sym != NULL); /* should still be set */ if (sym->dim.array.level > 0) { assert(close == ']'); /* checked earlier */ /* read the offset to the subarray and add it to the current address */ lval1->ident = iARRAYCELL; push1(); /* the optimizer makes this to a MOVE.alt */ rvalue(lval1); pop2(); ob_add(); /* adjust the "value" structure and find the referenced array */ lval1->ident = iREFARRAY; lval1->sym = finddepend(sym); assert(lval1->sym != NULL); assert(lval1->sym->dim.array.level == sym->dim.array.level - 1); /* try to parse subsequent array indices */ lvalue = FALSE; /* for now, a iREFARRAY is no lvalue */ goto restart; } /* if */ assert(sym->dim.array.level == 0); /* set type to fetch... INDIRECTLY */ lval1->ident = (char)((close == ']') ? iARRAYCELL : iARRAYCHAR); lval1->tag = sym->tag; /* a cell in an array is an lvalue, a character in an array is not * always a *valid* lvalue */ return TRUE; } else { /* tok=='(' -> function(...) */ if (!sym || (sym->ident != iFUNCTN && sym->ident != iREFFUNC)) { if (!sym && sc_status == statFIRST) { /* could be a "use before declaration"; in that case, create a stub * function so that the usage can be marked. */ sym = fetchfunc(lastsymbol, 0); if (sym) markusage(sym, uREAD); } /* if */ return error(12); /* invalid function call */ } else if ((sym->usage & uMISSING) != 0) { char symname[2 * sNAMEMAX + 16]; /* allow space for user defined operators */ funcdisplayname(symname, sym->name); error(4, symname); /* function not defined */ } /* if */ callfunction(sym); lval1->ident = iEXPRESSION; lval1->constval = 0; lval1->tag = sym->tag; return FALSE; /* result of function call is no lvalue */ } /* if */ } /* if */ if (sym && lval1->ident == iFUNCTN) { assert(sym->ident == iFUNCTN); address(sym); lval1->sym = NULL; lval1->ident = iREFFUNC; /* ??? however... function pointers (or function references are not (yet) allowed */ error(29); /* expression error, assumed 0 */ return FALSE; } /* if */ return lvalue; } /* primary * * Returns 1 if the operand is an lvalue (everything except arrays, functions * constants and -of course- errors). * Generates code to fetch the address of arrays. Code for constants is * already generated by constant(). * This routine first clears the entire lval array (all fields are set to 0). * * Global references: intest (may be altered, but restored upon termination) */ static int primary(value * lval) { char *st; int lvalue, tok; cell val; symbol *sym; if (matchtoken('(')) { /* sub-expression - (expression,...) */ pushstk((stkitem) intest); pushstk((stkitem) sc_allowtags); intest = 0; /* no longer in "test" expression */ sc_allowtags = TRUE; /* allow tagnames to be used in parenthised expressions */ do lvalue = hier14(lval); while (matchtoken(',')); needtoken(')'); lexclr(FALSE); /* clear lex() push-back, it should have been * cleared already by needtoken() */ sc_allowtags = (int)(long)popstk(); intest = (int)(long)popstk(); return lvalue; } /* if */ clear_value(lval); /* clear lval */ tok = lex(&val, &st); if (tok == tSYMBOL) { /* lastsymbol is char[sNAMEMAX+1], lex() should have truncated any symbol * to sNAMEMAX significant characters */ assert(strlen(st) < sizeof lastsymbol); strcpy(lastsymbol, st); } /* if */ if (tok == tSYMBOL && !findconst(st)) { /* first look for a local variable */ if ((sym = findloc(st))) { if (sym->ident == iLABEL) { error(29); /* expression error, assumed 0 */ const1(0); /* load 0 */ return FALSE; /* return 0 for labels (expression error) */ } /* if */ lval->sym = sym; lval->ident = sym->ident; lval->tag = sym->tag; if (sym->ident == iARRAY || sym->ident == iREFARRAY) { address(sym); /* get starting address in primary register */ return FALSE; /* return 0 for array (not lvalue) */ } else { return TRUE; /* return 1 if lvalue (not label or array) */ } /* if */ } /* if */ /* now try a global variable */ if ((sym = findglb(st))) { if (sym->ident == iFUNCTN || sym->ident == iREFFUNC) { /* if the function is only in the table because it was inserted as a * stub in the first pass (i.e. it was "used" but never declared or * implemented, issue an error */ if ((sym->usage & uPROTOTYPED) == 0) error(17, st); } else { if ((sym->usage & uDEFINE) == 0) error(17, st); lval->sym = sym; lval->ident = sym->ident; lval->tag = sym->tag; if (sym->ident == iARRAY || sym->ident == iREFARRAY) { address(sym); /* get starting address in primary register */ return FALSE; /* return 0 for array (not lvalue) */ } else { return TRUE; /* return 1 if lvalue (not function or array) */ } /* if */ } /* if */ } else { return error(17, st); /* undefined symbol */ } /* endif */ assert(sym != NULL); assert(sym->ident == iFUNCTN || sym->ident != iREFFUNC); lval->sym = sym; lval->ident = sym->ident; lval->tag = sym->tag; return FALSE; /* return 0 for function (not an lvalue) */ } /* if */ lexpush(); /* push the token, it is analyzed by constant() */ if (constant(lval) == 0) { error(29); /* expression error, assumed 0 */ const1(0); /* load 0 */ } /* if */ return FALSE; /* return 0 for constants (or errors) */ } static void clear_value(value * lval) { lval->sym = NULL; lval->constval = 0L; lval->tag = 0; lval->ident = 0; lval->boolresult = FALSE; /* do not clear lval->arrayidx, it is preset in hier14() */ } static void setdefarray(cell * string, cell size, cell array_sz, cell * dataaddr, int fconst) { /* The routine must copy the default array data onto the heap, as to avoid * that a function can change the default value. An optimization is that * the default array data is "dumped" into the data segment only once (on the * first use). */ assert(string != NULL); assert(size > 0); /* check whether to dump the default array */ assert(dataaddr != NULL); if (sc_status == statWRITE && *dataaddr < 0) { int i; *dataaddr = (litidx + glb_declared) * sizeof(cell); for (i = 0; i < size; i++) stowlit(*string++); } /* if */ /* if the function is known not to modify the array (meaning that it also * does not modify the default value), directly pass the address of the * array in the data segment. */ if (fconst) { const1(*dataaddr); } else { /* Generate the code: * CONST.pri dataaddr ;address of the default array data * HEAP array_sz*sizeof(cell) ;heap address in ALT * MOVS size*sizeof(cell) ;copy data from PRI to ALT * MOVE.PRI ;PRI = address on the heap */ const1(*dataaddr); /* "array_sz" is the size of the argument (the value between the brackets * in the declaration), "size" is the size of the default array data. */ assert(array_sz >= size); modheap((int)array_sz * sizeof(cell)); /* ??? should perhaps fill with zeros first */ memcopy(size * sizeof(cell)); moveto1(); } /* if */ } static int findnamedarg(arginfo * arg, char *name) { int i; for (i = 0; arg[i].ident != 0 && arg[i].ident != iVARARGS; i++) if (strcmp(arg[i].name, name) == 0) return i; return -1; } static int checktag(int tags[], int numtags, int exprtag) { int i; assert(tags != 0); assert(numtags > 0); for (i = 0; i < numtags; i++) if (matchtag(tags[i], exprtag, TRUE)) return TRUE; /* matching tag */ return FALSE; /* no tag matched */ } enum { ARG_UNHANDLED, ARG_IGNORED, ARG_DONE, }; /* callfunction * * Generates code to call a function. This routine handles default arguments * and positional as well as named parameters. */ static void callfunction(symbol * sym) { int close, lvalue; int argpos; /* index in the output stream (argpos==nargs if positional parameters) */ int argidx = 0; /* index in "arginfo" list */ int nargs = 0; /* number of arguments */ int heapalloc = 0; int namedparams = FALSE; value lval = { NULL, 0, 0, 0, 0, NULL }; arginfo *arg; char arglist[sMAXARGS]; constvalue arrayszlst = { NULL, "", 0, 0 }; /* array size list starts empty */ cell lexval; char *lexstr; assert(sym != NULL); arg = sym->dim.arglist; assert(arg != NULL); stgmark(sSTARTREORDER); for (argpos = 0; argpos < sMAXARGS; argpos++) arglist[argpos] = ARG_UNHANDLED; if (!matchtoken(')')) { do { if (matchtoken('.')) { namedparams = TRUE; if (needtoken(tSYMBOL)) tokeninfo(&lexval, &lexstr); else lexstr = ""; argpos = findnamedarg(arg, lexstr); if (argpos < 0) { error(17, lexstr); /* undefined symbol */ break; /* exit loop, argpos is invalid */ } /* if */ needtoken('='); argidx = argpos; } else { if (namedparams) error(44); /* positional parameters must precede named parameters */ argpos = nargs; } /* if */ stgmark((char)(sEXPRSTART + argpos)); /* mark beginning of new expression in stage */ if (arglist[argpos] != ARG_UNHANDLED) error(58); /* argument already set */ if (matchtoken('_')) { arglist[argpos] = ARG_IGNORED; /* flag argument as "present, but ignored" */ if (arg[argidx].ident == 0 || arg[argidx].ident == iVARARGS) { error(202); /* argument count mismatch */ } else if (!arg[argidx].hasdefault) { error(34, nargs + 1); /* argument has no default value */ } /* if */ if (arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS) argidx++; /* The rest of the code to handle default values is at the bottom * of this routine where default values for unspecified parameters * are (also) handled. Note that above, the argument is flagged as * ARG_IGNORED. */ } else { arglist[argpos] = ARG_DONE; /* flag argument as "present" */ lvalue = hier14(&lval); switch (arg[argidx].ident) { case 0: error(202); /* argument count mismatch */ break; case iVARARGS: /* always pass by reference */ if (lval.ident == iVARIABLE || lval.ident == iREFERENCE) { assert(lval.sym != NULL); if ((lval.sym->usage & uCONST) != 0 && (arg[argidx].usage & uCONST) == 0) { /* treat a "const" variable passed to a function with a non-const * "variable argument list" as a constant here */ assert(lvalue); rvalue(&lval); /* get value in PRI */ setheap_pri(); /* address of the value on the heap in PRI */ heapalloc++; } else if (lvalue) { address(lval.sym); } else { setheap_pri(); /* address of the value on the heap in PRI */ heapalloc++; } /* if */ } else if (lval.ident == iCONSTEXPR || lval.ident == iEXPRESSION || lval.ident == iARRAYCHAR) { /* fetch value if needed */ if (lval.ident == iARRAYCHAR) rvalue(&lval); /* allocate a cell on the heap and store the * value (already in PRI) there */ setheap_pri(); /* address of the value on the heap in PRI */ heapalloc++; } /* if */ /* ??? handle const array passed by reference */ /* otherwise, the address is already in PRI */ if (lval.sym) markusage(lval.sym, uWRITTEN); /* * Dont need this warning - its varargs. there is no way of knowing the * required tag/type... * if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag)) error(213); */ break; case iVARIABLE: if (lval.ident == iLABEL || lval.ident == iFUNCTN || lval.ident == iREFFUNC || lval.ident == iARRAY || lval.ident == iREFARRAY) error(35, argidx + 1); /* argument type mismatch */ if (lvalue) rvalue(&lval); /* get value (direct or indirect) */ /* otherwise, the expression result is already in PRI */ assert(arg[argidx].numtags > 0); check_userop(NULL, lval.tag, arg[argidx].tags[0], 2, NULL, &lval.tag); if (!checktag (arg[argidx].tags, arg[argidx].numtags, lval.tag)) error(213); argidx++; /* argument done */ break; case iREFERENCE: if (!lvalue || lval.ident == iARRAYCHAR) error(35, argidx + 1); /* argument type mismatch */ if (lval.sym && (lval.sym->usage & uCONST) != 0 && (arg[argidx].usage & uCONST) == 0) error(35, argidx + 1); /* argument type mismatch */ if (lval.ident == iVARIABLE || lval.ident == iREFERENCE) { if (lvalue) { assert(lval.sym != NULL); address(lval.sym); } else { setheap_pri(); /* address of the value on the heap in PRI */ heapalloc++; } /* if */ } /* if */ /* otherwise, the address is already in PRI */ if (!checktag (arg[argidx].tags, arg[argidx].numtags, lval.tag)) error(213); argidx++; /* argument done */ if (lval.sym) markusage(lval.sym, uWRITTEN); break; case iREFARRAY: if (lval.ident != iARRAY && lval.ident != iREFARRAY && lval.ident != iARRAYCELL) { error(35, argidx + 1); /* argument type mismatch */ break; } /* if */ if (lval.sym && (lval.sym->usage & uCONST) != 0 && (arg[argidx].usage & uCONST) == 0) error(35, argidx + 1); /* argument type mismatch */ /* Verify that the dimensions match with those in arg[argidx]. * A literal array always has a single dimension. * An iARRAYCELL parameter is also assumed to have a single dimension. */ if (!lval.sym || lval.ident == iARRAYCELL) { if (arg[argidx].numdim != 1) { error(48); /* array dimensions must match */ } else if (arg[argidx].dim[0] != 0) { assert(arg[argidx].dim[0] > 0); if (lval.ident == iARRAYCELL) { error(47); /* array sizes must match */ } else { assert(lval.constval != 0); /* literal array must have a size */ /* A literal array must have exactly the same size as the * function argument; a literal string may be smaller than * the function argument. */ if ((lval.constval > 0 && arg[argidx].dim[0] != lval.constval) || (lval.constval < 0 && arg[argidx].dim[0] < -lval.constval)) error(47); /* array sizes must match */ } /* if */ } /* if */ if (lval.ident != iARRAYCELL) { /* save array size, for default values with uSIZEOF flag */ cell array_sz = lval.constval; assert(array_sz != 0); /* literal array must have a size */ if (array_sz < 0) array_sz = -array_sz; append_constval(&arrayszlst, arg[argidx].name, array_sz, 0); } /* if */ } else { symbol *sym = lval.sym; short level = 0; assert(sym != NULL); if (sym->dim.array.level + 1 != arg[argidx].numdim) error(48); /* array dimensions must match */ /* the lengths for all dimensions must match, unless the dimension * length was defined at zero (which means "undefined") */ while (sym->dim.array.level > 0) { assert(level < sDIMEN_MAX); if (arg[argidx].dim[level] != 0 && sym->dim.array.length != arg[argidx].dim[level]) error(47); /* array sizes must match */ append_constval(&arrayszlst, arg[argidx].name, sym->dim.array.length, level); sym = finddepend(sym); assert(sym != NULL); level++; } /* if */ /* the last dimension is checked too, again, unless it is zero */ assert(level < sDIMEN_MAX); assert(sym != NULL); if (arg[argidx].dim[level] != 0 && sym->dim.array.length != arg[argidx].dim[level]) error(47); /* array sizes must match */ append_constval(&arrayszlst, arg[argidx].name, sym->dim.array.length, level); } /* if */ /* address already in PRI */ if (!checktag (arg[argidx].tags, arg[argidx].numtags, lval.tag)) error(213); // ??? set uWRITTEN? argidx++; /* argument done */ break; } /* switch */ push1(); /* store the function argument on the stack */ endexpr(FALSE); /* mark the end of a sub-expression */ } /* if */ assert(arglist[argpos] != ARG_UNHANDLED); nargs++; close = matchtoken(')'); if (!close) /* if not paranthese... */ if (!needtoken(',')) /* ...should be comma... */ break; /* ...but abort loop if neither */ } while (!close && freading && !matchtoken(tENDEXPR)); /* do */ } /* if */ /* check remaining function arguments (they may have default values) */ for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS; argidx++) { if (arglist[argidx] == ARG_DONE) continue; /* already seen and handled this argument */ /* in this first stage, we also skip the arguments with uSIZEOF and uTAGOF; * these are handled last */ if ((arg[argidx].hasdefault & uSIZEOF) != 0 || (arg[argidx].hasdefault & uTAGOF) != 0) { assert(arg[argidx].ident == iVARIABLE); continue; } /* if */ stgmark((char)(sEXPRSTART + argidx)); /* mark beginning of new expression in stage */ if (arg[argidx].hasdefault) { if (arg[argidx].ident == iREFARRAY) { short level; setdefarray(arg[argidx].defvalue.array.data, arg[argidx].defvalue.array.size, arg[argidx].defvalue.array.arraysize, &arg[argidx].defvalue.array.addr, (arg[argidx].usage & uCONST) != 0); if ((arg[argidx].usage & uCONST) == 0) heapalloc += arg[argidx].defvalue.array.arraysize; /* keep the lengths of all dimensions of a multi-dimensional default array */ assert(arg[argidx].numdim > 0); if (arg[argidx].numdim == 1) { append_constval(&arrayszlst, arg[argidx].name, arg[argidx].defvalue.array.arraysize, 0); } else { for (level = 0; level < arg[argidx].numdim; level++) { assert(level < sDIMEN_MAX); append_constval(&arrayszlst, arg[argidx].name, arg[argidx].dim[level], level); } /* for */ } /* if */ } else if (arg[argidx].ident == iREFERENCE) { setheap(arg[argidx].defvalue.val); /* address of the value on the heap in PRI */ heapalloc++; } else { int dummytag = arg[argidx].tags[0]; const1(arg[argidx].defvalue.val); assert(arg[argidx].numtags > 0); check_userop(NULL, arg[argidx].defvalue_tag, arg[argidx].tags[0], 2, NULL, &dummytag); assert(dummytag == arg[argidx].tags[0]); } /* if */ push1(); /* store the function argument on the stack */ endexpr(FALSE); /* mark the end of a sub-expression */ } else { error(202, argidx); /* argument count mismatch */ } /* if */ if (arglist[argidx] == ARG_UNHANDLED) nargs++; arglist[argidx] = ARG_DONE; } /* for */ /* now a second loop to catch the arguments with default values that are * the "sizeof" or "tagof" of other arguments */ for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS; argidx++) { constvalue *asz; cell array_sz; if (arglist[argidx] == ARG_DONE) continue; /* already seen and handled this argument */ stgmark((char)(sEXPRSTART + argidx)); /* mark beginning of new expression in stage */ assert(arg[argidx].ident == iVARIABLE); /* if "sizeof", must be single cell */ /* if unseen, must be "sizeof" or "tagof" */ assert((arg[argidx].hasdefault & uSIZEOF) != 0 || (arg[argidx].hasdefault & uTAGOF) != 0); if ((arg[argidx].hasdefault & uSIZEOF) != 0) { /* find the argument; if it isn't found, the argument's default value * was a "sizeof" of a non-array (a warning for this was already given * when declaring the function) */ asz = find_constval(&arrayszlst, arg[argidx].defvalue.size.symname, arg[argidx].defvalue.size.level); if (asz) { array_sz = asz->value; if (array_sz == 0) error(224, arg[argidx].name); /* indeterminate array size in "sizeof" expression */ } else { array_sz = 1; } /* if */ } else { symbol *sym; assert((arg[argidx].hasdefault & uTAGOF) != 0); sym = findloc(arg[argidx].defvalue.size.symname); if (!sym) sym = findglb(arg[argidx].defvalue.size.symname); array_sz = (sym) ? sym->tag : 0; exporttag(array_sz); } /* if */ const1(array_sz); push1(); /* store the function argument on the stack */ endexpr(FALSE); if (arglist[argidx] == ARG_UNHANDLED) nargs++; arglist[argidx] = ARG_DONE; } /* for */ stgmark(sENDREORDER); /* mark end of reversed evaluation */ pushval((cell) nargs * sizeof(cell)); ffcall(sym, nargs); if (sc_status != statSKIP) markusage(sym, uREAD); /* do not mark as "used" when this call itself is skipped */ if (sym->x.lib) sym->x.lib->value += 1; /* increment "usage count" of the library */ modheap(-heapalloc * sizeof(cell)); sideeffect = TRUE; /* assume functions carry out a side-effect */ delete_consttable(&arrayszlst); /* clear list of array sizes */ } /* dbltest * * Returns a non-zero value if lval1 an array and lval2 is not an array and * the operation is addition or subtraction. * * Returns the "shift" count (1 for 16-bit, 2 for 32-bit) to align a cell * to an array offset. */ static int dbltest(void (*oper) (), value * lval1, value * lval2) { if ((oper != ob_add) && (oper != ob_sub)) return 0; if (lval1->ident != iARRAY) return 0; if (lval2->ident == iARRAY) return 0; return sizeof(cell) / 2; /* 1 for 16-bit, 2 for 32-bit */ } /* commutative * * Test whether an operator is commutative, i.e. x oper y == y oper x. * Commutative operators are: + (addition) * * (multiplication) * == (equality) * != (inequality) * & (bitwise and) * ^ (bitwise xor) * | (bitwise or) * * If in an expression, code for the left operand has been generated and * the right operand is a constant and the operator is commutative, the * precautionary "push" of the primary register is scrapped and the constant * is read into the secondary register immediately. */ static int commutative(void (*oper) ()) { return oper == ob_add || oper == os_mult || oper == ob_eq || oper == ob_ne || oper == ob_and || oper == ob_xor || oper == ob_or; } /* constant * * Generates code to fetch a number, a literal character (which is returned * by lex() as a number as well) or a literal string (lex() stores the * strings in the literal queue). If the operand was a number, it is stored * in lval->constval. * * The function returns 1 if the token was a constant or a string, 0 * otherwise. */ static int constant(value * lval) { int tok, index, constant; cell val, item, cidx; char *st; symbol *sym; tok = lex(&val, &st); if (tok == tSYMBOL && (sym = findconst(st))) { lval->constval = sym->addr; const1(lval->constval); lval->ident = iCONSTEXPR; lval->tag = sym->tag; markusage(sym, uREAD); } else if (tok == tNUMBER) { lval->constval = val; const1(lval->constval); lval->ident = iCONSTEXPR; } else if (tok == tRATIONAL) { lval->constval = val; const1(lval->constval); lval->ident = iCONSTEXPR; lval->tag = sc_rationaltag; } else if (tok == tSTRING) { /* lex() stores starting index of string in the literal table in 'val' */ const1((val + glb_declared) * sizeof(cell)); lval->ident = iARRAY; /* pretend this is a global array */ lval->constval = val - litidx; /* constval == the negative value of the * size of the literal array; using a negative * value distinguishes between literal arrays * and literal strings (this was done for * array assignment). */ } else if (tok == '{') { int tag, lasttag = -1; val = litidx; do { /* cannot call constexpr() here, because "staging" is already turned * on at this point */ assert(staging); stgget(&index, &cidx); /* mark position in code generator */ expression(&constant, &item, &tag, FALSE); stgdel(index, cidx); /* scratch generated code */ if (constant == 0) error(8); /* must be constant expression */ if (lasttag < 0) lasttag = tag; else if (!matchtag(lasttag, tag, FALSE)) error(213); /* tagname mismatch */ stowlit(item); /* store expression result in literal table */ } while (matchtoken(',')); needtoken('}'); const1((val + glb_declared) * sizeof(cell)); lval->ident = iARRAY; /* pretend this is a global array */ lval->constval = litidx - val; /* constval == the size of the literal array */ } else { return FALSE; /* no, it cannot be interpreted as a constant */ } /* if */ return TRUE; /* yes, it was a constant value */ }