dvander@27: /*  Pawn compiler - Recursive descend expresion parser
dvander@27:  *
dvander@27:  *  Copyright (c) ITB CompuPhase, 1997-2005
dvander@27:  *
dvander@27:  *  This software is provided "as-is", without any express or implied warranty.
dvander@27:  *  In no event will the authors be held liable for any damages arising from
dvander@27:  *  the use of this software.
dvander@27:  *
dvander@27:  *  Permission is granted to anyone to use this software for any purpose,
dvander@27:  *  including commercial applications, and to alter it and redistribute it
dvander@27:  *  freely, subject to the following restrictions:
dvander@27:  *
dvander@27:  *  1.  The origin of this software must not be misrepresented; you must not
dvander@27:  *      claim that you wrote the original software. If you use this software in
dvander@27:  *      a product, an acknowledgment in the product documentation would be
dvander@101:  *      appreciated but is not reeq;quired.
dvander@27:  *  2.  Altered source versions must be plainly marked as such, and must not be
dvander@27:  *      misrepresented as being the original software.
dvander@27:  *  3.  This notice may not be removed or altered from any source distribution.
dvander@27:  *
faluco@62:  *  Version: $Id: sc3.c 3635 2006-08-13 12:19:41Z thiadmer $
dvander@27:  */
dvander@27: #include <assert.h>
dvander@27: #include <stdio.h>
dvander@27: #include <stdlib.h>     /* for _MAX_PATH */
dvander@27: #include <string.h>
dvander@27: #if defined FORTIFY
dvander@27:   #include <alloc/fortify.h>
dvander@27: #endif
dvander@27: #include "sc.h"
dvander@115: #include "sctracker.h"
dvander@27: 
dvander@27: static int skim(int *opstr,void (*testfunc)(int),int dropval,int endval,
dvander@27:                 int (*hier)(value*),value *lval);
dvander@27: static void dropout(int lvalue,void (*testfunc)(int val),int exit1,value *lval);
dvander@27: static int plnge(int *opstr,int opoff,int (*hier)(value *lval),value *lval,
dvander@27:                  char *forcetag,int chkbitwise);
dvander@27: static int plnge1(int (*hier)(value *lval),value *lval);
dvander@27: static void plnge2(void (*oper)(void),
dvander@27:                    int (*hier)(value *lval),
dvander@27:                    value *lval1,value *lval2);
dvander@27: static cell calc(cell left,void (*oper)(),cell right,char *boolresult);
dvander@27: static int hier14(value *lval);
dvander@27: static int hier13(value *lval);
dvander@27: static int hier12(value *lval);
dvander@27: static int hier11(value *lval);
dvander@27: static int hier10(value *lval);
dvander@27: static int hier9(value *lval);
dvander@27: static int hier8(value *lval);
dvander@27: static int hier7(value *lval);
dvander@27: static int hier6(value *lval);
dvander@27: static int hier5(value *lval);
dvander@27: static int hier4(value *lval);
dvander@27: static int hier3(value *lval);
dvander@27: static int hier2(value *lval);
dvander@27: static int hier1(value *lval1);
dvander@27: static int primary(value *lval);
dvander@27: static void clear_value(value *lval);
dvander@27: static void callfunction(symbol *sym,value *lval_result,int matchparanthesis);
dvander@27: static int dbltest(void (*oper)(),value *lval1,value *lval2);
dvander@27: static int commutative(void (*oper)());
dvander@27: static int constant(value *lval);
dvander@27: 
dvander@27: static char lastsymbol[sNAMEMAX+1]; /* name of last function/variable */
dvander@27: static int bitwise_opercount;   /* count of bitwise operators in an expression */
dvander@27: 
dvander@27: /* Function addresses of binary operators for signed operations */
dvander@27: static void (*op1[17])(void) = {
dvander@27:   os_mult,os_div,os_mod,        /* hier3, index 0 */
dvander@27:   ob_add,ob_sub,                /* hier4, index 3 */
dvander@27:   ob_sal,os_sar,ou_sar,         /* hier5, index 5 */
dvander@27:   ob_and,                       /* hier6, index 8 */
dvander@27:   ob_xor,                       /* hier7, index 9 */
dvander@27:   ob_or,                        /* hier8, index 10 */
dvander@27:   os_le,os_ge,os_lt,os_gt,      /* hier9, index 11 */
dvander@27:   ob_eq,ob_ne,                  /* hier10, index 15 */
dvander@27: };
dvander@27: /* These two functions are defined because the functions inc() and dec() in
dvander@27:  * SC4.C have a different prototype than the other code generation functions.
dvander@27:  * The arrays for user-defined functions use the function pointers for
dvander@27:  * identifying what kind of operation is requested; these functions must all
dvander@27:  * have the same prototype. As inc() and dec() are special cases already, it
dvander@27:  * is simplest to add two "do-nothing" functions.
dvander@27:  */
dvander@27: static void user_inc(void) {}
dvander@27: static void user_dec(void) {}
dvander@27: 
dvander@27: /*
dvander@27:  *  Searches for a binary operator a list of operators. The list is stored in
dvander@27:  *  the array "list". The last entry in the list should be set to 0.
dvander@27:  *
dvander@27:  *  The index of an operator in "list" (if found) is returned in "opidx". If
dvander@27:  *  no operator is found, nextop() returns 0.
dvander@27:  *
dvander@27:  *  If an operator is found in the expression, it cannot be used in a function
dvander@27:  *  call with omitted parantheses. Mark this...
dvander@27:  *
dvander@27:  *  Global references: sc_allowproccall   (modified)
dvander@27:  */
dvander@27: static int nextop(int *opidx,int *list)
dvander@27: {
dvander@27:   *opidx=0;
dvander@27:   while (*list){
dvander@27:     if (matchtoken(*list)){
dvander@27:       sc_allowproccall=FALSE;
dvander@27:       return TRUE;      /* found! */
dvander@27:     } else {
dvander@27:       list+=1;
dvander@27:       *opidx+=1;
dvander@27:     } /* if */
dvander@27:   } /* while */
dvander@27:   return FALSE;         /* entire list scanned, nothing found */
dvander@27: }
dvander@27: 
dvander@27: SC_FUNC int check_userop(void (*oper)(void),int tag1,int tag2,int numparam,
dvander@27:                          value *lval,int *resulttag)
dvander@27: {
dvander@27: static char *binoperstr[] = { "*", "/", "%", "+", "-", "", "", "",
dvander@27:                               "", "", "", "<=", ">=", "<", ">", "==", "!=" };
dvander@27: static int binoper_savepri[] = { FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
dvander@27:                                  FALSE, FALSE, FALSE, FALSE, FALSE,
dvander@27:                                  TRUE, TRUE, TRUE, TRUE, FALSE, FALSE };
dvander@27: static char *unoperstr[] = { "!", "-", "++", "--" };
dvander@27: static void (*unopers[])(void) = { lneg, neg, user_inc, user_dec };
dvander@27:   char opername[4] = "", symbolname[sNAMEMAX+1];
dvander@27:   int i,swapparams,savepri,savealt;
dvander@27:   int paramspassed;
dvander@27:   symbol *sym;
dvander@27: 
dvander@27:   /* since user-defined operators on untagged operands are forbidden, we have
dvander@27:    * a quick exit.
dvander@27:    */
dvander@27:   assert(numparam==1 || numparam==2);
dvander@27:   if (tag1==0 && (numparam==1 || tag2==0))
dvander@27:     return FALSE;
dvander@27: 
dvander@27:   savepri=savealt=FALSE;
dvander@27:   /* find the name with the operator */
dvander@27:   if (numparam==2) {
dvander@27:     if (oper==NULL) {
dvander@27:       /* assignment operator: a special case */
dvander@27:       strcpy(opername,"=");
dvander@27:       if (lval!=NULL && (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR))
dvander@27:         savealt=TRUE;
dvander@27:     } else {
dvander@27:       assert( (sizeof binoperstr / sizeof binoperstr[0]) == (sizeof op1 / sizeof op1[0]) );
dvander@27:       for (i=0; i<sizeof op1 / sizeof op1[0]; i++) {
dvander@27:         if (oper==op1[i]) {
dvander@27:           strcpy(opername,binoperstr[i]);
dvander@27:           savepri=binoper_savepri[i];
dvander@27:           break;
dvander@27:         } /* if */
dvander@27:       } /* for */
dvander@27:     } /* if */
dvander@27:   } else {
dvander@27:     assert(oper!=NULL);
dvander@27:     assert(numparam==1);
dvander@27:     /* try a select group of unary operators */
dvander@27:     assert( (sizeof unoperstr / sizeof unoperstr[0]) == (sizeof unopers / sizeof unopers[0]) );
dvander@27:     if (opername[0]=='\0') {
dvander@27:       for (i=0; i<sizeof unopers / sizeof unopers[0]; i++) {
dvander@27:         if (oper==unopers[i]) {
dvander@27:           strcpy(opername,unoperstr[i]);
dvander@27:           break;
dvander@27:         } /* if */
dvander@27:       } /* for */
dvander@27:     } /* if */
dvander@27:   } /* if */
dvander@27:   /* if not found, quit */
dvander@27:   if (opername[0]=='\0')
dvander@27:     return FALSE;
dvander@27: 
dvander@27:   /* create a symbol name from the tags and the operator name */
dvander@27:   assert(numparam==1 || numparam==2);
dvander@27:   operator_symname(symbolname,opername,tag1,tag2,numparam,tag2);
dvander@27:   swapparams=FALSE;
dvander@27:   sym=findglb(symbolname,sGLOBAL);
dvander@27:   if (sym==NULL /*|| (sym->usage & uDEFINE)==0*/) {  /* ??? should not check uDEFINE; first pass clears these bits */
dvander@27:     /* check for commutative operators */
dvander@27:     if (tag1==tag2 || oper==NULL || !commutative(oper))
dvander@27:       return FALSE;             /* not commutative, cannot swap operands */
dvander@27:     /* if arrived here, the operator is commutative and the tags are different,
dvander@27:      * swap tags and try again
dvander@27:      */
dvander@27:     assert(numparam==2);        /* commutative operator must be a binary operator */
dvander@27:     operator_symname(symbolname,opername,tag2,tag1,numparam,tag1);
dvander@27:     swapparams=TRUE;
dvander@27:     sym=findglb(symbolname,sGLOBAL);
dvander@27:     if (sym==NULL /*|| (sym->usage & uDEFINE)==0*/)
dvander@27:       return FALSE;
dvander@27:   } /* if */
dvander@27: 
dvander@27:   /* check existance and the proper declaration of this function */
dvander@27:   if ((sym->usage & uMISSING)!=0 || (sym->usage & uPROTOTYPED)==0) {
dvander@27:     char symname[2*sNAMEMAX+16];  /* allow space for user defined operators */
dvander@27:     funcdisplayname(symname,sym->name);
dvander@27:     if ((sym->usage & uMISSING)!=0)
dvander@27:       error(4,symname);           /* function not defined */
dvander@27:     if ((sym->usage & uPROTOTYPED)==0)
dvander@27:       error(71,symname);          /* operator must be declared before use */
dvander@27:   } /* if */
dvander@27: 
dvander@27:   /* we don't want to use the redefined operator in the function that
dvander@27:    * redefines the operator itself, otherwise the snippet below gives
dvander@27:    * an unexpected recursion:
dvander@27:    *    fixed:operator+(fixed:a, fixed:b)
dvander@27:    *        return a + b
dvander@27:    */
dvander@27:   if (sym==curfunc)
dvander@27:     return FALSE;
dvander@27: 
dvander@27:   /* for increment and decrement operators, the symbol must first be loaded
dvander@27:    * (and stored back afterwards)
dvander@27:    */
dvander@27:   if (oper==user_inc || oper==user_dec) {
dvander@27:     assert(!savepri);
dvander@27:     assert(lval!=NULL);
dvander@27:     if (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR)
dvander@27:       pushreg(sPRI);            /* save current address in PRI */
dvander@27:     rvalue(lval);               /* get the symbol's value in PRI */
dvander@27:   } /* if */
dvander@27: 
dvander@27:   assert(!savepri || !savealt); /* either one MAY be set, but not both */
dvander@27:   if (savepri) {
dvander@27:     /* the chained comparison operators require that the ALT register is
dvander@27:      * unmodified, so we save it here; actually, we save PRI because the normal
dvander@27:      * instruction sequence (without user operator) swaps PRI and ALT
dvander@27:      */
dvander@27:     pushreg(sPRI);              /* right-hand operand is in PRI */
dvander@27:   } else if (savealt) {
dvander@27:     /* for the assignment operator, ALT may contain an address at which the
dvander@27:      * result must be stored; this address must be preserved accross the
dvander@27:      * call
dvander@27:      */
dvander@27:     assert(lval!=NULL);         /* this was checked earlier */
dvander@27:     assert(lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR); /* checked earlier */
dvander@27:     pushreg(sALT);
dvander@27:   } /* if */
dvander@27: 
dvander@27:   /* push parameters, call the function */
dvander@27:   paramspassed= (oper==NULL) ? 1 : numparam;
dvander@27:   switch (paramspassed) {
dvander@27:   case 1:
dvander@27:     pushreg(sPRI);
dvander@27:     break;
dvander@27:   case 2:
dvander@27:     /* note that 1) a function expects that the parameters are pushed
dvander@27:      * in reversed order, and 2) the left operand is in the secondary register
dvander@27:      * and the right operand is in the primary register */
dvander@27:     if (swapparams) {
dvander@27:       pushreg(sALT);
dvander@27:       pushreg(sPRI);
dvander@27:     } else {
dvander@27:       pushreg(sPRI);
dvander@27:       pushreg(sALT);
dvander@27:     } /* if */
dvander@27:     break;
dvander@27:   default:
dvander@27:     assert(0);
dvander@27:   } /* switch */
dvander@27:   markexpr(sPARM,NULL,0);       /* mark the end of a sub-expression */
dvander@101:   pushval((cell)paramspassed /* *sizeof(cell)*/ );
dvander@27:   assert(sym->ident==iFUNCTN);
dvander@27:   ffcall(sym,NULL,paramspassed);
dvander@27:   if (sc_status!=statSKIP)
dvander@27:     markusage(sym,uREAD);       /* do not mark as "used" when this call itself is skipped */
dvander@27:   if ((sym->usage & uNATIVE)!=0 && sym->x.lib!=NULL)
dvander@27:     sym->x.lib->value += 1;     /* increment "usage count" of the library */
dvander@27:   sideeffect=TRUE;              /* assume functions carry out a side-effect */
dvander@27:   assert(resulttag!=NULL);
dvander@27:   *resulttag=sym->tag;          /* save tag of the called function */
dvander@27: 
dvander@27:   if (savepri || savealt)
dvander@27:     popreg(sALT);               /* restore the saved PRI/ALT that into ALT */
dvander@27:   if (oper==user_inc || oper==user_dec) {
dvander@27:     assert(lval!=NULL);
dvander@27:     if (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR)
dvander@27:       popreg(sALT);             /* restore address (in ALT) */
dvander@27:     store(lval);                /* store PRI in the symbol */
dvander@27:     moveto1();                  /* make sure PRI is restored on exit */
dvander@27:   } /* if */
dvander@27:   return TRUE;
dvander@27: }
dvander@27: 
dvander@151: SC_FUNC int checktags_string(int tags[], int numtags, value *sym1)
dvander@151: {
dvander@151:   int i;
dvander@151:   if (sym1->ident == iARRAY || sym1->ident == iREFARRAY)
dvander@151:   {
dvander@151:     return FALSE;
dvander@151:   }
dvander@151:   for (i=0; i<numtags; i++) {
dvander@151:     if ((sym1->tag == pc_tag_string && tags[i] == 0) ||
dvander@151: 		(sym1->tag == 0 && tags[i] == pc_tag_string))
dvander@151:       return TRUE;
dvander@151:   }
dvander@151:   return FALSE;
dvander@151: }
dvander@151: 
dvander@151: SC_FUNC int checktag_string(value *sym1, value *sym2)
dvander@151: {
dvander@151:   if (sym1->ident == iARRAY || sym2->ident == iARRAY
dvander@151: 	  || sym1->ident == iREFARRAY || sym2->ident == iREFARRAY)
dvander@151:   {
dvander@151:     return FALSE;
dvander@151:   }
dvander@151:   if ((sym1->tag == pc_tag_string && sym2->tag == 0)
dvander@151: 	  || (sym1->tag == 0 && sym2->tag == pc_tag_string))
dvander@151:   {
dvander@151:     return TRUE;
dvander@151:   }
dvander@151: 
dvander@151:   return FALSE;
dvander@151: }
dvander@151: 
dvander@151: SC_FUNC int matchtag_string(int ident, int tag)
dvander@151: {
dvander@151:   if (ident == iARRAY || ident == iREFARRAY)
dvander@151:     return FALSE;
dvander@151:   return (tag == pc_tag_string) ? TRUE : FALSE;
dvander@151: }
dvander@151: 
dvander@27: SC_FUNC int matchtag(int formaltag,int actualtag,int allowcoerce)
dvander@27: {
dvander@27:   if (formaltag!=actualtag) {
dvander@27:     /* if the formal tag is zero and the actual tag is not "fixed", the actual
dvander@27:      * tag is "coerced" to zero
dvander@27:      */
dvander@132:     if (!allowcoerce || formaltag!=0 || (actualtag & FIXEDTAG)!=0) {
dvander@132: 		if (formaltag & FUNCTAG)
dvander@132: 		{
dvander@132: 			if (actualtag == pc_functag || (formaltag == pc_functag && actualtag & FUNCTAG))
dvander@132: 			{
dvander@132: 				return TRUE;
dvander@132: 			} else if (actualtag & FUNCTAG) {
dvander@132: 				constvalue *v = find_tag_byval(actualtag);
dvander@132: 				int index;
dvander@132: 				short usage = uPUBLIC;
dvander@132: 				symbol *sym, *found = NULL;
dvander@132: 				funcenum_t *e;
dvander@132: 				functag_t *t;
dvander@132: 
dvander@132: 				if (strncmp(v->name, "$Func", 5) != 0)
dvander@132: 				{
dvander@132: 					return FALSE;
dvander@132: 				}
dvander@132: 
dvander@132: 				/* Now we have to go about looking up each function in this enum.  WHICH IS IT. */
dvander@132: 				e = funcenums_find_byval(formaltag);
dvander@132: 				if (!e)
dvander@132: 				{
dvander@132: 					return FALSE;
dvander@132: 				}
dvander@132: 
dvander@132: 				assert(v->name[5] == '@' || v->name[5] == '!');
dvander@132: 
dvander@132: 				/* Deduce which function type this is */
dvander@132: 				if (v->name[5] == '@')
dvander@132: 				{
dvander@132: 					usage = uPUBLIC;
dvander@132: 				} else if (v->name[5] = '!') {
dvander@338: 					usage = uSTOCK;
dvander@132: 				}
dvander@132: 
dvander@132: 				index = atoi(&v->name[6]);
dvander@132: 
dvander@132: 				assert(index >= 0);
dvander@132: 
dvander@132: 				/* Find the function, either by public idx or code addr */
dvander@132: 				if (usage == uPUBLIC)
dvander@132: 				{
dvander@132: 					for (sym=glbtab.next; sym!=NULL; sym=sym->next) {
dvander@132: 						if (sym->ident==iFUNCTN && (sym->usage & uPUBLIC)!=0 && (sym->vclass == sGLOBAL))
dvander@132: 						{
dvander@132: 							if (index-- == 0)
dvander@132: 							{
dvander@132: 								found = sym;
dvander@132: 								break;
dvander@132: 							}
dvander@132: 						}
dvander@132: 					}
dvander@338: 				} else if (usage == uSTOCK) {
dvander@132: 					for (sym=glbtab.next; sym!=NULL; sym=sym->next) {
dvander@132: 						if (sym->ident==iFUNCTN && (sym->vclass == sGLOBAL))
dvander@132: 						{
dvander@132: 							if (sym->codeaddr == index)
dvander@132: 							{
dvander@132: 								found = sym;
dvander@132: 								break;
dvander@132: 							}
dvander@132: 						}
dvander@132: 					}
dvander@132: 				}
dvander@132: 
dvander@132: 				if (!found)
dvander@132: 				{
dvander@132: 					assert(found);
dvander@132: 					return FALSE;
dvander@132: 				}
dvander@132: 
dvander@132: 				/* Wow, we now have:
dvander@132: 				 * 1) The functional enum deduced from formaltag
dvander@132: 				 * 2) The function trying to be shoved in deduced from actualtag
dvander@132: 				 * Now we have to check if it matches any one of the functags inside the enum.
dvander@132: 				 */
dvander@132: 				t = e->first;
dvander@132: 				while (t)
dvander@132: 				{
dvander@132: 					int curarg,skip=0,i;
dvander@132: 					arginfo *func_arg;
dvander@132: 					funcarg_t *enum_arg;
dvander@132: 					/* Check return type first. */
dvander@132: 					if (t->ret_tag != sym->tag)
dvander@132: 					{
dvander@132: 						t = t->next;
dvander@132: 						continue;
dvander@132: 					}
dvander@132: 					/* Check usage */
dvander@132: 					if (t->type != usage)
dvander@132: 					{
dvander@132: 						t = t->next;
dvander@132: 						continue;
dvander@132: 					}
dvander@132: 					/* Begin iterating arguments */
dvander@132: 					for (curarg=0; curarg<t->argcount; curarg++)
dvander@132: 					{
dvander@132: 						enum_arg = &t->args[curarg];
dvander@132: 						/* Check whether we've exhausted our arguments */
dvander@132: 						if (sym->dim.arglist[curarg].ident == 0)
dvander@132: 						{
dvander@132: 							/* Can we bail out early? */
dvander@132: 							if (!enum_arg->ommittable)
dvander@132: 							{
dvander@132: 								/* No! */
dvander@132: 								skip = 1;
dvander@132: 							}
dvander@132: 							break;
dvander@132: 						}
dvander@132: 						func_arg = &sym->dim.arglist[curarg];
dvander@132: 						/* First check the ident type */
dvander@132: 						if (enum_arg->ident != func_arg->ident)
dvander@132: 						{
dvander@132: 							skip = 1;
dvander@132: 							break;
dvander@132: 						}
dvander@132: 						/* Next check arrayness */
dvander@132: 						if (enum_arg->dimcount != func_arg->numdim)
dvander@132: 						{
dvander@132: 							skip = 1;
dvander@132: 							break;
dvander@132: 						}
dvander@132: 						if (enum_arg->dimcount > 0)
dvander@132: 						{
dvander@132: 							for (i=0; i<enum_arg->dimcount; i++)
dvander@132: 							{
dvander@132: 								if (enum_arg->dims[i] != func_arg->dim[i])
dvander@132: 								{
dvander@132: 									skip = 1;
dvander@132: 									break;
dvander@132: 								}
dvander@132: 							}
dvander@132: 							if (skip)
dvander@132: 							{
dvander@132: 								break;
dvander@132: 							}
dvander@132: 						}
dvander@132: 						/* Lastly, check the tags */
dvander@132: 						if (enum_arg->tagcount != func_arg->numtags)
dvander@132: 						{
dvander@132: 							skip = 1;
dvander@132: 							break;
dvander@132: 						}
dvander@132: 						/* They should all be in the same order just for clarity... */
dvander@132: 						for (i=0; i<enum_arg->tagcount; i++)
dvander@132: 						{
dvander@132: 							if (enum_arg->tags[i] != func_arg->tags[i])
dvander@132: 							{
dvander@132: 								skip = 1;
dvander@132: 								break;
dvander@132: 							}
dvander@132: 						}
dvander@132: 						if (skip)
dvander@132: 						{
dvander@132: 							break;
dvander@132: 						}
dvander@132: 					}
dvander@132: 					if (!skip)
dvander@132: 					{
dvander@132: 						/* Make sure there are no trailing arguments */
dvander@132: 						if (sym->dim.arglist[curarg].ident == 0)
dvander@132: 						{
dvander@132: 							return TRUE;
dvander@132: 						}
dvander@132: 					}
dvander@132: 					t = t->next;
dvander@132: 				}
dvander@132: 			}
dvander@132: 		}
dvander@132: 		return FALSE;
dvander@132: 	}
dvander@27:   } /* if */
dvander@27:   return TRUE;
dvander@27: }
dvander@27: 
dvander@27: /*
dvander@27:  *  The AMX pseudo-processor has no direct support for logical (boolean)
dvander@27:  *  operations. These have to be done via comparing and jumping. Since we are
dvander@27:  *  already jumping through the code, we might as well implement an "early
dvander@27:  *  drop-out" evaluation (also called "short-circuit"). This conforms to
dvander@27:  *  standard C:
dvander@27:  *
dvander@27:  *  expr1 || expr2           expr2 will only be evaluated if expr1 is false.
dvander@27:  *  expr1 && expr2           expr2 will only be evaluated if expr1 is true.
dvander@27:  *
dvander@27:  *  expr1 || expr2 && expr3  expr2 will only be evaluated if expr1 is false
dvander@27:  *                           and expr3 will only be evaluated if expr1 is
dvander@27:  *                           false and expr2 is true.
dvander@27:  *
dvander@27:  *  Code generation for the last example proceeds thus:
dvander@27:  *
dvander@27:  *      evaluate expr1
dvander@27:  *      operator || found
dvander@27:  *      jump to "l1" if result of expr1 not equal to 0
dvander@27:  *      evaluate expr2
dvander@27:  *      ->  operator && found; skip to higher level in hierarchy diagram
dvander@27:  *          jump to "l2" if result of expr2 equal to 0
dvander@27:  *          evaluate expr3
dvander@27:  *          jump to "l2" if result of expr3 equal to 0
dvander@27:  *          set expression result to 1 (true)
dvander@27:  *          jump to "l3"
dvander@27:  *      l2: set expression result to 0 (false)
dvander@27:  *      l3:
dvander@27:  *      <-  drop back to previous hierarchy level
dvander@27:  *      jump to "l1" if result of expr2 && expr3 not equal to 0
dvander@27:  *      set expression result to 0 (false)
dvander@27:  *      jump to "l4"
dvander@27:  *  l1: set expression result to 1 (true)
dvander@27:  *  l4:
dvander@27:  *
dvander@27:  */
dvander@27: 
dvander@27: /*  Skim over terms adjoining || and && operators
dvander@27:  *  dropval   The value of the expression after "dropping out". An "or" drops
dvander@27:  *            out when the left hand is TRUE, so dropval must be 1 on "or"
dvander@27:  *            expressions.
dvander@27:  *  endval    The value of the expression when no expression drops out. In an
dvander@27:  *            "or" expression, this happens when both the left hand and the
dvander@27:  *            right hand are FALSE, so endval must be 0 for "or" expressions.
dvander@27:  */
dvander@27: static int skim(int *opstr,void (*testfunc)(int),int dropval,int endval,
dvander@27:                 int (*hier)(value*),value *lval)
dvander@27: {
dvander@27:   int lvalue,hits,droplab,endlab,opidx;
dvander@27:   int allconst,foundop;
dvander@27:   cell constval;
dvander@27:   int index;
dvander@27:   cell cidx;
dvander@27: 
dvander@27:   stgget(&index,&cidx);         /* mark position in code generator */
dvander@27:   hits=FALSE;                   /* no logical operators "hit" yet */
dvander@27:   allconst=TRUE;                /* assume all values "const" */
dvander@27:   constval=0;
dvander@27:   droplab=0;                    /* to avoid a compiler warning */
dvander@27:   for ( ;; ) {
dvander@27:     lvalue=plnge1(hier,lval);   /* evaluate left expression */
dvander@27: 
dvander@27:     allconst= allconst && (lval->ident==iCONSTEXPR);
dvander@27:     if (allconst) {
dvander@27:       if (hits) {
dvander@27:         /* one operator was already found */
dvander@27:         if (testfunc==jmp_ne0)
dvander@27:           lval->constval= lval->constval || constval;
dvander@27:         else
dvander@27:           lval->constval= lval->constval && constval;
dvander@27:       } /* if */
dvander@27:       constval=lval->constval;  /* save result accumulated so far */
dvander@27:     } /* if */
dvander@27: 
dvander@27:     foundop=nextop(&opidx,opstr);
dvander@27:     if ((foundop || hits) && (lval->ident==iARRAY || lval->ident==iREFARRAY))
dvander@27:       error(33, lval->sym ? (lval->sym->name ? lval->sym->name : "-unknown") : "-unknown-");  /* array was not indexed in an expression */
dvander@27:     if (foundop) {
dvander@27:       if (!hits) {
dvander@27:         /* this is the first operator in the list */
dvander@27:         hits=TRUE;
dvander@27:         droplab=getlabel();
dvander@27:       } /* if */
dvander@27:       dropout(lvalue,testfunc,droplab,lval);
dvander@27:     } else if (hits) {                       /* no (more) identical operators */
dvander@27:       dropout(lvalue,testfunc,droplab,lval); /* found at least one operator! */
dvander@27:       ldconst(endval,sPRI);
dvander@27:       jumplabel(endlab=getlabel());
dvander@27:       setlabel(droplab);
dvander@27:       ldconst(dropval,sPRI);
dvander@27:       setlabel(endlab);
dvander@27:       lval->sym=NULL;
dvander@27:       lval->tag=pc_addtag("bool");  /* force tag to be "bool" */
dvander@27:       if (allconst) {
dvander@27:         lval->ident=iCONSTEXPR;
dvander@27:         lval->constval=constval;
dvander@27:         stgdel(index,cidx);         /* scratch generated code and calculate */
dvander@27:       } else {
dvander@27:         lval->ident=iEXPRESSION;
dvander@27:         lval->constval=0;
dvander@27:       } /* if */
dvander@27:       return FALSE;
dvander@27:     } else {
dvander@27:       return lvalue;            /* none of the operators in "opstr" were found */
dvander@27:     } /* if */
dvander@27: 
dvander@27:   } /* while */
dvander@27: }
dvander@27: 
dvander@27: /*
dvander@27:  *  Reads into the primary register the variable pointed to by lval if
dvander@27:  *  plunging through the hierarchy levels detected an lvalue. Otherwise
dvander@27:  *  if a constant was detected, it is loaded. If there is no constant and
dvander@27:  *  no lvalue, the primary register must already contain the expression
dvander@27:  *  result.
dvander@27:  *
dvander@27:  *  After that, the compare routines "jmp_ne0" or "jmp_eq0" are called, which
dvander@27:  *  compare the primary register against 0, and jump to the "early drop-out"
dvander@27:  *  label "exit1" if the condition is true.
dvander@27:  */
dvander@27: static void dropout(int lvalue,void (*testfunc)(int val),int exit1,value *lval)
dvander@27: {
dvander@27:   if (lvalue)
dvander@27:     rvalue(lval);
dvander@27:   else if (lval->ident==iCONSTEXPR)
dvander@27:     ldconst(lval->constval,sPRI);
dvander@27:   (*testfunc)(exit1);
dvander@27: }
dvander@27: 
dvander@27: static void checkfunction(value *lval)
dvander@27: {
dvander@27:   symbol *sym=lval->sym;
dvander@27: 
dvander@27:   if (sym==NULL || (sym->ident!=iFUNCTN && sym->ident!=iREFFUNC))
dvander@27:     return;             /* no known symbol, or not a function result */
dvander@27: 
dvander@27:   if ((sym->usage & uDEFINE)!=0) {
dvander@27:     /* function is defined, can now check the return value (but make an
dvander@27:      * exception for directly recursive functions)
dvander@27:      */
dvander@27:     if (sym!=curfunc && (sym->usage & uRETVALUE)==0) {
dvander@27:       char symname[2*sNAMEMAX+16];  /* allow space for user defined operators */
dvander@27:       funcdisplayname(symname,sym->name);
dvander@27:       error(209,symname);       /* function should return a value */
dvander@27:     } /* if */
dvander@27:   } else {
dvander@27:     /* function not yet defined, set */
dvander@27:     sym->usage|=uRETVALUE;      /* make sure that a future implementation of
dvander@27:                                  * the function uses "return <value>" */
dvander@27:   } /* if */
dvander@27: }
dvander@27: 
dvander@27: /*
dvander@27:  *  Plunge to a lower level
dvander@27:  */
dvander@27: static int plnge(int *opstr,int opoff,int (*hier)(value *lval),value *lval,
dvander@27:                  char *forcetag,int chkbitwise)
dvander@27: {
dvander@27:   int lvalue,opidx;
dvander@27:   int count;
dvander@27:   value lval2 = {0};
dvander@27: 
dvander@27:   lvalue=plnge1(hier,lval);
dvander@27:   if (nextop(&opidx,opstr)==0)
dvander@27:     return lvalue;              /* no operator in "opstr" found */
dvander@27:   if (lvalue)
dvander@27:     rvalue(lval);
dvander@27:   count=0;
dvander@27:   do {
dvander@27:     if (chkbitwise && count++>0 && bitwise_opercount!=0)
dvander@27:       error(212);
dvander@27:     opidx+=opoff;               /* add offset to index returned by nextop() */
dvander@27:     plnge2(op1[opidx],hier,lval,&lval2);
dvander@27:     if (op1[opidx]==ob_and || op1[opidx]==ob_or)
dvander@27:       bitwise_opercount++;
dvander@27:     if (forcetag!=NULL)
dvander@27:       lval->tag=pc_addtag(forcetag);
dvander@27:   } while (nextop(&opidx,opstr)); /* do */
dvander@27:   return FALSE;         /* result of expression is not an lvalue */
dvander@27: }
dvander@27: 
dvander@27: /*  plnge_rel
dvander@27:  *
dvander@27:  *  Binary plunge to lower level; this is very simular to plnge, but
dvander@27:  *  it has special code generation sequences for chained operations.
dvander@27:  */
dvander@27: static int plnge_rel(int *opstr,int opoff,int (*hier)(value *lval),value *lval)
dvander@27: {
dvander@27:   int lvalue,opidx;
dvander@27:   value lval2={0};
dvander@27:   int count;
dvander@27: 
dvander@27:   /* this function should only be called for relational operators */
dvander@27:   assert(op1[opoff]==os_le);
dvander@27:   lvalue=plnge1(hier,lval);
dvander@27:   if (nextop(&opidx,opstr)==0)
dvander@27:     return lvalue;              /* no operator in "opstr" found */
dvander@27:   if (lvalue)
dvander@27:     rvalue(lval);
dvander@27:   count=0;
dvander@27:   lval->boolresult=TRUE;
dvander@27:   do {
dvander@27:     /* same check as in plnge(), but "chkbitwise" is always TRUE */
dvander@27:     if (count>0 && bitwise_opercount!=0)
dvander@27:       error(212);
dvander@27:     if (count>0) {
dvander@27:       relop_prefix();
dvander@27:       *lval=lval2;      /* copy right hand expression of the previous iteration */
dvander@27:     } /* if */
dvander@27:     opidx+=opoff;
dvander@27:     plnge2(op1[opidx],hier,lval,&lval2);
dvander@27:     if (count++>0)
dvander@27:       relop_suffix();
dvander@27:   } while (nextop(&opidx,opstr)); /* enddo */
dvander@27:   lval->constval=lval->boolresult;
dvander@27:   lval->tag=pc_addtag("bool");    /* force tag to be "bool" */
dvander@27:   return FALSE;         /* result of expression is not an lvalue */
dvander@27: }
dvander@27: 
dvander@27: /*  plnge1
dvander@27:  *
dvander@27:  *  Unary plunge to lower level
dvander@27:  *  Called by: skim(), plnge(), plnge2(), plnge_rel(), hier14() and hier13()
dvander@27:  */
dvander@27: static int plnge1(int (*hier)(value *lval),value *lval)
dvander@27: {
dvander@27:   int lvalue,index;
dvander@27:   cell cidx;
dvander@27: 
dvander@27:   stgget(&index,&cidx); /* mark position in code generator */
dvander@27:   lvalue=(*hier)(lval);
dvander@27:   if (lval->ident==iCONSTEXPR)
dvander@27:     stgdel(index,cidx); /* load constant later */
dvander@27:   return lvalue;
dvander@27: }
dvander@27: 
dvander@27: /*  plnge2
dvander@27:  *
dvander@27:  *  Binary plunge to lower level
dvander@27:  *  Called by: plnge(), plnge_rel(), hier14() and hier1()
dvander@27:  */
dvander@27: static void plnge2(void (*oper)(void),
dvander@27:                    int (*hier)(value *lval),
dvander@27:                    value *lval1,value *lval2)
dvander@27: {
dvander@27:   int index;
dvander@27:   cell cidx;
dvander@27: 
dvander@27:   stgget(&index,&cidx);             /* mark position in code generator */
dvander@27:   if (lval1->ident==iCONSTEXPR) {   /* constant on left side; it is not yet loaded */
dvander@27:     if (plnge1(hier,lval2))
dvander@27:       rvalue(lval2);                /* load lvalue now */
dvander@27:     else if (lval2->ident==iCONSTEXPR)
dvander@27:       ldconst(lval2->constval<<dbltest(oper,lval2,lval1),sPRI);
dvander@27:     ldconst(lval1->constval<<dbltest(oper,lval2,lval1),sALT);
dvander@27:                    /* ^ doubling of constants operating on integer addresses */
dvander@27:                    /*   is restricted to "add" and "subtract" operators */
dvander@27:   } else {                          /* non-constant on left side */
dvander@27:     pushreg(sPRI);
dvander@27:     if (plnge1(hier,lval2))
dvander@27:       rvalue(lval2);
dvander@27:     if (lval2->ident==iCONSTEXPR) { /* constant on right side */
dvander@27:       if (commutative(oper)) {      /* test for commutative operators */
dvander@27:         value lvaltmp = {0};
dvander@27:         stgdel(index,cidx);         /* scratch pushreg() and constant fetch (then
dvander@27:                                      * fetch the constant again */
dvander@27:         ldconst(lval2->constval<<dbltest(oper,lval1,lval2),sALT);
dvander@27:         /* now, the primary register has the left operand and the secondary
dvander@27:          * register the right operand; swap the "lval" variables so that lval1
dvander@27:          * is associated with the secondary register and lval2 with the
dvander@27:          * primary register, as is the "normal" case.
dvander@27:          */
dvander@27:         lvaltmp=*lval1;
dvander@27:         *lval1=*lval2;
dvander@27:         *lval2=lvaltmp;
dvander@27:       } else {
dvander@27:         ldconst(lval2->constval<<dbltest(oper,lval1,lval2),sPRI);
dvander@27:         popreg(sALT);   /* pop result of left operand into secondary register */
dvander@27:       } /* if */
dvander@27:     } else {            /* non-constants on both sides */
dvander@27:       popreg(sALT);
dvander@27:       if (dbltest(oper,lval1,lval2))
dvander@27:         cell2addr();                    /* double primary register */
dvander@27:       if (dbltest(oper,lval2,lval1))
dvander@27:         cell2addr_alt();                /* double secondary register */
dvander@27:     } /* if */
dvander@27:   } /* if */
dvander@27:   if (oper) {
dvander@27:     /* If used in an expression, a function should return a value.
dvander@27:      * If the function has been defined, we can check this. If the
dvander@27:      * function was not defined, we can set this requirement (so that
dvander@27:      * a future function definition can check this bit.
dvander@27:      */
dvander@27:     checkfunction(lval1);
dvander@27:     checkfunction(lval2);
dvander@27:     if (lval1->ident==iARRAY || lval1->ident==iREFARRAY) {
dvander@27:       char *ptr=(lval1->sym!=NULL) ? lval1->sym->name : "-unknown-";
dvander@27:       error(33,ptr);                    /* array must be indexed */
dvander@27:     } else if (lval2->ident==iARRAY || lval2->ident==iREFARRAY) {
dvander@27:       char *ptr=(lval2->sym!=NULL) ? lval2->sym->name : "-unknown-";
dvander@27:       error(33,ptr);                    /* array must be indexed */
dvander@27:     } /* if */
dvander@27:     /* ??? ^^^ should do same kind of error checking with functions */
dvander@27: 
dvander@27:     /* check whether an "operator" function is defined for the tag names
dvander@27:      * (a constant expression cannot be optimized in that case)
dvander@27:      */
dvander@27:     if (check_userop(oper,lval1->tag,lval2->tag,2,NULL,&lval1->tag)) {
dvander@27:       lval1->ident=iEXPRESSION;
dvander@27:       lval1->constval=0;
dvander@27:     } else if (lval1->ident==iCONSTEXPR && lval2->ident==iCONSTEXPR) {
dvander@27:       /* only constant expression if both constant */
dvander@27:       stgdel(index,cidx);       /* scratch generated code and calculate */
dvander@27:       if (!matchtag(lval1->tag,lval2->tag,FALSE))
dvander@27:         error(213);             /* tagname mismatch */
dvander@27:       lval1->constval=calc(lval1->constval,oper,lval2->constval,&lval1->boolresult);
dvander@27:     } else {
dvander@151:       if (!checktag_string(lval1, lval2) && !matchtag(lval1->tag,lval2->tag,FALSE))
dvander@27:         error(213);             /* tagname mismatch */
dvander@27:       (*oper)();                /* do the (signed) operation */
dvander@27:       lval1->ident=iEXPRESSION;
dvander@27:     } /* if */
dvander@27:   } /* if */
dvander@27: }
dvander@27: 
faluco@62: static cell flooreddiv(cell a,cell b,int return_remainder)
dvander@27: {
faluco@62:   cell q,r;
faluco@62: 
faluco@62:   if (b==0) {
faluco@62:     error(29);
faluco@62:     return 0;
faluco@62:   } /* if */
faluco@62:   /* first implement truncated division in a portable way */
faluco@62:   #define IABS(a)       ((a)>=0 ? (a) : (-a))
faluco@62:   q=IABS(a)/IABS(b);
faluco@62:   if ((cell)(a ^ b)<0)
faluco@62:     q=-q;               /* swap sign if either "a" or "b" is negative (but not both) */
faluco@62:   r=a-q*b;              /* calculate the matching remainder */
faluco@62:   /* now "fiddle" with the values to get floored division */
faluco@62:   if (r!=0 && (cell)(r ^ b)<0) {
faluco@62:     q--;
faluco@62:     r+=b;
faluco@62:   } /* if */
faluco@62:   return return_remainder ? r : q;
dvander@27: }
dvander@27: 
dvander@27: static cell calc(cell left,void (*oper)(),cell right,char *boolresult)
dvander@27: {
dvander@27:   if (oper==ob_or)
dvander@27:     return (left | right);
dvander@27:   else if (oper==ob_xor)
dvander@27:     return (left ^ right);
dvander@27:   else if (oper==ob_and)
dvander@27:     return (left & right);
dvander@27:   else if (oper==ob_eq)
dvander@27:     return (left == right);
dvander@27:   else if (oper==ob_ne)
dvander@27:     return (left != right);
dvander@27:   else if (oper==os_le)
dvander@27:     return *boolresult &= (char)(left <= right), right;
dvander@27:   else if (oper==os_ge)
dvander@27:     return *boolresult &= (char)(left >= right), right;
dvander@27:   else if (oper==os_lt)
dvander@27:     return *boolresult &= (char)(left < right), right;
dvander@27:   else if (oper==os_gt)
dvander@27:     return *boolresult &= (char)(left > right), right;
dvander@27:   else if (oper==os_sar)
dvander@27:     return (left >> (int)right);
dvander@27:   else if (oper==ou_sar)
dvander@27:     return ((ucell)left >> (ucell)right);
dvander@27:   else if (oper==ob_sal)
dvander@27:     return ((ucell)left << (int)right);
dvander@27:   else if (oper==ob_add)
dvander@27:     return (left + right);
dvander@27:   else if (oper==ob_sub)
dvander@27:     return (left - right);
dvander@27:   else if (oper==os_mult)
dvander@27:     return (left * right);
dvander@27:   else if (oper==os_div)
faluco@62:     return flooreddiv(left,right,0);
dvander@27:   else if (oper==os_mod)
faluco@62:     return flooreddiv(left,right,1);
dvander@27:   else
dvander@27:     error(29);  /* invalid expression, assumed 0 (this should never occur) */
dvander@27:   return 0;
dvander@27: }
dvander@27: 
dvander@152: SC_FUNC int expression(cell *val,int *tag,symbol **symptr,int chkfuncresult,value *_lval)
dvander@27: {
dvander@27:   value lval={0};
dvander@64:   pushheaplist();
dvander@27: 
dvander@27:   if (hier14(&lval))
dvander@27:     rvalue(&lval);
dvander@27:   /* scrap any arrays left on the heap */
dvander@64:   popheaplist();
dvander@27: 
dvander@27:   if (lval.ident==iCONSTEXPR && val!=NULL)    /* constant expression */
dvander@27:     *val=lval.constval;
dvander@27:   if (tag!=NULL)
dvander@27:     *tag=lval.tag;
dvander@27:   if (symptr!=NULL)
dvander@27:     *symptr=lval.sym;
dvander@27:   if (chkfuncresult)
dvander@27:     checkfunction(&lval);
dvander@152:   if (_lval)
dvander@152:     *_lval=lval;
dvander@27:   return lval.ident;
dvander@27: }
dvander@27: 
dvander@27: SC_FUNC int sc_getstateid(constvalue **automaton,constvalue **state)
dvander@27: {
dvander@27:   char name[sNAMEMAX+1];
dvander@27:   cell val;
dvander@27:   char *str;
dvander@27:   int fsa,islabel;
dvander@27: 
dvander@27:   assert(automaton!=NULL);
dvander@27:   assert(state!=NULL);
dvander@27:   if (!(islabel=matchtoken(tLABEL)) && !needtoken(tSYMBOL))
dvander@27:     return 0;
dvander@27: 
dvander@27:   tokeninfo(&val,&str);
dvander@27:   assert(strlen(str)<sizeof name);
dvander@27:   strcpy(name,str);
dvander@27:   if (islabel || matchtoken(':')) {
dvander@27:     /* token is an automaton name, add the name and get a new token */
dvander@27:     *automaton=automaton_find(name);
dvander@27:     /* read in the state name before checking the automaton, to keep the parser
dvander@27:      * going (an "unknown automaton" error may occur when the "state" instruction
dvander@27:      * precedes any state definition)
dvander@27:      */
dvander@27:     if (!needtoken(tSYMBOL))
dvander@27:       return 0;
dvander@27:     tokeninfo(&val,&str);        /* do not copy the name yet, must check automaton first */
dvander@27:     if (*automaton==NULL) {
dvander@27:       error(86,name);            /* unknown automaton */
dvander@27:       return 0;
dvander@27:     } /* if */
dvander@27:     assert((*automaton)->index>0);
dvander@27:     assert(strlen(str)<sizeof name);
dvander@27:     strcpy(name,str);
dvander@27:   } else {
dvander@27:     *automaton=automaton_find("");
dvander@27:     assert(*automaton!=NULL);
dvander@27:     assert((*automaton)->index==0);
dvander@27:   } /* if */
dvander@27:   assert(*automaton!=NULL);
dvander@27:   fsa=(*automaton)->index;
dvander@27: 
dvander@27:   assert(*automaton!=NULL);
dvander@27:   *state=state_find(name,fsa);
dvander@27:   if (*state==NULL) {
dvander@27:     char *fsaname=(*automaton)->name;
dvander@27:     if (*fsaname=='\0')
dvander@27:       fsaname="<main>";
dvander@27:     error(87,name,fsaname);   /* unknown state for automaton */
dvander@27:     return 0;
dvander@27:   } /* if */
dvander@27: 
dvander@27:   return 1;
dvander@27: }
dvander@27: 
dvander@27: SC_FUNC cell array_totalsize(symbol *sym)
dvander@27: {
dvander@27:   cell length;
dvander@27: 
dvander@27:   assert(sym!=NULL);
dvander@27:   assert(sym->ident==iARRAY || sym->ident==iREFARRAY);
dvander@27:   length=sym->dim.array.length;
dvander@27:   if (sym->dim.array.level > 0) {
dvander@27:     cell sublength=array_totalsize(finddepend(sym));
dvander@27:     if (sublength>0)
dvander@27:       length=length+length*sublength;
dvander@27:     else
dvander@27:       length=0;
dvander@27:   } /* if */
dvander@27:   return length;
dvander@27: }
dvander@27: 
dvander@27: static cell array_levelsize(symbol *sym,int level)
dvander@27: {
dvander@27:   assert(sym!=NULL);
dvander@27:   assert(sym->ident==iARRAY || sym->ident==iREFARRAY);
dvander@27:   assert(level <= sym->dim.array.level);
dvander@27:   while (level-- > 0) {
dvander@27:     sym=finddepend(sym);
dvander@27:     assert(sym!=NULL);
dvander@27:   } /* if */
dvander@286:   return (sym->dim.array.slength ? sym->dim.array.slength : sym->dim.array.length);
dvander@27: }
dvander@27: 
dvander@27: /*  hier14
dvander@27:  *
dvander@27:  *  Lowest hierarchy level (except for the , operator).
dvander@27:  *
dvander@27:  *  Global references: sc_intest        (reffered to only)
dvander@27:  *                     sc_allowproccall (modified)
dvander@27:  */
dvander@27: static int hier14(value *lval1)
dvander@27: {
dvander@27:   int lvalue;
dvander@27:   value lval2={0},lval3={0};
dvander@27:   void (*oper)(void);
dvander@27:   int tok,level,i;
dvander@27:   cell val;
dvander@27:   char *st;
dvander@27:   int bwcount,leftarray;
dvander@27:   cell arrayidx1[sDIMEN_MAX],arrayidx2[sDIMEN_MAX];  /* last used array indices */
dvander@27:   cell *org_arrayidx;
dvander@27: 
dvander@27:   bwcount=bitwise_opercount;
dvander@27:   bitwise_opercount=0;
dvander@27:   /* initialize the index arrays with unlikely constant indices; note that
dvander@27:    * these indices will only be changed when the array is indexed with a
dvander@27:    * constant, and that negative array indices are invalid (so actually, any
dvander@27:    * negative value would do).
dvander@27:    */
dvander@27:   for (i=0; i<sDIMEN_MAX; i++)
dvander@27:     arrayidx1[i]=arrayidx2[i]=(cell)(-1L << (sizeof(cell)*8-1));
dvander@27:   org_arrayidx=lval1->arrayidx; /* save current pointer, to reset later */
dvander@27:   if (lval1->arrayidx==NULL)
dvander@27:     lval1->arrayidx=arrayidx1;
dvander@27:   lvalue=plnge1(hier13,lval1);
dvander@27:   if (lval1->ident!=iARRAYCELL && lval1->ident!=iARRAYCHAR)
dvander@27:     lval1->arrayidx=NULL;
dvander@27:   if (lval1->ident==iCONSTEXPR) /* load constant here */
dvander@27:     ldconst(lval1->constval,sPRI);
dvander@27:   tok=lex(&val,&st);
dvander@27:   switch (tok) {
dvander@27:     case taOR:
dvander@27:       oper=ob_or;
dvander@27:       break;
dvander@27:     case taXOR:
dvander@27:       oper=ob_xor;
dvander@27:       break;
dvander@27:     case taAND:
dvander@27:       oper=ob_and;
dvander@27:       break;
dvander@27:     case taADD:
dvander@27:       oper=ob_add;
dvander@27:       break;
dvander@27:     case taSUB:
dvander@27:       oper=ob_sub;
dvander@27:       break;
dvander@27:     case taMULT:
dvander@27:       oper=os_mult;
dvander@27:       break;
dvander@27:     case taDIV:
dvander@27:       oper=os_div;
dvander@27:       break;
dvander@27:     case taMOD:
dvander@27:       oper=os_mod;
dvander@27:       break;
dvander@27:     case taSHRU:
dvander@27:       oper=ou_sar;
dvander@27:       break;
dvander@27:     case taSHR:
dvander@27:       oper=os_sar;
dvander@27:       break;
dvander@27:     case taSHL:
dvander@27:       oper=ob_sal;
dvander@27:       break;
dvander@27:     case '=':           /* simple assignment */
dvander@27:       oper=NULL;
dvander@27:       if (sc_intest)
dvander@27:         error(211);     /* possibly unintended assignment */
dvander@27:       break;
dvander@27:     default:
dvander@27:       lexpush();
dvander@27:       bitwise_opercount=bwcount;
dvander@27:       lval1->arrayidx=org_arrayidx; /* restore array index pointer */
dvander@27:       return lvalue;
dvander@27:   } /* switch */
dvander@27: 
dvander@27:   /* if we get here, it was an assignment; first check a few special cases
dvander@27:    * and then the general */
dvander@27:   if (lval1->ident==iARRAYCHAR) {
dvander@27:     /* special case, assignment to packed character in a cell is permitted */
dvander@27:     lvalue=TRUE;
dvander@27:   } else if (lval1->ident==iARRAY || lval1->ident==iREFARRAY) {
dvander@27:     /* array assignment is permitted too (with restrictions) */
dvander@27:     if (oper)
dvander@27:       return error(23); /* array assignment must be simple assigment */
dvander@27:     assert(lval1->sym!=NULL);
dvander@27:     if (array_totalsize(lval1->sym)==0)
dvander@27:       return error(46,lval1->sym->name);        /* unknown array size */
dvander@27:     lvalue=TRUE;
dvander@27:   } /* if */
dvander@27: 
dvander@27:   /* operand on left side of assignment must be lvalue */
dvander@27:   if (!lvalue)
dvander@27:     return error(22);                   /* must be lvalue */
dvander@27:   /* may not change "constant" parameters */
dvander@27:   assert(lval1->sym!=NULL);
dvander@27:   if ((lval1->sym->usage & uCONST)!=0)
dvander@27:     return error(22);           /* assignment to const argument */
dvander@27:   sc_allowproccall=FALSE;       /* may no longer use "procedure call" syntax */
dvander@27: 
dvander@27:   lval3=*lval1;         /* save symbol to enable storage of expresion result */
dvander@27:   lval1->arrayidx=org_arrayidx; /* restore array index pointer */
dvander@27:   if (lval1->ident==iARRAYCELL || lval1->ident==iARRAYCHAR
dvander@27:       || lval1->ident==iARRAY || lval1->ident==iREFARRAY)
dvander@27:   {
dvander@27:     /* if indirect fetch: save PRI (cell address) */
dvander@27:     if (oper) {
dvander@27:       pushreg(sPRI);
dvander@27:       rvalue(lval1);
dvander@27:     } /* if */
dvander@27:     lval2.arrayidx=arrayidx2;
dvander@27:     plnge2(oper,hier14,lval1,&lval2);
dvander@27:     if (lval2.ident!=iARRAYCELL && lval2.ident!=iARRAYCHAR)
dvander@27:       lval2.arrayidx=NULL;
dvander@27:     if (oper)
dvander@27:       popreg(sALT);
dvander@27:     if (!oper && lval3.arrayidx!=NULL && lval2.arrayidx!=NULL
dvander@27:         && lval3.ident==lval2.ident && lval3.sym==lval2.sym)
dvander@27:     {
dvander@27:       int same=TRUE;
dvander@27:       assert(lval2.arrayidx==arrayidx2);
dvander@27:       for (i=0; i<sDIMEN_MAX; i++)
dvander@27:         same=same && (lval3.arrayidx[i]==lval2.arrayidx[i]);
dvander@27:         if (same)
dvander@27:           error(226,lval3.sym->name);   /* self-assignment */
dvander@27:     } /* if */
dvander@27:   } else {
dvander@27:     if (oper){
dvander@27:       rvalue(lval1);
dvander@27:       plnge2(oper,hier14,lval1,&lval2);
dvander@27:     } else {
dvander@27:       /* if direct fetch and simple assignment: no "push"
dvander@27:        * and "pop" needed -> call hier14() directly, */
dvander@27:       if (hier14(&lval2))
dvander@27:         rvalue(&lval2);         /* instead of plnge2(). */
dvander@27:       else if (lval2.ident==iVARIABLE)
dvander@27:         lval2.ident=iEXPRESSION;/* mark as "rvalue" if it is not an "lvalue" */
dvander@27:       checkfunction(&lval2);
dvander@27:       /* check whether lval2 and lval3 (old lval1) refer to the same variable */
dvander@27:       if (lval2.ident==iVARIABLE && lval3.ident==lval2.ident && lval3.sym==lval2.sym) {
dvander@27:         assert(lval3.sym!=NULL);
dvander@27:         error(226,lval3.sym->name);     /* self-assignment */
dvander@27:       } /* if */
dvander@27:     } /* if */
dvander@27:   } /* if */
dvander@27:   /* Array elements are sometimes considered as sub-arrays --when the
dvander@27:    * array index is an enumeration field and the enumeration size is greater
dvander@27:    * than 1. If the expression on the right side of the assignment is a cell,
dvander@27:    * or if an operation is in effect, this does not apply.
dvander@27:    */
dvander@27:   leftarray= lval3.ident==iARRAY || lval3.ident==iREFARRAY
dvander@27:              || ((lval3.ident==iARRAYCELL || lval3.ident==iARRAYCHAR)
dvander@27:                  && lval3.constval>1 && lval3.sym->dim.array.level==0
dvander@27:                  && !oper && (lval2.ident==iARRAY || lval2.ident==iREFARRAY));
dvander@27:   if (leftarray) {
dvander@27:     /* Left operand is an array, right operand should be an array variable
dvander@27:      * of the same size and the same dimension, an array literal (of the
dvander@27:      * same size) or a literal string. For single-dimensional arrays without
dvander@27:      * tag for the index, it is permitted to assign a smaller array into a
dvander@27:      * larger one (without warning). This is to make it easier to work with
dvander@27:      * strings.
dvander@27:      */
dvander@27:     int exactmatch=TRUE;
dvander@27:     int idxtag=0;
dvander@27:     int ltlength=(int)lval3.sym->dim.array.length;
dvander@27:     if ((lval3.ident==iARRAYCELL || lval3.ident==iARRAYCHAR)
dvander@27:         && lval3.constval>0 && lval3.sym->dim.array.level==0)
dvander@27:     {
dvander@27:       ltlength=(int)lval3.constval;
dvander@27:     } /* if */
dvander@27:     if (lval2.ident!=iARRAY && lval2.ident!=iREFARRAY
dvander@27:         && (lval2.sym==NULL || lval2.constval<=0))
dvander@27:       error(33,lval3.sym->name);        /* array must be indexed */
dvander@27:     if (lval2.sym!=NULL) {
dvander@27:       if (lval2.constval==0) {
dvander@27:         val=lval2.sym->dim.array.length;/* array variable */
dvander@27:       } else {
dvander@27:         val=lval2.constval;
dvander@27:         if (lval2.sym->dim.array.level!=0)
dvander@27:           error(28,lval2.sym->name);
dvander@27:       } /* if */
dvander@27:       level=lval2.sym->dim.array.level;
dvander@27:       idxtag=lval2.sym->x.tags.index;
dvander@27:       if (level==0 && idxtag==0 && lval3.sym->x.tags.index==0)
dvander@27:         exactmatch=FALSE;
dvander@27:     } else {
dvander@27:       val=lval2.constval;               /* literal array */
dvander@27:       level=0;
dvander@27:       /* If val is negative, it means that lval2 is a literal string.
dvander@27:        * The string array size may be smaller than the destination
dvander@27:        * array, provided that the destination array does not have an
dvander@27:        * index tag.
dvander@27:        */
dvander@27:       if (val<0) {
dvander@27:         val=-val;
dvander@27:         if (lval3.sym->x.tags.index==0)
dvander@27:           exactmatch=FALSE;
dvander@27:       } /* if */
dvander@27:     } /* if */
dvander@27:     if (lval3.sym->dim.array.level!=level)
dvander@27:       return error(48); /* array dimensions must match */
dvander@27:     else if (ltlength<val || exactmatch && ltlength>val || val==0)
dvander@27:       return error(47); /* array sizes must match */
dvander@27:     else if (lval3.ident!=iARRAYCELL && !matchtag(lval3.sym->x.tags.index,idxtag,TRUE))
dvander@27:       error(229,(lval2.sym!=NULL) ? lval2.sym->name : lval3.sym->name); /* index tag mismatch */
dvander@27:     if (level>0) {
dvander@27:       /* check the sizes of all sublevels too */
dvander@27:       symbol *sym1 = lval3.sym;
dvander@27:       symbol *sym2 = lval2.sym;
dvander@27:       int i;
dvander@27:       assert(sym1!=NULL && sym2!=NULL);
dvander@27:       /* ^^^ sym2 must be valid, because only variables can be
dvander@27:        *     multi-dimensional (there are no multi-dimensional literals),
dvander@27:        *     sym1 must be valid because it must be an lvalue
dvander@27:        */
dvander@27:       assert(exactmatch);
dvander@27:       for (i=0; i<level; i++) {
dvander@27:         sym1=finddepend(sym1);
dvander@27:         sym2=finddepend(sym2);
dvander@27:         assert(sym1!=NULL && sym2!=NULL);
dvander@27:         /* ^^^ both arrays have the same dimensions (this was checked
dvander@27:          *     earlier) so the dependend should always be found
dvander@27:          */
dvander@27:         if (sym1->dim.array.length!=sym2->dim.array.length)
dvander@27:           error(47);    /* array sizes must match */
dvander@27:         else if (!matchtag(sym1->x.tags.index,sym2->x.tags.index,TRUE))
dvander@27:           error(229,sym2->name);  /* index tag mismatch */
dvander@27:       } /* for */
dvander@27:       /* get the total size in cells of the multi-dimensional array */
dvander@27:       val=array_totalsize(lval3.sym);
dvander@27:       assert(val>0);    /* already checked */
dvander@27:     } /* if */
dvander@27:   } else {
dvander@27:     /* left operand is not an array, right operand should then not be either */
dvander@27:     if (lval2.ident==iARRAY || lval2.ident==iREFARRAY)
dvander@27:       error(6);         /* must be assigned to an array */
dvander@27:   } /* if */
dvander@27:   if (leftarray) {
dvander@27:     memcopy(val*sizeof(cell));
dvander@27:   } else {
dvander@27:     check_userop(NULL,lval2.tag,lval3.tag,2,&lval3,&lval2.tag);
dvander@27:     store(&lval3);      /* now, store the expression result */
dvander@27:   } /* if */
dvander@151:   if (!oper && !checktag_string(&lval3, &lval2) && !matchtag(lval3.tag,lval2.tag,TRUE))
dvander@27:     error(213);         /* tagname mismatch (if "oper", warning already given in plunge2()) */
dvander@27:   if (lval3.sym)
dvander@27:     markusage(lval3.sym,uWRITTEN);
dvander@27:   sideeffect=TRUE;
dvander@27:   bitwise_opercount=bwcount;
dvander@27:   lval1->ident=iEXPRESSION;
dvander@27:   return FALSE;         /* expression result is never an lvalue */
dvander@27: }
dvander@27: 
dvander@64: /**
dvander@64:  * Sums up array usage in the current heap tracer and convert it into a dynamic array.
dvander@64:  * This is used for the ternary operator, which needs to convert its array usage into
dvander@64:  * something dynamically managed.
dvander@64:  * !Note:
dvander@64:  * This might break if expressions can ever return dynamic arrays.
dvander@64:  * Thus, we assert() if something is non-static here.
dvander@64:  * Right now, this poses no problem because this type of expression is impossible:
dvander@64:  *   (a() ? return_array() : return_array()) ? return_array() : return_array()
dvander@64:  */
dvander@64: 
dvander@116: void dynarray_from_heaplist(memuse_list_t *heap)
dvander@64: {
dvander@116:   memuse_t *use=heap->head;
dvander@116:   memuse_t *tmp;
dvander@64:   long total=0;
dvander@64:   while (use) {
dvander@116:     assert(use->type==MEMUSE_STATIC);
dvander@64:     total+=use->size;
dvander@64:     tmp=use->prev;
dvander@64:     free(use);
dvander@64:     use=tmp;
dvander@64:   }
dvander@64:   free(heap);
dvander@64:   if (total)
dvander@65:     setheap_save(-total*sizeof(cell));
dvander@64: }
dvander@64: 
dvander@27: static int hier13(value *lval)
dvander@27: {
dvander@27:   int lvalue=plnge1(hier12,lval);
dvander@27:   if (matchtoken('?')) {
dvander@27:     int flab1=getlabel();
dvander@27:     int flab2=getlabel();
dvander@27:     value lval2={0};
dvander@27:     int array1,array2;
dvander@116:     memuse_list_t *heap;
dvander@64:     
dvander@64:     pushheaplist();
dvander@27:     if (lvalue) {
dvander@27:       rvalue(lval);
dvander@27:     } else if (lval->ident==iCONSTEXPR) {
dvander@27:       ldconst(lval->constval,sPRI);
dvander@27:       error(lval->constval ? 206 : 205);        /* redundant test */
dvander@27:     } /* if */
dvander@27:     jmp_eq0(flab1);             /* go to second expression if primary register==0 */
dvander@27:     PUSHSTK_I(sc_allowtags);
dvander@27:     sc_allowtags=FALSE;         /* do not allow tagnames here (colon is a special token) */
dvander@27:     if (hier13(lval))
dvander@27:       rvalue(lval);
dvander@27:     if (lval->ident==iCONSTEXPR)        /* load constant here */
dvander@27:       ldconst(lval->constval,sPRI);
dvander@27:     sc_allowtags=(short)POPSTK_I();     /* restore */
dvander@64:     heap=popsaveheaplist();
dvander@64:     dynarray_from_heaplist(heap);
dvander@64:     pushheaplist();
dvander@65:     jumplabel(flab2);
dvander@65:     setlabel(flab1);
dvander@27:     needtoken(':');
dvander@27:     if (hier13(&lval2))
dvander@27:       rvalue(&lval2);
dvander@27:     if (lval2.ident==iCONSTEXPR)        /* load constant here */
dvander@27:       ldconst(lval2.constval,sPRI);
dvander@27:     array1= (lval->ident==iARRAY || lval->ident==iREFARRAY);
dvander@27:     array2= (lval2.ident==iARRAY || lval2.ident==iREFARRAY);
dvander@27:     if (array1 && !array2) {
dvander@27:       char *ptr=(lval->sym->name!=NULL) ? lval->sym->name : "-unknown-";
dvander@27:       error(33,ptr);            /* array must be indexed */
dvander@27:     } else if (!array1 && array2) {
dvander@27:       char *ptr=(lval2.sym->name!=NULL) ? lval2.sym->name : "-unknown-";
dvander@27:       error(33,ptr);            /* array must be indexed */
dvander@27:     } /* if */
dvander@27:     /* ??? if both are arrays, should check dimensions */
dvander@27:     if (!matchtag(lval->tag,lval2.tag,FALSE))
dvander@27:       error(213);               /* tagname mismatch ('true' and 'false' expressions) */
dvander@64:     heap=popsaveheaplist();
dvander@64:     dynarray_from_heaplist(heap);
dvander@65:     setlabel(flab2);
dvander@66:     if (array1 && array2) {
dvander@116:       markheap(MEMUSE_DYNAMIC, 0);
dvander@66:     }
dvander@27:     if (lval->ident==iARRAY)
dvander@27:       lval->ident=iREFARRAY;    /* iARRAY becomes iREFARRAY */
dvander@27:     else if (lval->ident!=iREFARRAY)
dvander@27:       lval->ident=iEXPRESSION;  /* iREFARRAY stays iREFARRAY, rest becomes iEXPRESSION */
dvander@27:     return FALSE;               /* conditional expression is no lvalue */
dvander@27:   } else {
dvander@27:     return lvalue;
dvander@27:   } /* if */
dvander@27: }
dvander@27: 
dvander@27: /* the order of the operators in these lists is important and must be
dvander@27:  * the same as the order of the operators in the array "op1"
dvander@27:  */
dvander@27: static int list3[]  = {'*','/','%',0};
dvander@27: static int list4[]  = {'+','-',0};
dvander@27: static int list5[]  = {tSHL,tSHR,tSHRU,0};
dvander@27: static int list6[]  = {'&',0};
dvander@27: static int list7[]  = {'^',0};
dvander@27: static int list8[]  = {'|',0};
dvander@27: static int list9[]  = {tlLE,tlGE,'<','>',0};
dvander@27: static int list10[] = {tlEQ,tlNE,0};
dvander@27: static int list11[] = {tlAND,0};
dvander@27: static int list12[] = {tlOR,0};
dvander@27: 
dvander@27: static int hier12(value *lval)
dvander@27: {
dvander@27:   return skim(list12,jmp_ne0,1,0,hier11,lval);
dvander@27: }
dvander@27: 
dvander@27: static int hier11(value *lval)
dvander@27: {
dvander@27:   return skim(list11,jmp_eq0,0,1,hier10,lval);
dvander@27: }
dvander@27: 
dvander@27: static int hier10(value *lval)
dvander@27: { /* ==, != */
dvander@27:   return plnge(list10,15,hier9,lval,"bool",TRUE);
dvander@27: }                  /* ^ this variable is the starting index in the op1[]
dvander@27:                     *   array of the operators of this hierarchy level */
dvander@27: 
dvander@27: static int hier9(value *lval)
dvander@27: { /* <=, >=, <, > */
dvander@27:   return plnge_rel(list9,11,hier8,lval);
dvander@27: }
dvander@27: 
dvander@27: static int hier8(value *lval)
dvander@27: { /* | */
dvander@27:   return plnge(list8,10,hier7,lval,NULL,FALSE);
dvander@27: }
dvander@27: 
dvander@27: static int hier7(value *lval)
dvander@27: { /* ^ */
dvander@27:   return plnge(list7,9,hier6,lval,NULL,FALSE);
dvander@27: }
dvander@27: 
dvander@27: static int hier6(value *lval)
dvander@27: { /* & */
dvander@27:   return plnge(list6,8,hier5,lval,NULL,FALSE);
dvander@27: }
dvander@27: 
dvander@27: static int hier5(value *lval)
dvander@27: { /* <<, >>, >>> */
dvander@27:   return plnge(list5,5,hier4,lval,NULL,FALSE);
dvander@27: }
dvander@27: 
dvander@27: static int hier4(value *lval)
dvander@27: { /* +, - */
dvander@27:   return plnge(list4,3,hier3,lval,NULL,FALSE);
dvander@27: }
dvander@27: 
dvander@27: static int hier3(value *lval)
dvander@27: { /* *, /, % */
dvander@27:   return plnge(list3,0,hier2,lval,NULL,FALSE);
dvander@27: }
dvander@27: 
dvander@27: static int hier2(value *lval)
dvander@27: {
dvander@27:   int lvalue,tok;
dvander@27:   int tag,paranthese;
dvander@27:   cell val;
dvander@27:   char *st;
dvander@27:   symbol *sym;
dvander@27:   int saveresult;
dvander@27: 
dvander@27:   tok=lex(&val,&st);
dvander@27:   switch (tok) {
dvander@27:   case tINC:                    /* ++lval */
dvander@27:     if (!hier2(lval))
dvander@27:       return error(22);         /* must be lvalue */
dvander@27:     assert(lval->sym!=NULL);
dvander@27:     if ((lval->sym->usage & uCONST)!=0)
dvander@27:       return error(22);         /* assignment to const argument */
dvander@27:     if (!check_userop(user_inc,lval->tag,0,1,lval,&lval->tag))
dvander@27:       inc(lval);                /* increase variable first */
dvander@27:     rvalue(lval);               /* and read the result into PRI */
dvander@27:     sideeffect=TRUE;
dvander@27:     return FALSE;               /* result is no longer lvalue */
dvander@27:   case tDEC:                    /* --lval */
dvander@27:     if (!hier2(lval))
dvander@27:       return error(22);         /* must be lvalue */
dvander@27:     assert(lval->sym!=NULL);
dvander@27:     if ((lval->sym->usage & uCONST)!=0)
dvander@27:       return error(22);         /* assignment to const argument */
dvander@27:     if (!check_userop(user_dec,lval->tag,0,1,lval,&lval->tag))
dvander@27:       dec(lval);                /* decrease variable first */
dvander@27:     rvalue(lval);               /* and read the result into PRI */
dvander@27:     sideeffect=TRUE;
dvander@27:     return FALSE;               /* result is no longer lvalue */
dvander@27:   case '~':                     /* ~ (one's complement) */
dvander@27:     if (hier2(lval))
dvander@27:       rvalue(lval);
dvander@27:     invert();                   /* bitwise NOT */
dvander@27:     lval->constval=~lval->constval;
dvander@27:     return FALSE;
dvander@27:   case '!':                     /* ! (logical negate) */
dvander@27:     if (hier2(lval))
dvander@27:       rvalue(lval);
dvander@27:     if (check_userop(lneg,lval->tag,0,1,NULL,&lval->tag)) {
dvander@27:       lval->ident=iEXPRESSION;
dvander@27:       lval->constval=0;
dvander@27:     } else {
dvander@27:       lneg();                   /* 0 -> 1,  !0 -> 0 */
dvander@27:       lval->constval=!lval->constval;
dvander@27:       lval->tag=pc_addtag("bool");
dvander@27:     } /* if */
dvander@27:     return FALSE;
dvander@27:   case '-':                     /* unary - (two's complement) */
dvander@27:     if (hier2(lval))
dvander@27:       rvalue(lval);
dvander@27:     /* make a special check for a constant expression with the tag of a
dvander@27:      * rational number, so that we can simple swap the sign of that constant.
dvander@27:      */
dvander@27:     if (lval->ident==iCONSTEXPR && lval->tag==sc_rationaltag && sc_rationaltag!=0) {
dvander@27:       if (rational_digits==0) {
dvander@27:         #if PAWN_CELL_SIZE==32
dvander@27:           float *f = (float *)&lval->constval;
dvander@27:         #elif PAWN_CELL_SIZE==64
dvander@27:           double *f = (double *)&lval->constval;
dvander@27:         #else
dvander@27:           #error Unsupported cell size
dvander@27:         #endif
dvander@27:         *f= - *f; /* this modifies lval->constval */
dvander@27:       } else {
dvander@27:         /* the negation of a fixed point number is just an integer negation */
dvander@27:         lval->constval=-lval->constval;
dvander@27:       } /* if */
dvander@27:     } else if (check_userop(neg,lval->tag,0,1,NULL,&lval->tag)) {
dvander@27:       lval->ident=iEXPRESSION;
dvander@27:       lval->constval=0;
dvander@27:     } else {
dvander@27:       neg();                    /* arithmic negation */
dvander@27:       lval->constval=-lval->constval;
dvander@27:     } /* if */
dvander@27:     return FALSE;
dvander@27:   case tLABEL:                  /* tagname override */
dvander@27:     tag=pc_addtag(st);
dvander@27:     lval->cmptag=tag;
dvander@27:     lvalue=hier2(lval);
dvander@27:     lval->tag=tag;
dvander@27:     return lvalue;
dvander@27:   case tDEFINED:
dvander@27:     paranthese=0;
dvander@27:     while (matchtoken('('))
dvander@27:       paranthese++;
dvander@27:     tok=lex(&val,&st);
dvander@27:     if (tok!=tSYMBOL)
dvander@27:       return error(20,st);      /* illegal symbol name */
dvander@27:     sym=findloc(st);
dvander@27:     if (sym==NULL)
dvander@27:       sym=findglb(st,sSTATEVAR);
dvander@27:     if (sym!=NULL && sym->ident!=iFUNCTN && sym->ident!=iREFFUNC && (sym->usage & uDEFINE)==0)
dvander@27:       sym=NULL;                 /* symbol is not a function, it is in the table, but not "defined" */
dvander@27:     val= (sym!=NULL);
dvander@27:     if (!val && find_subst(st,strlen(st))!=NULL)
dvander@27:       val=1;
dvander@27:     clear_value(lval);
dvander@27:     lval->ident=iCONSTEXPR;
dvander@27:     lval->constval= val;
dvander@27:     lval->tag=pc_addtag("bool");
dvander@27:     ldconst(lval->constval,sPRI);
dvander@27:     while (paranthese--)
dvander@27:       needtoken(')');
dvander@27:     return FALSE;
dvander@27:   case tSIZEOF:
dvander@27:     paranthese=0;
dvander@27:     while (matchtoken('('))
dvander@27:       paranthese++;
dvander@27:     tok=lex(&val,&st);
dvander@27:     if (tok!=tSYMBOL)
dvander@27:       return error(20,st);      /* illegal symbol name */
dvander@27:     sym=findloc(st);
dvander@27:     if (sym==NULL)
dvander@27:       sym=findglb(st,sSTATEVAR);
dvander@27:     if (sym==NULL)
dvander@27:       return error(17,st);      /* undefined symbol */
dvander@27:     if (sym->ident==iCONSTEXPR)
dvander@27:       error(39);                /* constant symbol has no size */
dvander@27:     else if (sym->ident==iFUNCTN || sym->ident==iREFFUNC)
dvander@27:       error(72);                /* "function" symbol has no size */
dvander@27:     else if ((sym->usage & uDEFINE)==0)
dvander@27:       return error(17,st);      /* undefined symbol (symbol is in the table, but it is "used" only) */
dvander@27:     clear_value(lval);
dvander@27:     lval->ident=iCONSTEXPR;
dvander@27:     lval->constval=1;           /* preset */
dvander@27:     if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
dvander@27:       int level;
dvander@27:       symbol *idxsym=NULL;
dvander@27:       symbol *subsym=sym;
dvander@27:       for (level=0; matchtoken('['); level++) {
dvander@27:         idxsym=NULL;
dvander@27:         if (subsym!=NULL && level==subsym->dim.array.level && matchtoken(tSYMBOL)) {
dvander@27:           char *idxname;
dvander@27:           int cmptag=subsym->x.tags.index;
dvander@27:           tokeninfo(&val,&idxname);
dvander@27:           if ((idxsym=findconst(idxname,&cmptag))==NULL)
dvander@27:             error(80,idxname);  /* unknown symbol, or non-constant */
dvander@27:           else if (cmptag>1)
dvander@27:             error(91,idxname);  /* ambiguous constant */
dvander@27:         } /* if */
dvander@27:         needtoken(']');
dvander@27:         if (subsym!=NULL)
dvander@27:           subsym=finddepend(subsym);
dvander@27:       } /* for */
dvander@286: 	  if (level>sym->dim.array.level+1) {
dvander@27:         error(28,sym->name);  /* invalid subscript */
dvander@286:       } else if (level==sym->dim.array.level+1) {
dvander@27:         lval->constval= (idxsym!=NULL && idxsym->dim.array.length>0) ? idxsym->dim.array.length : 1;
dvander@286:       } else {
dvander@27:         lval->constval=array_levelsize(sym,level);
dvander@286:       }
dvander@286:       if (lval->constval==0 && strchr((char *)lptr,PREPROC_TERM)==NULL)
dvander@286:         error(224,st);          /* indeterminate array size in "sizeof" expression */
dvander@286:     } /* if */
dvander@286:     ldconst(lval->constval,sPRI);
dvander@286:     while (paranthese--)
dvander@286:       needtoken(')');
dvander@286:     return FALSE;
dvander@286:   case tCELLSOF:
dvander@286:     paranthese=0;
dvander@286:     while (matchtoken('('))
dvander@286:       paranthese++;
dvander@286:     tok=lex(&val,&st);
dvander@286:     if (tok!=tSYMBOL)
dvander@286:       return error(20,st);      /* illegal symbol name */
dvander@286:     sym=findloc(st);
dvander@286:     if (sym==NULL)
dvander@286:       sym=findglb(st,sSTATEVAR);
dvander@286:     if (sym==NULL)
dvander@286:       return error(17,st);      /* undefined symbol */
dvander@286:     if (sym->ident==iCONSTEXPR)
dvander@286:       error(39);                /* constant symbol has no size */
dvander@286:     else if (sym->ident==iFUNCTN || sym->ident==iREFFUNC)
dvander@286:       error(72);                /* "function" symbol has no size */
dvander@286:     else if ((sym->usage & uDEFINE)==0)
dvander@286:       return error(17,st);      /* undefined symbol (symbol is in the table, but it is "used" only) */
dvander@286:     clear_value(lval);
dvander@286:     lval->ident=iCONSTEXPR;
dvander@286:     lval->constval=1;           /* preset */
dvander@286:     if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
dvander@286:       int level;
dvander@286:       symbol *idxsym=NULL;
dvander@286:       symbol *subsym=sym;
dvander@286:       for (level=0; matchtoken('['); level++) {
dvander@286:         idxsym=NULL;
dvander@286:         if (subsym!=NULL && level==subsym->dim.array.level && matchtoken(tSYMBOL)) {
dvander@286:           char *idxname;
dvander@286:           int cmptag=subsym->x.tags.index;
dvander@286:           tokeninfo(&val,&idxname);
dvander@286:           if ((idxsym=findconst(idxname,&cmptag))==NULL)
dvander@286:             error(80,idxname);  /* unknown symbol, or non-constant */
dvander@286:           else if (cmptag>1)
dvander@286:             error(91,idxname);  /* ambiguous constant */
dvander@286:         } /* if */
dvander@286:         needtoken(']');
dvander@286:         if (subsym!=NULL)
dvander@286:           subsym=finddepend(subsym);
dvander@286:       } /* for */
dvander@286: 	  if (level>sym->dim.array.level+1) {
dvander@286:         error(28,sym->name);  /* invalid subscript */
dvander@286:       } else if (level==sym->dim.array.level+1) {
dvander@286:         lval->constval= (idxsym!=NULL && idxsym->dim.array.length>0) ? idxsym->dim.array.length : 1;
dvander@286:       } else {
dvander@286:         lval->constval=array_levelsize(sym,level);
dvander@286:       }
dvander@27:       if (lval->constval==0 && strchr((char *)lptr,PREPROC_TERM)==NULL)
dvander@27:         error(224,st);          /* indeterminate array size in "sizeof" expression */
dvander@27:     } /* if */
dvander@27:     ldconst(lval->constval,sPRI);
dvander@27:     while (paranthese--)
dvander@27:       needtoken(')');
dvander@27:     return FALSE;
dvander@27:   case tTAGOF:
dvander@27:     paranthese=0;
dvander@27:     while (matchtoken('('))
dvander@27:       paranthese++;
dvander@27:     tok=lex(&val,&st);
dvander@27:     if (tok!=tSYMBOL && tok!=tLABEL)
dvander@27:       return error(20,st);      /* illegal symbol name */
dvander@27:     if (tok==tLABEL) {
dvander@27:       constvalue *tagsym=find_constval(&tagname_tab,st,0);
dvander@27:       tag=(int)((tagsym!=NULL) ? tagsym->value : 0);
dvander@27:     } else {
dvander@27:       sym=findloc(st);
dvander@27:       if (sym==NULL)
dvander@27:         sym=findglb(st,sSTATEVAR);
dvander@27:       if (sym==NULL)
dvander@27:         return error(17,st);      /* undefined symbol */
dvander@27:       if ((sym->usage & uDEFINE)==0)
dvander@27:         return error(17,st);      /* undefined symbol (symbol is in the table, but it is "used" only) */
dvander@27:       tag=sym->tag;
dvander@27:     } /* if */
dvander@27:     if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
dvander@27:       int level;
dvander@27:       symbol *idxsym=NULL;
dvander@27:       symbol *subsym=sym;
dvander@27:       for (level=0; matchtoken('['); level++) {
dvander@27:         idxsym=NULL;
dvander@27:         if (subsym!=NULL && level==subsym->dim.array.level && matchtoken(tSYMBOL)) {
dvander@27:           char *idxname;
dvander@27:           int cmptag=subsym->x.tags.index;
dvander@27:           tokeninfo(&val,&idxname);
dvander@27:           if ((idxsym=findconst(idxname,&cmptag))==NULL)
dvander@27:             error(80,idxname);  /* unknown symbol, or non-constant */
dvander@27:           else if (cmptag>1)
dvander@27:             error(91,idxname);  /* ambiguous constant */
dvander@27:         } /* if */
dvander@27:         needtoken(']');
dvander@27:         if (subsym!=NULL)
dvander@27:           subsym=finddepend(subsym);
dvander@27:       } /* for */
dvander@27:       if (level>sym->dim.array.level+1)
dvander@27:         error(28,sym->name);  /* invalid subscript */
dvander@27:       else if (level==sym->dim.array.level+1 && idxsym!=NULL)
dvander@27:         tag= idxsym->x.tags.index;
dvander@27:     } /* if */
dvander@27:     exporttag(tag);
dvander@27:     clear_value(lval);
dvander@27:     lval->ident=iCONSTEXPR;
dvander@27:     lval->constval=tag | PUBLICTAG;
dvander@27:     ldconst(lval->constval,sPRI);
dvander@27:     while (paranthese--)
dvander@27:       needtoken(')');
dvander@27:     return FALSE;
dvander@27:   case tSTATE: {
dvander@27:     constvalue *automaton;
dvander@27:     constvalue *state;
dvander@27:     if (sc_getstateid(&automaton,&state)) {
dvander@27:       assert(automaton!=NULL);
dvander@27:       assert(automaton->index==0 && automaton->name[0]=='\0' || automaton->index>0);
dvander@27:       loadreg(automaton->value,sALT);
dvander@27:       assert(state!=NULL);
dvander@27:       ldconst(state->value,sPRI);
dvander@27:       ob_eq();
dvander@27:       clear_value(lval);
dvander@27:       lval->ident=iEXPRESSION;
dvander@27:       lval->tag=pc_addtag("bool");
dvander@27:     } /* if */
dvander@27:     return FALSE;
dvander@27:   } /* case */
dvander@27:   default:
dvander@27:     lexpush();
dvander@27:     lvalue=hier1(lval);
dvander@27:     /* check for postfix operators */
dvander@27:     if (matchtoken(';')) {
dvander@27:       /* Found a ';', do not look further for postfix operators */
dvander@27:       lexpush();                /* push ';' back after successful match */
dvander@27:       return lvalue;
dvander@27:     } else if (matchtoken(tTERM)) {
dvander@27:       /* Found a newline that ends a statement (this is the case when
dvander@27:        * semicolons are optional). Note that an explicit semicolon was
dvander@27:        * handled above. This case is similar, except that the token must
dvander@27:        * not be pushed back.
dvander@27:        */
dvander@27:       return lvalue;
dvander@27:     } else {
dvander@27:       tok=lex(&val,&st);
dvander@27:       switch (tok) {
dvander@27:       case tINC:                /* lval++ */
dvander@27:         if (!lvalue)
dvander@27:           return error(22);     /* must be lvalue */
dvander@27:         assert(lval->sym!=NULL);
dvander@27:         if ((lval->sym->usage & uCONST)!=0)
dvander@27:           return error(22);     /* assignment to const argument */
dvander@27:         /* on incrementing array cells, the address in PRI must be saved for
dvander@27:          * incremening the value, whereas the current value must be in PRI
dvander@27:          * on exit.
dvander@27:          */
dvander@27:         saveresult= (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR);
dvander@27:         if (saveresult)
dvander@27:           pushreg(sPRI);        /* save address in PRI */
dvander@27:         rvalue(lval);           /* read current value into PRI */
dvander@27:         if (saveresult)
dvander@27:           swap1();              /* save PRI on the stack, restore address in PRI */
dvander@27:         if (!check_userop(user_inc,lval->tag,0,1,lval,&lval->tag))
dvander@27:           inc(lval);            /* increase variable afterwards */
dvander@27:         if (saveresult)
dvander@27:           popreg(sPRI);         /* restore PRI (result of rvalue()) */
dvander@27:         sideeffect=TRUE;
dvander@27:         return FALSE;           /* result is no longer lvalue */
dvander@27:       case tDEC:                /* lval-- */
dvander@27:         if (!lvalue)
dvander@27:           return error(22);     /* must be lvalue */
dvander@27:         assert(lval->sym!=NULL);
dvander@27:         if ((lval->sym->usage & uCONST)!=0)
dvander@27:           return error(22);     /* assignment to const argument */
dvander@27:         saveresult= (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR);
dvander@27:         if (saveresult)
dvander@27:           pushreg(sPRI);        /* save address in PRI */
dvander@27:         rvalue(lval);           /* read current value into PRI */
dvander@27:         if (saveresult)
dvander@27:           swap1();              /* save PRI on the stack, restore address in PRI */
dvander@27:         if (!check_userop(user_dec,lval->tag,0,1,lval,&lval->tag))
dvander@27:           dec(lval);            /* decrease variable afterwards */
dvander@27:         if (saveresult)
dvander@27:           popreg(sPRI);         /* restore PRI (result of rvalue()) */
dvander@27:         sideeffect=TRUE;
dvander@27:         return FALSE;
dvander@151: /* This is temporarily disabled because we detect it automatically.
dvander@151:  * Thus, it could be weird if both were used at once
dvander@151:  */
dvander@151: #if 0
dvander@27:       case tCHAR:               /* char (compute required # of cells */
dvander@27:         if (lval->ident==iCONSTEXPR) {
dvander@27:           lval->constval *= sCHARBITS/8;  /* from char to bytes */
dvander@27:           lval->constval = (lval->constval + sizeof(cell)-1) / sizeof(cell);
dvander@27:         } else {
dvander@27:           if (lvalue)
dvander@27:             rvalue(lval);       /* fetch value if not already in PRI */
dvander@27:           char2addr();          /* from characters to bytes */
dvander@27:           addconst(sizeof(cell)-1);     /* make sure the value is rounded up */
dvander@27:           addr2cell();          /* truncate to number of cells */
dvander@27:         } /* if */
dvander@27:         return FALSE;
dvander@151: #endif
dvander@27:       default:
dvander@27:         lexpush();
dvander@27:         return lvalue;
dvander@27:       } /* switch */
dvander@27:     } /* if */
dvander@27:   } /* switch */
dvander@27: }
dvander@27: 
dvander@27: /*  hier1
dvander@27:  *
dvander@27:  *  The highest hierarchy level: it looks for pointer and array indices
dvander@27:  *  and function calls.
dvander@27:  *  Generates code to fetch a pointer value if it is indexed and code to
dvander@27:  *  add to the pointer value or the array address (the address is already
dvander@27:  *  read at primary()). It also generates code to fetch a function address
dvander@27:  *  if that hasn't already been done at primary() (check lval[4]) and calls
dvander@27:  *  callfunction() to call the function.
dvander@27:  */
dvander@27: static int hier1(value *lval1)
dvander@27: {
dvander@27:   int lvalue,index,tok,symtok;
dvander@27:   cell val,cidx;
dvander@27:   value lval2={0};
dvander@27:   char *st;
dvander@27:   char close;
dvander@27:   symbol *sym;
dvander@156:   int magic_string=0;
dvander@27:   symbol dummysymbol,*cursym;   /* for changing the index tags in case of enumerated pseudo-arrays */
dvander@27: 
dvander@27:   lvalue=primary(lval1);
dvander@27:   symtok=tokeninfo(&val,&st);   /* get token read by primary() */
dvander@27:   cursym=lval1->sym;
dvander@27: restart:
dvander@27:   sym=cursym;
dvander@27:   if (matchtoken('[') || matchtoken('{') || matchtoken('(')) {
dvander@27:     tok=tokeninfo(&val,&st);    /* get token read by matchtoken() */
dvander@163:     magic_string = (sym && (sym->tag == pc_tag_string && sym->dim.array.level == 0));
dvander@27:     if (sym==NULL && symtok!=tSYMBOL) {
dvander@27:       /* we do not have a valid symbol and we appear not to have read a valid
dvander@27:        * symbol name (so it is unlikely that we would have read a name of an
dvander@27:        * undefined symbol) */
dvander@27:       error(29);                /* expression error, assumed 0 */
dvander@27:       lexpush();                /* analyse '(', '{' or '[' again later */
dvander@27:       return FALSE;
dvander@27:     } /* if */
dvander@27:     if (tok=='[' || tok=='{') { /* subscript */
dvander@27:       close = (char)((tok=='[') ? ']' : '}');
dvander@27:       if (sym==NULL) {  /* sym==NULL if lval is a constant or a literal */
dvander@27:         error(28,"<no variable>");  /* cannot subscript */
dvander@27:         needtoken(close);
dvander@27:         return FALSE;
dvander@27:       } else if (sym->ident!=iARRAY && sym->ident!=iREFARRAY){
dvander@27:         error(28,sym->name);    /* cannot subscript, variable is not an array */
dvander@27:         needtoken(close);
dvander@27:         return FALSE;
dvander@27:       } else if (sym->dim.array.level>0 && close!=']') {
dvander@27:         error(51);      /* invalid subscript, must use [ ] */
dvander@27:         needtoken(close);
dvander@27:         return FALSE;
dvander@27:       } /* if */
dvander@27:       /* set the tag to match (enumeration fields as indices) */
dvander@27:       lval2.cmptag=sym->x.tags.index;
dvander@27:       stgget(&index,&cidx);     /* mark position in code generator */
dvander@27:       pushreg(sPRI);            /* save base address of the array */
dvander@27:       if (hier14(&lval2))       /* create expression for the array index */
dvander@27:         rvalue(&lval2);
dvander@27:       if (lval2.ident==iARRAY || lval2.ident==iREFARRAY)
dvander@27:         error(33,lval2.sym->name);      /* array must be indexed */
dvander@27:       needtoken(close);
dvander@154:       if ((sym->usage & uENUMROOT) && !matchtag(sym->x.tags.index,lval2.tag,TRUE))
dvander@27:         error(213);
dvander@27:       if (lval2.ident==iCONSTEXPR) {    /* constant expression */
dvander@27:         stgdel(index,cidx);             /* scratch generated code */
dvander@27:         if (lval1->arrayidx!=NULL) {    /* keep constant index, for checking */
dvander@27:           assert(sym->dim.array.level>=0 && sym->dim.array.level<sDIMEN_MAX);
dvander@27:           lval1->arrayidx[sym->dim.array.level]=lval2.constval;
dvander@27:         } /* if */
dvander@151:         if (close==']' && !(sym->tag == pc_tag_string && sym->dim.array.level == 0)) {
dvander@27:           /* normal array index */
dvander@27:           if (lval2.constval<0 || sym->dim.array.length!=0 && sym->dim.array.length<=lval2.constval)
dvander@27:             error(32,sym->name);        /* array index out of bounds */
dvander@27:           if (lval2.constval!=0) {
dvander@27:             /* don't add offsets for zero subscripts */
dvander@27:             #if PAWN_CELL_SIZE==16
dvander@27:               ldconst(lval2.constval<<1,sALT);
dvander@27:             #elif PAWN_CELL_SIZE==32
dvander@27:               ldconst(lval2.constval<<2,sALT);
dvander@27:             #elif PAWN_CELL_SIZE==64
dvander@27:               ldconst(lval2.constval<<3,sALT);
dvander@27:             #else
dvander@27:               #error Unsupported cell size
dvander@27:             #endif
dvander@27:             ob_add();
dvander@27:           } /* if */
dvander@27:         } else {
dvander@27:           /* character index */
dvander@27:           if (lval2.constval<0 || sym->dim.array.length!=0
dvander@27:               && sym->dim.array.length*((8*sizeof(cell))/sCHARBITS)<=(ucell)lval2.constval)
dvander@27:             error(32,sym->name);        /* array index out of bounds */
dvander@27:           if (lval2.constval!=0) {
dvander@27:             /* don't add offsets for zero subscripts */
dvander@27:             #if sCHARBITS==16
dvander@27:               ldconst(lval2.constval<<1,sALT);/* 16-bit character */
dvander@27:             #else
dvander@27:               ldconst(lval2.constval,sALT);   /* 8-bit character */
dvander@27:             #endif
dvander@27:             ob_add();
dvander@27:           } /* if */
dvander@27:           charalign();                  /* align character index into array */
dvander@27:         } /* if */
dvander@27:         /* if the array index is a field from an enumeration, get the tag name
dvander@27:          * from the field and save the size of the field too.
dvander@27:          */
dvander@27:         assert(lval2.sym==NULL || lval2.sym->dim.array.level==0);
dvander@27:         if (lval2.sym!=NULL && lval2.sym->dim.array.length>0 && sym->dim.array.level==0) {
dvander@27:           lval1->tag=lval2.sym->x.tags.index;
dvander@27:           lval1->constval=lval2.sym->dim.array.length;
dvander@27:         } /* if */
dvander@27:       } else {
dvander@27:         /* array index is not constant */
dvander@27:         lval1->arrayidx=NULL;           /* reset, so won't be checked */
dvander@156:         if (close==']' && !magic_string) {
dvander@27:           if (sym->dim.array.length!=0)
dvander@27:             ffbounds(sym->dim.array.length-1);  /* run time check for array bounds */
dvander@27:           cell2addr();  /* normal array index */
dvander@27:         } else {
dvander@27:           if (sym->dim.array.length!=0)
dvander@27:             ffbounds(sym->dim.array.length*(32/sCHARBITS)-1);
dvander@27:           char2addr();  /* character array index */
dvander@27:         } /* if */
dvander@27:         popreg(sALT);
dvander@27:         ob_add();       /* base address was popped into secondary register */
dvander@156:         if (close!=']' || magic_string)
dvander@27:           charalign();  /* align character index into array */
dvander@27:       } /* if */
dvander@27:       /* the indexed item may be another array (multi-dimensional arrays) */
dvander@27:       assert(cursym==sym && sym!=NULL); /* should still be set */
dvander@27:       if (sym->dim.array.level>0) {
dvander@27:         assert(close==']');     /* checked earlier */
dvander@27:         assert(cursym==lval1->sym);
dvander@27:         /* read the offset to the subarray and add it to the current address */
dvander@27:         lval1->ident=iARRAYCELL;
dvander@27:         pushreg(sPRI);          /* the optimizer makes this to a MOVE.alt */
dvander@27:         rvalue(lval1);
dvander@27:         popreg(sALT);
dvander@27:         ob_add();
dvander@27:         /* adjust the "value" structure and find the referenced array */
dvander@27:         lval1->ident=iREFARRAY;
dvander@27:         lval1->sym=finddepend(sym);
dvander@27:         assert(lval1->sym!=NULL);
dvander@27:         assert(lval1->sym->dim.array.level==sym->dim.array.level-1);
dvander@27:         cursym=lval1->sym;
dvander@27:         /* try to parse subsequent array indices */
dvander@27:         lvalue=FALSE;   /* for now, a iREFARRAY is no lvalue */
dvander@27:         goto restart;
dvander@27:       } /* if */
dvander@27:       assert(sym->dim.array.level==0);
dvander@27:       /* set type to fetch... INDIRECTLY */
dvander@151:       if (sym->tag == pc_tag_string) {
dvander@151:         lval1->ident = iARRAYCHAR;
dvander@151:       } else {
dvander@151:         lval1->ident= (char)((close==']') ? iARRAYCELL : iARRAYCHAR);
dvander@151:       }
dvander@27:       /* if the array index is a field from an enumeration, get the tag name
dvander@27:        * from the field and save the size of the field too. Otherwise, the
dvander@27:        * tag is the one from the array symbol.
dvander@27:        */
dvander@27:       if (lval2.ident==iCONSTEXPR && lval2.sym!=NULL
dvander@27:           && lval2.sym->dim.array.length>0 && sym->dim.array.level==0)
dvander@27:       {
dvander@27:         lval1->tag=lval2.sym->x.tags.index;
dvander@27:         lval1->constval=lval2.sym->dim.array.length;
dvander@27:         if (lval2.tag==sym->x.tags.index && lval1->constval>1 && matchtoken('[')) {
dvander@27:           /* an array indexed with an enumeration field may be considered a sub-array */
dvander@27:           lexpush();
dvander@27:           lvalue=FALSE;   /* for now, a iREFARRAY is no lvalue */
dvander@27:           lval1->ident=iREFARRAY;
dvander@27:           /* initialize a dummy symbol, which is a copy of the current symbol,
dvander@27:            * but with an adjusted index tag
dvander@27:            */
dvander@27:           assert(sym!=NULL);
dvander@27:           dummysymbol=*sym;
dvander@27:           /* get the tag of the root of the enumeration */
dvander@27:           assert(lval2.sym!=NULL);
dvander@27:           dummysymbol.x.tags.index=lval2.sym->x.tags.field;
dvander@27:           dummysymbol.dim.array.length=lval2.sym->dim.array.length;
dvander@27:           cursym=&dummysymbol;
dvander@27:           /* recurse */
dvander@27:           goto restart;
dvander@27:         } /* if */
dvander@27:       } else {
dvander@27:         assert(sym!=NULL);
dvander@27:         if (cursym!=&dummysymbol)
dvander@27:           lval1->tag=sym->tag;
dvander@27:         lval1->constval=0;
dvander@27:       } /* if */
dvander@27:       /* a cell in an array is an lvalue, a character in an array is not
dvander@27:        * always a *valid* lvalue */
dvander@27:       return TRUE;
dvander@27:     } else {            /* tok=='(' -> function(...) */
dvander@27:       assert(tok=='(');
dvander@27:       if (sym==NULL
dvander@27:           || (sym->ident!=iFUNCTN && sym->ident!=iREFFUNC))
dvander@27:       {
dvander@27:         if (sym==NULL && sc_status==statFIRST) {
dvander@27:           /* could be a "use before declaration"; in that case, create a stub
dvander@27:            * function so that the usage can be marked.
dvander@27:            */
dvander@27:           sym=fetchfunc(lastsymbol,0);
dvander@27:           if (sym==NULL)
dvander@27:             error(103); /* insufficient memory */
dvander@27:           markusage(sym,uREAD);
dvander@27:         } else {
dvander@27:           return error(12);           /* invalid function call */
dvander@27:         } /* if */
dvander@27:       } else if ((sym->usage & uMISSING)!=0) {
dvander@27:         char symname[2*sNAMEMAX+16];  /* allow space for user defined operators */
dvander@27:         funcdisplayname(symname,sym->name);
dvander@27:         error(4,symname);             /* function not defined */
dvander@27:       } /* if */
dvander@27:       callfunction(sym,lval1,TRUE);
dvander@27:       return FALSE;             /* result of function call is no lvalue */
dvander@27:     } /* if */
dvander@27:   } /* if */
dvander@27:   if (sym!=NULL && lval1->ident==iFUNCTN) {
dvander@27:     assert(sym->ident==iFUNCTN);
dvander@27:     if (sc_allowproccall) {
dvander@27:       callfunction(sym,lval1,FALSE);
dvander@27:     } else {
dvander@132:       symbol *oldsym=sym;
dvander@27:       int n=-1,iter=0;
dvander@132:       int usage = ((sym->usage & uPUBLIC) == uPUBLIC) ? uPUBLIC : 0;
dvander@132:       cell code_addr=0;
dvander@27:       for (sym=glbtab.next; sym!=NULL; sym=sym->next) {
dvander@132:         if (sym->ident==iFUNCTN && sym->vclass == sGLOBAL && (!usage || (sym->usage & usage)))
dvander@27:         {
dvander@27:           if (strcmp(sym->name, lval1->sym->name)==0) {
dvander@27:             n = iter;
dvander@132:             code_addr = sym->codeaddr;
dvander@27:             break;
dvander@27:           }
dvander@27:           iter++;
dvander@27:         }
dvander@27:       }
dvander@27:       if (n!=-1) {
dvander@132:         char faketag[sNAMEMAX+1];
dvander@27:         lval1->sym=NULL;
dvander@27:         lval1->ident=iCONSTEXPR;
dvander@132:         /* Generate a quick pseudo-tag! */
dvander@132:         if (usage == uPUBLIC) {
dvander@164:           lval1->constval=(n<<1)|1;
dvander@132:           snprintf(faketag, sizeof(faketag)-1, "$Func@%d", n);
dvander@132:         } else {
dvander@164:           lval1->constval=(code_addr<<1)|0;
dvander@132:           snprintf(faketag, sizeof(faketag)-1, "$Func!%d", code_addr);
dvander@132:         }
dvander@132:         lval1->tag=pc_addfunctag(faketag);
dvander@132:         oldsym->usage |= uREAD;
dvander@343: 		sym->usage |= uREAD;
dvander@27:       } else {
dvander@27:         error(76);                /* invalid function call, or syntax error */
dvander@27:       } /* if */
dvander@27:       return FALSE;
dvander@27:     }
dvander@27:   } /* if */
dvander@27:   return lvalue;
dvander@27: }
dvander@27: 
dvander@27: /*  primary
dvander@27:  *
dvander@27:  *  Returns 1 if the operand is an lvalue (everything except arrays, functions
dvander@27:  *  constants and -of course- errors).
dvander@27:  *  Generates code to fetch the address of arrays. Code for constants is
dvander@27:  *  already generated by constant().
dvander@27:  *  This routine first clears the entire lval array (all fields are set to 0).
dvander@27:  *
dvander@27:  *  Global references: sc_intest  (may be altered, but restored upon termination)
dvander@27:  */
dvander@27: static int primary(value *lval)
dvander@27: {
dvander@27:   char *st;
dvander@27:   int lvalue,tok;
dvander@27:   cell val;
dvander@27:   symbol *sym;
dvander@27: 
dvander@27:   if (matchtoken('(')){         /* sub-expression - (expression,...) */
dvander@27:     PUSHSTK_I(sc_intest);
dvander@27:     PUSHSTK_I(sc_allowtags);
dvander@27: 
dvander@27:     sc_intest=FALSE;            /* no longer in "test" expression */
dvander@27:     sc_allowtags=TRUE;          /* allow tagnames to be used in parenthesized expressions */
dvander@27:     sc_allowproccall=FALSE;
dvander@27:     do
dvander@27:       lvalue=hier14(lval);
dvander@27:     while (matchtoken(','));
dvander@27:     needtoken(')');
dvander@27:     lexclr(FALSE);              /* clear lex() push-back, it should have been
dvander@27:                                  * cleared already by needtoken() */
dvander@27:     sc_allowtags=(short)POPSTK_I();
dvander@27:     sc_intest=(short)POPSTK_I();
dvander@27:     return lvalue;
dvander@27:   } /* if */
dvander@27: 
dvander@27:   clear_value(lval);    /* clear lval */
dvander@27:   tok=lex(&val,&st);
dvander@27:   if (tok==tSYMBOL) {
dvander@27:     /* lastsymbol is char[sNAMEMAX+1], lex() should have truncated any symbol
dvander@27:      * to sNAMEMAX significant characters */
dvander@27:     assert(strlen(st)<sizeof lastsymbol);
dvander@27:     strcpy(lastsymbol,st);
dvander@27:   } /* if */
dvander@27:   if (tok==tSYMBOL && !findconst(st,NULL)) {
dvander@27:     /* first look for a local variable */
dvander@27:     if ((sym=findloc(st))!=0) {
dvander@27:       if (sym->ident==iLABEL) {
dvander@27:         error(29);          /* expression error, assumed 0 */
dvander@27:         ldconst(0,sPRI);    /* load 0 */
dvander@27:         return FALSE;       /* return 0 for labels (expression error) */
dvander@27:       } /* if */
dvander@27:       lval->sym=sym;
dvander@27:       lval->ident=sym->ident;
dvander@27:       lval->tag=sym->tag;
dvander@27:       if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
dvander@27:         address(sym,sPRI);  /* get starting address in primary register */
dvander@27:         return FALSE;       /* return 0 for array (not lvalue) */
dvander@27:       } else {
dvander@27:         return TRUE;        /* return 1 if lvalue (not label or array) */
dvander@27:       } /* if */
dvander@27:     } /* if */
dvander@27:     /* now try a global variable */
dvander@27:     if ((sym=findglb(st,sSTATEVAR))!=0) {
dvander@27:       if (sym->ident==iFUNCTN || sym->ident==iREFFUNC) {
dvander@27:         /* if the function is only in the table because it was inserted as a
dvander@27:          * stub in the first pass (i.e. it was "used" but never declared or
dvander@27:          * implemented, issue an error
dvander@27:          */
dvander@27:         if ((sym->usage & uPROTOTYPED)==0)
dvander@27:           error(17,st);
dvander@27:       } else {
dvander@27:         if ((sym->usage & uDEFINE)==0)
dvander@27:           error(17,st);
dvander@27:         lval->sym=sym;
dvander@27:         lval->ident=sym->ident;
dvander@27:         lval->tag=sym->tag;
dvander@27:         if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
dvander@27:           address(sym,sPRI);    /* get starting address in primary register */
dvander@27:           return FALSE;         /* return 0 for array (not lvalue) */
dvander@27:         } else {
dvander@27:           return TRUE;          /* return 1 if lvalue (not function or array) */
dvander@27:         } /* if */
dvander@27:       } /* if */
dvander@27:     } else {
dvander@27:       if (!sc_allowproccall)
dvander@27:         return error(17,st);    /* undefined symbol */
dvander@27:       /* an unknown symbol, but used in a way compatible with the "procedure
dvander@27:        * call" syntax. So assume that the symbol refers to a function.
dvander@27:        */
dvander@27:       assert(sc_status==statFIRST);
dvander@27:       sym=fetchfunc(st,0);
dvander@27:       if (sym==NULL)
dvander@27:         error(103);     /* insufficient memory */
dvander@27:     } /* if */
dvander@27:     assert(sym!=NULL);
dvander@27:     assert(sym->ident==iFUNCTN || sym->ident==iREFFUNC);
dvander@27:     lval->sym=sym;
dvander@27:     lval->ident=sym->ident;
dvander@27:     lval->tag=sym->tag;
dvander@27:     return FALSE;       /* return 0 for function (not an lvalue) */
dvander@27:   } /* if */
dvander@27:   lexpush();            /* push the token, it is analyzed by constant() */
dvander@27:   if (constant(lval)==0) {
dvander@27:     error(29);          /* expression error, assumed 0 */
dvander@27:     ldconst(0,sPRI);    /* load 0 */
dvander@27:   } /* if */
dvander@27:   return FALSE;         /* return 0 for constants (or errors) */
dvander@27: }
dvander@27: 
dvander@27: static void clear_value(value *lval)
dvander@27: {
dvander@27:   lval->sym=NULL;
dvander@27:   lval->constval=0L;
dvander@27:   lval->tag=0;
dvander@27:   lval->ident=0;
dvander@27:   lval->boolresult=FALSE;
dvander@27:   /* do not clear lval->arrayidx, it is preset in hier14() */
dvander@27:   /* do not clear lval->cmptag */
dvander@27: }
dvander@27: 
dvander@27: static void setdefarray(cell *string,cell size,cell array_sz,cell *dataaddr,int fconst)
dvander@27: {
dvander@27:   /* The routine must copy the default array data onto the heap, as to avoid
dvander@27:    * that a function can change the default value. An optimization is that
dvander@27:    * the default array data is "dumped" into the data segment only once (on the
dvander@27:    * first use).
dvander@27:    */
dvander@27:   assert(string!=NULL);
dvander@27:   assert(size>0);
dvander@27:   /* check whether to dump the default array */
dvander@27:   assert(dataaddr!=NULL);
dvander@27:   if (sc_status==statWRITE && *dataaddr<0) {
dvander@27:     int i;
dvander@27:     *dataaddr=(litidx+glb_declared)*sizeof(cell);
dvander@27:     for (i=0; i<size; i++)
dvander@27:       litadd(*string++);
dvander@27:   } /* if */
dvander@27: 
dvander@27:   /* if the function is known not to modify the array (meaning that it also
dvander@27:    * does not modify the default value), directly pass the address of the
dvander@27:    * array in the data segment.
dvander@27:    */
dvander@27:   if (fconst) {
dvander@27:     ldconst(*dataaddr,sPRI);
dvander@27:   } else {
dvander@27:     /* Generate the code:
dvander@27:      *  CONST.pri dataaddr                ;address of the default array data
dvander@27:      *  HEAP      array_sz*sizeof(cell)   ;heap address in ALT
dvander@27:      *  MOVS      size*sizeof(cell)       ;copy data from PRI to ALT
dvander@27:      *  MOVE.PRI                          ;PRI = address on the heap
dvander@27:      */
dvander@27:     ldconst(*dataaddr,sPRI);
dvander@27:     /* "array_sz" is the size of the argument (the value between the brackets
dvander@27:      * in the declaration), "size" is the size of the default array data.
dvander@27:      */
dvander@27:     assert(array_sz>=size);
dvander@27:     modheap((int)array_sz*sizeof(cell));
dvander@116:     markheap(MEMUSE_STATIC, array_sz);
dvander@27:     /* ??? should perhaps fill with zeros first */
dvander@27:     memcopy(size*sizeof(cell));
dvander@27:     moveto1();
dvander@27:   } /* if */
dvander@27: }
dvander@27: 
dvander@27: static int findnamedarg(arginfo *arg,char *name)
dvander@27: {
dvander@27:   int i;
dvander@27: 
dvander@27:   for (i=0; arg[i].ident!=0 && arg[i].ident!=iVARARGS; i++)
dvander@27:     if (strcmp(arg[i].name,name)==0)
dvander@27:       return i;
dvander@27:   return -1;
dvander@27: }
dvander@27: 
dvander@151: int checktag(int tags[],int numtags,int exprtag)
dvander@27: {
dvander@27:   int i;
dvander@27: 
dvander@27:   assert(tags!=0);
dvander@27:   assert(numtags>0);
dvander@27:   for (i=0; i<numtags; i++)
dvander@27:     if (matchtag(tags[i],exprtag,TRUE))
dvander@27:       return TRUE;    /* matching tag */
dvander@27:   return FALSE;       /* no tag matched */
dvander@27: }
dvander@27: 
dvander@27: enum {
dvander@27:   ARG_UNHANDLED,
dvander@27:   ARG_IGNORED,
dvander@27:   ARG_DONE,
dvander@27: };
dvander@27: 
dvander@27: /*  callfunction
dvander@27:  *
dvander@27:  *  Generates code to call a function. This routine handles default arguments
dvander@27:  *  and positional as well as named parameters.
dvander@27:  */
dvander@27: static void callfunction(symbol *sym,value *lval_result,int matchparanthesis)
dvander@27: {
dvander@27: static long nest_stkusage=0L;
dvander@27: static int nesting=0;
dvander@27:   int close,lvalue;
dvander@27:   int argpos;       /* index in the output stream (argpos==nargs if positional parameters) */
dvander@27:   int argidx=0;     /* index in "arginfo" list */
dvander@27:   int nargs=0;      /* number of arguments */
dvander@27:   int heapalloc=0;
dvander@27:   int namedparams=FALSE;
dvander@27:   value lval = {0};
dvander@27:   arginfo *arg;
dvander@27:   char arglist[sMAXARGS];
dvander@27:   constvalue arrayszlst = { NULL, "", 0, 0};/* array size list starts empty */
dvander@27:   constvalue taglst = { NULL, "", 0, 0};    /* tag list starts empty */
dvander@27:   symbol *symret;
dvander@27:   cell lexval;
dvander@27:   char *lexstr;
dvander@27: 
dvander@27:   assert(sym!=NULL);
dvander@27:   lval_result->ident=iEXPRESSION; /* preset, may be changed later */
dvander@27:   lval_result->constval=0;
dvander@27:   lval_result->tag=sym->tag;
dvander@27:   /* check whether this is a function that returns an array */
dvander@27:   symret=finddepend(sym);
dvander@27:   assert(symret==NULL || symret->ident==iREFARRAY);
dvander@27:   if (symret!=NULL) {
dvander@27:     int retsize;
dvander@27:     /* allocate space on the heap for the array, and pass the pointer to the
dvander@27:      * reserved memory block as a hidden parameter
dvander@27:      */
dvander@27:     retsize=(int)array_totalsize(symret);
dvander@27:     assert(retsize>0);
dvander@27:     modheap(retsize*sizeof(cell));/* address is in ALT */
dvander@27:     pushreg(sALT);                /* pass ALT as the last (hidden) parameter */
dvander@116:     markheap(MEMUSE_STATIC, retsize);
dvander@27:     /* also mark the ident of the result as "array" */
dvander@27:     lval_result->ident=iREFARRAY;
dvander@27:     lval_result->sym=symret;
dvander@27:   } /* if */
dvander@64:   pushheaplist();
dvander@27: 
dvander@27:   nesting++;
dvander@27:   assert(nest_stkusage>=0);
dvander@27:   #if !defined NDEBUG
dvander@27:     if (nesting==1)
dvander@27:       assert(nest_stkusage==0);
dvander@27:   #endif
dvander@27:   sc_allowproccall=FALSE;       /* parameters may not use procedure call syntax */
dvander@27: 
ds@52:   if ((sym->flags & flgDEPRECATED)!=0) {
dvander@27:     char *ptr= (sym->documentation!=NULL) ? sym->documentation : "";
ds@52:     error(234,sym->name,ptr);   /* deprecated (probably a native function) */
dvander@27:   } /* if */
dvander@27: 
dvander@27:   /* run through the arguments */
dvander@27:   arg=sym->dim.arglist;
dvander@27:   assert(arg!=NULL);
dvander@27:   stgmark(sSTARTREORDER);
dvander@27:   memset(arglist,ARG_UNHANDLED,sizeof arglist);
dvander@27:   if (matchparanthesis) {
dvander@27:     /* Opening brace was already parsed, if closing brace follows, this
dvander@27:      * call passes no parameters.
dvander@27:      */
dvander@27:     close=matchtoken(')');
dvander@27:   } else {
dvander@27:     /* When we find an end of line here, it may be a function call passing
dvander@27:      * no parameters, or it may be that the first parameter is on a line
dvander@27:      * below. But as a parameter can be anything, this is difficult to check.
dvander@27:      * The only simple check that we have is the use of "named parameters".
dvander@27:      */
dvander@27:     close=matchtoken(tTERM);
dvander@27:     if (close) {
dvander@27:       close=!matchtoken('.');
dvander@27:       if (!close)
dvander@27:         lexpush();                /* reset the '.' */
dvander@27:     } /* if */
dvander@27:   } /* if */
dvander@27:   if (!close) {
dvander@27:     do {
dvander@27:       if (matchtoken('.')) {
dvander@27:         namedparams=TRUE;
dvander@27:         if (needtoken(tSYMBOL))
dvander@27:           tokeninfo(&lexval,&lexstr);
dvander@27:         else
dvander@27:           lexstr="";
dvander@27:         argpos=findnamedarg(arg,lexstr);
dvander@27:         if (argpos<0) {
dvander@27:           error(17,lexstr);       /* undefined symbol */
dvander@27:           break;                  /* exit loop, argpos is invalid */
dvander@27:         } /* if */
dvander@27:         needtoken('=');
dvander@27:         argidx=argpos;
dvander@27:       } else {
dvander@27:         if (namedparams)
dvander@27:           error(44);   /* positional parameters must precede named parameters */
dvander@27:         argpos=nargs;
dvander@27:       } /* if */
dvander@27:       /* the number of arguments this was already checked at the declaration
dvander@27:        * of the function; check it again for functions with a variable
dvander@27:        * argument list
dvander@27:        */
dvander@27:       if (argpos>=sMAXARGS)
dvander@27:         error(45);                /* too many function arguments */
dvander@27:       stgmark((char)(sEXPRSTART+argpos));/* mark beginning of new expression in stage */
dvander@27:       if (arglist[argpos]!=ARG_UNHANDLED)
dvander@27:         error(58);                /* argument already set */
dvander@27:       if (matchtoken('_')) {
dvander@27:         arglist[argpos]=ARG_IGNORED;  /* flag argument as "present, but ignored" */
dvander@27:         if (arg[argidx].ident==0 || arg[argidx].ident==iVARARGS) {
dvander@27:           error(92);             /* argument count mismatch */
dvander@27:         } else if (!arg[argidx].hasdefault) {
dvander@27:           error(34,nargs+1);      /* argument has no default value */
dvander@27:         } /* if */
dvander@27:         if (arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS)
dvander@27:           argidx++;
dvander@27:         /* The rest of the code to handle default values is at the bottom
dvander@27:          * of this routine where default values for unspecified parameters
dvander@27:          * are (also) handled. Note that above, the argument is flagged as
dvander@27:          * ARG_IGNORED.
dvander@27:          */
dvander@27:       } else {
dvander@27:         arglist[argpos]=ARG_DONE; /* flag argument as "present" */
dvander@27:         if (arg[argidx].numtags==1)     /* set the expected tag, if any */
dvander@27:           lval.cmptag=arg[argidx].tags[0];
dvander@27:         lvalue=hier14(&lval);
dvander@27:         assert(sc_status==statFIRST || arg[argidx].tags!=NULL);
dvander@27:         switch (arg[argidx].ident) {
dvander@27:         case 0:
dvander@27:           error(92);             /* argument count mismatch */
dvander@27:           break;
dvander@27:         case iVARARGS:
dvander@27:           /* always pass by reference */
dvander@27:           if (lval.ident==iVARIABLE || lval.ident==iREFERENCE) {
dvander@27:             assert(lval.sym!=NULL);
dvander@27:             if ((lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0) {
dvander@27:               /* treat a "const" variable passed to a function with a non-const
dvander@27:                * "variable argument list" as a constant here */
dvander@27:               if (!lvalue) {
dvander@27:                 error(22);        /* need lvalue */
dvander@27:               } else {
dvander@27:                 rvalue(&lval);    /* get value in PRI */
dvander@27:                 setheap_pri();    /* address of the value on the heap in PRI */
dvander@116:                 heapalloc+=markheap(MEMUSE_STATIC, 1);
dvander@27:                 nest_stkusage++;
dvander@27:               } /* if */
dvander@27:             } else if (lvalue) {
dvander@27:               address(lval.sym,sPRI);
dvander@27:             } else {
dvander@27:               setheap_pri();      /* address of the value on the heap in PRI */
dvander@116:               heapalloc+=markheap(MEMUSE_STATIC, 1);
dvander@27:               nest_stkusage++;
dvander@27:             } /* if */
dvander@151:           } else if (lval.ident==iCONSTEXPR || lval.ident==iEXPRESSION)
dvander@27:           {
dvander@27:             /* allocate a cell on the heap and store the
dvander@27:              * value (already in PRI) there */
dvander@27:             setheap_pri();        /* address of the value on the heap in PRI */
dvander@116:             heapalloc+=markheap(MEMUSE_STATIC, 1);
dvander@27:             nest_stkusage++;
dvander@27:           } /* if */
dvander@27:           /* ??? handle const array passed by reference */
dvander@27:           /* otherwise, the address is already in PRI */
dvander@27:           if (lval.sym!=NULL)
dvander@27:             markusage(lval.sym,uWRITTEN);
dvander@151:           if (!checktags_string(arg[argidx].tags, arg[argidx].numtags, &lval)
dvander@151:               && !checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
dvander@27:             error(213);
dvander@27:           if (lval.tag!=0)
dvander@27:             append_constval(&taglst,arg[argidx].name,lval.tag,0);
dvander@27:           break;
dvander@27:         case iVARIABLE:
dvander@27:           if (lval.ident==iLABEL || lval.ident==iFUNCTN || lval.ident==iREFFUNC
dvander@27:               || lval.ident==iARRAY || lval.ident==iREFARRAY)
dvander@27:             error(35,argidx+1);   /* argument type mismatch */
dvander@27:           if (lvalue)
dvander@27:             rvalue(&lval);        /* get value (direct or indirect) */
dvander@27:           /* otherwise, the expression result is already in PRI */
dvander@27:           assert(arg[argidx].numtags>0);
dvander@27:           check_userop(NULL,lval.tag,arg[argidx].tags[0],2,NULL,&lval.tag);
dvander@151:           if (!checktags_string(arg[argidx].tags, arg[argidx].numtags, &lval)
dvander@151:               && !checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
dvander@27:             error(213);
dvander@27:           if (lval.tag!=0)
dvander@27:             append_constval(&taglst,arg[argidx].name,lval.tag,0);
dvander@27:           argidx++;               /* argument done */
dvander@27:           break;
dvander@27:         case iREFERENCE:
dvander@151:           if (!lvalue)
dvander@27:             error(35,argidx+1);   /* argument type mismatch */
dvander@27:           if (lval.sym!=NULL && (lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0)
dvander@27:             error(35,argidx+1);   /* argument type mismatch */
dvander@27:           if (lval.ident==iVARIABLE || lval.ident==iREFERENCE) {
dvander@27:             if (lvalue) {
dvander@27:               assert(lval.sym!=NULL);
dvander@27:               address(lval.sym,sPRI);
dvander@27:             } else {
dvander@27:               setheap_pri();      /* address of the value on the heap in PRI */
dvander@116:               heapalloc+=markheap(MEMUSE_STATIC, 1);
dvander@27:               nest_stkusage++;
dvander@27:             } /* if */
dvander@27:           } /* if */
dvander@27:           /* otherwise, the address is already in PRI */
dvander@27:           if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
dvander@27:             error(213);
dvander@27:           if (lval.tag!=0)
dvander@27:             append_constval(&taglst,arg[argidx].name,lval.tag,0);
dvander@27:           argidx++;               /* argument done */
dvander@27:           if (lval.sym!=NULL)
dvander@27:             markusage(lval.sym,uWRITTEN);
dvander@27:           break;
dvander@27:         case iREFARRAY:
dvander@27:           if (lval.ident!=iARRAY && lval.ident!=iREFARRAY
dvander@151:               && lval.ident!=iARRAYCELL && lval.ident!=iARRAYCHAR)
dvander@27:           {
dvander@27:             error(35,argidx+1);   /* argument type mismatch */
dvander@27:             break;
dvander@27:           } /* if */
dvander@27:           if (lval.sym!=NULL && (lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0)
dvander@27:             error(35,argidx+1); /* argument type mismatch */
dvander@27:           /* Verify that the dimensions match with those in arg[argidx].
dvander@27:            * A literal array always has a single dimension.
dvander@27:            * An iARRAYCELL parameter is also assumed to have a single dimension.
dvander@27:            */
dvander@151:           if (lval.sym==NULL || lval.ident==iARRAYCELL || lval.ident==iARRAYCHAR) {
dvander@27:             if (arg[argidx].numdim!=1) {
dvander@27:               error(48);        /* array dimensions must match */
dvander@27:             } else if (arg[argidx].dim[0]!=0) {
dvander@27:               assert(arg[argidx].dim[0]>0);
dvander@27:               if (lval.ident==iARRAYCELL) {
dvander@27:                 error(47);        /* array sizes must match */
dvander@27:               } else {
dvander@27:                 assert(lval.constval!=0); /* literal array must have a size */
dvander@27:                 /* A literal array must have exactly the same size as the
dvander@27:                  * function argument; a literal string may be smaller than
dvander@27:                  * the function argument.
dvander@27:                  */
dvander@27:                 if (lval.constval>0 && arg[argidx].dim[0]!=lval.constval
dvander@27:                     || lval.constval<0 && arg[argidx].dim[0] < -lval.constval)
dvander@27:                   error(47);      /* array sizes must match */
dvander@27:               } /* if */
dvander@27:             } /* if */
dvander@151:             if (lval.ident!=iARRAYCELL && lval.ident!=iARRAYCHAR) {
dvander@27:               /* save array size, for default values with uSIZEOF flag */
dvander@27:               cell array_sz=lval.constval;
dvander@27:               assert(array_sz!=0);/* literal array must have a size */
dvander@27:               if (array_sz<0)
dvander@27:                 array_sz= -array_sz;
dvander@27:               append_constval(&arrayszlst,arg[argidx].name,array_sz,0);
dvander@151:             }/* if */
dvander@27:           } else {
dvander@27:             symbol *sym=lval.sym;
dvander@27:             short level=0;
dvander@27:             assert(sym!=NULL);
dvander@27:             if (sym->dim.array.level+1!=arg[argidx].numdim)
dvander@27:               error(48);          /* array dimensions must match */
dvander@27:             /* the lengths for all dimensions must match, unless the dimension
dvander@27:              * length was defined at zero (which means "undefined")
dvander@27:              */
dvander@27:             while (sym->dim.array.level>0) {
dvander@27:               assert(level<sDIMEN_MAX);
dvander@27:               if (arg[argidx].dim[level]!=0 && sym->dim.array.length!=arg[argidx].dim[level])
dvander@27:                 error(47);        /* array sizes must match */
dvander@27:               else if (!matchtag(arg[argidx].idxtag[level],sym->x.tags.index,TRUE))
dvander@27:                 error(229,sym->name);   /* index tag mismatch */
dvander@27:               append_constval(&arrayszlst,arg[argidx].name,sym->dim.array.length,level);
dvander@27:               sym=finddepend(sym);
dvander@27:               assert(sym!=NULL);
dvander@27:               level++;
dvander@27:             } /* if */
dvander@27:             /* the last dimension is checked too, again, unless it is zero */
dvander@27:             assert(level<sDIMEN_MAX);
dvander@27:             assert(sym!=NULL);
dvander@27:             if (arg[argidx].dim[level]!=0 && sym->dim.array.length!=arg[argidx].dim[level])
dvander@27:               error(47);          /* array sizes must match */
dvander@27:             else if (!matchtag(arg[argidx].idxtag[level],sym->x.tags.index,TRUE))
dvander@27:               error(229,sym->name);   /* index tag mismatch */
dvander@27:             append_constval(&arrayszlst,arg[argidx].name,sym->dim.array.length,level);
dvander@27:           } /* if */
dvander@27:           /* address already in PRI */
dvander@27:           if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
dvander@27:             error(213);
dvander@27:           if (lval.tag!=0)
dvander@27:             append_constval(&taglst,arg[argidx].name,lval.tag,0);
dvander@27:           // ??? set uWRITTEN?
dvander@27:           argidx++;               /* argument done */
dvander@27:           break;
dvander@27:         } /* switch */
dvander@27:         pushreg(sPRI);            /* store the function argument on the stack */
dvander@27:         markexpr(sPARM,NULL,0);   /* mark the end of a sub-expression */
dvander@27:         nest_stkusage++;
dvander@27:       } /* if */
dvander@27:       assert(arglist[argpos]!=ARG_UNHANDLED);
dvander@27:       nargs++;
dvander@27:       if (matchparanthesis) {
dvander@27:         close=matchtoken(')');
dvander@27:         if (!close)               /* if not paranthese... */
dvander@27:           if (!needtoken(','))    /* ...should be comma... */
dvander@27:             break;                /* ...but abort loop if neither */
dvander@27:       } else {
dvander@27:         close=!matchtoken(',');
dvander@27:         if (close) {              /* if not comma... */
dvander@27:           if (needtoken(tTERM)==1)/* ...must be end of statement */
dvander@27:             lexpush();            /* push again, because end of statement is analised later */
dvander@27:         } /* if */
dvander@27:       } /* if */
dvander@27:     } while (!close && freading && !matchtoken(tENDEXPR)); /* do */
dvander@27:   } /* if */
dvander@27:   /* check remaining function arguments (they may have default values) */
dvander@27:   for (argidx=0; arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS; argidx++) {
dvander@27:     if (arglist[argidx]==ARG_DONE)
dvander@27:       continue;                 /* already seen and handled this argument */
dvander@27:     /* in this first stage, we also skip the arguments with uSIZEOF and uTAGOF;
dvander@27:      * these are handled last
dvander@27:      */
dvander@27:     if ((arg[argidx].hasdefault & uSIZEOF)!=0 || (arg[argidx].hasdefault & uTAGOF)!=0) {
dvander@27:       assert(arg[argidx].ident==iVARIABLE);
dvander@27:       continue;
dvander@27:     } /* if */
dvander@27:     stgmark((char)(sEXPRSTART+argidx));/* mark beginning of new expression in stage */
dvander@27:     if (arg[argidx].hasdefault) {
dvander@27:       if (arg[argidx].ident==iREFARRAY) {
dvander@27:         short level;
dvander@27:         setdefarray(arg[argidx].defvalue.array.data,
dvander@27:                     arg[argidx].defvalue.array.size,
dvander@27:                     arg[argidx].defvalue.array.arraysize,
dvander@27:                     &arg[argidx].defvalue.array.addr,
dvander@27:                     (arg[argidx].usage & uCONST)!=0);
dvander@27:         if ((arg[argidx].usage & uCONST)==0) {
dvander@27:           heapalloc+=arg[argidx].defvalue.array.arraysize;
dvander@27:           nest_stkusage+=arg[argidx].defvalue.array.arraysize;
dvander@27:         } /* if */
dvander@27:         /* keep the lengths of all dimensions of a multi-dimensional default array */
dvander@27:         assert(arg[argidx].numdim>0);
dvander@27:         if (arg[argidx].numdim==1) {
dvander@27:           append_constval(&arrayszlst,arg[argidx].name,arg[argidx].defvalue.array.arraysize,0);
dvander@27:         } else {
dvander@27:           for (level=0; level<arg[argidx].numdim; level++) {
dvander@27:             assert(level<sDIMEN_MAX);
dvander@27:             append_constval(&arrayszlst,arg[argidx].name,arg[argidx].dim[level],level);
dvander@27:           } /* for */
dvander@27:         } /* if */
dvander@27:       } else if (arg[argidx].ident==iREFERENCE) {
dvander@27:         setheap(arg[argidx].defvalue.val);
dvander@27:         /* address of the value on the heap in PRI */
dvander@116:         heapalloc+=markheap(MEMUSE_STATIC, 1);
dvander@27:         nest_stkusage++;
dvander@27:       } else {
dvander@27:         int dummytag=arg[argidx].tags[0];
dvander@27:         ldconst(arg[argidx].defvalue.val,sPRI);
dvander@27:         assert(arg[argidx].numtags>0);
dvander@27:         check_userop(NULL,arg[argidx].defvalue_tag,arg[argidx].tags[0],2,NULL,&dummytag);
dvander@27:         assert(dummytag==arg[argidx].tags[0]);
dvander@27:       } /* if */
dvander@27:       pushreg(sPRI);            /* store the function argument on the stack */
dvander@27:       markexpr(sPARM,NULL,0);   /* mark the end of a sub-expression */
dvander@27:       nest_stkusage++;
dvander@27:     } else {
dvander@103:       error(92,argidx);        /* argument count mismatch */
dvander@27:     } /* if */
dvander@27:     if (arglist[argidx]==ARG_UNHANDLED)
dvander@27:       nargs++;
dvander@27:     arglist[argidx]=ARG_DONE;
dvander@27:   } /* for */
dvander@27:   /* now a second loop to catch the arguments with default values that are
dvander@27:    * the "sizeof" or "tagof" of other arguments
dvander@27:    */
dvander@27:   for (argidx=0; arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS; argidx++) {
dvander@27:     constvalue *asz;
dvander@27:     cell array_sz;
dvander@27:     if (arglist[argidx]==ARG_DONE)
dvander@27:       continue;                 /* already seen and handled this argument */
dvander@27:     stgmark((char)(sEXPRSTART+argidx));/* mark beginning of new expression in stage */
dvander@27:     assert(arg[argidx].ident==iVARIABLE);           /* if "sizeof", must be single cell */
dvander@27:     /* if unseen, must be "sizeof" or "tagof" */
dvander@27:     assert((arg[argidx].hasdefault & uSIZEOF)!=0 || (arg[argidx].hasdefault & uTAGOF)!=0);
dvander@27:     if ((arg[argidx].hasdefault & uSIZEOF)!=0) {
dvander@27:       /* find the argument; if it isn't found, the argument's default value
dvander@27:        * was a "sizeof" of a non-array (a warning for this was already given
dvander@27:        * when declaring the function)
dvander@27:        */
dvander@27:       asz=find_constval(&arrayszlst,arg[argidx].defvalue.size.symname,
dvander@27:                         arg[argidx].defvalue.size.level);
dvander@27:       if (asz!=NULL) {
dvander@27:         array_sz=asz->value;
dvander@27:         if (array_sz==0)
dvander@27:           error(224,arg[argidx].name);    /* indeterminate array size in "sizeof" expression */
dvander@27:       } else {
dvander@27:         array_sz=1;
dvander@27:       } /* if */
dvander@27:     } else {
dvander@27:       asz=find_constval(&taglst,arg[argidx].defvalue.size.symname,
dvander@27:                         arg[argidx].defvalue.size.level);
dvander@27:       if (asz != NULL) {
dvander@27:         exporttag(asz->value);
dvander@27:         array_sz=asz->value | PUBLICTAG;  /* must be set, because it just was exported */
dvander@27:       } else {
dvander@27:         array_sz=0;
dvander@27:       } /* if */
dvander@27:     } /* if */
dvander@27:     ldconst(array_sz,sPRI);
dvander@27:     pushreg(sPRI);              /* store the function argument on the stack */
dvander@27:     markexpr(sPARM,NULL,0);
dvander@27:     nest_stkusage++;
dvander@27:     if (arglist[argidx]==ARG_UNHANDLED)
dvander@27:       nargs++;
dvander@27:     arglist[argidx]=ARG_DONE;
dvander@27:   } /* for */
dvander@27:   stgmark(sENDREORDER);         /* mark end of reversed evaluation */
dvander@101:   pushval((cell)nargs /* *sizeof(cell)*/ );
dvander@27:   nest_stkusage++;
dvander@27:   ffcall(sym,NULL,nargs);
dvander@27:   if (sc_status!=statSKIP)
dvander@27:     markusage(sym,uREAD);       /* do not mark as "used" when this call itself is skipped */
dvander@27:   if ((sym->usage & uNATIVE)!=0 &&sym->x.lib!=NULL)
dvander@27:     sym->x.lib->value += 1;     /* increment "usage count" of the library */
dvander@27:   if (symret!=NULL)
dvander@27:     popreg(sPRI);               /* pop hidden parameter as function result */
dvander@27:   sideeffect=TRUE;              /* assume functions carry out a side-effect */
dvander@27:   delete_consttable(&arrayszlst);     /* clear list of array sizes */
dvander@27:   delete_consttable(&taglst);   /* clear list of parameter tags */
dvander@27: 
dvander@27:   /* maintain max. amount of memory used */
dvander@27:   {
dvander@27:     long totalsize;
dvander@64:     totalsize=declared+heapalloc+1;   /* local variables & return value size,
dvander@27:                                        * +1 for PROC opcode */
dvander@27:     if (lval_result->ident==iREFARRAY)
dvander@27:       totalsize++;                    /* add hidden parameter (on the stack) */
dvander@27:     if ((sym->usage & uNATIVE)==0)
dvander@27:       totalsize++;                    /* add "call" opcode */
dvander@27:     totalsize+=nest_stkusage;
dvander@27:     assert(curfunc!=NULL);
dvander@27:     if (curfunc->x.stacksize<totalsize)
dvander@27:       curfunc->x.stacksize=totalsize;
dvander@27:     nest_stkusage-=nargs+heapalloc+1; /* stack/heap space, +1 for argcount param */
dvander@27:     /* if there is a syntax error in the script, the stack calculation is
dvander@27:      * probably incorrect; but we may not allow it to drop below zero
dvander@27:      */
dvander@27:     if (nest_stkusage<0)
dvander@27:       nest_stkusage=0;
dvander@27:   }
dvander@27: 
dvander@27:   /* scrap any arrays left on the heap, with the exception of the array that
dvander@27:    * this function has as a result (in other words, scrap all arrays on the
dvander@27:    * heap that caused by expressions in the function arguments)
dvander@27:    */
dvander@64:   popheaplist();
dvander@27:   nesting--;
dvander@27: }
dvander@27: 
dvander@27: /*  dbltest
dvander@27:  *
dvander@27:  *  Returns a non-zero value if lval1 an array and lval2 is not an array and
dvander@27:  *  the operation is addition or subtraction.
dvander@27:  *
dvander@27:  *  Returns the "shift" count (1 for 16-bit, 2 for 32-bit) to align a cell
dvander@27:  *  to an array offset.
dvander@27:  */
dvander@27: static int dbltest(void (*oper)(),value *lval1,value *lval2)
dvander@27: {
dvander@27:   if ((oper!=ob_add) && (oper!=ob_sub))
dvander@27:     return 0;
dvander@27:   if (lval1->ident!=iARRAY)
dvander@27:     return 0;
dvander@27:   if (lval2->ident==iARRAY)
dvander@27:     return 0;
dvander@27:   return sizeof(cell)/2;        /* 1 for 16-bit, 2 for 32-bit */
dvander@27: }
dvander@27: 
dvander@27: /*  commutative
dvander@27:  *
dvander@27:  *  Test whether an operator is commutative, i.e. x oper y == y oper x.
dvander@27:  *  Commutative operators are: +  (addition)
dvander@27:  *                             *  (multiplication)
dvander@27:  *                             == (equality)
dvander@27:  *                             != (inequality)
dvander@27:  *                             &  (bitwise and)
dvander@27:  *                             ^  (bitwise xor)
dvander@27:  *                             |  (bitwise or)
dvander@27:  *
dvander@27:  *  If in an expression, code for the left operand has been generated and
dvander@27:  *  the right operand is a constant and the operator is commutative, the
dvander@27:  *  precautionary "push" of the primary register is scrapped and the constant
dvander@27:  *  is read into the secondary register immediately.
dvander@27:  */
dvander@27: static int commutative(void (*oper)())
dvander@27: {
dvander@27:   return oper==ob_add || oper==os_mult
dvander@27:          || oper==ob_eq || oper==ob_ne
dvander@27:          || oper==ob_and || oper==ob_xor || oper==ob_or;
dvander@27: }
dvander@27: 
dvander@27: /*  constant
dvander@27:  *
dvander@27:  *  Generates code to fetch a number, a literal character (which is returned
dvander@27:  *  by lex() as a number as well) or a literal string (lex() stores the
dvander@27:  *  strings in the literal queue). If the operand was a number, it is stored
dvander@27:  *  in lval->constval.
dvander@27:  *
dvander@27:  *  The function returns 1 if the token was a constant or a string, 0
dvander@27:  *  otherwise.
dvander@27:  */
dvander@27: static int constant(value *lval)
dvander@27: {
dvander@27:   int tok,index,ident;
dvander@27:   cell val,item,cidx;
dvander@27:   char *st;
dvander@27:   symbol *sym;
dvander@27:   int cmptag=lval->cmptag;
dvander@27: 
dvander@27:   tok=lex(&val,&st);
dvander@27:   if (tok==tSYMBOL && (sym=findconst(st,&cmptag))!=0) {
dvander@27:     if (cmptag>1)
dvander@27:       error(91,sym->name);  /* ambiguity: multiple matching constants (different tags) */
dvander@27:     lval->constval=sym->addr;
dvander@27:     ldconst(lval->constval,sPRI);
dvander@27:     lval->ident=iCONSTEXPR;
dvander@27:     lval->tag=sym->tag;
dvander@27:     lval->sym=sym;
dvander@27:     markusage(sym,uREAD);
dvander@27:   } else if (tok==tNUMBER) {
dvander@27:     lval->constval=val;
dvander@27:     ldconst(lval->constval,sPRI);
dvander@27:     lval->ident=iCONSTEXPR;
dvander@27:   } else if (tok==tRATIONAL) {
dvander@27:     lval->constval=val;
dvander@27:     ldconst(lval->constval,sPRI);
dvander@27:     lval->ident=iCONSTEXPR;
dvander@27:     lval->tag=sc_rationaltag;
dvander@27:   } else if (tok==tSTRING) {
dvander@27:     /* lex() stores starting index of string in the literal table in 'val' */
dvander@27:     ldconst((val+glb_declared)*sizeof(cell),sPRI);
dvander@27:     lval->ident=iARRAY;         /* pretend this is a global array */
dvander@27:     lval->constval=val-litidx;  /* constval == the negative value of the
dvander@27:                                  * size of the literal array; using a negative
dvander@27:                                  * value distinguishes between literal arrays
dvander@27:                                  * and literal strings (this was done for
dvander@27:                                  * array assignment). */
dvander@151: 	lval->tag=pc_tag_string;
dvander@27:   } else if (tok=='{') {
dvander@27:     int tag,lasttag=-1;
dvander@27:     val=litidx;
dvander@27:     do {
dvander@27:       /* cannot call constexpr() here, because "staging" is already turned
dvander@27:        * on at this point */
dvander@27:       assert(staging);
dvander@27:       stgget(&index,&cidx);     /* mark position in code generator */
dvander@152:       ident=expression(&item,&tag,NULL,FALSE,NULL);
dvander@27:       stgdel(index,cidx);       /* scratch generated code */
dvander@27:       if (ident!=iCONSTEXPR)
dvander@27:         error(8);               /* must be constant expression */
dvander@27:       if (lasttag<0)
dvander@27:         lasttag=tag;
dvander@27:       else if (!matchtag(lasttag,tag,FALSE))
dvander@27:         error(213);             /* tagname mismatch */
dvander@27:       litadd(item);             /* store expression result in literal table */
dvander@27:     } while (matchtoken(','));
dvander@27:     if (!needtoken('}'))
dvander@27:       lexclr(FALSE);
dvander@27:     ldconst((val+glb_declared)*sizeof(cell),sPRI);
dvander@27:     lval->ident=iARRAY;         /* pretend this is a global array */
dvander@27:     lval->constval=litidx-val;  /* constval == the size of the literal array */
dvander@27:   } else {
dvander@27:     return FALSE;               /* no, it cannot be interpreted as a constant */
dvander@27:   } /* if */
dvander@27:   return TRUE;                  /* yes, it was a constant value */
dvander@27: }
dvander@27: