sourcemod-central: sourcepawn/compiler/sc3.c@ce01c2eb020c

     1 /*  Pawn compiler - Recursive descend expresion parser

     2  *

     3  *  Copyright (c) ITB CompuPhase, 1997-2005

     4  *

     5  *  This software is provided "as-is", without any express or implied warranty.

     6  *  In no event will the authors be held liable for any damages arising from

     7  *  the use of this software.

     8  *

     9  *  Permission is granted to anyone to use this software for any purpose,

    10  *  including commercial applications, and to alter it and redistribute it

    11  *  freely, subject to the following restrictions:

    12  *

    13  *  1.  The origin of this software must not be misrepresented; you must not

    14  *      claim that you wrote the original software. If you use this software in

    15  *      a product, an acknowledgment in the product documentation would be

    16  *      appreciated but is not reeq;quired.

    17  *  2.  Altered source versions must be plainly marked as such, and must not be

    18  *      misrepresented as being the original software.

    19  *  3.  This notice may not be removed or altered from any source distribution.

    20  *

    21  *  Version: $Id$

    22  */

    23 #include <assert.h>

    24 #include <stdio.h>

    25 #include <stdlib.h>     /* for _MAX_PATH */

    26 #include <string.h>

    27 #if defined FORTIFY

    28   #include <alloc/fortify.h>

    29 #endif

    30 #include "sc.h"

    31 #include "sctracker.h"

    33 static int skim(int *opstr,void (*testfunc)(int),int dropval,int endval,

    34                 int (*hier)(value*),value *lval);

    35 static void dropout(int lvalue,void (*testfunc)(int val),int exit1,value *lval);

    36 static int plnge(int *opstr,int opoff,int (*hier)(value *lval),value *lval,

    37                  char *forcetag,int chkbitwise);

    38 static int plnge1(int (*hier)(value *lval),value *lval);

    39 static void plnge2(void (*oper)(void),

    40                    int (*hier)(value *lval),

    41                    value *lval1,value *lval2);

    42 static cell calc(cell left,void (*oper)(),cell right,char *boolresult);

    43 static int hier14(value *lval);

    44 static int hier13(value *lval);

    45 static int hier12(value *lval);

    46 static int hier11(value *lval);

    47 static int hier10(value *lval);

    48 static int hier9(value *lval);

    49 static int hier8(value *lval);

    50 static int hier7(value *lval);

    51 static int hier6(value *lval);

    52 static int hier5(value *lval);

    53 static int hier4(value *lval);

    54 static int hier3(value *lval);

    55 static int hier2(value *lval);

    56 static int hier1(value *lval1);

    57 static int primary(value *lval);

    58 static void clear_value(value *lval);

    59 static void callfunction(symbol *sym,value *lval_result,int matchparanthesis);

    60 static int dbltest(void (*oper)(),value *lval1,value *lval2);

    61 static int commutative(void (*oper)());

    62 static int constant(value *lval);

    64 static char lastsymbol[sNAMEMAX+1]; /* name of last function/variable */

    65 static int bitwise_opercount;   /* count of bitwise operators in an expression */

    67 /* Function addresses of binary operators for signed operations */

    68 static void (*op1[17])(void) = {

    69   os_mult,os_div,os_mod,        /* hier3, index 0 */

    70   ob_add,ob_sub,                /* hier4, index 3 */

    71   ob_sal,os_sar,ou_sar,         /* hier5, index 5 */

    72   ob_and,                       /* hier6, index 8 */

    73   ob_xor,                       /* hier7, index 9 */

    74   ob_or,                        /* hier8, index 10 */

    75   os_le,os_ge,os_lt,os_gt,      /* hier9, index 11 */

    76   ob_eq,ob_ne,                  /* hier10, index 15 */

    77 };

    78 /* These two functions are defined because the functions inc() and dec() in

    79  * SC4.C have a different prototype than the other code generation functions.

    80  * The arrays for user-defined functions use the function pointers for

    81  * identifying what kind of operation is requested; these functions must all

    82  * have the same prototype. As inc() and dec() are special cases already, it

    83  * is simplest to add two "do-nothing" functions.

    84  */

    85 static void user_inc(void) {}

    86 static void user_dec(void) {}

    88 /*

    89  *  Searches for a binary operator a list of operators. The list is stored in

    90  *  the array "list". The last entry in the list should be set to 0.

    91  *

    92  *  The index of an operator in "list" (if found) is returned in "opidx". If

    93  *  no operator is found, nextop() returns 0.

    94  *

    95  *  If an operator is found in the expression, it cannot be used in a function

    96  *  call with omitted parantheses. Mark this...

    97  *

    98  *  Global references: sc_allowproccall   (modified)

    99  */

   100 static int nextop(int *opidx,int *list)

   101 {

   102   *opidx=0;

   103   while (*list){

   104     if (matchtoken(*list)){

   105       sc_allowproccall=FALSE;

   106       return TRUE;      /* found! */

   107     } else {

   108       list+=1;

   109       *opidx+=1;

   110     } /* if */

   111   } /* while */

   112   return FALSE;         /* entire list scanned, nothing found */

   113 }

   115 SC_FUNC int check_userop(void (*oper)(void),int tag1,int tag2,int numparam,

   116                          value *lval,int *resulttag)

   117 {

   118 static char *binoperstr[] = { "*", "/", "%", "+", "-", "", "", "",

   119                               "", "", "", "<=", ">=", "<", ">", "==", "!=" };

   120 static int binoper_savepri[] = { FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,

   121                                  FALSE, FALSE, FALSE, FALSE, FALSE,

   122                                  TRUE, TRUE, TRUE, TRUE, FALSE, FALSE };

   123 static char *unoperstr[] = { "!", "-", "++", "--" };

   124 static void (*unopers[])(void) = { lneg, neg, user_inc, user_dec };

   125   char opername[4] = "", symbolname[sNAMEMAX+1];

   126   int i,swapparams,savepri,savealt;

   127   int paramspassed;

   128   symbol *sym;

   130   /* since user-defined operators on untagged operands are forbidden, we have

   131    * a quick exit.

   132    */

   133   assert(numparam==1 || numparam==2);

   134   if (tag1==0 && (numparam==1 || tag2==0))

   135     return FALSE;

   137   savepri=savealt=FALSE;

   138   /* find the name with the operator */

   139   if (numparam==2) {

   140     if (oper==NULL) {

   141       /* assignment operator: a special case */

   142       strcpy(opername,"=");

   143       if (lval!=NULL && (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR))

   144         savealt=TRUE;

   145     } else {

   146       assert( (sizeof binoperstr / sizeof binoperstr[0]) == (sizeof op1 / sizeof op1[0]) );

   147       for (i=0; i<sizeof op1 / sizeof op1[0]; i++) {

   148         if (oper==op1[i]) {

   149           strcpy(opername,binoperstr[i]);

   150           savepri=binoper_savepri[i];

   151           break;

   152         } /* if */

   153       } /* for */

   154     } /* if */

   155   } else {

   156     assert(oper!=NULL);

   157     assert(numparam==1);

   158     /* try a select group of unary operators */

   159     assert( (sizeof unoperstr / sizeof unoperstr[0]) == (sizeof unopers / sizeof unopers[0]) );

   160     if (opername[0]=='\0') {

   161       for (i=0; i<sizeof unopers / sizeof unopers[0]; i++) {

   162         if (oper==unopers[i]) {

   163           strcpy(opername,unoperstr[i]);

   164           break;

   165         } /* if */

   166       } /* for */

   167     } /* if */

   168   } /* if */

   169   /* if not found, quit */

   170   if (opername[0]=='\0')

   171     return FALSE;

   173   /* create a symbol name from the tags and the operator name */

   174   assert(numparam==1 || numparam==2);

   175   operator_symname(symbolname,opername,tag1,tag2,numparam,tag2);

   176   swapparams=FALSE;

   177   sym=findglb(symbolname,sGLOBAL);

   178   if (sym==NULL /*|| (sym->usage & uDEFINE)==0*/) {  /* ??? should not check uDEFINE; first pass clears these bits */

   179     /* check for commutative operators */

   180     if (tag1==tag2 || oper==NULL || !commutative(oper))

   181       return FALSE;             /* not commutative, cannot swap operands */

   182     /* if arrived here, the operator is commutative and the tags are different,

   183      * swap tags and try again

   184      */

   185     assert(numparam==2);        /* commutative operator must be a binary operator */

   186     operator_symname(symbolname,opername,tag2,tag1,numparam,tag1);

   187     swapparams=TRUE;

   188     sym=findglb(symbolname,sGLOBAL);

   189     if (sym==NULL /*|| (sym->usage & uDEFINE)==0*/)

   190       return FALSE;

   191   } /* if */

   193   /* check existance and the proper declaration of this function */

   194   if ((sym->usage & uMISSING)!=0 || (sym->usage & uPROTOTYPED)==0) {

   195     char symname[2*sNAMEMAX+16];  /* allow space for user defined operators */

   196     funcdisplayname(symname,sym->name);

   197     if ((sym->usage & uMISSING)!=0)

   198       error(4,symname);           /* function not defined */

   199     if ((sym->usage & uPROTOTYPED)==0)

   200       error(71,symname);          /* operator must be declared before use */

   201   } /* if */

   203   /* we don't want to use the redefined operator in the function that

   204    * redefines the operator itself, otherwise the snippet below gives

   205    * an unexpected recursion:

   206    *    fixed:operator+(fixed:a, fixed:b)

   207    *        return a + b

   208    */

   209   if (sym==curfunc)

   210     return FALSE;

   212   /* for increment and decrement operators, the symbol must first be loaded

   213    * (and stored back afterwards)

   214    */

   215   if (oper==user_inc || oper==user_dec) {

   216     assert(!savepri);

   217     assert(lval!=NULL);

   218     if (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR)

   219       pushreg(sPRI);            /* save current address in PRI */

   220     rvalue(lval);               /* get the symbol's value in PRI */

   221   } /* if */

   223   assert(!savepri || !savealt); /* either one MAY be set, but not both */

   224   if (savepri) {

   225     /* the chained comparison operators require that the ALT register is

   226      * unmodified, so we save it here; actually, we save PRI because the normal

   227      * instruction sequence (without user operator) swaps PRI and ALT

   228      */

   229     pushreg(sPRI);              /* right-hand operand is in PRI */

   230   } else if (savealt) {

   231     /* for the assignment operator, ALT may contain an address at which the

   232      * result must be stored; this address must be preserved accross the

   233      * call

   234      */

   235     assert(lval!=NULL);         /* this was checked earlier */

   236     assert(lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR); /* checked earlier */

   237     pushreg(sALT);

   238   } /* if */

   240   /* push parameters, call the function */

   241   paramspassed= (oper==NULL) ? 1 : numparam;

   242   switch (paramspassed) {

   243   case 1:

   244     pushreg(sPRI);

   245     break;

   246   case 2:

   247     /* note that 1) a function expects that the parameters are pushed

   248      * in reversed order, and 2) the left operand is in the secondary register

   249      * and the right operand is in the primary register */

   250     if (swapparams) {

   251       pushreg(sALT);

   252       pushreg(sPRI);

   253     } else {

   254       pushreg(sPRI);

   255       pushreg(sALT);

   256     } /* if */

   257     break;

   258   default:

   259     assert(0);

   260   } /* switch */

   261   markexpr(sPARM,NULL,0);       /* mark the end of a sub-expression */

   262   pushval((cell)paramspassed /* *sizeof(cell)*/ );

   263   assert(sym->ident==iFUNCTN);

   264   ffcall(sym,NULL,paramspassed);

   265   if (sc_status!=statSKIP)

   266     markusage(sym,uREAD);       /* do not mark as "used" when this call itself is skipped */

   267   if ((sym->usage & uNATIVE)!=0 && sym->x.lib!=NULL)

   268     sym->x.lib->value += 1;     /* increment "usage count" of the library */

   269   sideeffect=TRUE;              /* assume functions carry out a side-effect */

   270   assert(resulttag!=NULL);

   271   *resulttag=sym->tag;          /* save tag of the called function */

   273   if (savepri || savealt)

   274     popreg(sALT);               /* restore the saved PRI/ALT that into ALT */

   275   if (oper==user_inc || oper==user_dec) {

   276     assert(lval!=NULL);

   277     if (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR)

   278       popreg(sALT);             /* restore address (in ALT) */

   279     store(lval);                /* store PRI in the symbol */

   280     moveto1();                  /* make sure PRI is restored on exit */

   281   } /* if */

   282   return TRUE;

   283 }

   285 SC_FUNC int checktags_string(int tags[], int numtags, value *sym1)

   286 {

   287   int i;

   288   if (sym1->ident == iARRAY || sym1->ident == iREFARRAY)

   289   {

   290     return FALSE;

   291   }

   292   for (i=0; i<numtags; i++) {

   293     if ((sym1->tag == pc_tag_string && tags[i] == 0) ||

   294 		(sym1->tag == 0 && tags[i] == pc_tag_string))

   295       return TRUE;

   296   }

   297   return FALSE;

   298 }

   300 SC_FUNC int checktag_string(value *sym1, value *sym2)

   301 {

   302   if (sym1->ident == iARRAY || sym2->ident == iARRAY

   303 	  || sym1->ident == iREFARRAY || sym2->ident == iREFARRAY)

   304   {

   305     return FALSE;

   306   }

   307   if ((sym1->tag == pc_tag_string && sym2->tag == 0)

   308 	  || (sym1->tag == 0 && sym2->tag == pc_tag_string))

   309   {

   310     return TRUE;

   311   }

   313   return FALSE;

   314 }

   316 SC_FUNC int matchtag_string(int ident, int tag)

   317 {

   318   if (ident == iARRAY || ident == iREFARRAY)

   319     return FALSE;

   320   return (tag == pc_tag_string) ? TRUE : FALSE;

   321 }

   323 SC_FUNC int matchtag(int formaltag,int actualtag,int allowcoerce)

   324 {

   325   if (formaltag!=actualtag) {

   326     /* if the formal tag is zero and the actual tag is not "fixed", the actual

   327      * tag is "coerced" to zero

   328      */

   329     if (!allowcoerce || formaltag!=0 || (actualtag & FIXEDTAG)!=0) {

   330 		if (formaltag == pc_anytag)

   331 		{

   332 			return TRUE;

   333 		}

   335 		if (formaltag & FUNCTAG)

   336 		{

   337 			if (actualtag == pc_functag || (formaltag == pc_functag && actualtag & FUNCTAG))

   338 			{

   339 				return TRUE;

   340 			} else if (actualtag & FUNCTAG) {

   341 				constvalue *v = find_tag_byval(actualtag);

   342 				int index;

   343 				short usage = uPUBLIC;

   344 				symbol *sym, *found = NULL;

   345 				funcenum_t *e;

   346 				functag_t *t;

   348 				if (strncmp(v->name, "$Func", 5) != 0)

   349 				{

   350 					return FALSE;

   351 				}

   353 				/* Now we have to go about looking up each function in this enum.  WHICH IS IT. */

   354 				e = funcenums_find_byval(formaltag);

   355 				if (!e)

   356 				{

   357 					return FALSE;

   358 				}

   360 				assert(v->name[5] == '@' || v->name[5] == '!');

   362 				/* Deduce which function type this is */

   363 				if (v->name[5] == '@')

   364 				{

   365 					usage = uPUBLIC;

   366 				} else if (v->name[5] = '!') {

   367 					usage = uSTOCK;

   368 				}

   370 				index = atoi(&v->name[6]);

   372 				assert(index >= 0);

   374 				/* Find the function, either by public idx or code addr */

   375 				if (usage == uPUBLIC)

   376 				{

   377 					for (sym=glbtab.next; sym!=NULL; sym=sym->next) {

   378 						if (sym->ident==iFUNCTN && (sym->usage & uPUBLIC)!=0 && (sym->vclass == sGLOBAL))

   379 						{

   380 							if (index-- == 0)

   381 							{

   382 								found = sym;

   383 								break;

   384 							}

   385 						}

   386 					}

   387 				} else if (usage == uSTOCK) {

   388 					for (sym=glbtab.next; sym!=NULL; sym=sym->next) {

   389 						if (sym->ident==iFUNCTN && (sym->vclass == sGLOBAL))

   390 						{

   391 							if (sym->codeaddr == index)

   392 							{

   393 								found = sym;

   394 								break;

   395 							}

   396 						}

   397 					}

   398 				}

   400 				if (!found)

   401 				{

   402 					assert(found);

   403 					return FALSE;

   404 				}

   406 				/* Wow, we now have:

   407 				 * 1) The functional enum deduced from formaltag

   408 				 * 2) The function trying to be shoved in deduced from actualtag

   409 				 * Now we have to check if it matches any one of the functags inside the enum.

   410 				 */

   411 				t = e->first;

   412 				while (t)

   413 				{

   414 					int curarg,skip=0,i;

   415 					arginfo *func_arg;

   416 					funcarg_t *enum_arg;

   417 					/* Check return type first. */

   418 					if (t->ret_tag != sym->tag)

   419 					{

   420 						t = t->next;

   421 						continue;

   422 					}

   423 					/* Check usage */

   424 					if (t->type != usage)

   425 					{

   426 						t = t->next;

   427 						continue;

   428 					}

   429 					/* Begin iterating arguments */

   430 					for (curarg=0; curarg<t->argcount; curarg++)

   431 					{

   432 						enum_arg = &t->args[curarg];

   433 						/* Check whether we've exhausted our arguments */

   434 						if (sym->dim.arglist[curarg].ident == 0)

   435 						{

   436 							/* Can we bail out early? */

   437 							if (!enum_arg->ommittable)

   438 							{

   439 								/* No! */

   440 								skip = 1;

   441 							}

   442 							break;

   443 						}

   444 						func_arg = &sym->dim.arglist[curarg];

   445 						/* First check the ident type */

   446 						if (enum_arg->ident != func_arg->ident)

   447 						{

   448 							skip = 1;

   449 							break;

   450 						}

   451 						/* Next check arrayness */

   452 						if (enum_arg->dimcount != func_arg->numdim)

   453 						{

   454 							skip = 1;

   455 							break;

   456 						}

   457 						if (enum_arg->dimcount > 0)

   458 						{

   459 							for (i=0; i<enum_arg->dimcount; i++)

   460 							{

   461 								if (enum_arg->dims[i] != func_arg->dim[i])

   462 								{

   463 									skip = 1;

   464 									break;

   465 								}

   466 							}

   467 							if (skip)

   468 							{

   469 								break;

   470 							}

   471 						}

   472 						/* Lastly, check the tags */

   473 						if (enum_arg->tagcount != func_arg->numtags)

   474 						{

   475 							skip = 1;

   476 							break;

   477 						}

   478 						/* They should all be in the same order just for clarity... */

   479 						for (i=0; i<enum_arg->tagcount; i++)

   480 						{

   481 							if (enum_arg->tags[i] != func_arg->tags[i])

   482 							{

   483 								skip = 1;

   484 								break;

   485 							}

   486 						}

   487 						if (skip)

   488 						{

   489 							break;

   490 						}

   491 					}

   492 					if (!skip)

   493 					{

   494 						/* Make sure there are no trailing arguments */

   495 						if (sym->dim.arglist[curarg].ident == 0)

   496 						{

   497 							return TRUE;

   498 						}

   499 					}

   500 					t = t->next;

   501 				}

   502 			}

   503 		}

   504 		return FALSE;

   505 	}

   506   } /* if */

   507   return TRUE;

   508 }

   510 /*

   511  *  The AMX pseudo-processor has no direct support for logical (boolean)

   512  *  operations. These have to be done via comparing and jumping. Since we are

   513  *  already jumping through the code, we might as well implement an "early

   514  *  drop-out" evaluation (also called "short-circuit"). This conforms to

   515  *  standard C:

   516  *

   517  *  expr1 || expr2           expr2 will only be evaluated if expr1 is false.

   518  *  expr1 && expr2           expr2 will only be evaluated if expr1 is true.

   519  *

   520  *  expr1 || expr2 && expr3  expr2 will only be evaluated if expr1 is false

   521  *                           and expr3 will only be evaluated if expr1 is

   522  *                           false and expr2 is true.

   523  *

   524  *  Code generation for the last example proceeds thus:

   525  *

   526  *      evaluate expr1

   527  *      operator || found

   528  *      jump to "l1" if result of expr1 not equal to 0

   529  *      evaluate expr2

   530  *      ->  operator && found; skip to higher level in hierarchy diagram

   531  *          jump to "l2" if result of expr2 equal to 0

   532  *          evaluate expr3

   533  *          jump to "l2" if result of expr3 equal to 0

   534  *          set expression result to 1 (true)

   535  *          jump to "l3"

   536  *      l2: set expression result to 0 (false)

   537  *      l3:

   538  *      <-  drop back to previous hierarchy level

   539  *      jump to "l1" if result of expr2 && expr3 not equal to 0

   540  *      set expression result to 0 (false)

   541  *      jump to "l4"

   542  *  l1: set expression result to 1 (true)

   543  *  l4:

   544  *

   545  */

   547 /*  Skim over terms adjoining || and && operators

   548  *  dropval   The value of the expression after "dropping out". An "or" drops

   549  *            out when the left hand is TRUE, so dropval must be 1 on "or"

   550  *            expressions.

   551  *  endval    The value of the expression when no expression drops out. In an

   552  *            "or" expression, this happens when both the left hand and the

   553  *            right hand are FALSE, so endval must be 0 for "or" expressions.

   554  */

   555 static int skim(int *opstr,void (*testfunc)(int),int dropval,int endval,

   556                 int (*hier)(value*),value *lval)

   557 {

   558   int lvalue,hits,droplab,endlab,opidx;

   559   int allconst,foundop;

   560   cell constval;

   561   int index;

   562   cell cidx;

   564   stgget(&index,&cidx);         /* mark position in code generator */

   565   hits=FALSE;                   /* no logical operators "hit" yet */

   566   allconst=TRUE;                /* assume all values "const" */

   567   constval=0;

   568   droplab=0;                    /* to avoid a compiler warning */

   569   for ( ;; ) {

   570     lvalue=plnge1(hier,lval);   /* evaluate left expression */

   572     allconst= allconst && (lval->ident==iCONSTEXPR);

   573     if (allconst) {

   574       if (hits) {

   575         /* one operator was already found */

   576         if (testfunc==jmp_ne0)

   577           lval->constval= lval->constval || constval;

   578         else

   579           lval->constval= lval->constval && constval;

   580       } /* if */

   581       constval=lval->constval;  /* save result accumulated so far */

   582     } /* if */

   584     foundop=nextop(&opidx,opstr);

   585     if ((foundop || hits) && (lval->ident==iARRAY || lval->ident==iREFARRAY))

   586       error(33, lval->sym ? (lval->sym->name ? lval->sym->name : "-unknown") : "-unknown-");  /* array was not indexed in an expression */

   587     if (foundop) {

   588       if (!hits) {

   589         /* this is the first operator in the list */

   590         hits=TRUE;

   591         droplab=getlabel();

   592       } /* if */

   593       dropout(lvalue,testfunc,droplab,lval);

   594     } else if (hits) {                       /* no (more) identical operators */

   595       dropout(lvalue,testfunc,droplab,lval); /* found at least one operator! */

   596       ldconst(endval,sPRI);

   597       jumplabel(endlab=getlabel());

   598       setlabel(droplab);

   599       ldconst(dropval,sPRI);

   600       setlabel(endlab);

   601       lval->sym=NULL;

   602       lval->tag=pc_addtag("bool");  /* force tag to be "bool" */

   603       if (allconst) {

   604         lval->ident=iCONSTEXPR;

   605         lval->constval=constval;

   606         stgdel(index,cidx);         /* scratch generated code and calculate */

   607       } else {

   608         lval->ident=iEXPRESSION;

   609         lval->constval=0;

   610       } /* if */

   611       return FALSE;

   612     } else {

   613       return lvalue;            /* none of the operators in "opstr" were found */

   614     } /* if */

   616   } /* while */

   617 }

   619 /*

   620  *  Reads into the primary register the variable pointed to by lval if

   621  *  plunging through the hierarchy levels detected an lvalue. Otherwise

   622  *  if a constant was detected, it is loaded. If there is no constant and

   623  *  no lvalue, the primary register must already contain the expression

   624  *  result.

   625  *

   626  *  After that, the compare routines "jmp_ne0" or "jmp_eq0" are called, which

   627  *  compare the primary register against 0, and jump to the "early drop-out"

   628  *  label "exit1" if the condition is true.

   629  */

   630 static void dropout(int lvalue,void (*testfunc)(int val),int exit1,value *lval)

   631 {

   632   if (lvalue)

   633     rvalue(lval);

   634   else if (lval->ident==iCONSTEXPR)

   635     ldconst(lval->constval,sPRI);

   636   (*testfunc)(exit1);

   637 }

   639 static void checkfunction(value *lval)

   640 {

   641   symbol *sym=lval->sym;

   643   if (sym==NULL || (sym->ident!=iFUNCTN && sym->ident!=iREFFUNC))

   644     return;             /* no known symbol, or not a function result */

   646   if ((sym->usage & uDEFINE)!=0) {

   647     /* function is defined, can now check the return value (but make an

   648      * exception for directly recursive functions)

   649      */

   650     if (sym!=curfunc && (sym->usage & uRETVALUE)==0) {

   651       char symname[2*sNAMEMAX+16];  /* allow space for user defined operators */

   652       funcdisplayname(symname,sym->name);

   653       error(209,symname);       /* function should return a value */

   654     } /* if */

   655   } else {

   656     /* function not yet defined, set */

   657     sym->usage|=uRETVALUE;      /* make sure that a future implementation of

   658                                  * the function uses "return <value>" */

   659   } /* if */

   660 }

   662 /*

   663  *  Plunge to a lower level

   664  */

   665 static int plnge(int *opstr,int opoff,int (*hier)(value *lval),value *lval,

   666                  char *forcetag,int chkbitwise)

   667 {

   668   int lvalue,opidx;

   669   int count;

   670   value lval2 = {0};

   672   lvalue=plnge1(hier,lval);

   673   if (nextop(&opidx,opstr)==0)

   674     return lvalue;              /* no operator in "opstr" found */

   675   if (lvalue)

   676     rvalue(lval);

   677   count=0;

   678   do {

   679     if (chkbitwise && count++>0 && bitwise_opercount!=0)

   680       error(212);

   681     opidx+=opoff;               /* add offset to index returned by nextop() */

   682     plnge2(op1[opidx],hier,lval,&lval2);

   683     if (op1[opidx]==ob_and || op1[opidx]==ob_or)

   684       bitwise_opercount++;

   685     if (forcetag!=NULL)

   686       lval->tag=pc_addtag(forcetag);

   687   } while (nextop(&opidx,opstr)); /* do */

   688   return FALSE;         /* result of expression is not an lvalue */

   689 }

   691 /*  plnge_rel

   692  *

   693  *  Binary plunge to lower level; this is very simular to plnge, but

   694  *  it has special code generation sequences for chained operations.

   695  */

   696 static int plnge_rel(int *opstr,int opoff,int (*hier)(value *lval),value *lval)

   697 {

   698   int lvalue,opidx;

   699   value lval2={0};

   700   int count;

   702   /* this function should only be called for relational operators */

   703   assert(op1[opoff]==os_le);

   704   lvalue=plnge1(hier,lval);

   705   if (nextop(&opidx,opstr)==0)

   706     return lvalue;              /* no operator in "opstr" found */

   707   if (lvalue)

   708     rvalue(lval);

   709   count=0;

   710   lval->boolresult=TRUE;

   711   do {

   712     /* same check as in plnge(), but "chkbitwise" is always TRUE */

   713     if (count>0 && bitwise_opercount!=0)

   714       error(212);

   715     if (count>0) {

   716       relop_prefix();

   717       *lval=lval2;      /* copy right hand expression of the previous iteration */

   718     } /* if */

   719     opidx+=opoff;

   720     plnge2(op1[opidx],hier,lval,&lval2);

   721     if (count++>0)

   722       relop_suffix();

   723   } while (nextop(&opidx,opstr)); /* enddo */

   724   lval->constval=lval->boolresult;

   725   lval->tag=pc_addtag("bool");    /* force tag to be "bool" */

   726   return FALSE;         /* result of expression is not an lvalue */

   727 }

   729 /*  plnge1

   730  *

   731  *  Unary plunge to lower level

   732  *  Called by: skim(), plnge(), plnge2(), plnge_rel(), hier14() and hier13()

   733  */

   734 static int plnge1(int (*hier)(value *lval),value *lval)

   735 {

   736   int lvalue,index;

   737   cell cidx;

   739   stgget(&index,&cidx); /* mark position in code generator */

   740   lvalue=(*hier)(lval);

   741   if (lval->ident==iCONSTEXPR)

   742     stgdel(index,cidx); /* load constant later */

   743   return lvalue;

   744 }

   746 /*  plnge2

   747  *

   748  *  Binary plunge to lower level

   749  *  Called by: plnge(), plnge_rel(), hier14() and hier1()

   750  */

   751 static void plnge2(void (*oper)(void),

   752                    int (*hier)(value *lval),

   753                    value *lval1,value *lval2)

   754 {

   755   int index;

   756   cell cidx;

   758   stgget(&index,&cidx);             /* mark position in code generator */

   759   if (lval1->ident==iCONSTEXPR) {   /* constant on left side; it is not yet loaded */

   760     if (plnge1(hier,lval2))

   761       rvalue(lval2);                /* load lvalue now */

   762     else if (lval2->ident==iCONSTEXPR)

   763       ldconst(lval2->constval<<dbltest(oper,lval2,lval1),sPRI);

   764     ldconst(lval1->constval<<dbltest(oper,lval2,lval1),sALT);

   765                    /* ^ doubling of constants operating on integer addresses */

   766                    /*   is restricted to "add" and "subtract" operators */

   767   } else {                          /* non-constant on left side */

   768     pushreg(sPRI);

   769     if (plnge1(hier,lval2))

   770       rvalue(lval2);

   771     if (lval2->ident==iCONSTEXPR) { /* constant on right side */

   772       if (commutative(oper)) {      /* test for commutative operators */

   773         value lvaltmp = {0};

   774         stgdel(index,cidx);         /* scratch pushreg() and constant fetch (then

   775                                      * fetch the constant again */

   776         ldconst(lval2->constval<<dbltest(oper,lval1,lval2),sALT);

   777         /* now, the primary register has the left operand and the secondary

   778          * register the right operand; swap the "lval" variables so that lval1

   779          * is associated with the secondary register and lval2 with the

   780          * primary register, as is the "normal" case.

   781          */

   782         lvaltmp=*lval1;

   783         *lval1=*lval2;

   784         *lval2=lvaltmp;

   785       } else {

   786         ldconst(lval2->constval<<dbltest(oper,lval1,lval2),sPRI);

   787         popreg(sALT);   /* pop result of left operand into secondary register */

   788       } /* if */

   789     } else {            /* non-constants on both sides */

   790       popreg(sALT);

   791       if (dbltest(oper,lval1,lval2))

   792         cell2addr();                    /* double primary register */

   793       if (dbltest(oper,lval2,lval1))

   794         cell2addr_alt();                /* double secondary register */

   795     } /* if */

   796   } /* if */

   797   if (oper) {

   798     /* If used in an expression, a function should return a value.

   799      * If the function has been defined, we can check this. If the

   800      * function was not defined, we can set this requirement (so that

   801      * a future function definition can check this bit.

   802      */

   803     checkfunction(lval1);

   804     checkfunction(lval2);

   805     if (lval1->ident==iARRAY || lval1->ident==iREFARRAY) {

   806       char *ptr=(lval1->sym!=NULL) ? lval1->sym->name : "-unknown-";

   807       error(33,ptr);                    /* array must be indexed */

   808     } else if (lval2->ident==iARRAY || lval2->ident==iREFARRAY) {

   809       char *ptr=(lval2->sym!=NULL) ? lval2->sym->name : "-unknown-";

   810       error(33,ptr);                    /* array must be indexed */

   811     } /* if */

   812     /* ??? ^^^ should do same kind of error checking with functions */

   814     /* check whether an "operator" function is defined for the tag names

   815      * (a constant expression cannot be optimized in that case)

   816      */

   817     if (check_userop(oper,lval1->tag,lval2->tag,2,NULL,&lval1->tag)) {

   818       lval1->ident=iEXPRESSION;

   819       lval1->constval=0;

   820     } else if (lval1->ident==iCONSTEXPR && lval2->ident==iCONSTEXPR) {

   821       /* only constant expression if both constant */

   822       stgdel(index,cidx);       /* scratch generated code and calculate */

   823       if (!matchtag(lval1->tag,lval2->tag,FALSE))

   824         error(213);             /* tagname mismatch */

   825       lval1->constval=calc(lval1->constval,oper,lval2->constval,&lval1->boolresult);

   826     } else {

   827       if (!checktag_string(lval1, lval2) && !matchtag(lval1->tag,lval2->tag,FALSE))

   828         error(213);             /* tagname mismatch */

   829       (*oper)();                /* do the (signed) operation */

   830       lval1->ident=iEXPRESSION;

   831     } /* if */

   832   } /* if */

   833 }

   835 static cell flooreddiv(cell a,cell b,int return_remainder)

   836 {

   837   cell q,r;

   839   if (b==0) {

   840     error(29);

   841     return 0;

   842   } /* if */

   843   /* first implement truncated division in a portable way */

   844   #define IABS(a)       ((a)>=0 ? (a) : (-a))

   845   q=IABS(a)/IABS(b);

   846   if ((cell)(a ^ b)<0)

   847     q=-q;               /* swap sign if either "a" or "b" is negative (but not both) */

   848   r=a-q*b;              /* calculate the matching remainder */

   849   /* now "fiddle" with the values to get floored division */

   850   if (r!=0 && (cell)(r ^ b)<0) {

   851     q--;

   852     r+=b;

   853   } /* if */

   854   return return_remainder ? r : q;

   855 }

   857 static cell calc(cell left,void (*oper)(),cell right,char *boolresult)

   858 {

   859   if (oper==ob_or)

   860     return (left | right);

   861   else if (oper==ob_xor)

   862     return (left ^ right);

   863   else if (oper==ob_and)

   864     return (left & right);

   865   else if (oper==ob_eq)

   866     return (left == right);

   867   else if (oper==ob_ne)

   868     return (left != right);

   869   else if (oper==os_le)

   870     return *boolresult &= (char)(left <= right), right;

   871   else if (oper==os_ge)

   872     return *boolresult &= (char)(left >= right), right;

   873   else if (oper==os_lt)

   874     return *boolresult &= (char)(left < right), right;

   875   else if (oper==os_gt)

   876     return *boolresult &= (char)(left > right), right;

   877   else if (oper==os_sar)

   878     return (left >> (int)right);

   879   else if (oper==ou_sar)

   880     return ((ucell)left >> (ucell)right);

   881   else if (oper==ob_sal)

   882     return ((ucell)left << (int)right);

   883   else if (oper==ob_add)

   884     return (left + right);

   885   else if (oper==ob_sub)

   886     return (left - right);

   887   else if (oper==os_mult)

   888     return (left * right);

   889   else if (oper==os_div)

   890     return flooreddiv(left,right,0);

   891   else if (oper==os_mod)

   892     return flooreddiv(left,right,1);

   893   else

   894     error(29);  /* invalid expression, assumed 0 (this should never occur) */

   895   return 0;

   896 }

   898 SC_FUNC int expression(cell *val,int *tag,symbol **symptr,int chkfuncresult,value *_lval)

   899 {

   900   value lval={0};

   901   pushheaplist();

   903   if (hier14(&lval))

   904     rvalue(&lval);

   905   /* scrap any arrays left on the heap */

   906   popheaplist();

   908   if (lval.ident==iCONSTEXPR && val!=NULL)    /* constant expression */

   909     *val=lval.constval;

   910   if (tag!=NULL)

   911     *tag=lval.tag;

   912   if (symptr!=NULL)

   913     *symptr=lval.sym;

   914   if (chkfuncresult)

   915     checkfunction(&lval);

   916   if (_lval)

   917     *_lval=lval;

   918   return lval.ident;

   919 }

   921 SC_FUNC int sc_getstateid(constvalue **automaton,constvalue **state)

   922 {

   923   char name[sNAMEMAX+1];

   924   cell val;

   925   char *str;

   926   int fsa,islabel;

   928   assert(automaton!=NULL);

   929   assert(state!=NULL);

   930   if (!(islabel=matchtoken(tLABEL)) && !needtoken(tSYMBOL))

   931     return 0;

   933   tokeninfo(&val,&str);

   934   assert(strlen(str)<sizeof name);

   935   strcpy(name,str);

   936   if (islabel || matchtoken(':')) {

   937     /* token is an automaton name, add the name and get a new token */

   938     *automaton=automaton_find(name);

   939     /* read in the state name before checking the automaton, to keep the parser

   940      * going (an "unknown automaton" error may occur when the "state" instruction

   941      * precedes any state definition)

   942      */

   943     if (!needtoken(tSYMBOL))

   944       return 0;

   945     tokeninfo(&val,&str);        /* do not copy the name yet, must check automaton first */

   946     if (*automaton==NULL) {

   947       error(86,name);            /* unknown automaton */

   948       return 0;

   949     } /* if */

   950     assert((*automaton)->index>0);

   951     assert(strlen(str)<sizeof name);

   952     strcpy(name,str);

   953   } else {

   954     *automaton=automaton_find("");

   955     assert(*automaton!=NULL);

   956     assert((*automaton)->index==0);

   957   } /* if */

   958   assert(*automaton!=NULL);

   959   fsa=(*automaton)->index;

   961   assert(*automaton!=NULL);

   962   *state=state_find(name,fsa);

   963   if (*state==NULL) {

   964     char *fsaname=(*automaton)->name;

   965     if (*fsaname=='\0')

   966       fsaname="<main>";

   967     error(87,name,fsaname);   /* unknown state for automaton */

   968     return 0;

   969   } /* if */

   971   return 1;

   972 }

   974 SC_FUNC cell array_totalsize(symbol *sym)

   975 {

   976   cell length;

   978   assert(sym!=NULL);

   979   assert(sym->ident==iARRAY || sym->ident==iREFARRAY);

   980   length=sym->dim.array.length;

   981   if (sym->dim.array.level > 0) {

   982     cell sublength=array_totalsize(finddepend(sym));

   983     if (sublength>0)

   984       length=length+length*sublength;

   985     else

   986       length=0;

   987   } /* if */

   988   return length;

   989 }

   991 static cell array_levelsize(symbol *sym,int level)

   992 {

   993   assert(sym!=NULL);

   994   assert(sym->ident==iARRAY || sym->ident==iREFARRAY);

   995   assert(level <= sym->dim.array.level);

   996   while (level-- > 0) {

   997     sym=finddepend(sym);

   998     assert(sym!=NULL);

   999   } /* if */

  1000   return (sym->dim.array.slength ? sym->dim.array.slength : sym->dim.array.length);

  1001 }

  1003 /*  hier14

  1004  *

  1005  *  Lowest hierarchy level (except for the , operator).

  1006  *

  1007  *  Global references: sc_intest        (reffered to only)

  1008  *                     sc_allowproccall (modified)

  1009  */

  1010 static int hier14(value *lval1)

  1011 {

  1012   int lvalue;

  1013   value lval2={0},lval3={0};

  1014   void (*oper)(void);

  1015   int tok,level,i;

  1016   cell val;

  1017   char *st;

  1018   int bwcount,leftarray;

  1019   cell arrayidx1[sDIMEN_MAX],arrayidx2[sDIMEN_MAX];  /* last used array indices */

  1020   cell *org_arrayidx;

  1022   bwcount=bitwise_opercount;

  1023   bitwise_opercount=0;

  1024   /* initialize the index arrays with unlikely constant indices; note that

  1025    * these indices will only be changed when the array is indexed with a

  1026    * constant, and that negative array indices are invalid (so actually, any

  1027    * negative value would do).

  1028    */

  1029   for (i=0; i<sDIMEN_MAX; i++)

  1030     arrayidx1[i]=arrayidx2[i]=(cell)(-1L << (sizeof(cell)*8-1));

  1031   org_arrayidx=lval1->arrayidx; /* save current pointer, to reset later */

  1032   if (lval1->arrayidx==NULL)

  1033     lval1->arrayidx=arrayidx1;

  1034   lvalue=plnge1(hier13,lval1);

  1035   if (lval1->ident!=iARRAYCELL && lval1->ident!=iARRAYCHAR)

  1036     lval1->arrayidx=NULL;

  1037   if (lval1->ident==iCONSTEXPR) /* load constant here */

  1038     ldconst(lval1->constval,sPRI);

  1039   tok=lex(&val,&st);

  1040   switch (tok) {

  1041     case taOR:

  1042       oper=ob_or;

  1043       break;

  1044     case taXOR:

  1045       oper=ob_xor;

  1046       break;

  1047     case taAND:

  1048       oper=ob_and;

  1049       break;

  1050     case taADD:

  1051       oper=ob_add;

  1052       break;

  1053     case taSUB:

  1054       oper=ob_sub;

  1055       break;

  1056     case taMULT:

  1057       oper=os_mult;

  1058       break;

  1059     case taDIV:

  1060       oper=os_div;

  1061       break;

  1062     case taMOD:

  1063       oper=os_mod;

  1064       break;

  1065     case taSHRU:

  1066       oper=ou_sar;

  1067       break;

  1068     case taSHR:

  1069       oper=os_sar;

  1070       break;

  1071     case taSHL:

  1072       oper=ob_sal;

  1073       break;

  1074     case '=':           /* simple assignment */

  1075       oper=NULL;

  1076       if (sc_intest)

  1077         error(211);     /* possibly unintended assignment */

  1078       break;

  1079     default:

  1080       lexpush();

  1081       bitwise_opercount=bwcount;

  1082       lval1->arrayidx=org_arrayidx; /* restore array index pointer */

  1083       return lvalue;

  1084   } /* switch */

  1086   /* if we get here, it was an assignment; first check a few special cases

  1087    * and then the general */

  1088   if (lval1->ident==iARRAYCHAR) {

  1089     /* special case, assignment to packed character in a cell is permitted */

  1090     lvalue=TRUE;

  1091   } else if (lval1->ident==iARRAY || lval1->ident==iREFARRAY) {

  1092     /* array assignment is permitted too (with restrictions) */

  1093     if (oper)

  1094       return error(23); /* array assignment must be simple assigment */

  1095     assert(lval1->sym!=NULL);

  1096     if (array_totalsize(lval1->sym)==0)

  1097       return error(46,lval1->sym->name);        /* unknown array size */

  1098     lvalue=TRUE;

  1099   } /* if */

  1101   /* operand on left side of assignment must be lvalue */

  1102   if (!lvalue)

  1103     return error(22);                   /* must be lvalue */

  1104   /* may not change "constant" parameters */

  1105   assert(lval1->sym!=NULL);

  1106   if ((lval1->sym->usage & uCONST)!=0)

  1107     return error(22);           /* assignment to const argument */

  1108   sc_allowproccall=FALSE;       /* may no longer use "procedure call" syntax */

  1110   lval3=*lval1;         /* save symbol to enable storage of expresion result */

  1111   lval1->arrayidx=org_arrayidx; /* restore array index pointer */

  1112   if (lval1->ident==iARRAYCELL || lval1->ident==iARRAYCHAR

  1113       || lval1->ident==iARRAY || lval1->ident==iREFARRAY)

  1114   {

  1115     /* if indirect fetch: save PRI (cell address) */

  1116     if (oper) {

  1117       pushreg(sPRI);

  1118       rvalue(lval1);

  1119     } /* if */

  1120     lval2.arrayidx=arrayidx2;

  1121     plnge2(oper,hier14,lval1,&lval2);

  1122     if (lval2.ident!=iARRAYCELL && lval2.ident!=iARRAYCHAR)

  1123       lval2.arrayidx=NULL;

  1124     if (oper)

  1125       popreg(sALT);

  1126     if (!oper && lval3.arrayidx!=NULL && lval2.arrayidx!=NULL

  1127         && lval3.ident==lval2.ident && lval3.sym==lval2.sym)

  1128     {

  1129       int same=TRUE;

  1130       assert(lval2.arrayidx==arrayidx2);

  1131       for (i=0; i<sDIMEN_MAX; i++)

  1132         same=same && (lval3.arrayidx[i]==lval2.arrayidx[i]);

  1133         if (same)

  1134           error(226,lval3.sym->name);   /* self-assignment */

  1135     } /* if */

  1136   } else {

  1137     if (oper){

  1138       rvalue(lval1);

  1139       plnge2(oper,hier14,lval1,&lval2);

  1140     } else {

  1141       /* if direct fetch and simple assignment: no "push"

  1142        * and "pop" needed -> call hier14() directly, */

  1143       if (hier14(&lval2))

  1144         rvalue(&lval2);         /* instead of plnge2(). */

  1145       else if (lval2.ident==iVARIABLE)

  1146         lval2.ident=iEXPRESSION;/* mark as "rvalue" if it is not an "lvalue" */

  1147       checkfunction(&lval2);

  1148       /* check whether lval2 and lval3 (old lval1) refer to the same variable */

  1149       if (lval2.ident==iVARIABLE && lval3.ident==lval2.ident && lval3.sym==lval2.sym) {

  1150         assert(lval3.sym!=NULL);

  1151         error(226,lval3.sym->name);     /* self-assignment */

  1152       } /* if */

  1153     } /* if */

  1154   } /* if */

  1155   /* Array elements are sometimes considered as sub-arrays --when the

  1156    * array index is an enumeration field and the enumeration size is greater

  1157    * than 1. If the expression on the right side of the assignment is a cell,

  1158    * or if an operation is in effect, this does not apply.

  1159    */

  1160   leftarray= lval3.ident==iARRAY || lval3.ident==iREFARRAY

  1161              || ((lval3.ident==iARRAYCELL || lval3.ident==iARRAYCHAR)

  1162                  && lval3.constval>1 && lval3.sym->dim.array.level==0

  1163                  && !oper && (lval2.ident==iARRAY || lval2.ident==iREFARRAY));

  1164   if (leftarray) {

  1165     /* Left operand is an array, right operand should be an array variable

  1166      * of the same size and the same dimension, an array literal (of the

  1167      * same size) or a literal string. For single-dimensional arrays without

  1168      * tag for the index, it is permitted to assign a smaller array into a

  1169      * larger one (without warning). This is to make it easier to work with

  1170      * strings.

  1171      */

  1172     int exactmatch=TRUE;

  1173     int idxtag=0;

  1174     int ltlength=(int)lval3.sym->dim.array.length;

  1175     if ((lval3.ident==iARRAYCELL || lval3.ident==iARRAYCHAR)

  1176         && lval3.constval>0 && lval3.sym->dim.array.level==0)

  1177     {

  1178       ltlength=(int)lval3.constval;

  1179     } /* if */

  1180     if (lval2.ident!=iARRAY && lval2.ident!=iREFARRAY

  1181         && (lval2.sym==NULL || lval2.constval<=0))

  1182       error(33,lval3.sym->name);        /* array must be indexed */

  1183     if (lval2.sym!=NULL) {

  1184       if (lval2.constval==0) {

  1185         val=lval2.sym->dim.array.length;/* array variable */

  1186       } else {

  1187         val=lval2.constval;

  1188         if (lval2.sym->dim.array.level!=0)

  1189           error(28,lval2.sym->name);

  1190       } /* if */

  1191       level=lval2.sym->dim.array.level;

  1192       idxtag=lval2.sym->x.tags.index;

  1193       if (level==0 && idxtag==0 && lval3.sym->x.tags.index==0)

  1194         exactmatch=FALSE;

  1195     } else {

  1196       val=lval2.constval;               /* literal array */

  1197       level=0;

  1198       /* If val is negative, it means that lval2 is a literal string.

  1199        * The string array size may be smaller than the destination

  1200        * array, provided that the destination array does not have an

  1201        * index tag.

  1202        */

  1203       if (val<0) {

  1204         val=-val;

  1205         if (lval3.sym->x.tags.index==0)

  1206           exactmatch=FALSE;

  1207       } /* if */

  1208     } /* if */

  1209     if (lval3.sym->dim.array.level!=level)

  1210       return error(48); /* array dimensions must match */

  1211     else if (ltlength<val || exactmatch && ltlength>val || val==0)

  1212       return error(47); /* array sizes must match */

  1213     else if (lval3.ident!=iARRAYCELL && !matchtag(lval3.sym->x.tags.index,idxtag,TRUE))

  1214       error(229,(lval2.sym!=NULL) ? lval2.sym->name : lval3.sym->name); /* index tag mismatch */

  1215     if (level>0) {

  1216       /* check the sizes of all sublevels too */

  1217       symbol *sym1 = lval3.sym;

  1218       symbol *sym2 = lval2.sym;

  1219       int i;

  1220       assert(sym1!=NULL && sym2!=NULL);

  1221       /* ^^^ sym2 must be valid, because only variables can be

  1222        *     multi-dimensional (there are no multi-dimensional literals),

  1223        *     sym1 must be valid because it must be an lvalue

  1224        */

  1225       assert(exactmatch);

  1226       for (i=0; i<level; i++) {

  1227         sym1=finddepend(sym1);

  1228         sym2=finddepend(sym2);

  1229         assert(sym1!=NULL && sym2!=NULL);

  1230         /* ^^^ both arrays have the same dimensions (this was checked

  1231          *     earlier) so the dependend should always be found

  1232          */

  1233         if (sym1->dim.array.length!=sym2->dim.array.length)

  1234           error(47);    /* array sizes must match */

  1235         else if (!matchtag(sym1->x.tags.index,sym2->x.tags.index,TRUE))

  1236           error(229,sym2->name);  /* index tag mismatch */

  1237       } /* for */

  1238       /* get the total size in cells of the multi-dimensional array */

  1239       val=array_totalsize(lval3.sym);

  1240       assert(val>0);    /* already checked */

  1241     } /* if */

  1242   } else {

  1243     /* left operand is not an array, right operand should then not be either */

  1244     if (lval2.ident==iARRAY || lval2.ident==iREFARRAY)

  1245       error(6);         /* must be assigned to an array */

  1246   } /* if */

  1247   if (leftarray) {

  1248     memcopy(val*sizeof(cell));

  1249   } else {

  1250     check_userop(NULL,lval2.tag,lval3.tag,2,&lval3,&lval2.tag);

  1251     store(&lval3);      /* now, store the expression result */

  1252   } /* if */

  1253   if (!oper && !checktag_string(&lval3, &lval2) && !matchtag(lval3.tag,lval2.tag,TRUE))

  1254     error(213);         /* tagname mismatch (if "oper", warning already given in plunge2()) */

  1255   if (lval3.sym)

  1256     markusage(lval3.sym,uWRITTEN);

  1257   sideeffect=TRUE;

  1258   bitwise_opercount=bwcount;

  1259   lval1->ident=iEXPRESSION;

  1260   return FALSE;         /* expression result is never an lvalue */

  1261 }

  1263 /**

  1264  * Sums up array usage in the current heap tracer and convert it into a dynamic array.

  1265  * This is used for the ternary operator, which needs to convert its array usage into

  1266  * something dynamically managed.

  1267  * !Note:

  1268  * This might break if expressions can ever return dynamic arrays.

  1269  * Thus, we assert() if something is non-static here.

  1270  * Right now, this poses no problem because this type of expression is impossible:

  1271  *   (a() ? return_array() : return_array()) ? return_array() : return_array()

  1272  */

  1274 long dynarray_from_heaplist(memuse_list_t *heap)

  1275 {

  1276   memuse_t *use=heap->head;

  1277   memuse_t *tmp;

  1278   long total=0;

  1279   while (use) {

  1280     assert(use->type==MEMUSE_STATIC);

  1281     total+=use->size;

  1282     tmp=use->prev;

  1283     free(use);

  1284     use=tmp;

  1285   }

  1286   free(heap);

  1287   if (total)

  1288     setheap_save(-total*sizeof(cell));

  1289   return total;

  1290 }

  1292 static int hier13(value *lval)

  1293 {

  1294   int lvalue=plnge1(hier12,lval);

  1295   if (matchtoken('?')) {

  1296     int flab1=getlabel();

  1297     int flab2=getlabel();

  1298     value lval2={0};

  1299     int array1,array2;

  1300     long total1,total2;

  1301     memuse_list_t *heap;

  1303     pushheaplist();

  1304     if (lvalue) {

  1305       rvalue(lval);

  1306     } else if (lval->ident==iCONSTEXPR) {

  1307       ldconst(lval->constval,sPRI);

  1308       error(lval->constval ? 206 : 205);        /* redundant test */

  1309     } /* if */

  1310     jmp_eq0(flab1);             /* go to second expression if primary register==0 */

  1311     PUSHSTK_I(sc_allowtags);

  1312     sc_allowtags=FALSE;         /* do not allow tagnames here (colon is a special token) */

  1313     if (hier13(lval))

  1314       rvalue(lval);

  1315     if (lval->ident==iCONSTEXPR)        /* load constant here */

  1316       ldconst(lval->constval,sPRI);

  1317     sc_allowtags=(short)POPSTK_I();     /* restore */

  1318     heap=popsaveheaplist();

  1319     total1=dynarray_from_heaplist(heap);

  1320     pushheaplist();

  1321     jumplabel(flab2);

  1322     setlabel(flab1);

  1323     needtoken(':');

  1324     if (hier13(&lval2))

  1325       rvalue(&lval2);

  1326     if (lval2.ident==iCONSTEXPR)        /* load constant here */

  1327       ldconst(lval2.constval,sPRI);

  1328     array1= (lval->ident==iARRAY || lval->ident==iREFARRAY);

  1329     array2= (lval2.ident==iARRAY || lval2.ident==iREFARRAY);

  1330     if (array1 && !array2) {

  1331       char *ptr=(lval->sym->name!=NULL) ? lval->sym->name : "-unknown-";

  1332       error(33,ptr);            /* array must be indexed */

  1333     } else if (!array1 && array2) {

  1334       char *ptr=(lval2.sym->name!=NULL) ? lval2.sym->name : "-unknown-";

  1335       error(33,ptr);            /* array must be indexed */

  1336     } /* if */

  1337     /* ??? if both are arrays, should check dimensions */

  1338     if (!matchtag(lval->tag,lval2.tag,FALSE))

  1339       error(213);               /* tagname mismatch ('true' and 'false' expressions) */

  1340     heap=popsaveheaplist();

  1341     total2=dynarray_from_heaplist(heap);

  1342     setlabel(flab2);

  1343     if ((array1 && array2) && (total1 && total2)) {

  1344       markheap(MEMUSE_DYNAMIC, 0);

  1345     }

  1346     if (lval->ident==iARRAY)

  1347       lval->ident=iREFARRAY;    /* iARRAY becomes iREFARRAY */

  1348     else if (lval->ident!=iREFARRAY)

  1349       lval->ident=iEXPRESSION;  /* iREFARRAY stays iREFARRAY, rest becomes iEXPRESSION */

  1350     return FALSE;               /* conditional expression is no lvalue */

  1351   } else {

  1352     return lvalue;

  1353   } /* if */

  1354 }

  1356 /* the order of the operators in these lists is important and must be

  1357  * the same as the order of the operators in the array "op1"

  1358  */

  1359 static int list3[]  = {'*','/','%',0};

  1360 static int list4[]  = {'+','-',0};

  1361 static int list5[]  = {tSHL,tSHR,tSHRU,0};

  1362 static int list6[]  = {'&',0};

  1363 static int list7[]  = {'^',0};

  1364 static int list8[]  = {'|',0};

  1365 static int list9[]  = {tlLE,tlGE,'<','>',0};

  1366 static int list10[] = {tlEQ,tlNE,0};

  1367 static int list11[] = {tlAND,0};

  1368 static int list12[] = {tlOR,0};

  1370 static int hier12(value *lval)

  1371 {

  1372   return skim(list12,jmp_ne0,1,0,hier11,lval);

  1373 }

  1375 static int hier11(value *lval)

  1376 {

  1377   return skim(list11,jmp_eq0,0,1,hier10,lval);

  1378 }

  1380 static int hier10(value *lval)

  1381 { /* ==, != */

  1382   return plnge(list10,15,hier9,lval,"bool",TRUE);

  1383 }                  /* ^ this variable is the starting index in the op1[]

  1384                     *   array of the operators of this hierarchy level */

  1386 static int hier9(value *lval)

  1387 { /* <=, >=, <, > */

  1388   return plnge_rel(list9,11,hier8,lval);

  1389 }

  1391 static int hier8(value *lval)

  1392 { /* | */

  1393   return plnge(list8,10,hier7,lval,NULL,FALSE);

  1394 }

  1396 static int hier7(value *lval)

  1397 { /* ^ */

  1398   return plnge(list7,9,hier6,lval,NULL,FALSE);

  1399 }

  1401 static int hier6(value *lval)

  1402 { /* & */

  1403   return plnge(list6,8,hier5,lval,NULL,FALSE);

  1404 }

  1406 static int hier5(value *lval)

  1407 { /* <<, >>, >>> */

  1408   return plnge(list5,5,hier4,lval,NULL,FALSE);

  1409 }

  1411 static int hier4(value *lval)

  1412 { /* +, - */

  1413   return plnge(list4,3,hier3,lval,NULL,FALSE);

  1414 }

  1416 static int hier3(value *lval)

  1417 { /* *, /, % */

  1418   return plnge(list3,0,hier2,lval,NULL,FALSE);

  1419 }

  1421 static int hier2(value *lval)

  1422 {

  1423   int lvalue,tok;

  1424   int tag,paranthese;

  1425   cell val;

  1426   char *st;

  1427   symbol *sym;

  1428   int saveresult;

  1430   tok=lex(&val,&st);

  1431   switch (tok) {

  1432   case tINC:                    /* ++lval */

  1433     if (!hier2(lval))

  1434       return error(22);         /* must be lvalue */

  1435     assert(lval->sym!=NULL);

  1436     if ((lval->sym->usage & uCONST)!=0)

  1437       return error(22);         /* assignment to const argument */

  1438     if (!check_userop(user_inc,lval->tag,0,1,lval,&lval->tag))

  1439       inc(lval);                /* increase variable first */

  1440     rvalue(lval);               /* and read the result into PRI */

  1441     sideeffect=TRUE;

  1442     return FALSE;               /* result is no longer lvalue */

  1443   case tDEC:                    /* --lval */

  1444     if (!hier2(lval))

  1445       return error(22);         /* must be lvalue */

  1446     assert(lval->sym!=NULL);

  1447     if ((lval->sym->usage & uCONST)!=0)

  1448       return error(22);         /* assignment to const argument */

  1449     if (!check_userop(user_dec,lval->tag,0,1,lval,&lval->tag))

  1450       dec(lval);                /* decrease variable first */

  1451     rvalue(lval);               /* and read the result into PRI */

  1452     sideeffect=TRUE;

  1453     return FALSE;               /* result is no longer lvalue */

  1454   case '~':                     /* ~ (one's complement) */

  1455     if (hier2(lval))

  1456       rvalue(lval);

  1457     invert();                   /* bitwise NOT */

  1458     lval->constval=~lval->constval;

  1459     return FALSE;

  1460   case '!':                     /* ! (logical negate) */

  1461     if (hier2(lval))

  1462       rvalue(lval);

  1463     if (check_userop(lneg,lval->tag,0,1,NULL,&lval->tag)) {

  1464       lval->ident=iEXPRESSION;

  1465       lval->constval=0;

  1466     } else {

  1467       lneg();                   /* 0 -> 1,  !0 -> 0 */

  1468       lval->constval=!lval->constval;

  1469       lval->tag=pc_addtag("bool");

  1470     } /* if */

  1471     return FALSE;

  1472   case '-':                     /* unary - (two's complement) */

  1473     if (hier2(lval))

  1474       rvalue(lval);

  1475     /* make a special check for a constant expression with the tag of a

  1476      * rational number, so that we can simple swap the sign of that constant.

  1477      */

  1478     if (lval->ident==iCONSTEXPR && lval->tag==sc_rationaltag && sc_rationaltag!=0) {

  1479       if (rational_digits==0) {

  1480         #if PAWN_CELL_SIZE==32

  1481           float *f = (float *)&lval->constval;

  1482         #elif PAWN_CELL_SIZE==64

  1483           double *f = (double *)&lval->constval;

  1484         #else

  1485           #error Unsupported cell size

  1486         #endif

  1487         *f= - *f; /* this modifies lval->constval */

  1488       } else {

  1489         /* the negation of a fixed point number is just an integer negation */

  1490         lval->constval=-lval->constval;

  1491       } /* if */

  1492     } else if (check_userop(neg,lval->tag,0,1,NULL,&lval->tag)) {

  1493       lval->ident=iEXPRESSION;

  1494       lval->constval=0;

  1495     } else {

  1496       neg();                    /* arithmic negation */

  1497       lval->constval=-lval->constval;

  1498     } /* if */

  1499     return FALSE;

  1500   case tLABEL:                  /* tagname override */

  1501     tag=pc_addtag(st);

  1502     lval->cmptag=tag;

  1503     lvalue=hier2(lval);

  1504     lval->tag=tag;

  1505     return lvalue;

  1506   case tDEFINED:

  1507     paranthese=0;

  1508     while (matchtoken('('))

  1509       paranthese++;

  1510     tok=lex(&val,&st);

  1511     if (tok!=tSYMBOL)

  1512       return error(20,st);      /* illegal symbol name */

  1513     sym=findloc(st);

  1514     if (sym==NULL)

  1515       sym=findglb(st,sSTATEVAR);

  1516     if (sym!=NULL && sym->ident!=iFUNCTN && sym->ident!=iREFFUNC && (sym->usage & uDEFINE)==0)

  1517       sym=NULL;                 /* symbol is not a function, it is in the table, but not "defined" */

  1518     val= (sym!=NULL);

  1519     if (!val && find_subst(st,strlen(st))!=NULL)

  1520       val=1;

  1521     clear_value(lval);

  1522     lval->ident=iCONSTEXPR;

  1523     lval->constval= val;

  1524     lval->tag=pc_addtag("bool");

  1525     ldconst(lval->constval,sPRI);

  1526     while (paranthese--)

  1527       needtoken(')');

  1528     return FALSE;

  1529   case tSIZEOF:

  1530     paranthese=0;

  1531     while (matchtoken('('))

  1532       paranthese++;

  1533     tok=lex(&val,&st);

  1534     if (tok!=tSYMBOL)

  1535       return error(20,st);      /* illegal symbol name */

  1536     sym=findloc(st);

  1537     if (sym==NULL)

  1538       sym=findglb(st,sSTATEVAR);

  1539     if (sym==NULL)

  1540       return error(17,st);      /* undefined symbol */

  1541     if (sym->ident==iCONSTEXPR)

  1542       error(39);                /* constant symbol has no size */

  1543     else if (sym->ident==iFUNCTN || sym->ident==iREFFUNC)

  1544       error(72);                /* "function" symbol has no size */

  1545     else if ((sym->usage & uDEFINE)==0)

  1546       return error(17,st);      /* undefined symbol (symbol is in the table, but it is "used" only) */

  1547     clear_value(lval);

  1548     lval->ident=iCONSTEXPR;

  1549     lval->constval=1;           /* preset */

  1550     if (sym->ident==iARRAY || sym->ident==iREFARRAY) {

  1551       int level;

  1552       symbol *idxsym=NULL;

  1553       symbol *subsym=sym;

  1554       for (level=0; matchtoken('['); level++) {

  1555         idxsym=NULL;

  1556         if (subsym!=NULL && level==subsym->dim.array.level && matchtoken(tSYMBOL)) {

  1557           char *idxname;

  1558           int cmptag=subsym->x.tags.index;

  1559           tokeninfo(&val,&idxname);

  1560           if ((idxsym=findconst(idxname,&cmptag))==NULL)

  1561             error(80,idxname);  /* unknown symbol, or non-constant */

  1562           else if (cmptag>1)

  1563             error(91,idxname);  /* ambiguous constant */

  1564         } /* if */

  1565         needtoken(']');

  1566         if (subsym!=NULL)

  1567           subsym=finddepend(subsym);

  1568       } /* for */

  1569 	  if (level>sym->dim.array.level+1) {

  1570         error(28,sym->name);  /* invalid subscript */

  1571       } else if (level==sym->dim.array.level+1) {

  1572         lval->constval= (idxsym!=NULL && idxsym->dim.array.length>0) ? idxsym->dim.array.length : 1;

  1573       } else {

  1574         lval->constval=array_levelsize(sym,level);

  1575       }

  1576       if (lval->constval==0 && strchr((char *)lptr,PREPROC_TERM)==NULL)

  1577         error(224,st);          /* indeterminate array size in "sizeof" expression */

  1578     } /* if */

  1579     ldconst(lval->constval,sPRI);

  1580     while (paranthese--)

  1581       needtoken(')');

  1582     return FALSE;

  1583   case tCELLSOF:

  1584     paranthese=0;

  1585     while (matchtoken('('))

  1586       paranthese++;

  1587     tok=lex(&val,&st);

  1588     if (tok!=tSYMBOL)

  1589       return error(20,st);      /* illegal symbol name */

  1590     sym=findloc(st);

  1591     if (sym==NULL)

  1592       sym=findglb(st,sSTATEVAR);

  1593     if (sym==NULL)

  1594       return error(17,st);      /* undefined symbol */

  1595     if (sym->ident==iCONSTEXPR)

  1596       error(39);                /* constant symbol has no size */

  1597     else if (sym->ident==iFUNCTN || sym->ident==iREFFUNC)

  1598       error(72);                /* "function" symbol has no size */

  1599     else if ((sym->usage & uDEFINE)==0)

  1600       return error(17,st);      /* undefined symbol (symbol is in the table, but it is "used" only) */

  1601     clear_value(lval);

  1602     lval->ident=iCONSTEXPR;

  1603     lval->constval=1;           /* preset */

  1604     if (sym->ident==iARRAY || sym->ident==iREFARRAY) {

  1605       int level;

  1606       symbol *idxsym=NULL;

  1607       symbol *subsym=sym;

  1608       for (level=0; matchtoken('['); level++) {

  1609         idxsym=NULL;

  1610         if (subsym!=NULL && level==subsym->dim.array.level && matchtoken(tSYMBOL)) {

  1611           char *idxname;

  1612           int cmptag=subsym->x.tags.index;

  1613           tokeninfo(&val,&idxname);

  1614           if ((idxsym=findconst(idxname,&cmptag))==NULL)

  1615             error(80,idxname);  /* unknown symbol, or non-constant */

  1616           else if (cmptag>1)

  1617             error(91,idxname);  /* ambiguous constant */

  1618         } /* if */

  1619         needtoken(']');

  1620         if (subsym!=NULL)

  1621           subsym=finddepend(subsym);

  1622       } /* for */

  1623 	  if (level>sym->dim.array.level+1) {

  1624         error(28,sym->name);  /* invalid subscript */

  1625       } else if (level==sym->dim.array.level+1) {

  1626         lval->constval= (idxsym!=NULL && idxsym->dim.array.length>0) ? idxsym->dim.array.length : 1;

  1627       } else {

  1628         lval->constval=array_levelsize(sym,level);

  1629       }

  1630       if (lval->constval==0 && strchr((char *)lptr,PREPROC_TERM)==NULL)

  1631         error(224,st);          /* indeterminate array size in "sizeof" expression */

  1632     } /* if */

  1633     ldconst(lval->constval,sPRI);

  1634     while (paranthese--)

  1635       needtoken(')');

  1636     return FALSE;

  1637   case tTAGOF:

  1638     paranthese=0;

  1639     while (matchtoken('('))

  1640       paranthese++;

  1641     tok=lex(&val,&st);

  1642     if (tok!=tSYMBOL && tok!=tLABEL)

  1643       return error(20,st);      /* illegal symbol name */

  1644     if (tok==tLABEL) {

  1645       constvalue *tagsym=find_constval(&tagname_tab,st,0);

  1646       tag=(int)((tagsym!=NULL) ? tagsym->value : 0);

  1647     } else {

  1648       sym=findloc(st);

  1649       if (sym==NULL)

  1650         sym=findglb(st,sSTATEVAR);

  1651       if (sym==NULL)

  1652         return error(17,st);      /* undefined symbol */

  1653       if ((sym->usage & uDEFINE)==0)

  1654         return error(17,st);      /* undefined symbol (symbol is in the table, but it is "used" only) */

  1655       tag=sym->tag;

  1656     } /* if */

  1657     if (sym->ident==iARRAY || sym->ident==iREFARRAY) {

  1658       int level;

  1659       symbol *idxsym=NULL;

  1660       symbol *subsym=sym;

  1661       for (level=0; matchtoken('['); level++) {

  1662         idxsym=NULL;

  1663         if (subsym!=NULL && level==subsym->dim.array.level && matchtoken(tSYMBOL)) {

  1664           char *idxname;

  1665           int cmptag=subsym->x.tags.index;

  1666           tokeninfo(&val,&idxname);

  1667           if ((idxsym=findconst(idxname,&cmptag))==NULL)

  1668             error(80,idxname);  /* unknown symbol, or non-constant */

  1669           else if (cmptag>1)

  1670             error(91,idxname);  /* ambiguous constant */

  1671         } /* if */

  1672         needtoken(']');

  1673         if (subsym!=NULL)

  1674           subsym=finddepend(subsym);

  1675       } /* for */

  1676       if (level>sym->dim.array.level+1)

  1677         error(28,sym->name);  /* invalid subscript */

  1678       else if (level==sym->dim.array.level+1 && idxsym!=NULL)

  1679         tag= idxsym->x.tags.index;

  1680     } /* if */

  1681     exporttag(tag);

  1682     clear_value(lval);

  1683     lval->ident=iCONSTEXPR;

  1684     lval->constval=tag | PUBLICTAG;

  1685     ldconst(lval->constval,sPRI);

  1686     while (paranthese--)

  1687       needtoken(')');

  1688     return FALSE;

  1689   case tSTATE: {

  1690     constvalue *automaton;

  1691     constvalue *state;

  1692     if (sc_getstateid(&automaton,&state)) {

  1693       assert(automaton!=NULL);

  1694       assert(automaton->index==0 && automaton->name[0]=='\0' || automaton->index>0);

  1695       loadreg(automaton->value,sALT);

  1696       assert(state!=NULL);

  1697       ldconst(state->value,sPRI);

  1698       ob_eq();

  1699       clear_value(lval);

  1700       lval->ident=iEXPRESSION;

  1701       lval->tag=pc_addtag("bool");

  1702     } /* if */

  1703     return FALSE;

  1704   } /* case */

  1705   default:

  1706     lexpush();

  1707     lvalue=hier1(lval);

  1708     /* check for postfix operators */

  1709     if (matchtoken(';')) {

  1710       /* Found a ';', do not look further for postfix operators */

  1711       lexpush();                /* push ';' back after successful match */

  1712       return lvalue;

  1713     } else if (matchtoken(tTERM)) {

  1714       /* Found a newline that ends a statement (this is the case when

  1715        * semicolons are optional). Note that an explicit semicolon was

  1716        * handled above. This case is similar, except that the token must

  1717        * not be pushed back.

  1718        */

  1719       return lvalue;

  1720     } else {

  1721       tok=lex(&val,&st);

  1722       switch (tok) {

  1723       case tINC:                /* lval++ */

  1724         if (!lvalue)

  1725           return error(22);     /* must be lvalue */

  1726         assert(lval->sym!=NULL);

  1727         if ((lval->sym->usage & uCONST)!=0)

  1728           return error(22);     /* assignment to const argument */

  1729         /* on incrementing array cells, the address in PRI must be saved for

  1730          * incremening the value, whereas the current value must be in PRI

  1731          * on exit.

  1732          */

  1733         saveresult= (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR);

  1734         if (saveresult)

  1735           pushreg(sPRI);        /* save address in PRI */

  1736         rvalue(lval);           /* read current value into PRI */

  1737         if (saveresult)

  1738           swap1();              /* save PRI on the stack, restore address in PRI */

  1739         if (!check_userop(user_inc,lval->tag,0,1,lval,&lval->tag))

  1740           inc(lval);            /* increase variable afterwards */

  1741         if (saveresult)

  1742           popreg(sPRI);         /* restore PRI (result of rvalue()) */

  1743         sideeffect=TRUE;

  1744         return FALSE;           /* result is no longer lvalue */

  1745       case tDEC:                /* lval-- */

  1746         if (!lvalue)

  1747           return error(22);     /* must be lvalue */

  1748         assert(lval->sym!=NULL);

  1749         if ((lval->sym->usage & uCONST)!=0)

  1750           return error(22);     /* assignment to const argument */

  1751         saveresult= (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR);

  1752         if (saveresult)

  1753           pushreg(sPRI);        /* save address in PRI */

  1754         rvalue(lval);           /* read current value into PRI */

  1755         if (saveresult)

  1756           swap1();              /* save PRI on the stack, restore address in PRI */

  1757         if (!check_userop(user_dec,lval->tag,0,1,lval,&lval->tag))

  1758           dec(lval);            /* decrease variable afterwards */

  1759         if (saveresult)

  1760           popreg(sPRI);         /* restore PRI (result of rvalue()) */

  1761         sideeffect=TRUE;

  1762         return FALSE;

  1763 /* This is temporarily disabled because we detect it automatically.

  1764  * Thus, it could be weird if both were used at once

  1765  */

  1766 #if 0

  1767       case tCHAR:               /* char (compute required # of cells */

  1768         if (lval->ident==iCONSTEXPR) {

  1769           lval->constval *= sCHARBITS/8;  /* from char to bytes */

  1770           lval->constval = (lval->constval + sizeof(cell)-1) / sizeof(cell);

  1771         } else {

  1772           if (lvalue)

  1773             rvalue(lval);       /* fetch value if not already in PRI */

  1774           char2addr();          /* from characters to bytes */

  1775           addconst(sizeof(cell)-1);     /* make sure the value is rounded up */

  1776           addr2cell();          /* truncate to number of cells */

  1777         } /* if */

  1778         return FALSE;

  1779 #endif

  1780       default:

  1781         lexpush();

  1782         return lvalue;

  1783       } /* switch */

  1784     } /* if */

  1785   } /* switch */

  1786 }

  1788 /*  hier1

  1789  *

  1790  *  The highest hierarchy level: it looks for pointer and array indices

  1791  *  and function calls.

  1792  *  Generates code to fetch a pointer value if it is indexed and code to

  1793  *  add to the pointer value or the array address (the address is already

  1794  *  read at primary()). It also generates code to fetch a function address

  1795  *  if that hasn't already been done at primary() (check lval[4]) and calls

  1796  *  callfunction() to call the function.

  1797  */

  1798 static int hier1(value *lval1)

  1799 {

  1800   int lvalue,index,tok,symtok;

  1801   cell val,cidx;

  1802   value lval2={0};

  1803   char *st;

  1804   char close;

  1805   symbol *sym;

  1806   int magic_string=0;

  1807   symbol dummysymbol,*cursym;   /* for changing the index tags in case of enumerated pseudo-arrays */

  1809   lvalue=primary(lval1);

  1810   symtok=tokeninfo(&val,&st);   /* get token read by primary() */

  1811   cursym=lval1->sym;

  1812 restart:

  1813   sym=cursym;

  1814   if (matchtoken('[') || matchtoken('{') || matchtoken('(')) {

  1815     tok=tokeninfo(&val,&st);    /* get token read by matchtoken() */

  1816     magic_string = (sym && (sym->tag == pc_tag_string && sym->dim.array.level == 0));

  1817     if (sym==NULL && symtok!=tSYMBOL) {

  1818       /* we do not have a valid symbol and we appear not to have read a valid

  1819        * symbol name (so it is unlikely that we would have read a name of an

  1820        * undefined symbol) */

  1821       error(29);                /* expression error, assumed 0 */

  1822       lexpush();                /* analyse '(', '{' or '[' again later */

  1823       return FALSE;

  1824     } /* if */

  1825     if (tok=='[' || tok=='{') { /* subscript */

  1826       close = (char)((tok=='[') ? ']' : '}');

  1827       if (sym==NULL) {  /* sym==NULL if lval is a constant or a literal */

  1828         error(28,"<no variable>");  /* cannot subscript */

  1829         needtoken(close);

  1830         return FALSE;

  1831       } else if (sym->ident!=iARRAY && sym->ident!=iREFARRAY){

  1832         error(28,sym->name);    /* cannot subscript, variable is not an array */

  1833         needtoken(close);

  1834         return FALSE;

  1835       } else if (sym->dim.array.level>0 && close!=']') {

  1836         error(51);      /* invalid subscript, must use [ ] */

  1837         needtoken(close);

  1838         return FALSE;

  1839       } /* if */

  1840       /* set the tag to match (enumeration fields as indices) */

  1841       lval2.cmptag=sym->x.tags.index;

  1842       stgget(&index,&cidx);     /* mark position in code generator */

  1843       pushreg(sPRI);            /* save base address of the array */

  1844       if (hier14(&lval2))       /* create expression for the array index */

  1845         rvalue(&lval2);

  1846       if (lval2.ident==iARRAY || lval2.ident==iREFARRAY)

  1847         error(33,lval2.sym->name);      /* array must be indexed */

  1848       needtoken(close);

  1849       if ((sym->usage & uENUMROOT) && !matchtag(sym->x.tags.index,lval2.tag,TRUE))

  1850         error(213);

  1851       if (lval2.ident==iCONSTEXPR) {    /* constant expression */

  1852         stgdel(index,cidx);             /* scratch generated code */

  1853         if (lval1->arrayidx!=NULL) {    /* keep constant index, for checking */

  1854           assert(sym->dim.array.level>=0 && sym->dim.array.level<sDIMEN_MAX);

  1855           lval1->arrayidx[sym->dim.array.level]=lval2.constval;

  1856         } /* if */

  1857         if (close==']' && !(sym->tag == pc_tag_string && sym->dim.array.level == 0)) {

  1858           /* normal array index */

  1859           if (lval2.constval<0 || sym->dim.array.length!=0 && sym->dim.array.length<=lval2.constval)

  1860             error(32,sym->name);        /* array index out of bounds */

  1861           if (lval2.constval!=0) {

  1862             /* don't add offsets for zero subscripts */

  1863             #if PAWN_CELL_SIZE==16

  1864               ldconst(lval2.constval<<1,sALT);

  1865             #elif PAWN_CELL_SIZE==32

  1866               ldconst(lval2.constval<<2,sALT);

  1867             #elif PAWN_CELL_SIZE==64

  1868               ldconst(lval2.constval<<3,sALT);

  1869             #else

  1870               #error Unsupported cell size

  1871             #endif

  1872             ob_add();

  1873           } /* if */

  1874         } else {

  1875           /* character index */

  1876           if (lval2.constval<0 || sym->dim.array.length!=0

  1877               && sym->dim.array.length*((8*sizeof(cell))/sCHARBITS)<=(ucell)lval2.constval)

  1878             error(32,sym->name);        /* array index out of bounds */

  1879           if (lval2.constval!=0) {

  1880             /* don't add offsets for zero subscripts */

  1881             #if sCHARBITS==16

  1882               ldconst(lval2.constval<<1,sALT);/* 16-bit character */

  1883             #else

  1884               ldconst(lval2.constval,sALT);   /* 8-bit character */

  1885             #endif

  1886             ob_add();

  1887           } /* if */

  1888           charalign();                  /* align character index into array */

  1889         } /* if */

  1890         /* if the array index is a field from an enumeration, get the tag name

  1891          * from the field and save the size of the field too.

  1892          */

  1893         assert(lval2.sym==NULL || lval2.sym->dim.array.level==0);

  1894         if (lval2.sym!=NULL && lval2.sym->dim.array.length>0 && sym->dim.array.level==0) {

  1895           lval1->tag=lval2.sym->x.tags.index;

  1896           lval1->constval=lval2.sym->dim.array.length;

  1897         } /* if */

  1898       } else {

  1899         /* array index is not constant */

  1900         lval1->arrayidx=NULL;           /* reset, so won't be checked */

  1901         if (close==']' && !magic_string) {

  1902           if (sym->dim.array.length!=0)

  1903             ffbounds(sym->dim.array.length-1);  /* run time check for array bounds */

  1904           cell2addr();  /* normal array index */

  1905         } else {

  1906           if (sym->dim.array.length!=0)

  1907             ffbounds(sym->dim.array.length*(32/sCHARBITS)-1);

  1908           char2addr();  /* character array index */

  1909         } /* if */

  1910         popreg(sALT);

  1911         ob_add();       /* base address was popped into secondary register */

  1912         if (close!=']' || magic_string)

  1913           charalign();  /* align character index into array */

  1914       } /* if */

  1915       /* the indexed item may be another array (multi-dimensional arrays) */

  1916       assert(cursym==sym && sym!=NULL); /* should still be set */

  1917       if (sym->dim.array.level>0) {

  1918         assert(close==']');     /* checked earlier */

  1919         assert(cursym==lval1->sym);

  1920         /* read the offset to the subarray and add it to the current address */

  1921         lval1->ident=iARRAYCELL;

  1922         pushreg(sPRI);          /* the optimizer makes this to a MOVE.alt */

  1923         rvalue(lval1);

  1924         popreg(sALT);

  1925         ob_add();

  1926         /* adjust the "value" structure and find the referenced array */

  1927         lval1->ident=iREFARRAY;

  1928         lval1->sym=finddepend(sym);

  1929         assert(lval1->sym!=NULL);

  1930         assert(lval1->sym->dim.array.level==sym->dim.array.level-1);

  1931         cursym=lval1->sym;

  1932         /* try to parse subsequent array indices */

  1933         lvalue=FALSE;   /* for now, a iREFARRAY is no lvalue */

  1934         goto restart;

  1935       } /* if */

  1936       assert(sym->dim.array.level==0);

  1937       /* set type to fetch... INDIRECTLY */

  1938       if (sym->tag == pc_tag_string) {

  1939         lval1->ident = iARRAYCHAR;

  1940       } else {

  1941         lval1->ident= (char)((close==']') ? iARRAYCELL : iARRAYCHAR);

  1942       }

  1943       /* if the array index is a field from an enumeration, get the tag name

  1944        * from the field and save the size of the field too. Otherwise, the

  1945        * tag is the one from the array symbol.

  1946        */

  1947       if (lval2.ident==iCONSTEXPR && lval2.sym!=NULL

  1948           && lval2.sym->dim.array.length>0 && sym->dim.array.level==0)

  1949       {

  1950         lval1->tag=lval2.sym->x.tags.index;

  1951         lval1->constval=lval2.sym->dim.array.length;

  1952         if (lval2.tag==sym->x.tags.index && lval1->constval>1 && matchtoken('[')) {

  1953           /* an array indexed with an enumeration field may be considered a sub-array */

  1954           lexpush();

  1955           lvalue=FALSE;   /* for now, a iREFARRAY is no lvalue */

  1956           lval1->ident=iREFARRAY;

  1957           /* initialize a dummy symbol, which is a copy of the current symbol,

  1958            * but with an adjusted index tag

  1959            */

  1960           assert(sym!=NULL);

  1961           dummysymbol=*sym;

  1962           /* get the tag of the root of the enumeration */

  1963           assert(lval2.sym!=NULL);

  1964           dummysymbol.x.tags.index=lval2.sym->x.tags.field;

  1965           dummysymbol.dim.array.length=lval2.sym->dim.array.length;

  1966           cursym=&dummysymbol;

  1967           /* recurse */

  1968           goto restart;

  1969         } /* if */

  1970       } else {

  1971         assert(sym!=NULL);

  1972         if (cursym!=&dummysymbol)

  1973           lval1->tag=sym->tag;

  1974         lval1->constval=0;

  1975       } /* if */

  1976       /* a cell in an array is an lvalue, a character in an array is not

  1977        * always a *valid* lvalue */

  1978       return TRUE;

  1979     } else {            /* tok=='(' -> function(...) */

  1980       assert(tok=='(');

  1981       if (sym==NULL

  1982           || (sym->ident!=iFUNCTN && sym->ident!=iREFFUNC))

  1983       {

  1984         if (sym==NULL && sc_status==statFIRST) {

  1985           /* could be a "use before declaration"; in that case, create a stub

  1986            * function so that the usage can be marked.

  1987            */

  1988           sym=fetchfunc(lastsymbol,0);

  1989           if (sym==NULL)

  1990             error(103); /* insufficient memory */

  1991           markusage(sym,uREAD);

  1992         } else {

  1993           return error(12);           /* invalid function call */

  1994         } /* if */

  1995       } else if ((sym->usage & uMISSING)!=0) {

  1996         char symname[2*sNAMEMAX+16];  /* allow space for user defined operators */

  1997         funcdisplayname(symname,sym->name);

  1998         error(4,symname);             /* function not defined */

  1999       } /* if */

  2000       callfunction(sym,lval1,TRUE);

  2001       return FALSE;             /* result of function call is no lvalue */

  2002     } /* if */

  2003   } /* if */

  2004   if (sym!=NULL && lval1->ident==iFUNCTN) {

  2005     assert(sym->ident==iFUNCTN);

  2006     if (sc_allowproccall) {

  2007       callfunction(sym,lval1,FALSE);

  2008     } else {

  2009       symbol *oldsym=sym;

  2010       int n=-1,iter=0;

  2011       int usage = ((sym->usage & uPUBLIC) == uPUBLIC) ? uPUBLIC : 0;

  2012       cell code_addr=0;

  2013       for (sym=glbtab.next; sym!=NULL; sym=sym->next) {

  2014         if (sym->ident==iFUNCTN && sym->vclass == sGLOBAL && (!usage || (sym->usage & usage)))

  2015         {

  2016           if (strcmp(sym->name, lval1->sym->name)==0) {

  2017             n = iter;

  2018             code_addr = sym->codeaddr;

  2019             break;

  2020           }

  2021           iter++;

  2022         }

  2023       }

  2024       if (n!=-1) {

  2025         char faketag[sNAMEMAX+1];

  2026         lval1->sym=NULL;

  2027         lval1->ident=iCONSTEXPR;

  2028         /* Generate a quick pseudo-tag! */

  2029         if (usage == uPUBLIC) {

  2030           lval1->constval=(n<<1)|1;

  2031           snprintf(faketag, sizeof(faketag)-1, "$Func@%d", n);

  2032         } else {

  2033           lval1->constval=(code_addr<<1)|0;

  2034           snprintf(faketag, sizeof(faketag)-1, "$Func!%d", code_addr);

  2035         }

  2036         lval1->tag=pc_addfunctag(faketag);

  2037         oldsym->usage |= uREAD;

  2038 		sym->usage |= uREAD;

  2039       } else {

  2040         error(76);                /* invalid function call, or syntax error */

  2041       } /* if */

  2042       return FALSE;

  2043     }

  2044   } /* if */

  2045   return lvalue;

  2046 }

  2048 /*  primary

  2049  *

  2050  *  Returns 1 if the operand is an lvalue (everything except arrays, functions

  2051  *  constants and -of course- errors).

  2052  *  Generates code to fetch the address of arrays. Code for constants is

  2053  *  already generated by constant().

  2054  *  This routine first clears the entire lval array (all fields are set to 0).

  2055  *

  2056  *  Global references: sc_intest  (may be altered, but restored upon termination)

  2057  */

  2058 static int primary(value *lval)

  2059 {

  2060   char *st;

  2061   int lvalue,tok;

  2062   cell val;

  2063   symbol *sym;

  2065   if (matchtoken('(')){         /* sub-expression - (expression,...) */

  2066     PUSHSTK_I(sc_intest);

  2067     PUSHSTK_I(sc_allowtags);

  2069     sc_intest=FALSE;            /* no longer in "test" expression */

  2070     sc_allowtags=TRUE;          /* allow tagnames to be used in parenthesized expressions */

  2071     sc_allowproccall=FALSE;

  2072     do

  2073       lvalue=hier14(lval);

  2074     while (matchtoken(','));

  2075     needtoken(')');

  2076     lexclr(FALSE);              /* clear lex() push-back, it should have been

  2077                                  * cleared already by needtoken() */

  2078     sc_allowtags=(short)POPSTK_I();

  2079     sc_intest=(short)POPSTK_I();

  2080     return lvalue;

  2081   } /* if */

  2083   clear_value(lval);    /* clear lval */

  2084   tok=lex(&val,&st);

  2085   if (tok==tSYMBOL) {

  2086     /* lastsymbol is char[sNAMEMAX+1], lex() should have truncated any symbol

  2087      * to sNAMEMAX significant characters */

  2088     assert(strlen(st)<sizeof lastsymbol);

  2089     strcpy(lastsymbol,st);

  2090   } /* if */

  2091   if (tok==tSYMBOL && !findconst(st,NULL)) {

  2092     /* first look for a local variable */

  2093     if ((sym=findloc(st))!=0) {

  2094       if (sym->ident==iLABEL) {

  2095         error(29);          /* expression error, assumed 0 */

  2096         ldconst(0,sPRI);    /* load 0 */

  2097         return FALSE;       /* return 0 for labels (expression error) */

  2098       } /* if */

  2099       lval->sym=sym;

  2100       lval->ident=sym->ident;

  2101       lval->tag=sym->tag;

  2102       if (sym->ident==iARRAY || sym->ident==iREFARRAY) {

  2103         address(sym,sPRI);  /* get starting address in primary register */

  2104         return FALSE;       /* return 0 for array (not lvalue) */

  2105       } else {

  2106         return TRUE;        /* return 1 if lvalue (not label or array) */

  2107       } /* if */

  2108     } /* if */

  2109     /* now try a global variable */

  2110     if ((sym=findglb(st,sSTATEVAR))!=0) {

  2111       if (sym->ident==iFUNCTN || sym->ident==iREFFUNC) {

  2112         /* if the function is only in the table because it was inserted as a

  2113          * stub in the first pass (i.e. it was "used" but never declared or

  2114          * implemented, issue an error

  2115          */

  2116         if ((sym->usage & uPROTOTYPED)==0)

  2117           error(17,st);

  2118       } else {

  2119         if ((sym->usage & uDEFINE)==0)

  2120           error(17,st);

  2121         lval->sym=sym;

  2122         lval->ident=sym->ident;

  2123         lval->tag=sym->tag;

  2124         if (sym->ident==iARRAY || sym->ident==iREFARRAY) {

  2125           address(sym,sPRI);    /* get starting address in primary register */

  2126           return FALSE;         /* return 0 for array (not lvalue) */

  2127         } else {

  2128           return TRUE;          /* return 1 if lvalue (not function or array) */

  2129         } /* if */

  2130       } /* if */

  2131     } else {

  2132       if (!sc_allowproccall)

  2133         return error(17,st);    /* undefined symbol */

  2134       /* an unknown symbol, but used in a way compatible with the "procedure

  2135        * call" syntax. So assume that the symbol refers to a function.

  2136        */

  2137       assert(sc_status==statFIRST);

  2138       sym=fetchfunc(st,0);

  2139       if (sym==NULL)

  2140         error(103);     /* insufficient memory */

  2141     } /* if */

  2142     assert(sym!=NULL);

  2143     assert(sym->ident==iFUNCTN || sym->ident==iREFFUNC);

  2144     lval->sym=sym;

  2145     lval->ident=sym->ident;

  2146     lval->tag=sym->tag;

  2147     return FALSE;       /* return 0 for function (not an lvalue) */

  2148   } /* if */

  2149   lexpush();            /* push the token, it is analyzed by constant() */

  2150   if (constant(lval)==0) {

  2151     error(29);          /* expression error, assumed 0 */

  2152     ldconst(0,sPRI);    /* load 0 */

  2153   } /* if */

  2154   return FALSE;         /* return 0 for constants (or errors) */

  2155 }

  2157 static void clear_value(value *lval)

  2158 {

  2159   lval->sym=NULL;

  2160   lval->constval=0L;

  2161   lval->tag=0;

  2162   lval->ident=0;

  2163   lval->boolresult=FALSE;

  2164   /* do not clear lval->arrayidx, it is preset in hier14() */

  2165   /* do not clear lval->cmptag */

  2166 }

  2168 static void setdefarray(cell *string,cell size,cell array_sz,cell *dataaddr,int fconst)

  2169 {

  2170   /* The routine must copy the default array data onto the heap, as to avoid

  2171    * that a function can change the default value. An optimization is that

  2172    * the default array data is "dumped" into the data segment only once (on the

  2173    * first use).

  2174    */

  2175   assert(string!=NULL);

  2176   assert(size>0);

  2177   /* check whether to dump the default array */

  2178   assert(dataaddr!=NULL);

  2179   if (sc_status==statWRITE && *dataaddr<0) {

  2180     int i;

  2181     *dataaddr=(litidx+glb_declared)*sizeof(cell);

  2182     for (i=0; i<size; i++)

  2183       litadd(*string++);

  2184   } /* if */

  2186   /* if the function is known not to modify the array (meaning that it also

  2187    * does not modify the default value), directly pass the address of the

  2188    * array in the data segment.

  2189    */

  2190   if (fconst) {

  2191     ldconst(*dataaddr,sPRI);

  2192   } else {

  2193     /* Generate the code:

  2194      *  CONST.pri dataaddr                ;address of the default array data

  2195      *  HEAP      array_sz*sizeof(cell)   ;heap address in ALT

  2196      *  MOVS      size*sizeof(cell)       ;copy data from PRI to ALT

  2197      *  MOVE.PRI                          ;PRI = address on the heap

  2198      */

  2199     ldconst(*dataaddr,sPRI);

  2200     /* "array_sz" is the size of the argument (the value between the brackets

  2201      * in the declaration), "size" is the size of the default array data.

  2202      */

  2203     assert(array_sz>=size);

  2204     modheap((int)array_sz*sizeof(cell));

  2205     markheap(MEMUSE_STATIC, array_sz);

  2206     /* ??? should perhaps fill with zeros first */

  2207     memcopy(size*sizeof(cell));

  2208     moveto1();

  2209   } /* if */

  2210 }

  2212 static int findnamedarg(arginfo *arg,char *name)

  2213 {

  2214   int i;

  2216   for (i=0; arg[i].ident!=0 && arg[i].ident!=iVARARGS; i++)

  2217     if (strcmp(arg[i].name,name)==0)

  2218       return i;

  2219   return -1;

  2220 }

  2222 int checktag(int tags[],int numtags,int exprtag)

  2223 {

  2224   int i;

  2226   assert(tags!=0);

  2227   assert(numtags>0);

  2228   for (i=0; i<numtags; i++)

  2229     if (matchtag(tags[i],exprtag,TRUE))

  2230       return TRUE;    /* matching tag */

  2231   return FALSE;       /* no tag matched */

  2232 }

  2234 enum {

  2235   ARG_UNHANDLED,

  2236   ARG_IGNORED,

  2237   ARG_DONE,

  2238 };

  2240 /*  callfunction

  2241  *

  2242  *  Generates code to call a function. This routine handles default arguments

  2243  *  and positional as well as named parameters.

  2244  */

  2245 static void callfunction(symbol *sym,value *lval_result,int matchparanthesis)

  2246 {

  2247 static long nest_stkusage=0L;

  2248 static int nesting=0;

  2249   int close,lvalue;

  2250   int argpos;       /* index in the output stream (argpos==nargs if positional parameters) */

  2251   int argidx=0;     /* index in "arginfo" list */

  2252   int nargs=0;      /* number of arguments */

  2253   int heapalloc=0;

  2254   int namedparams=FALSE;

  2255   value lval = {0};

  2256   arginfo *arg;

  2257   char arglist[sMAXARGS];

  2258   constvalue arrayszlst = { NULL, "", 0, 0};/* array size list starts empty */

  2259   constvalue taglst = { NULL, "", 0, 0};    /* tag list starts empty */

  2260   symbol *symret;

  2261   cell lexval;

  2262   char *lexstr;

  2264   assert(sym!=NULL);

  2265   lval_result->ident=iEXPRESSION; /* preset, may be changed later */

  2266   lval_result->constval=0;

  2267   lval_result->tag=sym->tag;

  2268   /* check whether this is a function that returns an array */

  2269   symret=finddepend(sym);

  2270   assert(symret==NULL || symret->ident==iREFARRAY);

  2271   if (symret!=NULL) {

  2272     int retsize;

  2273     /* allocate space on the heap for the array, and pass the pointer to the

  2274      * reserved memory block as a hidden parameter

  2275      */

  2276     retsize=(int)array_totalsize(symret);

  2277     assert(retsize>0);

  2278     modheap(retsize*sizeof(cell));/* address is in ALT */

  2279     pushreg(sALT);                /* pass ALT as the last (hidden) parameter */

  2280     markheap(MEMUSE_STATIC, retsize);

  2281     /* also mark the ident of the result as "array" */

  2282     lval_result->ident=iREFARRAY;

  2283     lval_result->sym=symret;

  2284   } /* if */

  2285   pushheaplist();

  2287   nesting++;

  2288   assert(nest_stkusage>=0);

  2289   #if !defined NDEBUG

  2290     if (nesting==1)

  2291       assert(nest_stkusage==0);

  2292   #endif

  2293   sc_allowproccall=FALSE;       /* parameters may not use procedure call syntax */

  2295   if ((sym->flags & flgDEPRECATED)!=0) {

  2296     char *ptr= (sym->documentation!=NULL) ? sym->documentation : "";

  2297     error(234,sym->name,ptr);   /* deprecated (probably a native function) */

  2298   } /* if */

  2300   /* run through the arguments */

  2301   arg=sym->dim.arglist;

  2302   assert(arg!=NULL);

  2303   stgmark(sSTARTREORDER);

  2304   memset(arglist,ARG_UNHANDLED,sizeof arglist);

  2305   if (matchparanthesis) {

  2306     /* Opening brace was already parsed, if closing brace follows, this

  2307      * call passes no parameters.

  2308      */

  2309     close=matchtoken(')');

  2310   } else {

  2311     /* When we find an end of line here, it may be a function call passing

  2312      * no parameters, or it may be that the first parameter is on a line

  2313      * below. But as a parameter can be anything, this is difficult to check.

  2314      * The only simple check that we have is the use of "named parameters".

  2315      */

  2316     close=matchtoken(tTERM);

  2317     if (close) {

  2318       close=!matchtoken('.');

  2319       if (!close)

  2320         lexpush();                /* reset the '.' */

  2321     } /* if */

  2322   } /* if */

  2323   if (!close) {

  2324     do {

  2325       if (matchtoken('.')) {

  2326         namedparams=TRUE;

  2327         if (needtoken(tSYMBOL))

  2328           tokeninfo(&lexval,&lexstr);

  2329         else

  2330           lexstr="";

  2331         argpos=findnamedarg(arg,lexstr);

  2332         if (argpos<0) {

  2333           error(17,lexstr);       /* undefined symbol */

  2334           break;                  /* exit loop, argpos is invalid */

  2335         } /* if */

  2336         needtoken('=');

  2337         argidx=argpos;

  2338       } else {

  2339         if (namedparams)

  2340           error(44);   /* positional parameters must precede named parameters */

  2341         argpos=nargs;

  2342       } /* if */

  2343       /* the number of arguments this was already checked at the declaration

  2344        * of the function; check it again for functions with a variable

  2345        * argument list

  2346        */

  2347       if (argpos>=sMAXARGS)

  2348         error(45);                /* too many function arguments */

  2349       stgmark((char)(sEXPRSTART+argpos));/* mark beginning of new expression in stage */

  2350       if (arglist[argpos]!=ARG_UNHANDLED)

  2351         error(58);                /* argument already set */

  2352       if (matchtoken('_')) {

  2353         arglist[argpos]=ARG_IGNORED;  /* flag argument as "present, but ignored" */

  2354         if (arg[argidx].ident==0 || arg[argidx].ident==iVARARGS) {

  2355           error(92);             /* argument count mismatch */

  2356         } else if (!arg[argidx].hasdefault) {

  2357           error(34,nargs+1);      /* argument has no default value */

  2358         } /* if */

  2359         if (arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS)

  2360           argidx++;

  2361         /* The rest of the code to handle default values is at the bottom

  2362          * of this routine where default values for unspecified parameters

  2363          * are (also) handled. Note that above, the argument is flagged as

  2364          * ARG_IGNORED.

  2365          */

  2366       } else {

  2367         arglist[argpos]=ARG_DONE; /* flag argument as "present" */

  2368         if (arg[argidx].numtags==1)     /* set the expected tag, if any */

  2369           lval.cmptag=arg[argidx].tags[0];

  2370         lvalue=hier14(&lval);

  2371         assert(sc_status==statFIRST || arg[argidx].tags!=NULL);

  2372         switch (arg[argidx].ident) {

  2373         case 0:

  2374           error(92);             /* argument count mismatch */

  2375           break;

  2376         case iVARARGS:

  2377           /* always pass by reference */

  2378           if (lval.ident==iVARIABLE || lval.ident==iREFERENCE) {

  2379             assert(lval.sym!=NULL);

  2380             if ((lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0) {

  2381               /* treat a "const" variable passed to a function with a non-const

  2382                * "variable argument list" as a constant here */

  2383               if (!lvalue) {

  2384                 error(22);        /* need lvalue */

  2385               } else {

  2386                 rvalue(&lval);    /* get value in PRI */

  2387                 setheap_pri();    /* address of the value on the heap in PRI */

  2388                 heapalloc+=markheap(MEMUSE_STATIC, 1);

  2389                 nest_stkusage++;

  2390               } /* if */

  2391             } else if (lvalue) {

  2392               address(lval.sym,sPRI);

  2393             } else {

  2394               setheap_pri();      /* address of the value on the heap in PRI */

  2395               heapalloc+=markheap(MEMUSE_STATIC, 1);

  2396               nest_stkusage++;

  2397             } /* if */

  2398           } else if (lval.ident==iCONSTEXPR || lval.ident==iEXPRESSION)

  2399           {

  2400             /* allocate a cell on the heap and store the

  2401              * value (already in PRI) there */

  2402             setheap_pri();        /* address of the value on the heap in PRI */

  2403             heapalloc+=markheap(MEMUSE_STATIC, 1);

  2404             nest_stkusage++;

  2405           } /* if */

  2406           /* ??? handle const array passed by reference */

  2407           /* otherwise, the address is already in PRI */

  2408           if (lval.sym!=NULL)

  2409             markusage(lval.sym,uWRITTEN);

  2410           if (!checktags_string(arg[argidx].tags, arg[argidx].numtags, &lval)

  2411               && !checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))

  2412             error(213);

  2413           if (lval.tag!=0)

  2414             append_constval(&taglst,arg[argidx].name,lval.tag,0);

  2415           break;

  2416         case iVARIABLE:

  2417           if (lval.ident==iLABEL || lval.ident==iFUNCTN || lval.ident==iREFFUNC

  2418               || lval.ident==iARRAY || lval.ident==iREFARRAY)

  2419             error(35,argidx+1);   /* argument type mismatch */

  2420           if (lvalue)

  2421             rvalue(&lval);        /* get value (direct or indirect) */

  2422           /* otherwise, the expression result is already in PRI */

  2423           assert(arg[argidx].numtags>0);

  2424           check_userop(NULL,lval.tag,arg[argidx].tags[0],2,NULL,&lval.tag);

  2425           if (!checktags_string(arg[argidx].tags, arg[argidx].numtags, &lval)

  2426               && !checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))

  2427             error(213);

  2428           if (lval.tag!=0)

  2429             append_constval(&taglst,arg[argidx].name,lval.tag,0);

  2430           argidx++;               /* argument done */

  2431           break;

  2432         case iREFERENCE:

  2433           if (!lvalue)

  2434             error(35,argidx+1);   /* argument type mismatch */

  2435           if (lval.sym!=NULL && (lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0)

  2436             error(35,argidx+1);   /* argument type mismatch */

  2437           if (lval.ident==iVARIABLE || lval.ident==iREFERENCE) {

  2438             if (lvalue) {

  2439               assert(lval.sym!=NULL);

  2440               address(lval.sym,sPRI);

  2441             } else {

  2442               setheap_pri();      /* address of the value on the heap in PRI */

  2443               heapalloc+=markheap(MEMUSE_STATIC, 1);

  2444               nest_stkusage++;

  2445             } /* if */

  2446           } /* if */

  2447           /* otherwise, the address is already in PRI */

  2448           if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))

  2449             error(213);

  2450           if (lval.tag!=0)

  2451             append_constval(&taglst,arg[argidx].name,lval.tag,0);

  2452           argidx++;               /* argument done */

  2453           if (lval.sym!=NULL)

  2454             markusage(lval.sym,uWRITTEN);

  2455           break;

  2456         case iREFARRAY:

  2457           if (lval.ident!=iARRAY && lval.ident!=iREFARRAY

  2458               && lval.ident!=iARRAYCELL && lval.ident!=iARRAYCHAR)

  2459           {

  2460             error(35,argidx+1);   /* argument type mismatch */

  2461             break;

  2462           } /* if */

  2463           if (lval.sym!=NULL && (lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0)

  2464             error(35,argidx+1); /* argument type mismatch */

  2465           /* Verify that the dimensions match with those in arg[argidx].

  2466            * A literal array always has a single dimension.

  2467            * An iARRAYCELL parameter is also assumed to have a single dimension.

  2468            */

  2469           if (lval.sym==NULL || lval.ident==iARRAYCELL || lval.ident==iARRAYCHAR) {

  2470             if (arg[argidx].numdim!=1) {

  2471               error(48);        /* array dimensions must match */

  2472             } else if (arg[argidx].dim[0]!=0) {

  2473               assert(arg[argidx].dim[0]>0);

  2474               if (lval.ident==iARRAYCELL) {

  2475                 error(47);        /* array sizes must match */

  2476               } else {

  2477                 assert(lval.constval!=0); /* literal array must have a size */

  2478                 /* A literal array must have exactly the same size as the

  2479                  * function argument; a literal string may be smaller than

  2480                  * the function argument.

  2481                  */

  2482                 if (lval.constval>0 && arg[argidx].dim[0]!=lval.constval

  2483                     || lval.constval<0 && arg[argidx].dim[0] < -lval.constval)

  2484                   error(47);      /* array sizes must match */

  2485               } /* if */

  2486             } /* if */

  2487             if (lval.ident!=iARRAYCELL && lval.ident!=iARRAYCHAR) {

  2488               /* save array size, for default values with uSIZEOF flag */

  2489               cell array_sz=lval.constval;

  2490               assert(array_sz!=0);/* literal array must have a size */

  2491               if (array_sz<0)

  2492                 array_sz= -array_sz;

  2493               append_constval(&arrayszlst,arg[argidx].name,array_sz,0);

  2494             }/* if */

  2495           } else {

  2496             symbol *sym=lval.sym;

  2497             short level=0;

  2498             assert(sym!=NULL);

  2499             if (sym->dim.array.level+1!=arg[argidx].numdim)

  2500               error(48);          /* array dimensions must match */

  2501             /* the lengths for all dimensions must match, unless the dimension

  2502              * length was defined at zero (which means "undefined")

  2503              */

  2504             while (sym->dim.array.level>0) {

  2505               assert(level<sDIMEN_MAX);

  2506               if (arg[argidx].dim[level]!=0 && sym->dim.array.length!=arg[argidx].dim[level])

  2507                 error(47);        /* array sizes must match */

  2508               else if (!matchtag(arg[argidx].idxtag[level],sym->x.tags.index,TRUE))

  2509                 error(229,sym->name);   /* index tag mismatch */

  2510               append_constval(&arrayszlst,arg[argidx].name,sym->dim.array.length,level);

  2511               sym=finddepend(sym);

  2512               assert(sym!=NULL);

  2513               level++;

  2514             } /* if */

  2515             /* the last dimension is checked too, again, unless it is zero */

  2516             assert(level<sDIMEN_MAX);

  2517             assert(sym!=NULL);

  2518             if (arg[argidx].dim[level]!=0 && sym->dim.array.length!=arg[argidx].dim[level])

  2519               error(47);          /* array sizes must match */

  2520             else if (!matchtag(arg[argidx].idxtag[level],sym->x.tags.index,TRUE))

  2521               error(229,sym->name);   /* index tag mismatch */

  2522             append_constval(&arrayszlst,arg[argidx].name,sym->dim.array.length,level);

  2523           } /* if */

  2524           /* address already in PRI */

  2525           if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))

  2526             error(213);

  2527           if (lval.tag!=0)

  2528             append_constval(&taglst,arg[argidx].name,lval.tag,0);

  2529           // ??? set uWRITTEN?

  2530           argidx++;               /* argument done */

  2531           break;

  2532         } /* switch */

  2533         pushreg(sPRI);            /* store the function argument on the stack */

  2534         markexpr(sPARM,NULL,0);   /* mark the end of a sub-expression */

  2535         nest_stkusage++;

  2536       } /* if */

  2537       assert(arglist[argpos]!=ARG_UNHANDLED);

  2538       nargs++;

  2539       if (matchparanthesis) {

  2540         close=matchtoken(')');

  2541         if (!close)               /* if not paranthese... */

  2542           if (!needtoken(','))    /* ...should be comma... */

  2543             break;                /* ...but abort loop if neither */

  2544       } else {

  2545         close=!matchtoken(',');

  2546         if (close) {              /* if not comma... */

  2547           if (needtoken(tTERM)==1)/* ...must be end of statement */

  2548             lexpush();            /* push again, because end of statement is analised later */

  2549         } /* if */

  2550       } /* if */

  2551     } while (!close && freading && !matchtoken(tENDEXPR)); /* do */

  2552   } /* if */

  2553   /* check remaining function arguments (they may have default values) */

  2554   for (argidx=0; arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS; argidx++) {

  2555     if (arglist[argidx]==ARG_DONE)

  2556       continue;                 /* already seen and handled this argument */

  2557     /* in this first stage, we also skip the arguments with uSIZEOF and uTAGOF;

  2558      * these are handled last

  2559      */

  2560     if ((arg[argidx].hasdefault & uSIZEOF)!=0 || (arg[argidx].hasdefault & uTAGOF)!=0) {

  2561       assert(arg[argidx].ident==iVARIABLE);

  2562       continue;

  2563     } /* if */

  2564     stgmark((char)(sEXPRSTART+argidx));/* mark beginning of new expression in stage */

  2565     if (arg[argidx].hasdefault) {

  2566       if (arg[argidx].ident==iREFARRAY) {

  2567         short level;

  2568         setdefarray(arg[argidx].defvalue.array.data,

  2569                     arg[argidx].defvalue.array.size,

  2570                     arg[argidx].defvalue.array.arraysize,

  2571                     &arg[argidx].defvalue.array.addr,

  2572                     (arg[argidx].usage & uCONST)!=0);

  2573         if ((arg[argidx].usage & uCONST)==0) {

  2574           heapalloc+=arg[argidx].defvalue.array.arraysize;

  2575           nest_stkusage+=arg[argidx].defvalue.array.arraysize;

  2576         } /* if */

  2577         /* keep the lengths of all dimensions of a multi-dimensional default array */

  2578         assert(arg[argidx].numdim>0);

  2579         if (arg[argidx].numdim==1) {

  2580           append_constval(&arrayszlst,arg[argidx].name,arg[argidx].defvalue.array.arraysize,0);

  2581         } else {

  2582           for (level=0; level<arg[argidx].numdim; level++) {

  2583             assert(level<sDIMEN_MAX);

  2584             append_constval(&arrayszlst,arg[argidx].name,arg[argidx].dim[level],level);

  2585           } /* for */

  2586         } /* if */

  2587       } else if (arg[argidx].ident==iREFERENCE) {

  2588         setheap(arg[argidx].defvalue.val);

  2589         /* address of the value on the heap in PRI */

  2590         heapalloc+=markheap(MEMUSE_STATIC, 1);

  2591         nest_stkusage++;

  2592       } else {

  2593         int dummytag=arg[argidx].tags[0];

  2594         ldconst(arg[argidx].defvalue.val,sPRI);

  2595         assert(arg[argidx].numtags>0);

  2596         check_userop(NULL,arg[argidx].defvalue_tag,arg[argidx].tags[0],2,NULL,&dummytag);

  2597         assert(dummytag==arg[argidx].tags[0]);

  2598       } /* if */

  2599       pushreg(sPRI);            /* store the function argument on the stack */

  2600       markexpr(sPARM,NULL,0);   /* mark the end of a sub-expression */

  2601       nest_stkusage++;

  2602     } else {

  2603       error(92,argidx);        /* argument count mismatch */

  2604     } /* if */

  2605     if (arglist[argidx]==ARG_UNHANDLED)

  2606       nargs++;

  2607     arglist[argidx]=ARG_DONE;

  2608   } /* for */

  2609   /* now a second loop to catch the arguments with default values that are

  2610    * the "sizeof" or "tagof" of other arguments

  2611    */

  2612   for (argidx=0; arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS; argidx++) {

  2613     constvalue *asz;

  2614     cell array_sz;

  2615     if (arglist[argidx]==ARG_DONE)

  2616       continue;                 /* already seen and handled this argument */

  2617     stgmark((char)(sEXPRSTART+argidx));/* mark beginning of new expression in stage */

  2618     assert(arg[argidx].ident==iVARIABLE);           /* if "sizeof", must be single cell */

  2619     /* if unseen, must be "sizeof" or "tagof" */

  2620     assert((arg[argidx].hasdefault & uSIZEOF)!=0 || (arg[argidx].hasdefault & uTAGOF)!=0);

  2621     if ((arg[argidx].hasdefault & uSIZEOF)!=0) {

  2622       /* find the argument; if it isn't found, the argument's default value

  2623        * was a "sizeof" of a non-array (a warning for this was already given

  2624        * when declaring the function)

  2625        */

  2626       asz=find_constval(&arrayszlst,arg[argidx].defvalue.size.symname,

  2627                         arg[argidx].defvalue.size.level);

  2628       if (asz!=NULL) {

  2629         array_sz=asz->value;

  2630         if (array_sz==0)

  2631           error(224,arg[argidx].name);    /* indeterminate array size in "sizeof" expression */

  2632       } else {

  2633         array_sz=1;

  2634       } /* if */

  2635     } else {

  2636       asz=find_constval(&taglst,arg[argidx].defvalue.size.symname,

  2637                         arg[argidx].defvalue.size.level);

  2638       if (asz != NULL) {

  2639         exporttag(asz->value);

  2640         array_sz=asz->value | PUBLICTAG;  /* must be set, because it just was exported */

  2641       } else {

  2642         array_sz=0;

  2643       } /* if */

  2644     } /* if */

  2645     ldconst(array_sz,sPRI);

  2646     pushreg(sPRI);              /* store the function argument on the stack */

  2647     markexpr(sPARM,NULL,0);

  2648     nest_stkusage++;

  2649     if (arglist[argidx]==ARG_UNHANDLED)

  2650       nargs++;

  2651     arglist[argidx]=ARG_DONE;

  2652   } /* for */

  2653   stgmark(sENDREORDER);         /* mark end of reversed evaluation */

  2654   pushval((cell)nargs /* *sizeof(cell)*/ );

  2655   nest_stkusage++;

  2656   ffcall(sym,NULL,nargs);

  2657   if (sc_status!=statSKIP)

  2658     markusage(sym,uREAD);       /* do not mark as "used" when this call itself is skipped */

  2659   if ((sym->usage & uNATIVE)!=0 &&sym->x.lib!=NULL)

  2660     sym->x.lib->value += 1;     /* increment "usage count" of the library */

  2661   if (symret!=NULL)

  2662     popreg(sPRI);               /* pop hidden parameter as function result */

  2663   sideeffect=TRUE;              /* assume functions carry out a side-effect */

  2664   delete_consttable(&arrayszlst);     /* clear list of array sizes */

  2665   delete_consttable(&taglst);   /* clear list of parameter tags */

  2667   /* maintain max. amount of memory used */

  2668   {

  2669     long totalsize;

  2670     totalsize=declared+heapalloc+1;   /* local variables & return value size,

  2671                                        * +1 for PROC opcode */

  2672     if (lval_result->ident==iREFARRAY)

  2673       totalsize++;                    /* add hidden parameter (on the stack) */

  2674     if ((sym->usage & uNATIVE)==0)

  2675       totalsize++;                    /* add "call" opcode */

  2676     totalsize+=nest_stkusage;

  2677     assert(curfunc!=NULL);

  2678     if (curfunc->x.stacksize<totalsize)

  2679       curfunc->x.stacksize=totalsize;

  2680     nest_stkusage-=nargs+heapalloc+1; /* stack/heap space, +1 for argcount param */

  2681     /* if there is a syntax error in the script, the stack calculation is

  2682      * probably incorrect; but we may not allow it to drop below zero

  2683      */

  2684     if (nest_stkusage<0)

  2685       nest_stkusage=0;

  2686   }

  2688   /* scrap any arrays left on the heap, with the exception of the array that

  2689    * this function has as a result (in other words, scrap all arrays on the

  2690    * heap that caused by expressions in the function arguments)

  2691    */

  2692   popheaplist();

  2693   nesting--;

  2694 }

  2696 /*  dbltest

  2697  *

  2698  *  Returns a non-zero value if lval1 an array and lval2 is not an array and

  2699  *  the operation is addition or subtraction.

  2700  *

  2701  *  Returns the "shift" count (1 for 16-bit, 2 for 32-bit) to align a cell

  2702  *  to an array offset.

  2703  */

  2704 static int dbltest(void (*oper)(),value *lval1,value *lval2)

  2705 {

  2706   if ((oper!=ob_add) && (oper!=ob_sub))

  2707     return 0;

  2708   if (lval1->ident!=iARRAY)

  2709     return 0;

  2710   if (lval2->ident==iARRAY)

  2711     return 0;

  2712   return sizeof(cell)/2;        /* 1 for 16-bit, 2 for 32-bit */

  2713 }

  2715 /*  commutative

  2716  *

  2717  *  Test whether an operator is commutative, i.e. x oper y == y oper x.

  2718  *  Commutative operators are: +  (addition)

  2719  *                             *  (multiplication)

  2720  *                             == (equality)

  2721  *                             != (inequality)

  2722  *                             &  (bitwise and)

  2723  *                             ^  (bitwise xor)

  2724  *                             |  (bitwise or)

  2725  *

  2726  *  If in an expression, code for the left operand has been generated and

  2727  *  the right operand is a constant and the operator is commutative, the

  2728  *  precautionary "push" of the primary register is scrapped and the constant

  2729  *  is read into the secondary register immediately.

  2730  */

  2731 static int commutative(void (*oper)())

  2732 {

  2733   return oper==ob_add || oper==os_mult

  2734          || oper==ob_eq || oper==ob_ne

  2735          || oper==ob_and || oper==ob_xor || oper==ob_or;

  2736 }

  2738 /*  constant

  2739  *

  2740  *  Generates code to fetch a number, a literal character (which is returned

  2741  *  by lex() as a number as well) or a literal string (lex() stores the

  2742  *  strings in the literal queue). If the operand was a number, it is stored

  2743  *  in lval->constval.

  2744  *

  2745  *  The function returns 1 if the token was a constant or a string, 0

  2746  *  otherwise.

  2747  */

  2748 static int constant(value *lval)

  2749 {

  2750   int tok,index,ident;

  2751   cell val,item,cidx;

  2752   char *st;

  2753   symbol *sym;

  2754   int cmptag=lval->cmptag;

  2756   tok=lex(&val,&st);

  2757   if (tok==tSYMBOL && (sym=findconst(st,&cmptag))!=0) {

  2758     if (cmptag>1)

  2759       error(91,sym->name);  /* ambiguity: multiple matching constants (different tags) */

  2760     lval->constval=sym->addr;

  2761     ldconst(lval->constval,sPRI);

  2762     lval->ident=iCONSTEXPR;

  2763     lval->tag=sym->tag;

  2764     lval->sym=sym;

  2765     markusage(sym,uREAD);

  2766   } else if (tok==tNUMBER) {

  2767     lval->constval=val;

  2768     ldconst(lval->constval,sPRI);

  2769     lval->ident=iCONSTEXPR;

  2770   } else if (tok==tRATIONAL) {

  2771     lval->constval=val;

  2772     ldconst(lval->constval,sPRI);

  2773     lval->ident=iCONSTEXPR;

  2774     lval->tag=sc_rationaltag;

  2775   } else if (tok==tSTRING) {

  2776     /* lex() stores starting index of string in the literal table in 'val' */

  2777     ldconst((val+glb_declared)*sizeof(cell),sPRI);

  2778     lval->ident=iARRAY;         /* pretend this is a global array */

  2779     lval->constval=val-litidx;  /* constval == the negative value of the

  2780                                  * size of the literal array; using a negative

  2781                                  * value distinguishes between literal arrays

  2782                                  * and literal strings (this was done for

  2783                                  * array assignment). */

  2784 	lval->tag=pc_tag_string;

  2785   } else if (tok=='{') {

  2786     int tag,lasttag=-1;

  2787     val=litidx;

  2788     do {

  2789       /* cannot call constexpr() here, because "staging" is already turned

  2790        * on at this point */

  2791       assert(staging);

  2792       stgget(&index,&cidx);     /* mark position in code generator */

  2793       ident=expression(&item,&tag,NULL,FALSE,NULL);

  2794       stgdel(index,cidx);       /* scratch generated code */

  2795       if (ident!=iCONSTEXPR)

  2796         error(8);               /* must be constant expression */

  2797       if (lasttag<0)

  2798         lasttag=tag;

  2799       else if (!matchtag(lasttag,tag,FALSE))

  2800         error(213);             /* tagname mismatch */

  2801       litadd(item);             /* store expression result in literal table */

  2802     } while (matchtoken(','));

  2803     if (!needtoken('}'))

  2804       lexclr(FALSE);

  2805     ldconst((val+glb_declared)*sizeof(cell),sPRI);

  2806     lval->ident=iARRAY;         /* pretend this is a global array */

  2807     lval->constval=litidx-val;  /* constval == the size of the literal array */

  2808   } else {

  2809     return FALSE;               /* no, it cannot be interpreted as a constant */

  2810   } /* if */

  2811   return TRUE;                  /* yes, it was a constant value */

  2812 }

author	Scott Ehlert <ds@alliedmods.net>
	Thu Apr 05 10:55:40 2007 +0000 (2007-04-05)
changeset 669	ce01c2eb020c
parent 632	5fd3bbbf2dc0
child 745	35ac681f343f
permissions	-rw-r--r--