enlightenment
/
efl
4
5
Fork 9
Code Issues 8 Pull Requests 1 Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
20424 Commits
488 Branches
1 Tag
649 MiB
 
 
 
 
 
 
Tag: Branch: Tree: 4bc0210bd3
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '4bc0210bd3'
${ noResults }
efl/src/bin/embryo/embryo_cc_sc3.c

2438 lines
74 KiB
Raw Blame History

/* 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);