2439 lines
74 KiB
C
2439 lines
74 KiB
C
/* 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 <config.h>
|
|
#endif
|
|
|
|
#include <assert.h>
|
|
#include <stdio.h>
|
|
#include <limits.h> /* for PATH_MAX */
|
|
#include <string.h>
|
|
|
|
#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 idx;
|
|
cell cidx;
|
|
|
|
stgget(&idx, &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(idx, 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 <value>" */
|
|
} /* 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, idx;
|
|
cell cidx;
|
|
|
|
stgget(&idx, &cidx); /* mark position in code generator */
|
|
lvalue = (*hier) (lval);
|
|
if (lval->ident == iCONSTEXPR)
|
|
stgdel(idx, 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 idx;
|
|
cell cidx;
|
|
|
|
stgget(&idx, &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(idx, 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(idx, 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, idx, 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(&idx, &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(idx, 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, idx, 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(&idx, &cidx); /* mark position in code generator */
|
|
expression(&constant, &item, &tag, FALSE);
|
|
stgdel(idx, 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 */
|
|
}
|