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