1 /* Small compiler - Recursive descend expresion parser
3 * Copyright (c) ITB CompuPhase, 1997-2003
5 * This software is provided "as-is", without any express or implied warranty.
6 * In no event will the authors be held liable for any damages arising from
7 * the use of this software.
9 * Permission is granted to anyone to use this software for any purpose,
10 * including commercial applications, and to alter it and redistribute it
11 * freely, subject to the following restrictions:
13 * 1. The origin of this software must not be misrepresented; you must not
14 * claim that you wrote the original software. If you use this software in
15 * a product, an acknowledgment in the product documentation would be
16 * appreciated but is not required.
17 * 2. Altered source versions must be plainly marked as such, and must not be
18 * misrepresented as being the original software.
19 * 3. This notice may not be removed or altered from any source distribution.
25 * vim:ts=8:sw=3:sts=8:noexpandtab:cino=>5n-3f0^-2{2
34 #include <stdlib.h> /* for _MAX_PATH */
37 #include "embryo_cc_sc.h"
39 static int skim(int *opstr, void (*testfunc) (int), int dropval,
40 int endval, int (*hier) (value *), value * lval);
41 static void dropout(int lvalue, void (*testfunc) (int val), int exit1,
43 static int plnge(int *opstr, int opoff, int (*hier) (value * lval),
44 value * lval, char *forcetag, int chkbitwise);
45 static int plnge1(int (*hier) (value * lval), value * lval);
46 static void plnge2(void (*oper) (void),
47 int (*hier) (value * lval),
48 value * lval1, value * lval2);
49 static cell calc(cell left, void (*oper) (), cell right,
51 static int hier13(value * lval);
52 static int hier12(value * lval);
53 static int hier11(value * lval);
54 static int hier10(value * lval);
55 static int hier9(value * lval);
56 static int hier8(value * lval);
57 static int hier7(value * lval);
58 static int hier6(value * lval);
59 static int hier5(value * lval);
60 static int hier4(value * lval);
61 static int hier3(value * lval);
62 static int hier2(value * lval);
63 static int hier1(value * lval1);
64 static int primary(value * lval);
65 static void clear_value(value * lval);
66 static void callfunction(symbol * sym);
67 static int dbltest(void (*oper) (), value * lval1, value * lval2);
68 static int commutative(void (*oper) ());
69 static int constant(value * lval);
71 static char lastsymbol[sNAMEMAX + 1]; /* name of last function/variable */
72 static int bitwise_opercount; /* count of bitwise operators in an expression */
74 /* Function addresses of binary operators for signed operations */
75 static void (*op1[17]) (void) =
77 os_mult, os_div, os_mod, /* hier3, index 0 */
78 ob_add, ob_sub, /* hier4, index 3 */
79 ob_sal, os_sar, ou_sar, /* hier5, index 5 */
80 ob_and, /* hier6, index 8 */
81 ob_xor, /* hier7, index 9 */
82 ob_or, /* hier8, index 10 */
83 os_le, os_ge, os_lt, os_gt, /* hier9, index 11 */
84 ob_eq, ob_ne, /* hier10, index 15 */
86 /* These two functions are defined because the functions inc() and dec() in
87 * SC4.C have a different prototype than the other code generation functions.
88 * The arrays for user-defined functions use the function pointers for
89 * identifying what kind of operation is requested; these functions must all
90 * have the same prototype. As inc() and dec() are special cases already, it
91 * is simplest to add two "do-nothing" functions.
103 * Searches for a binary operator a list of operators. The list is stored in
104 * the array "list". The last entry in the list should be set to 0.
106 * The index of an operator in "list" (if found) is returned in "opidx". If
107 * no operator is found, nextop() returns 0.
110 nextop(int *opidx, int *list)
115 if (matchtoken(*list))
117 return TRUE; /* found! */
125 return FALSE; /* entire list scanned, nothing found */
129 check_userop(void (*oper) (void), int tag1, int tag2, int numparam,
130 value * lval, int *resulttag)
132 static char *binoperstr[] = { "*", "/", "%", "+", "-", "", "", "",
133 "", "", "", "<=", ">=", "<", ">", "==", "!="
135 static int binoper_savepri[] =
136 { FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
137 FALSE, FALSE, FALSE, FALSE, FALSE,
138 TRUE, TRUE, TRUE, TRUE, FALSE, FALSE
140 static char *unoperstr[] = { "!", "-", "++", "--" };
141 static void (*unopers[]) (void) =
143 lneg, neg, user_inc, user_dec};
144 char opername[4] = "", symbolname[sNAMEMAX + 1];
145 int i, swapparams, savepri, savealt;
149 /* since user-defined operators on untagged operands are forbidden, we have
152 assert(numparam == 1 || numparam == 2);
153 if (tag1 == 0 && (numparam == 1 || tag2 == 0))
156 savepri = savealt = FALSE;
157 /* find the name with the operator */
162 /* assignment operator: a special case */
163 strcpy(opername, "=");
165 && (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR))
170 assert((sizeof binoperstr / sizeof binoperstr[0]) ==
171 (sizeof op1 / sizeof op1[0]));
172 for (i = 0; i < sizeof op1 / sizeof op1[0]; i++)
176 strcpy(opername, binoperstr[i]);
177 savepri = binoper_savepri[i];
185 assert(oper != NULL);
186 assert(numparam == 1);
187 /* try a select group of unary operators */
188 assert((sizeof unoperstr / sizeof unoperstr[0]) ==
189 (sizeof unopers / sizeof unopers[0]));
190 if (opername[0] == '\0')
192 for (i = 0; i < sizeof unopers / sizeof unopers[0]; i++)
194 if (oper == unopers[i])
196 strcpy(opername, unoperstr[i]);
202 /* if not found, quit */
203 if (opername[0] == '\0')
206 /* create a symbol name from the tags and the operator name */
207 assert(numparam == 1 || numparam == 2);
208 operator_symname(symbolname, opername, tag1, tag2, numparam, tag2);
210 sym = findglb(symbolname);
211 if (sym == NULL /*|| (sym->usage & uDEFINE)==0 */ )
212 { /* ??? should not check uDEFINE; first pass clears these bits */
213 /* check for commutative operators */
214 if (tag1 == tag2 || oper == NULL || !commutative(oper))
215 return FALSE; /* not commutative, cannot swap operands */
216 /* if arrived here, the operator is commutative and the tags are different,
217 * swap tags and try again
219 assert(numparam == 2); /* commutative operator must be a binary operator */
220 operator_symname(symbolname, opername, tag2, tag1, numparam, tag1);
222 sym = findglb(symbolname);
223 if (sym == NULL /*|| (sym->usage & uDEFINE)==0 */ )
227 /* check existance and the proper declaration of this function */
228 if ((sym->usage & uMISSING) != 0 || (sym->usage & uPROTOTYPED) == 0)
230 char symname[2 * sNAMEMAX + 16]; /* allow space for user defined operators */
232 funcdisplayname(symname, sym->name);
233 if ((sym->usage & uMISSING) != 0)
234 error(4, symname); /* function not defined */
235 if ((sym->usage & uPROTOTYPED) == 0)
236 error(71, symname); /* operator must be declared before use */
239 /* we don't want to use the redefined operator in the function that
240 * redefines the operator itself, otherwise the snippet below gives
241 * an unexpected recursion:
242 * fixed:operator+(fixed:a, fixed:b)
248 /* for increment and decrement operators, the symbol must first be loaded
249 * (and stored back afterwards)
251 if (oper == user_inc || oper == user_dec)
254 assert(lval != NULL);
255 if (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR)
256 push1(); /* save current address in PRI */
257 rvalue(lval); /* get the symbol's value in PRI */
260 assert(!savepri || !savealt); /* either one MAY be set, but not both */
263 /* the chained comparison operators require that the ALT register is
264 * unmodified, so we save it here; actually, we save PRI because the normal
265 * instruction sequence (without user operator) swaps PRI and ALT
267 push1(); /* right-hand operand is in PRI */
271 /* for the assignment operator, ALT may contain an address at which the
272 * result must be stored; this address must be preserved accross the
275 assert(lval != NULL); /* this was checked earlier */
276 assert(lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR); /* checked earlier */
280 /* push parameters, call the function */
281 paramspassed = (oper == NULL) ? 1 : numparam;
282 switch (paramspassed)
288 /* note that 1) a function expects that the parameters are pushed
289 * in reversed order, and 2) the left operand is in the secondary register
290 * and the right operand is in the primary register */
305 endexpr(FALSE); /* mark the end of a sub-expression */
306 pushval((cell) paramspassed * sizeof(cell));
307 assert(sym->ident == iFUNCTN);
308 ffcall(sym, paramspassed);
309 if (sc_status != statSKIP)
310 markusage(sym, uREAD); /* do not mark as "used" when this call itself is skipped */
311 if (sym->x.lib != NULL)
312 sym->x.lib->value += 1; /* increment "usage count" of the library */
313 sideeffect = TRUE; /* assume functions carry out a side-effect */
314 assert(resulttag != NULL);
315 *resulttag = sym->tag; /* save tag of the called function */
317 if (savepri || savealt)
318 pop2(); /* restore the saved PRI/ALT that into ALT */
319 if (oper == user_inc || oper == user_dec)
321 assert(lval != NULL);
322 if (lval->ident == iARRAYCELL || lval->ident == iARRAYCHAR)
323 pop2(); /* restore address (in ALT) */
324 store(lval); /* store PRI in the symbol */
325 moveto1(); /* make sure PRI is restored on exit */
331 matchtag(int formaltag, int actualtag, int allowcoerce)
333 if (formaltag != actualtag)
335 /* if the formal tag is zero and the actual tag is not "fixed", the actual
336 * tag is "coerced" to zero
338 if (!allowcoerce || formaltag != 0 || (actualtag & FIXEDTAG) != 0)
345 * The AMX pseudo-processor has no direct support for logical (boolean)
346 * operations. These have to be done via comparing and jumping. Since we are
347 * already jumping through the code, we might as well implement an "early
348 * drop-out" evaluation (also called "short-circuit"). This conforms to
351 * expr1 || expr2 expr2 will only be evaluated if expr1 is false.
352 * expr1 && expr2 expr2 will only be evaluated if expr1 is true.
354 * expr1 || expr2 && expr3 expr2 will only be evaluated if expr1 is false
355 * and expr3 will only be evaluated if expr1 is
356 * false and expr2 is true.
358 * Code generation for the last example proceeds thus:
362 * jump to "l1" if result of expr1 not equal to 0
364 * -> operator && found; skip to higher level in hierarchy diagram
365 * jump to "l2" if result of expr2 equal to 0
367 * jump to "l2" if result of expr3 equal to 0
368 * set expression result to 1 (true)
370 * l2: set expression result to 0 (false)
372 * <- drop back to previous hierarchy level
373 * jump to "l1" if result of expr2 && expr3 not equal to 0
374 * set expression result to 0 (false)
376 * l1: set expression result to 1 (true)
381 /* Skim over terms adjoining || and && operators
382 * dropval The value of the expression after "dropping out". An "or" drops
383 * out when the left hand is TRUE, so dropval must be 1 on "or"
385 * endval The value of the expression when no expression drops out. In an
386 * "or" expression, this happens when both the left hand and the
387 * right hand are FALSE, so endval must be 0 for "or" expressions.
390 skim(int *opstr, void (*testfunc) (int), int dropval, int endval,
391 int (*hier) (value *), value * lval)
393 int lvalue, hits, droplab, endlab, opidx;
399 stgget(&index, &cidx); /* mark position in code generator */
400 hits = FALSE; /* no logical operators "hit" yet */
401 allconst = TRUE; /* assume all values "const" */
403 droplab = 0; /* to avoid a compiler warning */
406 lvalue = plnge1(hier, lval); /* evaluate left expression */
408 allconst = allconst && (lval->ident == iCONSTEXPR);
413 /* one operator was already found */
414 if (testfunc == jmp_ne0)
415 lval->constval = lval->constval || constval;
417 lval->constval = lval->constval && constval;
419 constval = lval->constval; /* save result accumulated so far */
422 if (nextop(&opidx, opstr))
426 /* this is the first operator in the list */
428 droplab = getlabel();
430 dropout(lvalue, testfunc, droplab, lval);
433 { /* no (more) identical operators */
434 dropout(lvalue, testfunc, droplab, lval); /* found at least one operator! */
436 jumplabel(endlab = getlabel());
444 lval->ident = iCONSTEXPR;
445 lval->constval = constval;
446 stgdel(index, cidx); /* scratch generated code and calculate */
450 lval->ident = iEXPRESSION;
457 return lvalue; /* none of the operators in "opstr" were found */
464 * Reads into the primary register the variable pointed to by lval if
465 * plunging through the hierarchy levels detected an lvalue. Otherwise
466 * if a constant was detected, it is loaded. If there is no constant and
467 * no lvalue, the primary register must already contain the expression
470 * After that, the compare routines "jmp_ne0" or "jmp_eq0" are called, which
471 * compare the primary register against 0, and jump to the "early drop-out"
472 * label "exit1" if the condition is true.
475 dropout(int lvalue, void (*testfunc) (int val), int exit1, value * lval)
479 else if (lval->ident == iCONSTEXPR)
480 const1(lval->constval);
485 checkfunction(value * lval)
487 symbol *sym = lval->sym;
489 if (sym == NULL || (sym->ident != iFUNCTN && sym->ident != iREFFUNC))
490 return; /* no known symbol, or not a function result */
492 if ((sym->usage & uDEFINE) != 0)
494 /* function is defined, can now check the return value (but make an
495 * exception for directly recursive functions)
497 if (sym != curfunc && (sym->usage & uRETVALUE) == 0)
499 char symname[2 * sNAMEMAX + 16]; /* allow space for user defined operators */
501 funcdisplayname(symname, sym->name);
502 error(209, symname); /* function should return a value */
507 /* function not yet defined, set */
508 sym->usage |= uRETVALUE; /* make sure that a future implementation of
509 * the function uses "return <value>" */
514 * Plunge to a lower level
517 plnge(int *opstr, int opoff, int (*hier) (value * lval), value * lval,
518 char *forcetag, int chkbitwise)
522 value lval2 = { NULL, 0, 0, 0, 0, NULL };
524 lvalue = plnge1(hier, lval);
525 if (nextop(&opidx, opstr) == 0)
526 return lvalue; /* no operator in "opstr" found */
532 if (chkbitwise && count++ > 0 && bitwise_opercount != 0)
534 opidx += opoff; /* add offset to index returned by nextop() */
535 plnge2(op1[opidx], hier, lval, &lval2);
536 if (op1[opidx] == ob_and || op1[opidx] == ob_or)
538 if (forcetag != NULL)
539 lval->tag = sc_addtag(forcetag);
541 while (nextop(&opidx, opstr)); /* do */
542 return FALSE; /* result of expression is not an lvalue */
547 * Binary plunge to lower level; this is very simular to plnge, but
548 * it has special code generation sequences for chained operations.
551 plnge_rel(int *opstr, int opoff, int (*hier) (value * lval), value * lval)
554 value lval2 = { NULL, 0, 0, 0, 0, NULL };
557 /* this function should only be called for relational operators */
558 assert(op1[opoff] == os_le);
559 lvalue = plnge1(hier, lval);
560 if (nextop(&opidx, opstr) == 0)
561 return lvalue; /* no operator in "opstr" found */
565 lval->boolresult = TRUE;
568 /* same check as in plnge(), but "chkbitwise" is always TRUE */
569 if (count > 0 && bitwise_opercount != 0)
574 *lval = lval2; /* copy right hand expression of the previous iteration */
577 plnge2(op1[opidx], hier, lval, &lval2);
581 while (nextop(&opidx, opstr)); /* enddo */
582 lval->constval = lval->boolresult;
583 lval->tag = sc_addtag("bool"); /* force tag to be "bool" */
584 return FALSE; /* result of expression is not an lvalue */
589 * Unary plunge to lower level
590 * Called by: skim(), plnge(), plnge2(), plnge_rel(), hier14() and hier13()
593 plnge1(int (*hier) (value * lval), value * lval)
598 stgget(&index, &cidx); /* mark position in code generator */
599 lvalue = (*hier) (lval);
600 if (lval->ident == iCONSTEXPR)
601 stgdel(index, cidx); /* load constant later */
607 * Binary plunge to lower level
608 * Called by: plnge(), plnge_rel(), hier14() and hier1()
611 plnge2(void (*oper) (void),
612 int (*hier) (value * lval), value * lval1, value * lval2)
617 stgget(&index, &cidx); /* mark position in code generator */
618 if (lval1->ident == iCONSTEXPR)
619 { /* constant on left side; it is not yet loaded */
620 if (plnge1(hier, lval2))
621 rvalue(lval2); /* load lvalue now */
622 else if (lval2->ident == iCONSTEXPR)
623 const1(lval2->constval << dbltest(oper, lval2, lval1));
624 const2(lval1->constval << dbltest(oper, lval2, lval1));
625 /* ^ doubling of constants operating on integer addresses */
626 /* is restricted to "add" and "subtract" operators */
629 { /* non-constant on left side */
631 if (plnge1(hier, lval2))
633 if (lval2->ident == iCONSTEXPR)
634 { /* constant on right side */
635 if (commutative(oper))
636 { /* test for commutative operators */
637 value lvaltmp = { NULL, 0, 0, 0, 0, NULL };
638 stgdel(index, cidx); /* scratch push1() and constant fetch (then
639 * fetch the constant again */
640 const2(lval2->constval << dbltest(oper, lval1, lval2));
641 /* now, the primary register has the left operand and the secondary
642 * register the right operand; swap the "lval" variables so that lval1
643 * is associated with the secondary register and lval2 with the
644 * primary register, as is the "normal" case.
652 const1(lval2->constval << dbltest(oper, lval1, lval2));
653 pop2(); /* pop result of left operand into secondary register */
657 { /* non-constants on both sides */
659 if (dbltest(oper, lval1, lval2))
660 cell2addr(); /* double primary register */
661 if (dbltest(oper, lval2, lval1))
662 cell2addr_alt(); /* double secondary register */
667 /* If used in an expression, a function should return a value.
668 * If the function has been defined, we can check this. If the
669 * function was not defined, we can set this requirement (so that
670 * a future function definition can check this bit.
672 checkfunction(lval1);
673 checkfunction(lval2);
674 if (lval1->ident == iARRAY || lval1->ident == iREFARRAY)
677 (lval1->sym != NULL) ? lval1->sym->name : "-unknown-";
678 error(33, ptr); /* array must be indexed */
680 else if (lval2->ident == iARRAY || lval2->ident == iREFARRAY)
683 (lval2->sym != NULL) ? lval2->sym->name : "-unknown-";
684 error(33, ptr); /* array must be indexed */
686 /* ??? ^^^ should do same kind of error checking with functions */
688 /* check whether an "operator" function is defined for the tag names
689 * (a constant expression cannot be optimized in that case)
691 if (check_userop(oper, lval1->tag, lval2->tag, 2, NULL, &lval1->tag))
693 lval1->ident = iEXPRESSION;
696 else if (lval1->ident == iCONSTEXPR && lval2->ident == iCONSTEXPR)
698 /* only constant expression if both constant */
699 stgdel(index, cidx); /* scratch generated code and calculate */
700 if (!matchtag(lval1->tag, lval2->tag, FALSE))
701 error(213); /* tagname mismatch */
703 calc(lval1->constval, oper, lval2->constval,
708 if (!matchtag(lval1->tag, lval2->tag, FALSE))
709 error(213); /* tagname mismatch */
710 (*oper) (); /* do the (signed) operation */
711 lval1->ident = iEXPRESSION;
717 truemodulus(cell a, cell b)
719 return (a % b + b) % b;
723 calc(cell left, void (*oper) (), cell right, char *boolresult)
726 return (left | right);
727 else if (oper == ob_xor)
728 return (left ^ right);
729 else if (oper == ob_and)
730 return (left & right);
731 else if (oper == ob_eq)
732 return (left == right);
733 else if (oper == ob_ne)
734 return (left != right);
735 else if (oper == os_le)
736 return *boolresult &= (char)(left <= right), right;
737 else if (oper == os_ge)
738 return *boolresult &= (char)(left >= right), right;
739 else if (oper == os_lt)
740 return *boolresult &= (char)(left < right), right;
741 else if (oper == os_gt)
742 return *boolresult &= (char)(left > right), right;
743 else if (oper == os_sar)
744 return (left >> (int)right);
745 else if (oper == ou_sar)
746 return ((ucell) left >> (ucell) right);
747 else if (oper == ob_sal)
748 return ((ucell) left << (int)right);
749 else if (oper == ob_add)
750 return (left + right);
751 else if (oper == ob_sub)
752 return (left - right);
753 else if (oper == os_mult)
754 return (left * right);
755 else if (oper == os_div)
756 return (left - truemodulus(left, right)) / right;
757 else if (oper == os_mod)
758 return truemodulus(left, right);
760 error(29); /* invalid expression, assumed 0 (this should never occur) */
765 expression(int *constant, cell * val, int *tag, int chkfuncresult)
767 value lval = { NULL, 0, 0, 0, 0, NULL };
771 if (lval.ident == iCONSTEXPR)
772 { /* constant expression */
774 *val = lval.constval;
784 checkfunction(&lval);
789 array_totalsize(symbol * sym)
794 assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
795 length = sym->dim.array.length;
796 if (sym->dim.array.level > 0)
798 cell sublength = array_totalsize(finddepend(sym));
801 length = length + length * sublength;
809 array_levelsize(symbol * sym, int level)
812 assert(sym->ident == iARRAY || sym->ident == iREFARRAY);
813 assert(level <= sym->dim.array.level);
816 sym = finddepend(sym);
819 return sym->dim.array.length;
824 * Lowest hierarchy level (except for the , operator).
826 * Global references: intest (reffered to only)
829 hier14(value * lval1)
832 value lval2 = { NULL, 0, 0, 0, 0, NULL };
833 value lval3 = { NULL, 0, 0, 0, 0, NULL };
839 cell arrayidx1[sDIMEN_MAX], arrayidx2[sDIMEN_MAX]; /* last used array indices */
842 bwcount = bitwise_opercount;
843 bitwise_opercount = 0;
844 for (i = 0; i < sDIMEN_MAX; i++)
845 arrayidx1[i] = arrayidx2[i] = 0;
846 org_arrayidx = lval1->arrayidx; /* save current pointer, to reset later */
847 if (lval1->arrayidx == NULL)
848 lval1->arrayidx = arrayidx1;
849 lvalue = plnge1(hier13, lval1);
850 if (lval1->ident != iARRAYCELL && lval1->ident != iARRAYCHAR)
851 lval1->arrayidx = NULL;
852 if (lval1->ident == iCONSTEXPR) /* load constant here */
853 const1(lval1->constval);
854 tok = lex(&val, &st);
890 case '=': /* simple assignment */
893 error(211); /* possibly unintended assignment */
897 bitwise_opercount = bwcount;
898 lval1->arrayidx = org_arrayidx; /* restore array index pointer */
902 /* if we get here, it was an assignment; first check a few special cases
903 * and then the general */
904 if (lval1->ident == iARRAYCHAR)
906 /* special case, assignment to packed character in a cell is permitted */
909 else if (lval1->ident == iARRAY || lval1->ident == iREFARRAY)
911 /* array assignment is permitted too (with restrictions) */
913 return error(23); /* array assignment must be simple assigment */
914 assert(lval1->sym != NULL);
915 if (array_totalsize(lval1->sym) == 0)
916 return error(46, lval1->sym->name); /* unknown array size */
920 /* operand on left side of assignment must be lvalue */
922 return error(22); /* must be lvalue */
923 /* may not change "constant" parameters */
924 assert(lval1->sym != NULL);
925 if ((lval1->sym->usage & uCONST) != 0)
926 return error(22); /* assignment to const argument */
927 lval3 = *lval1; /* save symbol to enable storage of expresion result */
928 lval1->arrayidx = org_arrayidx; /* restore array index pointer */
929 if (lval1->ident == iARRAYCELL || lval1->ident == iARRAYCHAR
930 || lval1->ident == iARRAY || lval1->ident == iREFARRAY)
932 /* if indirect fetch: save PRI (cell address) */
938 lval2.arrayidx = arrayidx2;
939 plnge2(oper, hier14, lval1, &lval2);
940 if (lval2.ident != iARRAYCELL && lval2.ident != iARRAYCHAR)
941 lval2.arrayidx = NULL;
944 if (!oper && lval3.arrayidx != NULL && lval2.arrayidx != NULL
945 && lval3.ident == lval2.ident && lval3.sym == lval2.sym)
949 assert(lval3.arrayidx == arrayidx1);
950 assert(lval2.arrayidx == arrayidx2);
951 for (i = 0; i < sDIMEN_MAX; i++)
952 same = same && (lval3.arrayidx[i] == lval2.arrayidx[i]);
954 error(226, lval3.sym->name); /* self-assignment */
962 plnge2(oper, hier14, lval1, &lval2);
966 /* if direct fetch and simple assignment: no "push"
967 * and "pop" needed -> call hier14() directly, */
969 rvalue(&lval2); /* instead of plnge2(). */
970 checkfunction(&lval2);
971 /* check whether lval2 and lval3 (old lval1) refer to the same variable */
972 if (lval2.ident == iVARIABLE && lval3.ident == lval2.ident
973 && lval3.sym == lval2.sym)
975 assert(lval3.sym != NULL);
976 error(226, lval3.sym->name); /* self-assignment */
980 if (lval3.ident == iARRAY || lval3.ident == iREFARRAY)
982 /* left operand is an array, right operand should be an array variable
983 * of the same size and the same dimension, an array literal (of the
984 * same size) or a literal string.
986 int exactmatch = TRUE;
988 if (lval2.ident != iARRAY && lval2.ident != iREFARRAY)
989 error(33, lval3.sym->name); /* array must be indexed */
990 if (lval2.sym != NULL)
992 val = lval2.sym->dim.array.length; /* array variable */
993 level = lval2.sym->dim.array.level;
997 val = lval2.constval; /* literal array */
999 /* If val is negative, it means that lval2 is a
1000 * literal string. The string array size may be
1001 * smaller than the destination array.
1009 if (lval3.sym->dim.array.level != level)
1010 return error(48); /* array dimensions must match */
1011 else if (lval3.sym->dim.array.length < val
1012 || (exactmatch && lval3.sym->dim.array.length > val))
1013 return error(47); /* array sizes must match */
1016 /* check the sizes of all sublevels too */
1017 symbol *sym1 = lval3.sym;
1018 symbol *sym2 = lval2.sym;
1021 assert(sym1 != NULL && sym2 != NULL);
1022 /* ^^^ sym2 must be valid, because only variables can be
1023 * multi-dimensional (there are no multi-dimensional arrays),
1024 * sym1 must be valid because it must be an lvalue
1027 for (i = 0; i < level; i++)
1029 sym1 = finddepend(sym1);
1030 sym2 = finddepend(sym2);
1031 assert(sym1 != NULL && sym2 != NULL);
1032 /* ^^^ both arrays have the same dimensions (this was checked
1033 * earlier) so the dependend should always be found
1035 if (sym1->dim.array.length != sym2->dim.array.length)
1036 error(47); /* array sizes must match */
1038 /* get the total size in cells of the multi-dimensional array */
1039 val = array_totalsize(lval3.sym);
1040 assert(val > 0); /* already checked */
1045 /* left operand is not an array, right operand should then not be either */
1046 if (lval2.ident == iARRAY || lval2.ident == iREFARRAY)
1047 error(6); /* must be assigned to an array */
1049 if (lval3.ident == iARRAY || lval3.ident == iREFARRAY)
1051 memcopy(val * sizeof(cell));
1055 check_userop(NULL, lval2.tag, lval3.tag, 2, &lval3, &lval2.tag);
1056 store(&lval3); /* now, store the expression result */
1058 if (!oper && !matchtag(lval3.tag, lval2.tag, TRUE))
1059 error(213); /* tagname mismatch (if "oper", warning already given in plunge2()) */
1061 markusage(lval3.sym, uWRITTEN);
1063 bitwise_opercount = bwcount;
1064 return FALSE; /* expression result is never an lvalue */
1068 hier13(value * lval)
1070 int lvalue, flab1, flab2;
1071 value lval2 = { NULL, 0, 0, 0, 0, NULL };
1074 lvalue = plnge1(hier12, lval);
1075 if (matchtoken('?'))
1083 else if (lval->ident == iCONSTEXPR)
1085 const1(lval->constval);
1086 error(lval->constval ? 206 : 205); /* redundant test */
1088 jmp_eq0(flab1); /* go to second expression if primary register==0 */
1096 array1 = (lval->ident == iARRAY || lval->ident == iREFARRAY);
1097 array2 = (lval2.ident == iARRAY || lval2.ident == iREFARRAY);
1098 if (array1 && !array2)
1101 (lval->sym->name != NULL) ? lval->sym->name : "-unknown-";
1102 error(33, ptr); /* array must be indexed */
1104 else if (!array1 && array2)
1107 (lval2.sym->name != NULL) ? lval2.sym->name : "-unknown-";
1108 error(33, ptr); /* array must be indexed */
1110 /* ??? if both are arrays, should check dimensions */
1111 if (!matchtag(lval->tag, lval2.tag, FALSE))
1112 error(213); /* tagname mismatch ('true' and 'false' expressions) */
1114 if (lval->ident == iARRAY)
1115 lval->ident = iREFARRAY; /* iARRAY becomes iREFARRAY */
1116 else if (lval->ident != iREFARRAY)
1117 lval->ident = iEXPRESSION; /* iREFARRAY stays iREFARRAY, rest becomes iEXPRESSION */
1118 return FALSE; /* conditional expression is no lvalue */
1126 /* the order of the operators in these lists is important and must cohere */
1127 /* with the order of the operators in the array "op1" */
1128 static int list3[] = { '*', '/', '%', 0 };
1129 static int list4[] = { '+', '-', 0 };
1130 static int list5[] = { tSHL, tSHR, tSHRU, 0 };
1131 static int list6[] = { '&', 0 };
1132 static int list7[] = { '^', 0 };
1133 static int list8[] = { '|', 0 };
1134 static int list9[] = { tlLE, tlGE, '<', '>', 0 };
1135 static int list10[] = { tlEQ, tlNE, 0 };
1136 static int list11[] = { tlAND, 0 };
1137 static int list12[] = { tlOR, 0 };
1140 hier12(value * lval)
1142 return skim(list12, jmp_ne0, 1, 0, hier11, lval);
1146 hier11(value * lval)
1148 return skim(list11, jmp_eq0, 0, 1, hier10, lval);
1152 hier10(value * lval)
1154 return plnge(list10, 15, hier9, lval, "bool", TRUE);
1155 } /* ^ this variable is the starting index in the op1[]
1156 * array of the operators of this hierarchy level */
1160 { /* <=, >=, <, > */
1161 return plnge_rel(list9, 11, hier8, lval);
1167 return plnge(list8, 10, hier7, lval, NULL, FALSE);
1173 return plnge(list7, 9, hier6, lval, NULL, FALSE);
1179 return plnge(list6, 8, hier5, lval, NULL, FALSE);
1185 return plnge(list5, 5, hier4, lval, NULL, FALSE);
1191 return plnge(list4, 3, hier3, lval, NULL, FALSE);
1197 return plnge(list3, 0, hier2, lval, NULL, FALSE);
1204 int tag, paranthese;
1210 tok = lex(&val, &st);
1213 case tINC: /* ++lval */
1215 return error(22); /* must be lvalue */
1216 assert(lval->sym != NULL);
1217 if ((lval->sym->usage & uCONST) != 0)
1218 return error(22); /* assignment to const argument */
1219 if (!check_userop(user_inc, lval->tag, 0, 1, lval, &lval->tag))
1220 inc(lval); /* increase variable first */
1221 rvalue(lval); /* and read the result into PRI */
1223 return FALSE; /* result is no longer lvalue */
1224 case tDEC: /* --lval */
1226 return error(22); /* must be lvalue */
1227 assert(lval->sym != NULL);
1228 if ((lval->sym->usage & uCONST) != 0)
1229 return error(22); /* assignment to const argument */
1230 if (!check_userop(user_dec, lval->tag, 0, 1, lval, &lval->tag))
1231 dec(lval); /* decrease variable first */
1232 rvalue(lval); /* and read the result into PRI */
1234 return FALSE; /* result is no longer lvalue */
1235 case '~': /* ~ (one's complement) */
1238 invert(); /* bitwise NOT */
1239 lval->constval = ~lval->constval;
1241 case '!': /* ! (logical negate) */
1244 if (check_userop(lneg, lval->tag, 0, 1, NULL, &lval->tag))
1246 lval->ident = iEXPRESSION;
1251 lneg(); /* 0 -> 1, !0 -> 0 */
1252 lval->constval = !lval->constval;
1253 lval->tag = sc_addtag("bool");
1256 case '-': /* unary - (two's complement) */
1259 /* make a special check for a constant expression with the tag of a
1260 * rational number, so that we can simple swap the sign of that constant.
1262 if (lval->ident == iCONSTEXPR && lval->tag == sc_rationaltag
1263 && sc_rationaltag != 0)
1265 if (rational_digits == 0)
1267 float *f = (float *)&lval->constval;
1269 *f = -*f; /* this modifies lval->constval */
1273 /* the negation of a fixed point number is just an integer negation */
1274 lval->constval = -lval->constval;
1277 else if (check_userop(neg, lval->tag, 0, 1, NULL, &lval->tag))
1279 lval->ident = iEXPRESSION;
1284 neg(); /* arithmic negation */
1285 lval->constval = -lval->constval;
1288 case tLABEL: /* tagname override */
1289 tag = sc_addtag(st);
1290 lvalue = hier2(lval);
1295 while (matchtoken('('))
1297 tok = lex(&val, &st);
1299 return error(20, st); /* illegal symbol name */
1303 if (sym != NULL && sym->ident != iFUNCTN && sym->ident != iREFFUNC
1304 && (sym->usage & uDEFINE) == 0)
1305 sym = NULL; /* symbol is not a function, it is in the table, but not "defined" */
1306 val = (sym != NULL);
1307 if (!val && find_subst(st, strlen(st)) != NULL)
1310 lval->ident = iCONSTEXPR;
1311 lval->constval = val;
1312 const1(lval->constval);
1313 while (paranthese--)
1318 while (matchtoken('('))
1320 tok = lex(&val, &st);
1322 return error(20, st); /* illegal symbol name */
1327 return error(17, st); /* undefined symbol */
1328 if (sym->ident == iCONSTEXPR)
1329 error(39); /* constant symbol has no size */
1330 else if (sym->ident == iFUNCTN || sym->ident == iREFFUNC)
1331 error(72); /* "function" symbol has no size */
1332 else if ((sym->usage & uDEFINE) == 0)
1333 return error(17, st); /* undefined symbol (symbol is in the table, but it is "used" only) */
1335 lval->ident = iCONSTEXPR;
1336 lval->constval = 1; /* preset */
1337 if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1341 for (level = 0; matchtoken('['); level++)
1343 if (level > sym->dim.array.level)
1344 error(28); /* invalid subscript */
1346 lval->constval = array_levelsize(sym, level);
1347 if (lval->constval == 0 && strchr(lptr, PREPROC_TERM) == NULL)
1348 error(224, st); /* indeterminate array size in "sizeof" expression */
1350 const1(lval->constval);
1351 while (paranthese--)
1356 while (matchtoken('('))
1358 tok = lex(&val, &st);
1359 if (tok != tSYMBOL && tok != tLABEL)
1360 return error(20, st); /* illegal symbol name */
1363 tag = sc_addtag(st);
1371 return error(17, st); /* undefined symbol */
1372 if ((sym->usage & uDEFINE) == 0)
1373 return error(17, st); /* undefined symbol (symbol is in the table, but it is "used" only) */
1378 lval->ident = iCONSTEXPR;
1379 lval->constval = tag;
1380 const1(lval->constval);
1381 while (paranthese--)
1386 lvalue = hier1(lval);
1387 /* check for postfix operators */
1388 if (matchtoken(';'))
1390 /* Found a ';', do not look further for postfix operators */
1391 lexpush(); /* push ';' back after successful match */
1394 else if (matchtoken(tTERM))
1396 /* Found a newline that ends a statement (this is the case when
1397 * semicolons are optional). Note that an explicit semicolon was
1398 * handled above. This case is similar, except that the token must
1399 * not be pushed back.
1405 tok = lex(&val, &st);
1408 case tINC: /* lval++ */
1410 return error(22); /* must be lvalue */
1411 assert(lval->sym != NULL);
1412 if ((lval->sym->usage & uCONST) != 0)
1413 return error(22); /* assignment to const argument */
1414 /* on incrementing array cells, the address in PRI must be saved for
1415 * incremening the value, whereas the current value must be in PRI
1418 saveresult = (lval->ident == iARRAYCELL
1419 || lval->ident == iARRAYCHAR);
1421 push1(); /* save address in PRI */
1422 rvalue(lval); /* read current value into PRI */
1424 swap1(); /* save PRI on the stack, restore address in PRI */
1426 (user_inc, lval->tag, 0, 1, lval, &lval->tag))
1427 inc(lval); /* increase variable afterwards */
1429 pop1(); /* restore PRI (result of rvalue()) */
1431 return FALSE; /* result is no longer lvalue */
1432 case tDEC: /* lval-- */
1434 return error(22); /* must be lvalue */
1435 assert(lval->sym != NULL);
1436 if ((lval->sym->usage & uCONST) != 0)
1437 return error(22); /* assignment to const argument */
1438 saveresult = (lval->ident == iARRAYCELL
1439 || lval->ident == iARRAYCHAR);
1441 push1(); /* save address in PRI */
1442 rvalue(lval); /* read current value into PRI */
1444 swap1(); /* save PRI on the stack, restore address in PRI */
1446 (user_dec, lval->tag, 0, 1, lval, &lval->tag))
1447 dec(lval); /* decrease variable afterwards */
1449 pop1(); /* restore PRI (result of rvalue()) */
1452 case tCHAR: /* char (compute required # of cells */
1453 if (lval->ident == iCONSTEXPR)
1455 lval->constval *= charbits / 8; /* from char to bytes */
1457 (lval->constval + sizeof(cell) - 1) / sizeof(cell);
1462 rvalue(lval); /* fetch value if not already in PRI */
1463 char2addr(); /* from characters to bytes */
1464 addconst(sizeof(cell) - 1); /* make sure the value is rounded up */
1465 addr2cell(); /* truncate to number of cells */
1478 * The highest hierarchy level: it looks for pointer and array indices
1479 * and function calls.
1480 * Generates code to fetch a pointer value if it is indexed and code to
1481 * add to the pointer value or the array address (the address is already
1482 * read at primary()). It also generates code to fetch a function address
1483 * if that hasn't already been done at primary() (check lval[4]) and calls
1484 * callfunction() to call the function.
1487 hier1(value * lval1)
1489 int lvalue, index, tok, symtok;
1491 value lval2 = { NULL, 0, 0, 0, 0, NULL };
1496 lvalue = primary(lval1);
1497 symtok = tokeninfo(&val, &st); /* get token read by primary() */
1500 if (matchtoken('[') || matchtoken('{') || matchtoken('('))
1502 tok = tokeninfo(&val, &st); /* get token read by matchtoken() */
1503 if (sym == NULL && symtok != tSYMBOL)
1505 /* we do not have a valid symbol and we appear not to have read a valid
1506 * symbol name (so it is unlikely that we would have read a name of an
1507 * undefined symbol) */
1508 error(29); /* expression error, assumed 0 */
1509 lexpush(); /* analyse '(', '{' or '[' again later */
1512 if (tok == '[' || tok == '{')
1514 close = (char)((tok == '[') ? ']' : '}');
1516 { /* sym==NULL if lval is a constant or a literal */
1517 error(28); /* cannot subscript */
1521 else if (sym->ident != iARRAY && sym->ident != iREFARRAY)
1523 error(28); /* cannot subscript, variable is not an array */
1527 else if (sym->dim.array.level > 0 && close != ']')
1529 error(51); /* invalid subscript, must use [ ] */
1533 stgget(&index, &cidx); /* mark position in code generator */
1534 push1(); /* save base address of the array */
1535 if (hier14(&lval2)) /* create expression for the array index */
1537 if (lval2.ident == iARRAY || lval2.ident == iREFARRAY)
1538 error(33, lval2.sym->name); /* array must be indexed */
1540 if (!matchtag(sym->x.idxtag, lval2.tag, TRUE))
1542 if (lval2.ident == iCONSTEXPR)
1543 { /* constant expression */
1544 stgdel(index, cidx); /* scratch generated code */
1545 if (lval1->arrayidx != NULL)
1546 { /* keep constant index, for checking */
1547 assert(sym->dim.array.level >= 0
1548 && sym->dim.array.level < sDIMEN_MAX);
1549 lval1->arrayidx[sym->dim.array.level] = lval2.constval;
1553 /* normal array index */
1554 if (lval2.constval < 0 || (sym->dim.array.length != 0
1555 && sym->dim.array.length <= lval2.constval))
1556 error(32, sym->name); /* array index out of bounds */
1557 if (lval2.constval != 0)
1559 /* don't add offsets for zero subscripts */
1561 const2(lval2.constval << 1);
1563 const2(lval2.constval << 2);
1570 /* character index */
1571 if (lval2.constval < 0 || (sym->dim.array.length != 0
1572 && sym->dim.array.length * ((8 * sizeof(cell)) /
1574 (ucell) lval2.constval))
1575 error(32, sym->name); /* array index out of bounds */
1576 if (lval2.constval != 0)
1578 /* don't add offsets for zero subscripts */
1580 const2(lval2.constval << 1); /* 16-bit character */
1582 const2(lval2.constval); /* 8-bit character */
1585 charalign(); /* align character index into array */
1590 /* array index is not constant */
1591 lval1->arrayidx = NULL; /* reset, so won't be checked */
1594 if (sym->dim.array.length != 0)
1595 ffbounds(sym->dim.array.length - 1); /* run time check for array bounds */
1596 cell2addr(); /* normal array index */
1600 if (sym->dim.array.length != 0)
1601 ffbounds(sym->dim.array.length * (32 / charbits) - 1);
1602 char2addr(); /* character array index */
1605 ob_add(); /* base address was popped into secondary register */
1607 charalign(); /* align character index into array */
1609 /* the indexed item may be another array (multi-dimensional arrays) */
1610 assert(lval1->sym == sym && sym != NULL); /* should still be set */
1611 if (sym->dim.array.level > 0)
1613 assert(close == ']'); /* checked earlier */
1614 /* read the offset to the subarray and add it to the current address */
1615 lval1->ident = iARRAYCELL;
1616 push1(); /* the optimizer makes this to a MOVE.alt */
1620 /* adjust the "value" structure and find the referenced array */
1621 lval1->ident = iREFARRAY;
1622 lval1->sym = finddepend(sym);
1623 assert(lval1->sym != NULL);
1624 assert(lval1->sym->dim.array.level ==
1625 sym->dim.array.level - 1);
1626 /* try to parse subsequent array indices */
1627 lvalue = FALSE; /* for now, a iREFARRAY is no lvalue */
1630 assert(sym->dim.array.level == 0);
1631 /* set type to fetch... INDIRECTLY */
1632 lval1->ident = (char)((close == ']') ? iARRAYCELL : iARRAYCHAR);
1633 lval1->tag = sym->tag;
1634 /* a cell in an array is an lvalue, a character in an array is not
1635 * always a *valid* lvalue */
1639 { /* tok=='(' -> function(...) */
1641 || (sym->ident != iFUNCTN && sym->ident != iREFFUNC))
1643 if (sym == NULL && sc_status == statFIRST)
1645 /* could be a "use before declaration"; in that case, create a stub
1646 * function so that the usage can be marked.
1648 sym = fetchfunc(lastsymbol, 0);
1650 markusage(sym, uREAD);
1652 return error(12); /* invalid function call */
1654 else if ((sym->usage & uMISSING) != 0)
1656 char symname[2 * sNAMEMAX + 16]; /* allow space for user defined operators */
1658 funcdisplayname(symname, sym->name);
1659 error(4, symname); /* function not defined */
1662 lval1->ident = iEXPRESSION;
1663 lval1->constval = 0;
1664 lval1->tag = sym->tag;
1665 return FALSE; /* result of function call is no lvalue */
1668 if (sym != NULL && lval1->ident == iFUNCTN)
1670 assert(sym->ident == iFUNCTN);
1673 lval1->ident = iREFFUNC;
1674 /* ??? however... function pointers (or function references are not (yet) allowed */
1675 error(29); /* expression error, assumed 0 */
1683 * Returns 1 if the operand is an lvalue (everything except arrays, functions
1684 * constants and -of course- errors).
1685 * Generates code to fetch the address of arrays. Code for constants is
1686 * already generated by constant().
1687 * This routine first clears the entire lval array (all fields are set to 0).
1689 * Global references: intest (may be altered, but restored upon termination)
1692 primary(value * lval)
1699 if (matchtoken('('))
1700 { /* sub-expression - (expression,...) */
1701 /* FIXME: 64bit unsafe */
1702 pushstk((stkitem) intest);
1703 /* FIXME: 64bit unsafe */
1704 pushstk((stkitem) sc_allowtags);
1706 intest = 0; /* no longer in "test" expression */
1707 sc_allowtags = TRUE; /* allow tagnames to be used in parenthised expressions */
1709 lvalue = hier14(lval);
1710 while (matchtoken(','));
1712 lexclr(FALSE); /* clear lex() push-back, it should have been
1713 * cleared already by needtoken() */
1714 sc_allowtags = (int)(long)popstk();
1715 intest = (int)(long)popstk();
1719 clear_value(lval); /* clear lval */
1720 tok = lex(&val, &st);
1723 /* lastsymbol is char[sNAMEMAX+1], lex() should have truncated any symbol
1724 * to sNAMEMAX significant characters */
1725 assert(strlen(st) < sizeof lastsymbol);
1726 strcpy(lastsymbol, st);
1728 if (tok == tSYMBOL && !findconst(st))
1730 /* first look for a local variable */
1731 if ((sym = findloc(st)) != 0)
1733 if (sym->ident == iLABEL)
1735 error(29); /* expression error, assumed 0 */
1736 const1(0); /* load 0 */
1737 return FALSE; /* return 0 for labels (expression error) */
1740 lval->ident = sym->ident;
1741 lval->tag = sym->tag;
1742 if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1744 address(sym); /* get starting address in primary register */
1745 return FALSE; /* return 0 for array (not lvalue) */
1749 return TRUE; /* return 1 if lvalue (not label or array) */
1752 /* now try a global variable */
1753 if ((sym = findglb(st)) != 0)
1755 if (sym->ident == iFUNCTN || sym->ident == iREFFUNC)
1757 /* if the function is only in the table because it was inserted as a
1758 * stub in the first pass (i.e. it was "used" but never declared or
1759 * implemented, issue an error
1761 if ((sym->usage & uPROTOTYPED) == 0)
1766 if ((sym->usage & uDEFINE) == 0)
1769 lval->ident = sym->ident;
1770 lval->tag = sym->tag;
1771 if (sym->ident == iARRAY || sym->ident == iREFARRAY)
1773 address(sym); /* get starting address in primary register */
1774 return FALSE; /* return 0 for array (not lvalue) */
1778 return TRUE; /* return 1 if lvalue (not function or array) */
1784 return error(17, st); /* undefined symbol */
1786 assert(sym != NULL);
1787 assert(sym->ident == iFUNCTN || sym->ident != iREFFUNC);
1789 lval->ident = sym->ident;
1790 lval->tag = sym->tag;
1791 return FALSE; /* return 0 for function (not an lvalue) */
1793 lexpush(); /* push the token, it is analyzed by constant() */
1794 if (constant(lval) == 0)
1796 error(29); /* expression error, assumed 0 */
1797 const1(0); /* load 0 */
1799 return FALSE; /* return 0 for constants (or errors) */
1803 clear_value(value * lval)
1806 lval->constval = 0L;
1809 lval->boolresult = FALSE;
1810 /* do not clear lval->arrayidx, it is preset in hier14() */
1814 setdefarray(cell * string, cell size, cell array_sz, cell * dataaddr,
1817 /* The routine must copy the default array data onto the heap, as to avoid
1818 * that a function can change the default value. An optimization is that
1819 * the default array data is "dumped" into the data segment only once (on the
1822 assert(string != NULL);
1824 /* check whether to dump the default array */
1825 assert(dataaddr != NULL);
1826 if (sc_status == statWRITE && *dataaddr < 0)
1830 *dataaddr = (litidx + glb_declared) * sizeof(cell);
1831 for (i = 0; i < size; i++)
1835 /* if the function is known not to modify the array (meaning that it also
1836 * does not modify the default value), directly pass the address of the
1837 * array in the data segment.
1845 /* Generate the code:
1846 * CONST.pri dataaddr ;address of the default array data
1847 * HEAP array_sz*sizeof(cell) ;heap address in ALT
1848 * MOVS size*sizeof(cell) ;copy data from PRI to ALT
1849 * MOVE.PRI ;PRI = address on the heap
1852 /* "array_sz" is the size of the argument (the value between the brackets
1853 * in the declaration), "size" is the size of the default array data.
1855 assert(array_sz >= size);
1856 modheap((int)array_sz * sizeof(cell));
1857 /* ??? should perhaps fill with zeros first */
1858 memcopy(size * sizeof(cell));
1864 findnamedarg(arginfo * arg, char *name)
1868 for (i = 0; arg[i].ident != 0 && arg[i].ident != iVARARGS; i++)
1869 if (strcmp(arg[i].name, name) == 0)
1875 checktag(int tags[], int numtags, int exprtag)
1880 assert(numtags > 0);
1881 for (i = 0; i < numtags; i++)
1882 if (matchtag(tags[i], exprtag, TRUE))
1883 return TRUE; /* matching tag */
1884 return FALSE; /* no tag matched */
1896 * Generates code to call a function. This routine handles default arguments
1897 * and positional as well as named parameters.
1900 callfunction(symbol * sym)
1903 int argpos; /* index in the output stream (argpos==nargs if positional parameters) */
1904 int argidx = 0; /* index in "arginfo" list */
1905 int nargs = 0; /* number of arguments */
1907 int namedparams = FALSE;
1908 value lval = { NULL, 0, 0, 0, 0, NULL };
1910 char arglist[sMAXARGS];
1911 constvalue arrayszlst = { NULL, "", 0, 0 }; /* array size list starts empty */
1915 assert(sym != NULL);
1916 arg = sym->dim.arglist;
1917 assert(arg != NULL);
1918 stgmark(sSTARTREORDER);
1919 for (argpos = 0; argpos < sMAXARGS; argpos++)
1920 arglist[argpos] = ARG_UNHANDLED;
1921 if (!matchtoken(')'))
1925 if (matchtoken('.'))
1928 if (needtoken(tSYMBOL))
1929 tokeninfo(&lexval, &lexstr);
1932 argpos = findnamedarg(arg, lexstr);
1935 error(17, lexstr); /* undefined symbol */
1936 break; /* exit loop, argpos is invalid */
1944 error(44); /* positional parameters must precede named parameters */
1947 stgmark((char)(sEXPRSTART + argpos)); /* mark beginning of new expression in stage */
1948 if (arglist[argpos] != ARG_UNHANDLED)
1949 error(58); /* argument already set */
1950 if (matchtoken('_'))
1952 arglist[argpos] = ARG_IGNORED; /* flag argument as "present, but ignored" */
1953 if (arg[argidx].ident == 0 || arg[argidx].ident == iVARARGS)
1955 error(202); /* argument count mismatch */
1957 else if (!arg[argidx].hasdefault)
1959 error(34, nargs + 1); /* argument has no default value */
1961 if (arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS)
1963 /* The rest of the code to handle default values is at the bottom
1964 * of this routine where default values for unspecified parameters
1965 * are (also) handled. Note that above, the argument is flagged as
1971 arglist[argpos] = ARG_DONE; /* flag argument as "present" */
1972 lvalue = hier14(&lval);
1973 switch (arg[argidx].ident)
1976 error(202); /* argument count mismatch */
1979 /* always pass by reference */
1980 if (lval.ident == iVARIABLE || lval.ident == iREFERENCE)
1982 assert(lval.sym != NULL);
1983 if ((lval.sym->usage & uCONST) != 0
1984 && (arg[argidx].usage & uCONST) == 0)
1986 /* treat a "const" variable passed to a function with a non-const
1987 * "variable argument list" as a constant here */
1989 rvalue(&lval); /* get value in PRI */
1990 setheap_pri(); /* address of the value on the heap in PRI */
1999 setheap_pri(); /* address of the value on the heap in PRI */
2003 else if (lval.ident == iCONSTEXPR
2004 || lval.ident == iEXPRESSION
2005 || lval.ident == iARRAYCHAR)
2007 /* fetch value if needed */
2008 if (lval.ident == iARRAYCHAR)
2010 /* allocate a cell on the heap and store the
2011 * value (already in PRI) there */
2012 setheap_pri(); /* address of the value on the heap in PRI */
2015 /* ??? handle const array passed by reference */
2016 /* otherwise, the address is already in PRI */
2017 if (lval.sym != NULL)
2018 markusage(lval.sym, uWRITTEN);
2020 * Dont need this warning - its varargs. there is no way of knowing the
2021 * required tag/type...
2023 if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
2028 if (lval.ident == iLABEL || lval.ident == iFUNCTN
2029 || lval.ident == iREFFUNC || lval.ident == iARRAY
2030 || lval.ident == iREFARRAY)
2031 error(35, argidx + 1); /* argument type mismatch */
2033 rvalue(&lval); /* get value (direct or indirect) */
2034 /* otherwise, the expression result is already in PRI */
2035 assert(arg[argidx].numtags > 0);
2036 check_userop(NULL, lval.tag, arg[argidx].tags[0], 2,
2039 (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2041 argidx++; /* argument done */
2044 if (!lvalue || lval.ident == iARRAYCHAR)
2045 error(35, argidx + 1); /* argument type mismatch */
2046 if (lval.sym != NULL && (lval.sym->usage & uCONST) != 0
2047 && (arg[argidx].usage & uCONST) == 0)
2048 error(35, argidx + 1); /* argument type mismatch */
2049 if (lval.ident == iVARIABLE || lval.ident == iREFERENCE)
2053 assert(lval.sym != NULL);
2058 setheap_pri(); /* address of the value on the heap in PRI */
2062 /* otherwise, the address is already in PRI */
2064 (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2066 argidx++; /* argument done */
2067 if (lval.sym != NULL)
2068 markusage(lval.sym, uWRITTEN);
2071 if (lval.ident != iARRAY && lval.ident != iREFARRAY
2072 && lval.ident != iARRAYCELL)
2074 error(35, argidx + 1); /* argument type mismatch */
2077 if (lval.sym != NULL && (lval.sym->usage & uCONST) != 0
2078 && (arg[argidx].usage & uCONST) == 0)
2079 error(35, argidx + 1); /* argument type mismatch */
2080 /* Verify that the dimensions match with those in arg[argidx].
2081 * A literal array always has a single dimension.
2082 * An iARRAYCELL parameter is also assumed to have a single dimension.
2084 if (lval.sym == NULL || lval.ident == iARRAYCELL)
2086 if (arg[argidx].numdim != 1)
2088 error(48); /* array dimensions must match */
2090 else if (arg[argidx].dim[0] != 0)
2092 assert(arg[argidx].dim[0] > 0);
2093 if (lval.ident == iARRAYCELL)
2095 error(47); /* array sizes must match */
2099 assert(lval.constval != 0); /* literal array must have a size */
2100 /* A literal array must have exactly the same size as the
2101 * function argument; a literal string may be smaller than
2102 * the function argument.
2104 if ((lval.constval > 0
2105 && arg[argidx].dim[0] != lval.constval)
2106 || (lval.constval < 0
2107 && arg[argidx].dim[0] <
2109 error(47); /* array sizes must match */
2112 if (lval.ident != iARRAYCELL)
2114 /* save array size, for default values with uSIZEOF flag */
2115 cell array_sz = lval.constval;
2117 assert(array_sz != 0); /* literal array must have a size */
2119 array_sz = -array_sz;
2120 append_constval(&arrayszlst, arg[argidx].name,
2126 symbol *sym = lval.sym;
2129 assert(sym != NULL);
2130 if (sym->dim.array.level + 1 != arg[argidx].numdim)
2131 error(48); /* array dimensions must match */
2132 /* the lengths for all dimensions must match, unless the dimension
2133 * length was defined at zero (which means "undefined")
2135 while (sym->dim.array.level > 0)
2137 assert(level < sDIMEN_MAX);
2138 if (arg[argidx].dim[level] != 0
2139 && sym->dim.array.length !=
2140 arg[argidx].dim[level])
2141 error(47); /* array sizes must match */
2142 append_constval(&arrayszlst, arg[argidx].name,
2143 sym->dim.array.length, level);
2144 sym = finddepend(sym);
2145 assert(sym != NULL);
2148 /* the last dimension is checked too, again, unless it is zero */
2149 assert(level < sDIMEN_MAX);
2150 assert(sym != NULL);
2151 if (arg[argidx].dim[level] != 0
2152 && sym->dim.array.length !=
2153 arg[argidx].dim[level])
2154 error(47); /* array sizes must match */
2155 append_constval(&arrayszlst, arg[argidx].name,
2156 sym->dim.array.length, level);
2158 /* address already in PRI */
2160 (arg[argidx].tags, arg[argidx].numtags, lval.tag))
2162 // ??? set uWRITTEN?
2163 argidx++; /* argument done */
2166 push1(); /* store the function argument on the stack */
2167 endexpr(FALSE); /* mark the end of a sub-expression */
2169 assert(arglist[argpos] != ARG_UNHANDLED);
2171 close = matchtoken(')');
2172 if (!close) /* if not paranthese... */
2173 if (!needtoken(',')) /* ...should be comma... */
2174 break; /* ...but abort loop if neither */
2176 while (!close && freading && !matchtoken(tENDEXPR)); /* do */
2178 /* check remaining function arguments (they may have default values) */
2179 for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS;
2182 if (arglist[argidx] == ARG_DONE)
2183 continue; /* already seen and handled this argument */
2184 /* in this first stage, we also skip the arguments with uSIZEOF and uTAGOF;
2185 * these are handled last
2187 if ((arg[argidx].hasdefault & uSIZEOF) != 0
2188 || (arg[argidx].hasdefault & uTAGOF) != 0)
2190 assert(arg[argidx].ident == iVARIABLE);
2193 stgmark((char)(sEXPRSTART + argidx)); /* mark beginning of new expression in stage */
2194 if (arg[argidx].hasdefault)
2196 if (arg[argidx].ident == iREFARRAY)
2200 setdefarray(arg[argidx].defvalue.array.data,
2201 arg[argidx].defvalue.array.size,
2202 arg[argidx].defvalue.array.arraysize,
2203 &arg[argidx].defvalue.array.addr,
2204 (arg[argidx].usage & uCONST) != 0);
2205 if ((arg[argidx].usage & uCONST) == 0)
2206 heapalloc += arg[argidx].defvalue.array.arraysize;
2207 /* keep the lengths of all dimensions of a multi-dimensional default array */
2208 assert(arg[argidx].numdim > 0);
2209 if (arg[argidx].numdim == 1)
2211 append_constval(&arrayszlst, arg[argidx].name,
2212 arg[argidx].defvalue.array.arraysize, 0);
2216 for (level = 0; level < arg[argidx].numdim; level++)
2218 assert(level < sDIMEN_MAX);
2219 append_constval(&arrayszlst, arg[argidx].name,
2220 arg[argidx].dim[level], level);
2224 else if (arg[argidx].ident == iREFERENCE)
2226 setheap(arg[argidx].defvalue.val);
2227 /* address of the value on the heap in PRI */
2232 int dummytag = arg[argidx].tags[0];
2234 const1(arg[argidx].defvalue.val);
2235 assert(arg[argidx].numtags > 0);
2236 check_userop(NULL, arg[argidx].defvalue_tag,
2237 arg[argidx].tags[0], 2, NULL, &dummytag);
2238 assert(dummytag == arg[argidx].tags[0]);
2240 push1(); /* store the function argument on the stack */
2241 endexpr(FALSE); /* mark the end of a sub-expression */
2245 error(202, argidx); /* argument count mismatch */
2247 if (arglist[argidx] == ARG_UNHANDLED)
2249 arglist[argidx] = ARG_DONE;
2251 /* now a second loop to catch the arguments with default values that are
2252 * the "sizeof" or "tagof" of other arguments
2254 for (argidx = 0; arg[argidx].ident != 0 && arg[argidx].ident != iVARARGS;
2260 if (arglist[argidx] == ARG_DONE)
2261 continue; /* already seen and handled this argument */
2262 stgmark((char)(sEXPRSTART + argidx)); /* mark beginning of new expression in stage */
2263 assert(arg[argidx].ident == iVARIABLE); /* if "sizeof", must be single cell */
2264 /* if unseen, must be "sizeof" or "tagof" */
2265 assert((arg[argidx].hasdefault & uSIZEOF) != 0
2266 || (arg[argidx].hasdefault & uTAGOF) != 0);
2267 if ((arg[argidx].hasdefault & uSIZEOF) != 0)
2269 /* find the argument; if it isn't found, the argument's default value
2270 * was a "sizeof" of a non-array (a warning for this was already given
2271 * when declaring the function)
2273 asz = find_constval(&arrayszlst, arg[argidx].defvalue.size.symname,
2274 arg[argidx].defvalue.size.level);
2277 array_sz = asz->value;
2279 error(224, arg[argidx].name); /* indeterminate array size in "sizeof" expression */
2290 assert((arg[argidx].hasdefault & uTAGOF) != 0);
2291 sym = findloc(arg[argidx].defvalue.size.symname);
2293 sym = findglb(arg[argidx].defvalue.size.symname);
2294 array_sz = (sym != NULL) ? sym->tag : 0;
2295 exporttag(array_sz);
2298 push1(); /* store the function argument on the stack */
2300 if (arglist[argidx] == ARG_UNHANDLED)
2302 arglist[argidx] = ARG_DONE;
2304 stgmark(sENDREORDER); /* mark end of reversed evaluation */
2305 pushval((cell) nargs * sizeof(cell));
2307 if (sc_status != statSKIP)
2308 markusage(sym, uREAD); /* do not mark as "used" when this call itself is skipped */
2309 if (sym->x.lib != NULL)
2310 sym->x.lib->value += 1; /* increment "usage count" of the library */
2311 modheap(-heapalloc * sizeof(cell));
2312 sideeffect = TRUE; /* assume functions carry out a side-effect */
2313 delete_consttable(&arrayszlst); /* clear list of array sizes */
2318 * Returns a non-zero value if lval1 an array and lval2 is not an array and
2319 * the operation is addition or subtraction.
2321 * Returns the "shift" count (1 for 16-bit, 2 for 32-bit) to align a cell
2322 * to an array offset.
2325 dbltest(void (*oper) (), value * lval1, value * lval2)
2327 if ((oper != ob_add) && (oper != ob_sub))
2329 if (lval1->ident != iARRAY)
2331 if (lval2->ident == iARRAY)
2333 return sizeof(cell) / 2; /* 1 for 16-bit, 2 for 32-bit */
2338 * Test whether an operator is commutative, i.e. x oper y == y oper x.
2339 * Commutative operators are: + (addition)
2340 * * (multiplication)
2347 * If in an expression, code for the left operand has been generated and
2348 * the right operand is a constant and the operator is commutative, the
2349 * precautionary "push" of the primary register is scrapped and the constant
2350 * is read into the secondary register immediately.
2353 commutative(void (*oper) ())
2355 return oper == ob_add || oper == os_mult
2356 || oper == ob_eq || oper == ob_ne
2357 || oper == ob_and || oper == ob_xor || oper == ob_or;
2362 * Generates code to fetch a number, a literal character (which is returned
2363 * by lex() as a number as well) or a literal string (lex() stores the
2364 * strings in the literal queue). If the operand was a number, it is stored
2365 * in lval->constval.
2367 * The function returns 1 if the token was a constant or a string, 0
2371 constant(value * lval)
2373 int tok, index, constant;
2374 cell val, item, cidx;
2378 tok = lex(&val, &st);
2379 if (tok == tSYMBOL && (sym = findconst(st)) != 0)
2381 lval->constval = sym->addr;
2382 const1(lval->constval);
2383 lval->ident = iCONSTEXPR;
2384 lval->tag = sym->tag;
2385 markusage(sym, uREAD);
2387 else if (tok == tNUMBER)
2389 lval->constval = val;
2390 const1(lval->constval);
2391 lval->ident = iCONSTEXPR;
2393 else if (tok == tRATIONAL)
2395 lval->constval = val;
2396 const1(lval->constval);
2397 lval->ident = iCONSTEXPR;
2398 lval->tag = sc_rationaltag;
2400 else if (tok == tSTRING)
2402 /* lex() stores starting index of string in the literal table in 'val' */
2403 const1((val + glb_declared) * sizeof(cell));
2404 lval->ident = iARRAY; /* pretend this is a global array */
2405 lval->constval = val - litidx; /* constval == the negative value of the
2406 * size of the literal array; using a negative
2407 * value distinguishes between literal arrays
2408 * and literal strings (this was done for
2409 * array assignment). */
2411 else if (tok == '{')
2413 int tag, lasttag = -1;
2418 /* cannot call constexpr() here, because "staging" is already turned
2419 * on at this point */
2421 stgget(&index, &cidx); /* mark position in code generator */
2422 expression(&constant, &item, &tag, FALSE);
2423 stgdel(index, cidx); /* scratch generated code */
2425 error(8); /* must be constant expression */
2428 else if (!matchtag(lasttag, tag, FALSE))
2429 error(213); /* tagname mismatch */
2430 stowlit(item); /* store expression result in literal table */
2432 while (matchtoken(','));
2434 const1((val + glb_declared) * sizeof(cell));
2435 lval->ident = iARRAY; /* pretend this is a global array */
2436 lval->constval = litidx - val; /* constval == the size of the literal array */
2440 return FALSE; /* no, it cannot be interpreted as a constant */
2442 return TRUE; /* yes, it was a constant value */