1.1 --- a/compiler-init/sc3.c Sat Jul 15 05:02:38 2006 +0000
1.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
1.3 @@ -1,2469 +0,0 @@
1.4 -/* Pawn compiler - Recursive descend expresion parser
1.5 - *
1.6 - * Copyright (c) ITB CompuPhase, 1997-2005
1.7 - *
1.8 - * This software is provided "as-is", without any express or implied warranty.
1.9 - * In no event will the authors be held liable for any damages arising from
1.10 - * the use of this software.
1.11 - *
1.12 - * Permission is granted to anyone to use this software for any purpose,
1.13 - * including commercial applications, and to alter it and redistribute it
1.14 - * freely, subject to the following restrictions:
1.15 - *
1.16 - * 1. The origin of this software must not be misrepresented; you must not
1.17 - * claim that you wrote the original software. If you use this software in
1.18 - * a product, an acknowledgment in the product documentation would be
1.19 - * appreciated but is not required.
1.20 - * 2. Altered source versions must be plainly marked as such, and must not be
1.21 - * misrepresented as being the original software.
1.22 - * 3. This notice may not be removed or altered from any source distribution.
1.23 - *
1.24 - * Version: $Id: sc3.c 3598 2006-07-04 13:44:04Z thiadmer $
1.25 - */
1.26 -#include <assert.h>
1.27 -#include <stdio.h>
1.28 -#include <stdlib.h> /* for _MAX_PATH */
1.29 -#include <string.h>
1.30 -#if defined FORTIFY
1.31 - #include <alloc/fortify.h>
1.32 -#endif
1.33 -#include "sc.h"
1.34 -
1.35 -static int skim(int *opstr,void (*testfunc)(int),int dropval,int endval,
1.36 - int (*hier)(value*),value *lval);
1.37 -static void dropout(int lvalue,void (*testfunc)(int val),int exit1,value *lval);
1.38 -static int plnge(int *opstr,int opoff,int (*hier)(value *lval),value *lval,
1.39 - char *forcetag,int chkbitwise);
1.40 -static int plnge1(int (*hier)(value *lval),value *lval);
1.41 -static void plnge2(void (*oper)(void),
1.42 - int (*hier)(value *lval),
1.43 - value *lval1,value *lval2);
1.44 -static cell calc(cell left,void (*oper)(),cell right,char *boolresult);
1.45 -static int hier14(value *lval);
1.46 -static int hier13(value *lval);
1.47 -static int hier12(value *lval);
1.48 -static int hier11(value *lval);
1.49 -static int hier10(value *lval);
1.50 -static int hier9(value *lval);
1.51 -static int hier8(value *lval);
1.52 -static int hier7(value *lval);
1.53 -static int hier6(value *lval);
1.54 -static int hier5(value *lval);
1.55 -static int hier4(value *lval);
1.56 -static int hier3(value *lval);
1.57 -static int hier2(value *lval);
1.58 -static int hier1(value *lval1);
1.59 -static int primary(value *lval);
1.60 -static void clear_value(value *lval);
1.61 -static void callfunction(symbol *sym,value *lval_result,int matchparanthesis);
1.62 -static int dbltest(void (*oper)(),value *lval1,value *lval2);
1.63 -static int commutative(void (*oper)());
1.64 -static int constant(value *lval);
1.65 -
1.66 -static char lastsymbol[sNAMEMAX+1]; /* name of last function/variable */
1.67 -static int bitwise_opercount; /* count of bitwise operators in an expression */
1.68 -static int decl_heap=0;
1.69 -
1.70 -/* Function addresses of binary operators for signed operations */
1.71 -static void (*op1[17])(void) = {
1.72 - os_mult,os_div,os_mod, /* hier3, index 0 */
1.73 - ob_add,ob_sub, /* hier4, index 3 */
1.74 - ob_sal,os_sar,ou_sar, /* hier5, index 5 */
1.75 - ob_and, /* hier6, index 8 */
1.76 - ob_xor, /* hier7, index 9 */
1.77 - ob_or, /* hier8, index 10 */
1.78 - os_le,os_ge,os_lt,os_gt, /* hier9, index 11 */
1.79 - ob_eq,ob_ne, /* hier10, index 15 */
1.80 -};
1.81 -/* These two functions are defined because the functions inc() and dec() in
1.82 - * SC4.C have a different prototype than the other code generation functions.
1.83 - * The arrays for user-defined functions use the function pointers for
1.84 - * identifying what kind of operation is requested; these functions must all
1.85 - * have the same prototype. As inc() and dec() are special cases already, it
1.86 - * is simplest to add two "do-nothing" functions.
1.87 - */
1.88 -static void user_inc(void) {}
1.89 -static void user_dec(void) {}
1.90 -
1.91 -/*
1.92 - * Searches for a binary operator a list of operators. The list is stored in
1.93 - * the array "list". The last entry in the list should be set to 0.
1.94 - *
1.95 - * The index of an operator in "list" (if found) is returned in "opidx". If
1.96 - * no operator is found, nextop() returns 0.
1.97 - *
1.98 - * If an operator is found in the expression, it cannot be used in a function
1.99 - * call with omitted parantheses. Mark this...
1.100 - *
1.101 - * Global references: sc_allowproccall (modified)
1.102 - */
1.103 -static int nextop(int *opidx,int *list)
1.104 -{
1.105 - *opidx=0;
1.106 - while (*list){
1.107 - if (matchtoken(*list)){
1.108 - sc_allowproccall=FALSE;
1.109 - return TRUE; /* found! */
1.110 - } else {
1.111 - list+=1;
1.112 - *opidx+=1;
1.113 - } /* if */
1.114 - } /* while */
1.115 - return FALSE; /* entire list scanned, nothing found */
1.116 -}
1.117 -
1.118 -SC_FUNC int check_userop(void (*oper)(void),int tag1,int tag2,int numparam,
1.119 - value *lval,int *resulttag)
1.120 -{
1.121 -static char *binoperstr[] = { "*", "/", "%", "+", "-", "", "", "",
1.122 - "", "", "", "<=", ">=", "<", ">", "==", "!=" };
1.123 -static int binoper_savepri[] = { FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
1.124 - FALSE, FALSE, FALSE, FALSE, FALSE,
1.125 - TRUE, TRUE, TRUE, TRUE, FALSE, FALSE };
1.126 -static char *unoperstr[] = { "!", "-", "++", "--" };
1.127 -static void (*unopers[])(void) = { lneg, neg, user_inc, user_dec };
1.128 - char opername[4] = "", symbolname[sNAMEMAX+1];
1.129 - int i,swapparams,savepri,savealt;
1.130 - int paramspassed;
1.131 - symbol *sym;
1.132 -
1.133 - /* since user-defined operators on untagged operands are forbidden, we have
1.134 - * a quick exit.
1.135 - */
1.136 - assert(numparam==1 || numparam==2);
1.137 - if (tag1==0 && (numparam==1 || tag2==0))
1.138 - return FALSE;
1.139 -
1.140 - savepri=savealt=FALSE;
1.141 - /* find the name with the operator */
1.142 - if (numparam==2) {
1.143 - if (oper==NULL) {
1.144 - /* assignment operator: a special case */
1.145 - strcpy(opername,"=");
1.146 - if (lval!=NULL && (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR))
1.147 - savealt=TRUE;
1.148 - } else {
1.149 - assert( (sizeof binoperstr / sizeof binoperstr[0]) == (sizeof op1 / sizeof op1[0]) );
1.150 - for (i=0; i<sizeof op1 / sizeof op1[0]; i++) {
1.151 - if (oper==op1[i]) {
1.152 - strcpy(opername,binoperstr[i]);
1.153 - savepri=binoper_savepri[i];
1.154 - break;
1.155 - } /* if */
1.156 - } /* for */
1.157 - } /* if */
1.158 - } else {
1.159 - assert(oper!=NULL);
1.160 - assert(numparam==1);
1.161 - /* try a select group of unary operators */
1.162 - assert( (sizeof unoperstr / sizeof unoperstr[0]) == (sizeof unopers / sizeof unopers[0]) );
1.163 - if (opername[0]=='\0') {
1.164 - for (i=0; i<sizeof unopers / sizeof unopers[0]; i++) {
1.165 - if (oper==unopers[i]) {
1.166 - strcpy(opername,unoperstr[i]);
1.167 - break;
1.168 - } /* if */
1.169 - } /* for */
1.170 - } /* if */
1.171 - } /* if */
1.172 - /* if not found, quit */
1.173 - if (opername[0]=='\0')
1.174 - return FALSE;
1.175 -
1.176 - /* create a symbol name from the tags and the operator name */
1.177 - assert(numparam==1 || numparam==2);
1.178 - operator_symname(symbolname,opername,tag1,tag2,numparam,tag2);
1.179 - swapparams=FALSE;
1.180 - sym=findglb(symbolname,sGLOBAL);
1.181 - if (sym==NULL /*|| (sym->usage & uDEFINE)==0*/) { /* ??? should not check uDEFINE; first pass clears these bits */
1.182 - /* check for commutative operators */
1.183 - if (tag1==tag2 || oper==NULL || !commutative(oper))
1.184 - return FALSE; /* not commutative, cannot swap operands */
1.185 - /* if arrived here, the operator is commutative and the tags are different,
1.186 - * swap tags and try again
1.187 - */
1.188 - assert(numparam==2); /* commutative operator must be a binary operator */
1.189 - operator_symname(symbolname,opername,tag2,tag1,numparam,tag1);
1.190 - swapparams=TRUE;
1.191 - sym=findglb(symbolname,sGLOBAL);
1.192 - if (sym==NULL /*|| (sym->usage & uDEFINE)==0*/)
1.193 - return FALSE;
1.194 - } /* if */
1.195 -
1.196 - /* check existance and the proper declaration of this function */
1.197 - if ((sym->usage & uMISSING)!=0 || (sym->usage & uPROTOTYPED)==0) {
1.198 - char symname[2*sNAMEMAX+16]; /* allow space for user defined operators */
1.199 - funcdisplayname(symname,sym->name);
1.200 - if ((sym->usage & uMISSING)!=0)
1.201 - error(4,symname); /* function not defined */
1.202 - if ((sym->usage & uPROTOTYPED)==0)
1.203 - error(71,symname); /* operator must be declared before use */
1.204 - } /* if */
1.205 -
1.206 - /* we don't want to use the redefined operator in the function that
1.207 - * redefines the operator itself, otherwise the snippet below gives
1.208 - * an unexpected recursion:
1.209 - * fixed:operator+(fixed:a, fixed:b)
1.210 - * return a + b
1.211 - */
1.212 - if (sym==curfunc)
1.213 - return FALSE;
1.214 -
1.215 - /* for increment and decrement operators, the symbol must first be loaded
1.216 - * (and stored back afterwards)
1.217 - */
1.218 - if (oper==user_inc || oper==user_dec) {
1.219 - assert(!savepri);
1.220 - assert(lval!=NULL);
1.221 - if (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR)
1.222 - pushreg(sPRI); /* save current address in PRI */
1.223 - rvalue(lval); /* get the symbol's value in PRI */
1.224 - } /* if */
1.225 -
1.226 - assert(!savepri || !savealt); /* either one MAY be set, but not both */
1.227 - if (savepri) {
1.228 - /* the chained comparison operators require that the ALT register is
1.229 - * unmodified, so we save it here; actually, we save PRI because the normal
1.230 - * instruction sequence (without user operator) swaps PRI and ALT
1.231 - */
1.232 - pushreg(sPRI); /* right-hand operand is in PRI */
1.233 - } else if (savealt) {
1.234 - /* for the assignment operator, ALT may contain an address at which the
1.235 - * result must be stored; this address must be preserved accross the
1.236 - * call
1.237 - */
1.238 - assert(lval!=NULL); /* this was checked earlier */
1.239 - assert(lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR); /* checked earlier */
1.240 - pushreg(sALT);
1.241 - } /* if */
1.242 -
1.243 - /* push parameters, call the function */
1.244 - paramspassed= (oper==NULL) ? 1 : numparam;
1.245 - switch (paramspassed) {
1.246 - case 1:
1.247 - pushreg(sPRI);
1.248 - break;
1.249 - case 2:
1.250 - /* note that 1) a function expects that the parameters are pushed
1.251 - * in reversed order, and 2) the left operand is in the secondary register
1.252 - * and the right operand is in the primary register */
1.253 - if (swapparams) {
1.254 - pushreg(sALT);
1.255 - pushreg(sPRI);
1.256 - } else {
1.257 - pushreg(sPRI);
1.258 - pushreg(sALT);
1.259 - } /* if */
1.260 - break;
1.261 - default:
1.262 - assert(0);
1.263 - } /* switch */
1.264 - markexpr(sPARM,NULL,0); /* mark the end of a sub-expression */
1.265 - pushval((cell)paramspassed*sizeof(cell));
1.266 - assert(sym->ident==iFUNCTN);
1.267 - ffcall(sym,NULL,paramspassed);
1.268 - if (sc_status!=statSKIP)
1.269 - markusage(sym,uREAD); /* do not mark as "used" when this call itself is skipped */
1.270 - if ((sym->usage & uNATIVE)!=0 && sym->x.lib!=NULL)
1.271 - sym->x.lib->value += 1; /* increment "usage count" of the library */
1.272 - sideeffect=TRUE; /* assume functions carry out a side-effect */
1.273 - assert(resulttag!=NULL);
1.274 - *resulttag=sym->tag; /* save tag of the called function */
1.275 -
1.276 - if (savepri || savealt)
1.277 - popreg(sALT); /* restore the saved PRI/ALT that into ALT */
1.278 - if (oper==user_inc || oper==user_dec) {
1.279 - assert(lval!=NULL);
1.280 - if (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR)
1.281 - popreg(sALT); /* restore address (in ALT) */
1.282 - store(lval); /* store PRI in the symbol */
1.283 - moveto1(); /* make sure PRI is restored on exit */
1.284 - } /* if */
1.285 - return TRUE;
1.286 -}
1.287 -
1.288 -SC_FUNC int matchtag(int formaltag,int actualtag,int allowcoerce)
1.289 -{
1.290 - if (formaltag!=actualtag) {
1.291 - /* if the formal tag is zero and the actual tag is not "fixed", the actual
1.292 - * tag is "coerced" to zero
1.293 - */
1.294 - if (!allowcoerce || formaltag!=0 || (actualtag & FIXEDTAG)!=0)
1.295 - return FALSE;
1.296 - } /* if */
1.297 - return TRUE;
1.298 -}
1.299 -
1.300 -/*
1.301 - * The AMX pseudo-processor has no direct support for logical (boolean)
1.302 - * operations. These have to be done via comparing and jumping. Since we are
1.303 - * already jumping through the code, we might as well implement an "early
1.304 - * drop-out" evaluation (also called "short-circuit"). This conforms to
1.305 - * standard C:
1.306 - *
1.307 - * expr1 || expr2 expr2 will only be evaluated if expr1 is false.
1.308 - * expr1 && expr2 expr2 will only be evaluated if expr1 is true.
1.309 - *
1.310 - * expr1 || expr2 && expr3 expr2 will only be evaluated if expr1 is false
1.311 - * and expr3 will only be evaluated if expr1 is
1.312 - * false and expr2 is true.
1.313 - *
1.314 - * Code generation for the last example proceeds thus:
1.315 - *
1.316 - * evaluate expr1
1.317 - * operator || found
1.318 - * jump to "l1" if result of expr1 not equal to 0
1.319 - * evaluate expr2
1.320 - * -> operator && found; skip to higher level in hierarchy diagram
1.321 - * jump to "l2" if result of expr2 equal to 0
1.322 - * evaluate expr3
1.323 - * jump to "l2" if result of expr3 equal to 0
1.324 - * set expression result to 1 (true)
1.325 - * jump to "l3"
1.326 - * l2: set expression result to 0 (false)
1.327 - * l3:
1.328 - * <- drop back to previous hierarchy level
1.329 - * jump to "l1" if result of expr2 && expr3 not equal to 0
1.330 - * set expression result to 0 (false)
1.331 - * jump to "l4"
1.332 - * l1: set expression result to 1 (true)
1.333 - * l4:
1.334 - *
1.335 - */
1.336 -
1.337 -/* Skim over terms adjoining || and && operators
1.338 - * dropval The value of the expression after "dropping out". An "or" drops
1.339 - * out when the left hand is TRUE, so dropval must be 1 on "or"
1.340 - * expressions.
1.341 - * endval The value of the expression when no expression drops out. In an
1.342 - * "or" expression, this happens when both the left hand and the
1.343 - * right hand are FALSE, so endval must be 0 for "or" expressions.
1.344 - */
1.345 -static int skim(int *opstr,void (*testfunc)(int),int dropval,int endval,
1.346 - int (*hier)(value*),value *lval)
1.347 -{
1.348 - int lvalue,hits,droplab,endlab,opidx;
1.349 - int allconst,foundop;
1.350 - cell constval;
1.351 - int index;
1.352 - cell cidx;
1.353 -
1.354 - stgget(&index,&cidx); /* mark position in code generator */
1.355 - hits=FALSE; /* no logical operators "hit" yet */
1.356 - allconst=TRUE; /* assume all values "const" */
1.357 - constval=0;
1.358 - droplab=0; /* to avoid a compiler warning */
1.359 - for ( ;; ) {
1.360 - lvalue=plnge1(hier,lval); /* evaluate left expression */
1.361 -
1.362 - allconst= allconst && (lval->ident==iCONSTEXPR);
1.363 - if (allconst) {
1.364 - if (hits) {
1.365 - /* one operator was already found */
1.366 - if (testfunc==jmp_ne0)
1.367 - lval->constval= lval->constval || constval;
1.368 - else
1.369 - lval->constval= lval->constval && constval;
1.370 - } /* if */
1.371 - constval=lval->constval; /* save result accumulated so far */
1.372 - } /* if */
1.373 -
1.374 - foundop=nextop(&opidx,opstr);
1.375 - if ((foundop || hits) && (lval->ident==iARRAY || lval->ident==iREFARRAY))
1.376 - error(33, lval->sym ? (lval->sym->name ? lval->sym->name : "-unknown") : "-unknown-"); /* array was not indexed in an expression */
1.377 - if (foundop) {
1.378 - if (!hits) {
1.379 - /* this is the first operator in the list */
1.380 - hits=TRUE;
1.381 - droplab=getlabel();
1.382 - } /* if */
1.383 - dropout(lvalue,testfunc,droplab,lval);
1.384 - } else if (hits) { /* no (more) identical operators */
1.385 - dropout(lvalue,testfunc,droplab,lval); /* found at least one operator! */
1.386 - ldconst(endval,sPRI);
1.387 - jumplabel(endlab=getlabel());
1.388 - setlabel(droplab);
1.389 - ldconst(dropval,sPRI);
1.390 - setlabel(endlab);
1.391 - lval->sym=NULL;
1.392 - lval->tag=pc_addtag("bool"); /* force tag to be "bool" */
1.393 - if (allconst) {
1.394 - lval->ident=iCONSTEXPR;
1.395 - lval->constval=constval;
1.396 - stgdel(index,cidx); /* scratch generated code and calculate */
1.397 - } else {
1.398 - lval->ident=iEXPRESSION;
1.399 - lval->constval=0;
1.400 - } /* if */
1.401 - return FALSE;
1.402 - } else {
1.403 - return lvalue; /* none of the operators in "opstr" were found */
1.404 - } /* if */
1.405 -
1.406 - } /* while */
1.407 -}
1.408 -
1.409 -/*
1.410 - * Reads into the primary register the variable pointed to by lval if
1.411 - * plunging through the hierarchy levels detected an lvalue. Otherwise
1.412 - * if a constant was detected, it is loaded. If there is no constant and
1.413 - * no lvalue, the primary register must already contain the expression
1.414 - * result.
1.415 - *
1.416 - * After that, the compare routines "jmp_ne0" or "jmp_eq0" are called, which
1.417 - * compare the primary register against 0, and jump to the "early drop-out"
1.418 - * label "exit1" if the condition is true.
1.419 - */
1.420 -static void dropout(int lvalue,void (*testfunc)(int val),int exit1,value *lval)
1.421 -{
1.422 - if (lvalue)
1.423 - rvalue(lval);
1.424 - else if (lval->ident==iCONSTEXPR)
1.425 - ldconst(lval->constval,sPRI);
1.426 - (*testfunc)(exit1);
1.427 -}
1.428 -
1.429 -static void checkfunction(value *lval)
1.430 -{
1.431 - symbol *sym=lval->sym;
1.432 -
1.433 - if (sym==NULL || (sym->ident!=iFUNCTN && sym->ident!=iREFFUNC))
1.434 - return; /* no known symbol, or not a function result */
1.435 -
1.436 - if ((sym->usage & uDEFINE)!=0) {
1.437 - /* function is defined, can now check the return value (but make an
1.438 - * exception for directly recursive functions)
1.439 - */
1.440 - if (sym!=curfunc && (sym->usage & uRETVALUE)==0) {
1.441 - char symname[2*sNAMEMAX+16]; /* allow space for user defined operators */
1.442 - funcdisplayname(symname,sym->name);
1.443 - error(209,symname); /* function should return a value */
1.444 - } /* if */
1.445 - } else {
1.446 - /* function not yet defined, set */
1.447 - sym->usage|=uRETVALUE; /* make sure that a future implementation of
1.448 - * the function uses "return <value>" */
1.449 - } /* if */
1.450 -}
1.451 -
1.452 -/*
1.453 - * Plunge to a lower level
1.454 - */
1.455 -static int plnge(int *opstr,int opoff,int (*hier)(value *lval),value *lval,
1.456 - char *forcetag,int chkbitwise)
1.457 -{
1.458 - int lvalue,opidx;
1.459 - int count;
1.460 - value lval2 = {0};
1.461 -
1.462 - lvalue=plnge1(hier,lval);
1.463 - if (nextop(&opidx,opstr)==0)
1.464 - return lvalue; /* no operator in "opstr" found */
1.465 - if (lvalue)
1.466 - rvalue(lval);
1.467 - count=0;
1.468 - do {
1.469 - if (chkbitwise && count++>0 && bitwise_opercount!=0)
1.470 - error(212);
1.471 - opidx+=opoff; /* add offset to index returned by nextop() */
1.472 - plnge2(op1[opidx],hier,lval,&lval2);
1.473 - if (op1[opidx]==ob_and || op1[opidx]==ob_or)
1.474 - bitwise_opercount++;
1.475 - if (forcetag!=NULL)
1.476 - lval->tag=pc_addtag(forcetag);
1.477 - } while (nextop(&opidx,opstr)); /* do */
1.478 - return FALSE; /* result of expression is not an lvalue */
1.479 -}
1.480 -
1.481 -/* plnge_rel
1.482 - *
1.483 - * Binary plunge to lower level; this is very simular to plnge, but
1.484 - * it has special code generation sequences for chained operations.
1.485 - */
1.486 -static int plnge_rel(int *opstr,int opoff,int (*hier)(value *lval),value *lval)
1.487 -{
1.488 - int lvalue,opidx;
1.489 - value lval2={0};
1.490 - int count;
1.491 -
1.492 - /* this function should only be called for relational operators */
1.493 - assert(op1[opoff]==os_le);
1.494 - lvalue=plnge1(hier,lval);
1.495 - if (nextop(&opidx,opstr)==0)
1.496 - return lvalue; /* no operator in "opstr" found */
1.497 - if (lvalue)
1.498 - rvalue(lval);
1.499 - count=0;
1.500 - lval->boolresult=TRUE;
1.501 - do {
1.502 - /* same check as in plnge(), but "chkbitwise" is always TRUE */
1.503 - if (count>0 && bitwise_opercount!=0)
1.504 - error(212);
1.505 - if (count>0) {
1.506 - relop_prefix();
1.507 - *lval=lval2; /* copy right hand expression of the previous iteration */
1.508 - } /* if */
1.509 - opidx+=opoff;
1.510 - plnge2(op1[opidx],hier,lval,&lval2);
1.511 - if (count++>0)
1.512 - relop_suffix();
1.513 - } while (nextop(&opidx,opstr)); /* enddo */
1.514 - lval->constval=lval->boolresult;
1.515 - lval->tag=pc_addtag("bool"); /* force tag to be "bool" */
1.516 - return FALSE; /* result of expression is not an lvalue */
1.517 -}
1.518 -
1.519 -/* plnge1
1.520 - *
1.521 - * Unary plunge to lower level
1.522 - * Called by: skim(), plnge(), plnge2(), plnge_rel(), hier14() and hier13()
1.523 - */
1.524 -static int plnge1(int (*hier)(value *lval),value *lval)
1.525 -{
1.526 - int lvalue,index;
1.527 - cell cidx;
1.528 -
1.529 - stgget(&index,&cidx); /* mark position in code generator */
1.530 - lvalue=(*hier)(lval);
1.531 - if (lval->ident==iCONSTEXPR)
1.532 - stgdel(index,cidx); /* load constant later */
1.533 - return lvalue;
1.534 -}
1.535 -
1.536 -/* plnge2
1.537 - *
1.538 - * Binary plunge to lower level
1.539 - * Called by: plnge(), plnge_rel(), hier14() and hier1()
1.540 - */
1.541 -static void plnge2(void (*oper)(void),
1.542 - int (*hier)(value *lval),
1.543 - value *lval1,value *lval2)
1.544 -{
1.545 - int index;
1.546 - cell cidx;
1.547 -
1.548 - stgget(&index,&cidx); /* mark position in code generator */
1.549 - if (lval1->ident==iCONSTEXPR) { /* constant on left side; it is not yet loaded */
1.550 - if (plnge1(hier,lval2))
1.551 - rvalue(lval2); /* load lvalue now */
1.552 - else if (lval2->ident==iCONSTEXPR)
1.553 - ldconst(lval2->constval<<dbltest(oper,lval2,lval1),sPRI);
1.554 - ldconst(lval1->constval<<dbltest(oper,lval2,lval1),sALT);
1.555 - /* ^ doubling of constants operating on integer addresses */
1.556 - /* is restricted to "add" and "subtract" operators */
1.557 - } else { /* non-constant on left side */
1.558 - pushreg(sPRI);
1.559 - if (plnge1(hier,lval2))
1.560 - rvalue(lval2);
1.561 - if (lval2->ident==iCONSTEXPR) { /* constant on right side */
1.562 - if (commutative(oper)) { /* test for commutative operators */
1.563 - value lvaltmp = {0};
1.564 - stgdel(index,cidx); /* scratch pushreg() and constant fetch (then
1.565 - * fetch the constant again */
1.566 - ldconst(lval2->constval<<dbltest(oper,lval1,lval2),sALT);
1.567 - /* now, the primary register has the left operand and the secondary
1.568 - * register the right operand; swap the "lval" variables so that lval1
1.569 - * is associated with the secondary register and lval2 with the
1.570 - * primary register, as is the "normal" case.
1.571 - */
1.572 - lvaltmp=*lval1;
1.573 - *lval1=*lval2;
1.574 - *lval2=lvaltmp;
1.575 - } else {
1.576 - ldconst(lval2->constval<<dbltest(oper,lval1,lval2),sPRI);
1.577 - popreg(sALT); /* pop result of left operand into secondary register */
1.578 - } /* if */
1.579 - } else { /* non-constants on both sides */
1.580 - popreg(sALT);
1.581 - if (dbltest(oper,lval1,lval2))
1.582 - cell2addr(); /* double primary register */
1.583 - if (dbltest(oper,lval2,lval1))
1.584 - cell2addr_alt(); /* double secondary register */
1.585 - } /* if */
1.586 - } /* if */
1.587 - if (oper) {
1.588 - /* If used in an expression, a function should return a value.
1.589 - * If the function has been defined, we can check this. If the
1.590 - * function was not defined, we can set this requirement (so that
1.591 - * a future function definition can check this bit.
1.592 - */
1.593 - checkfunction(lval1);
1.594 - checkfunction(lval2);
1.595 - if (lval1->ident==iARRAY || lval1->ident==iREFARRAY) {
1.596 - char *ptr=(lval1->sym!=NULL) ? lval1->sym->name : "-unknown-";
1.597 - error(33,ptr); /* array must be indexed */
1.598 - } else if (lval2->ident==iARRAY || lval2->ident==iREFARRAY) {
1.599 - char *ptr=(lval2->sym!=NULL) ? lval2->sym->name : "-unknown-";
1.600 - error(33,ptr); /* array must be indexed */
1.601 - } /* if */
1.602 - /* ??? ^^^ should do same kind of error checking with functions */
1.603 -
1.604 - /* check whether an "operator" function is defined for the tag names
1.605 - * (a constant expression cannot be optimized in that case)
1.606 - */
1.607 - if (check_userop(oper,lval1->tag,lval2->tag,2,NULL,&lval1->tag)) {
1.608 - lval1->ident=iEXPRESSION;
1.609 - lval1->constval=0;
1.610 - } else if (lval1->ident==iCONSTEXPR && lval2->ident==iCONSTEXPR) {
1.611 - /* only constant expression if both constant */
1.612 - stgdel(index,cidx); /* scratch generated code and calculate */
1.613 - if (!matchtag(lval1->tag,lval2->tag,FALSE))
1.614 - error(213); /* tagname mismatch */
1.615 - lval1->constval=calc(lval1->constval,oper,lval2->constval,&lval1->boolresult);
1.616 - } else {
1.617 - if (!matchtag(lval1->tag,lval2->tag,FALSE))
1.618 - error(213); /* tagname mismatch */
1.619 - (*oper)(); /* do the (signed) operation */
1.620 - lval1->ident=iEXPRESSION;
1.621 - } /* if */
1.622 - } /* if */
1.623 -}
1.624 -
1.625 -static cell truemodulus(cell a,cell b)
1.626 -{
1.627 - return (a % b + b) % b;
1.628 -}
1.629 -
1.630 -static cell calc(cell left,void (*oper)(),cell right,char *boolresult)
1.631 -{
1.632 - if (oper==ob_or)
1.633 - return (left | right);
1.634 - else if (oper==ob_xor)
1.635 - return (left ^ right);
1.636 - else if (oper==ob_and)
1.637 - return (left & right);
1.638 - else if (oper==ob_eq)
1.639 - return (left == right);
1.640 - else if (oper==ob_ne)
1.641 - return (left != right);
1.642 - else if (oper==os_le)
1.643 - return *boolresult &= (char)(left <= right), right;
1.644 - else if (oper==os_ge)
1.645 - return *boolresult &= (char)(left >= right), right;
1.646 - else if (oper==os_lt)
1.647 - return *boolresult &= (char)(left < right), right;
1.648 - else if (oper==os_gt)
1.649 - return *boolresult &= (char)(left > right), right;
1.650 - else if (oper==os_sar)
1.651 - return (left >> (int)right);
1.652 - else if (oper==ou_sar)
1.653 - return ((ucell)left >> (ucell)right);
1.654 - else if (oper==ob_sal)
1.655 - return ((ucell)left << (int)right);
1.656 - else if (oper==ob_add)
1.657 - return (left + right);
1.658 - else if (oper==ob_sub)
1.659 - return (left - right);
1.660 - else if (oper==os_mult)
1.661 - return (left * right);
1.662 - else if (oper==os_div)
1.663 - return (left - truemodulus(left,right)) / right;
1.664 - else if (oper==os_mod)
1.665 - return truemodulus(left,right);
1.666 - else
1.667 - error(29); /* invalid expression, assumed 0 (this should never occur) */
1.668 - return 0;
1.669 -}
1.670 -
1.671 -SC_FUNC int expression(cell *val,int *tag,symbol **symptr,int chkfuncresult)
1.672 -{
1.673 - int locheap=decl_heap;
1.674 - value lval={0};
1.675 -
1.676 - if (hier14(&lval))
1.677 - rvalue(&lval);
1.678 - /* scrap any arrays left on the heap */
1.679 - assert(decl_heap>=locheap);
1.680 - modheap((locheap-decl_heap)*sizeof(cell)); /* remove heap space, so negative delta */
1.681 - decl_heap=locheap;
1.682 -
1.683 - if (lval.ident==iCONSTEXPR && val!=NULL) /* constant expression */
1.684 - *val=lval.constval;
1.685 - if (tag!=NULL)
1.686 - *tag=lval.tag;
1.687 - if (symptr!=NULL)
1.688 - *symptr=lval.sym;
1.689 - if (chkfuncresult)
1.690 - checkfunction(&lval);
1.691 - return lval.ident;
1.692 -}
1.693 -
1.694 -SC_FUNC int sc_getstateid(constvalue **automaton,constvalue **state)
1.695 -{
1.696 - char name[sNAMEMAX+1];
1.697 - cell val;
1.698 - char *str;
1.699 - int fsa,islabel;
1.700 -
1.701 - assert(automaton!=NULL);
1.702 - assert(state!=NULL);
1.703 - if (!(islabel=matchtoken(tLABEL)) && !needtoken(tSYMBOL))
1.704 - return 0;
1.705 -
1.706 - tokeninfo(&val,&str);
1.707 - assert(strlen(str)<sizeof name);
1.708 - strcpy(name,str);
1.709 - if (islabel || matchtoken(':')) {
1.710 - /* token is an automaton name, add the name and get a new token */
1.711 - *automaton=automaton_find(name);
1.712 - /* read in the state name before checking the automaton, to keep the parser
1.713 - * going (an "unknown automaton" error may occur when the "state" instruction
1.714 - * precedes any state definition)
1.715 - */
1.716 - if (!needtoken(tSYMBOL))
1.717 - return 0;
1.718 - tokeninfo(&val,&str); /* do not copy the name yet, must check automaton first */
1.719 - if (*automaton==NULL) {
1.720 - error(86,name); /* unknown automaton */
1.721 - return 0;
1.722 - } /* if */
1.723 - assert((*automaton)->index>0);
1.724 - assert(strlen(str)<sizeof name);
1.725 - strcpy(name,str);
1.726 - } else {
1.727 - *automaton=automaton_find("");
1.728 - assert(*automaton!=NULL);
1.729 - assert((*automaton)->index==0);
1.730 - } /* if */
1.731 - assert(*automaton!=NULL);
1.732 - fsa=(*automaton)->index;
1.733 -
1.734 - assert(*automaton!=NULL);
1.735 - *state=state_find(name,fsa);
1.736 - if (*state==NULL) {
1.737 - char *fsaname=(*automaton)->name;
1.738 - if (*fsaname=='\0')
1.739 - fsaname="<main>";
1.740 - error(87,name,fsaname); /* unknown state for automaton */
1.741 - return 0;
1.742 - } /* if */
1.743 -
1.744 - return 1;
1.745 -}
1.746 -
1.747 -SC_FUNC cell array_totalsize(symbol *sym)
1.748 -{
1.749 - cell length;
1.750 -
1.751 - assert(sym!=NULL);
1.752 - assert(sym->ident==iARRAY || sym->ident==iREFARRAY);
1.753 - length=sym->dim.array.length;
1.754 - if (sym->dim.array.level > 0) {
1.755 - cell sublength=array_totalsize(finddepend(sym));
1.756 - if (sublength>0)
1.757 - length=length+length*sublength;
1.758 - else
1.759 - length=0;
1.760 - } /* if */
1.761 - return length;
1.762 -}
1.763 -
1.764 -static cell array_levelsize(symbol *sym,int level)
1.765 -{
1.766 - assert(sym!=NULL);
1.767 - assert(sym->ident==iARRAY || sym->ident==iREFARRAY);
1.768 - assert(level <= sym->dim.array.level);
1.769 - while (level-- > 0) {
1.770 - sym=finddepend(sym);
1.771 - assert(sym!=NULL);
1.772 - } /* if */
1.773 - return sym->dim.array.length;
1.774 -}
1.775 -
1.776 -/* hier14
1.777 - *
1.778 - * Lowest hierarchy level (except for the , operator).
1.779 - *
1.780 - * Global references: sc_intest (reffered to only)
1.781 - * sc_allowproccall (modified)
1.782 - */
1.783 -static int hier14(value *lval1)
1.784 -{
1.785 - int lvalue;
1.786 - value lval2={0},lval3={0};
1.787 - void (*oper)(void);
1.788 - int tok,level,i;
1.789 - cell val;
1.790 - char *st;
1.791 - int bwcount,leftarray;
1.792 - cell arrayidx1[sDIMEN_MAX],arrayidx2[sDIMEN_MAX]; /* last used array indices */
1.793 - cell *org_arrayidx;
1.794 -
1.795 - bwcount=bitwise_opercount;
1.796 - bitwise_opercount=0;
1.797 - /* initialize the index arrays with unlikely constant indices; note that
1.798 - * these indices will only be changed when the array is indexed with a
1.799 - * constant, and that negative array indices are invalid (so actually, any
1.800 - * negative value would do).
1.801 - */
1.802 - for (i=0; i<sDIMEN_MAX; i++)
1.803 - arrayidx1[i]=arrayidx2[i]=(cell)(-1L << (sizeof(cell)*8-1));
1.804 - org_arrayidx=lval1->arrayidx; /* save current pointer, to reset later */
1.805 - if (lval1->arrayidx==NULL)
1.806 - lval1->arrayidx=arrayidx1;
1.807 - lvalue=plnge1(hier13,lval1);
1.808 - if (lval1->ident!=iARRAYCELL && lval1->ident!=iARRAYCHAR)
1.809 - lval1->arrayidx=NULL;
1.810 - if (lval1->ident==iCONSTEXPR) /* load constant here */
1.811 - ldconst(lval1->constval,sPRI);
1.812 - tok=lex(&val,&st);
1.813 - switch (tok) {
1.814 - case taOR:
1.815 - oper=ob_or;
1.816 - break;
1.817 - case taXOR:
1.818 - oper=ob_xor;
1.819 - break;
1.820 - case taAND:
1.821 - oper=ob_and;
1.822 - break;
1.823 - case taADD:
1.824 - oper=ob_add;
1.825 - break;
1.826 - case taSUB:
1.827 - oper=ob_sub;
1.828 - break;
1.829 - case taMULT:
1.830 - oper=os_mult;
1.831 - break;
1.832 - case taDIV:
1.833 - oper=os_div;
1.834 - break;
1.835 - case taMOD:
1.836 - oper=os_mod;
1.837 - break;
1.838 - case taSHRU:
1.839 - oper=ou_sar;
1.840 - break;
1.841 - case taSHR:
1.842 - oper=os_sar;
1.843 - break;
1.844 - case taSHL:
1.845 - oper=ob_sal;
1.846 - break;
1.847 - case '=': /* simple assignment */
1.848 - oper=NULL;
1.849 - if (sc_intest)
1.850 - error(211); /* possibly unintended assignment */
1.851 - break;
1.852 - default:
1.853 - lexpush();
1.854 - bitwise_opercount=bwcount;
1.855 - lval1->arrayidx=org_arrayidx; /* restore array index pointer */
1.856 - return lvalue;
1.857 - } /* switch */
1.858 -
1.859 - /* if we get here, it was an assignment; first check a few special cases
1.860 - * and then the general */
1.861 - if (lval1->ident==iARRAYCHAR) {
1.862 - /* special case, assignment to packed character in a cell is permitted */
1.863 - lvalue=TRUE;
1.864 - } else if (lval1->ident==iARRAY || lval1->ident==iREFARRAY) {
1.865 - /* array assignment is permitted too (with restrictions) */
1.866 - if (oper)
1.867 - return error(23); /* array assignment must be simple assigment */
1.868 - assert(lval1->sym!=NULL);
1.869 - if (array_totalsize(lval1->sym)==0)
1.870 - return error(46,lval1->sym->name); /* unknown array size */
1.871 - lvalue=TRUE;
1.872 - } /* if */
1.873 -
1.874 - /* operand on left side of assignment must be lvalue */
1.875 - if (!lvalue)
1.876 - return error(22); /* must be lvalue */
1.877 - /* may not change "constant" parameters */
1.878 - assert(lval1->sym!=NULL);
1.879 - if ((lval1->sym->usage & uCONST)!=0)
1.880 - return error(22); /* assignment to const argument */
1.881 - sc_allowproccall=FALSE; /* may no longer use "procedure call" syntax */
1.882 -
1.883 - lval3=*lval1; /* save symbol to enable storage of expresion result */
1.884 - lval1->arrayidx=org_arrayidx; /* restore array index pointer */
1.885 - if (lval1->ident==iARRAYCELL || lval1->ident==iARRAYCHAR
1.886 - || lval1->ident==iARRAY || lval1->ident==iREFARRAY)
1.887 - {
1.888 - /* if indirect fetch: save PRI (cell address) */
1.889 - if (oper) {
1.890 - pushreg(sPRI);
1.891 - rvalue(lval1);
1.892 - } /* if */
1.893 - lval2.arrayidx=arrayidx2;
1.894 - plnge2(oper,hier14,lval1,&lval2);
1.895 - if (lval2.ident!=iARRAYCELL && lval2.ident!=iARRAYCHAR)
1.896 - lval2.arrayidx=NULL;
1.897 - if (oper)
1.898 - popreg(sALT);
1.899 - if (!oper && lval3.arrayidx!=NULL && lval2.arrayidx!=NULL
1.900 - && lval3.ident==lval2.ident && lval3.sym==lval2.sym)
1.901 - {
1.902 - int same=TRUE;
1.903 - assert(lval2.arrayidx==arrayidx2);
1.904 - for (i=0; i<sDIMEN_MAX; i++)
1.905 - same=same && (lval3.arrayidx[i]==lval2.arrayidx[i]);
1.906 - if (same)
1.907 - error(226,lval3.sym->name); /* self-assignment */
1.908 - } /* if */
1.909 - } else {
1.910 - if (oper){
1.911 - rvalue(lval1);
1.912 - plnge2(oper,hier14,lval1,&lval2);
1.913 - } else {
1.914 - /* if direct fetch and simple assignment: no "push"
1.915 - * and "pop" needed -> call hier14() directly, */
1.916 - if (hier14(&lval2))
1.917 - rvalue(&lval2); /* instead of plnge2(). */
1.918 - else if (lval2.ident==iVARIABLE)
1.919 - lval2.ident=iEXPRESSION;/* mark as "rvalue" if it is not an "lvalue" */
1.920 - checkfunction(&lval2);
1.921 - /* check whether lval2 and lval3 (old lval1) refer to the same variable */
1.922 - if (lval2.ident==iVARIABLE && lval3.ident==lval2.ident && lval3.sym==lval2.sym) {
1.923 - assert(lval3.sym!=NULL);
1.924 - error(226,lval3.sym->name); /* self-assignment */
1.925 - } /* if */
1.926 - } /* if */
1.927 - } /* if */
1.928 - /* Array elements are sometimes considered as sub-arrays --when the
1.929 - * array index is an enumeration field and the enumeration size is greater
1.930 - * than 1. If the expression on the right side of the assignment is a cell,
1.931 - * or if an operation is in effect, this does not apply.
1.932 - */
1.933 - leftarray= lval3.ident==iARRAY || lval3.ident==iREFARRAY
1.934 - || ((lval3.ident==iARRAYCELL || lval3.ident==iARRAYCHAR)
1.935 - && lval3.constval>1 && lval3.sym->dim.array.level==0
1.936 - && !oper && (lval2.ident==iARRAY || lval2.ident==iREFARRAY));
1.937 - if (leftarray) {
1.938 - /* Left operand is an array, right operand should be an array variable
1.939 - * of the same size and the same dimension, an array literal (of the
1.940 - * same size) or a literal string. For single-dimensional arrays without
1.941 - * tag for the index, it is permitted to assign a smaller array into a
1.942 - * larger one (without warning). This is to make it easier to work with
1.943 - * strings.
1.944 - */
1.945 - int exactmatch=TRUE;
1.946 - int idxtag=0;
1.947 - int ltlength=(int)lval3.sym->dim.array.length;
1.948 - if ((lval3.ident==iARRAYCELL || lval3.ident==iARRAYCHAR)
1.949 - && lval3.constval>0 && lval3.sym->dim.array.level==0)
1.950 - {
1.951 - ltlength=(int)lval3.constval;
1.952 - } /* if */
1.953 - if (lval2.ident!=iARRAY && lval2.ident!=iREFARRAY
1.954 - && (lval2.sym==NULL || lval2.constval<=0))
1.955 - error(33,lval3.sym->name); /* array must be indexed */
1.956 - if (lval2.sym!=NULL) {
1.957 - if (lval2.constval==0) {
1.958 - val=lval2.sym->dim.array.length;/* array variable */
1.959 - } else {
1.960 - val=lval2.constval;
1.961 - if (lval2.sym->dim.array.level!=0)
1.962 - error(28,lval2.sym->name);
1.963 - } /* if */
1.964 - level=lval2.sym->dim.array.level;
1.965 - idxtag=lval2.sym->x.tags.index;
1.966 - if (level==0 && idxtag==0 && lval3.sym->x.tags.index==0)
1.967 - exactmatch=FALSE;
1.968 - } else {
1.969 - val=lval2.constval; /* literal array */
1.970 - level=0;
1.971 - /* If val is negative, it means that lval2 is a literal string.
1.972 - * The string array size may be smaller than the destination
1.973 - * array, provided that the destination array does not have an
1.974 - * index tag.
1.975 - */
1.976 - if (val<0) {
1.977 - val=-val;
1.978 - if (lval3.sym->x.tags.index==0)
1.979 - exactmatch=FALSE;
1.980 - } /* if */
1.981 - } /* if */
1.982 - if (lval3.sym->dim.array.level!=level)
1.983 - return error(48); /* array dimensions must match */
1.984 - else if (ltlength<val || exactmatch && ltlength>val || val==0)
1.985 - return error(47); /* array sizes must match */
1.986 - else if (lval3.ident!=iARRAYCELL && !matchtag(lval3.sym->x.tags.index,idxtag,TRUE))
1.987 - error(229,(lval2.sym!=NULL) ? lval2.sym->name : lval3.sym->name); /* index tag mismatch */
1.988 - if (level>0) {
1.989 - /* check the sizes of all sublevels too */
1.990 - symbol *sym1 = lval3.sym;
1.991 - symbol *sym2 = lval2.sym;
1.992 - int i;
1.993 - assert(sym1!=NULL && sym2!=NULL);
1.994 - /* ^^^ sym2 must be valid, because only variables can be
1.995 - * multi-dimensional (there are no multi-dimensional literals),
1.996 - * sym1 must be valid because it must be an lvalue
1.997 - */
1.998 - assert(exactmatch);
1.999 - for (i=0; i<level; i++) {
1.1000 - sym1=finddepend(sym1);
1.1001 - sym2=finddepend(sym2);
1.1002 - assert(sym1!=NULL && sym2!=NULL);
1.1003 - /* ^^^ both arrays have the same dimensions (this was checked
1.1004 - * earlier) so the dependend should always be found
1.1005 - */
1.1006 - if (sym1->dim.array.length!=sym2->dim.array.length)
1.1007 - error(47); /* array sizes must match */
1.1008 - else if (!matchtag(sym1->x.tags.index,sym2->x.tags.index,TRUE))
1.1009 - error(229,sym2->name); /* index tag mismatch */
1.1010 - } /* for */
1.1011 - /* get the total size in cells of the multi-dimensional array */
1.1012 - val=array_totalsize(lval3.sym);
1.1013 - assert(val>0); /* already checked */
1.1014 - } /* if */
1.1015 - } else {
1.1016 - /* left operand is not an array, right operand should then not be either */
1.1017 - if (lval2.ident==iARRAY || lval2.ident==iREFARRAY)
1.1018 - error(6); /* must be assigned to an array */
1.1019 - } /* if */
1.1020 - if (leftarray) {
1.1021 - memcopy(val*sizeof(cell));
1.1022 - } else {
1.1023 - check_userop(NULL,lval2.tag,lval3.tag,2,&lval3,&lval2.tag);
1.1024 - store(&lval3); /* now, store the expression result */
1.1025 - } /* if */
1.1026 - if (!oper && !matchtag(lval3.tag,lval2.tag,TRUE))
1.1027 - error(213); /* tagname mismatch (if "oper", warning already given in plunge2()) */
1.1028 - if (lval3.sym)
1.1029 - markusage(lval3.sym,uWRITTEN);
1.1030 - sideeffect=TRUE;
1.1031 - bitwise_opercount=bwcount;
1.1032 - lval1->ident=iEXPRESSION;
1.1033 - return FALSE; /* expression result is never an lvalue */
1.1034 -}
1.1035 -
1.1036 -static int hier13(value *lval)
1.1037 -{
1.1038 - int lvalue=plnge1(hier12,lval);
1.1039 - if (matchtoken('?')) {
1.1040 - int flab1=getlabel();
1.1041 - int flab2=getlabel();
1.1042 - value lval2={0};
1.1043 - int array1,array2;
1.1044 -
1.1045 - if (lvalue) {
1.1046 - rvalue(lval);
1.1047 - } else if (lval->ident==iCONSTEXPR) {
1.1048 - ldconst(lval->constval,sPRI);
1.1049 - error(lval->constval ? 206 : 205); /* redundant test */
1.1050 - } /* if */
1.1051 - jmp_eq0(flab1); /* go to second expression if primary register==0 */
1.1052 - PUSHSTK_I(sc_allowtags);
1.1053 - sc_allowtags=FALSE; /* do not allow tagnames here (colon is a special token) */
1.1054 - if (hier13(lval))
1.1055 - rvalue(lval);
1.1056 - if (lval->ident==iCONSTEXPR) /* load constant here */
1.1057 - ldconst(lval->constval,sPRI);
1.1058 - sc_allowtags=(short)POPSTK_I(); /* restore */
1.1059 - jumplabel(flab2);
1.1060 - setlabel(flab1);
1.1061 - needtoken(':');
1.1062 - if (hier13(&lval2))
1.1063 - rvalue(&lval2);
1.1064 - if (lval2.ident==iCONSTEXPR) /* load constant here */
1.1065 - ldconst(lval2.constval,sPRI);
1.1066 - array1= (lval->ident==iARRAY || lval->ident==iREFARRAY);
1.1067 - array2= (lval2.ident==iARRAY || lval2.ident==iREFARRAY);
1.1068 - if (array1 && !array2) {
1.1069 - char *ptr=(lval->sym->name!=NULL) ? lval->sym->name : "-unknown-";
1.1070 - error(33,ptr); /* array must be indexed */
1.1071 - } else if (!array1 && array2) {
1.1072 - char *ptr=(lval2.sym->name!=NULL) ? lval2.sym->name : "-unknown-";
1.1073 - error(33,ptr); /* array must be indexed */
1.1074 - } /* if */
1.1075 - /* ??? if both are arrays, should check dimensions */
1.1076 - if (!matchtag(lval->tag,lval2.tag,FALSE))
1.1077 - error(213); /* tagname mismatch ('true' and 'false' expressions) */
1.1078 - setlabel(flab2);
1.1079 - if (lval->ident==iARRAY)
1.1080 - lval->ident=iREFARRAY; /* iARRAY becomes iREFARRAY */
1.1081 - else if (lval->ident!=iREFARRAY)
1.1082 - lval->ident=iEXPRESSION; /* iREFARRAY stays iREFARRAY, rest becomes iEXPRESSION */
1.1083 - return FALSE; /* conditional expression is no lvalue */
1.1084 - } else {
1.1085 - return lvalue;
1.1086 - } /* if */
1.1087 -}
1.1088 -
1.1089 -/* the order of the operators in these lists is important and must be
1.1090 - * the same as the order of the operators in the array "op1"
1.1091 - */
1.1092 -static int list3[] = {'*','/','%',0};
1.1093 -static int list4[] = {'+','-',0};
1.1094 -static int list5[] = {tSHL,tSHR,tSHRU,0};
1.1095 -static int list6[] = {'&',0};
1.1096 -static int list7[] = {'^',0};
1.1097 -static int list8[] = {'|',0};
1.1098 -static int list9[] = {tlLE,tlGE,'<','>',0};
1.1099 -static int list10[] = {tlEQ,tlNE,0};
1.1100 -static int list11[] = {tlAND,0};
1.1101 -static int list12[] = {tlOR,0};
1.1102 -
1.1103 -static int hier12(value *lval)
1.1104 -{
1.1105 - return skim(list12,jmp_ne0,1,0,hier11,lval);
1.1106 -}
1.1107 -
1.1108 -static int hier11(value *lval)
1.1109 -{
1.1110 - return skim(list11,jmp_eq0,0,1,hier10,lval);
1.1111 -}
1.1112 -
1.1113 -static int hier10(value *lval)
1.1114 -{ /* ==, != */
1.1115 - return plnge(list10,15,hier9,lval,"bool",TRUE);
1.1116 -} /* ^ this variable is the starting index in the op1[]
1.1117 - * array of the operators of this hierarchy level */
1.1118 -
1.1119 -static int hier9(value *lval)
1.1120 -{ /* <=, >=, <, > */
1.1121 - return plnge_rel(list9,11,hier8,lval);
1.1122 -}
1.1123 -
1.1124 -static int hier8(value *lval)
1.1125 -{ /* | */
1.1126 - return plnge(list8,10,hier7,lval,NULL,FALSE);
1.1127 -}
1.1128 -
1.1129 -static int hier7(value *lval)
1.1130 -{ /* ^ */
1.1131 - return plnge(list7,9,hier6,lval,NULL,FALSE);
1.1132 -}
1.1133 -
1.1134 -static int hier6(value *lval)
1.1135 -{ /* & */
1.1136 - return plnge(list6,8,hier5,lval,NULL,FALSE);
1.1137 -}
1.1138 -
1.1139 -static int hier5(value *lval)
1.1140 -{ /* <<, >>, >>> */
1.1141 - return plnge(list5,5,hier4,lval,NULL,FALSE);
1.1142 -}
1.1143 -
1.1144 -static int hier4(value *lval)
1.1145 -{ /* +, - */
1.1146 - return plnge(list4,3,hier3,lval,NULL,FALSE);
1.1147 -}
1.1148 -
1.1149 -static int hier3(value *lval)
1.1150 -{ /* *, /, % */
1.1151 - return plnge(list3,0,hier2,lval,NULL,FALSE);
1.1152 -}
1.1153 -
1.1154 -static int hier2(value *lval)
1.1155 -{
1.1156 - int lvalue,tok;
1.1157 - int tag,paranthese;
1.1158 - cell val;
1.1159 - char *st;
1.1160 - symbol *sym;
1.1161 - int saveresult;
1.1162 -
1.1163 - tok=lex(&val,&st);
1.1164 - switch (tok) {
1.1165 - case tINC: /* ++lval */
1.1166 - if (!hier2(lval))
1.1167 - return error(22); /* must be lvalue */
1.1168 - assert(lval->sym!=NULL);
1.1169 - if ((lval->sym->usage & uCONST)!=0)
1.1170 - return error(22); /* assignment to const argument */
1.1171 - if (!check_userop(user_inc,lval->tag,0,1,lval,&lval->tag))
1.1172 - inc(lval); /* increase variable first */
1.1173 - rvalue(lval); /* and read the result into PRI */
1.1174 - sideeffect=TRUE;
1.1175 - return FALSE; /* result is no longer lvalue */
1.1176 - case tDEC: /* --lval */
1.1177 - if (!hier2(lval))
1.1178 - return error(22); /* must be lvalue */
1.1179 - assert(lval->sym!=NULL);
1.1180 - if ((lval->sym->usage & uCONST)!=0)
1.1181 - return error(22); /* assignment to const argument */
1.1182 - if (!check_userop(user_dec,lval->tag,0,1,lval,&lval->tag))
1.1183 - dec(lval); /* decrease variable first */
1.1184 - rvalue(lval); /* and read the result into PRI */
1.1185 - sideeffect=TRUE;
1.1186 - return FALSE; /* result is no longer lvalue */
1.1187 - case '~': /* ~ (one's complement) */
1.1188 - if (hier2(lval))
1.1189 - rvalue(lval);
1.1190 - invert(); /* bitwise NOT */
1.1191 - lval->constval=~lval->constval;
1.1192 - return FALSE;
1.1193 - case '!': /* ! (logical negate) */
1.1194 - if (hier2(lval))
1.1195 - rvalue(lval);
1.1196 - if (check_userop(lneg,lval->tag,0,1,NULL,&lval->tag)) {
1.1197 - lval->ident=iEXPRESSION;
1.1198 - lval->constval=0;
1.1199 - } else {
1.1200 - lneg(); /* 0 -> 1, !0 -> 0 */
1.1201 - lval->constval=!lval->constval;
1.1202 - lval->tag=pc_addtag("bool");
1.1203 - } /* if */
1.1204 - return FALSE;
1.1205 - case '-': /* unary - (two's complement) */
1.1206 - if (hier2(lval))
1.1207 - rvalue(lval);
1.1208 - /* make a special check for a constant expression with the tag of a
1.1209 - * rational number, so that we can simple swap the sign of that constant.
1.1210 - */
1.1211 - if (lval->ident==iCONSTEXPR && lval->tag==sc_rationaltag && sc_rationaltag!=0) {
1.1212 - if (rational_digits==0) {
1.1213 - #if PAWN_CELL_SIZE==32
1.1214 - float *f = (float *)&lval->constval;
1.1215 - #elif PAWN_CELL_SIZE==64
1.1216 - double *f = (double *)&lval->constval;
1.1217 - #else
1.1218 - #error Unsupported cell size
1.1219 - #endif
1.1220 - *f= - *f; /* this modifies lval->constval */
1.1221 - } else {
1.1222 - /* the negation of a fixed point number is just an integer negation */
1.1223 - lval->constval=-lval->constval;
1.1224 - } /* if */
1.1225 - } else if (check_userop(neg,lval->tag,0,1,NULL,&lval->tag)) {
1.1226 - lval->ident=iEXPRESSION;
1.1227 - lval->constval=0;
1.1228 - } else {
1.1229 - neg(); /* arithmic negation */
1.1230 - lval->constval=-lval->constval;
1.1231 - } /* if */
1.1232 - return FALSE;
1.1233 - case tLABEL: /* tagname override */
1.1234 - tag=pc_addtag(st);
1.1235 - lval->cmptag=tag;
1.1236 - lvalue=hier2(lval);
1.1237 - lval->tag=tag;
1.1238 - return lvalue;
1.1239 - case tDEFINED:
1.1240 - paranthese=0;
1.1241 - while (matchtoken('('))
1.1242 - paranthese++;
1.1243 - tok=lex(&val,&st);
1.1244 - if (tok!=tSYMBOL)
1.1245 - return error(20,st); /* illegal symbol name */
1.1246 - sym=findloc(st);
1.1247 - if (sym==NULL)
1.1248 - sym=findglb(st,sSTATEVAR);
1.1249 - if (sym!=NULL && sym->ident!=iFUNCTN && sym->ident!=iREFFUNC && (sym->usage & uDEFINE)==0)
1.1250 - sym=NULL; /* symbol is not a function, it is in the table, but not "defined" */
1.1251 - val= (sym!=NULL);
1.1252 - if (!val && find_subst(st,strlen(st))!=NULL)
1.1253 - val=1;
1.1254 - clear_value(lval);
1.1255 - lval->ident=iCONSTEXPR;
1.1256 - lval->constval= val;
1.1257 - lval->tag=pc_addtag("bool");
1.1258 - ldconst(lval->constval,sPRI);
1.1259 - while (paranthese--)
1.1260 - needtoken(')');
1.1261 - return FALSE;
1.1262 - case tSIZEOF:
1.1263 - paranthese=0;
1.1264 - while (matchtoken('('))
1.1265 - paranthese++;
1.1266 - tok=lex(&val,&st);
1.1267 - if (tok!=tSYMBOL)
1.1268 - return error(20,st); /* illegal symbol name */
1.1269 - sym=findloc(st);
1.1270 - if (sym==NULL)
1.1271 - sym=findglb(st,sSTATEVAR);
1.1272 - if (sym==NULL)
1.1273 - return error(17,st); /* undefined symbol */
1.1274 - if (sym->ident==iCONSTEXPR)
1.1275 - error(39); /* constant symbol has no size */
1.1276 - else if (sym->ident==iFUNCTN || sym->ident==iREFFUNC)
1.1277 - error(72); /* "function" symbol has no size */
1.1278 - else if ((sym->usage & uDEFINE)==0)
1.1279 - return error(17,st); /* undefined symbol (symbol is in the table, but it is "used" only) */
1.1280 - clear_value(lval);
1.1281 - lval->ident=iCONSTEXPR;
1.1282 - lval->constval=1; /* preset */
1.1283 - if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
1.1284 - int level;
1.1285 - symbol *idxsym=NULL;
1.1286 - symbol *subsym=sym;
1.1287 - for (level=0; matchtoken('['); level++) {
1.1288 - idxsym=NULL;
1.1289 - if (subsym!=NULL && level==subsym->dim.array.level && matchtoken(tSYMBOL)) {
1.1290 - char *idxname;
1.1291 - int cmptag=subsym->x.tags.index;
1.1292 - tokeninfo(&val,&idxname);
1.1293 - if ((idxsym=findconst(idxname,&cmptag))==NULL)
1.1294 - error(80,idxname); /* unknown symbol, or non-constant */
1.1295 - else if (cmptag>1)
1.1296 - error(91,idxname); /* ambiguous constant */
1.1297 - } /* if */
1.1298 - needtoken(']');
1.1299 - if (subsym!=NULL)
1.1300 - subsym=finddepend(subsym);
1.1301 - } /* for */
1.1302 - if (level>sym->dim.array.level+1)
1.1303 - error(28,sym->name); /* invalid subscript */
1.1304 - else if (level==sym->dim.array.level+1)
1.1305 - lval->constval= (idxsym!=NULL && idxsym->dim.array.length>0) ? idxsym->dim.array.length : 1;
1.1306 - else
1.1307 - lval->constval=array_levelsize(sym,level);
1.1308 - if (lval->constval==0 && strchr((char *)lptr,PREPROC_TERM)==NULL)
1.1309 - error(224,st); /* indeterminate array size in "sizeof" expression */
1.1310 - } /* if */
1.1311 - ldconst(lval->constval,sPRI);
1.1312 - while (paranthese--)
1.1313 - needtoken(')');
1.1314 - return FALSE;
1.1315 - case tTAGOF:
1.1316 - paranthese=0;
1.1317 - while (matchtoken('('))
1.1318 - paranthese++;
1.1319 - tok=lex(&val,&st);
1.1320 - if (tok!=tSYMBOL && tok!=tLABEL)
1.1321 - return error(20,st); /* illegal symbol name */
1.1322 - if (tok==tLABEL) {
1.1323 - constvalue *tagsym=find_constval(&tagname_tab,st,0);
1.1324 - tag=(int)((tagsym!=NULL) ? tagsym->value : 0);
1.1325 - } else {
1.1326 - sym=findloc(st);
1.1327 - if (sym==NULL)
1.1328 - sym=findglb(st,sSTATEVAR);
1.1329 - if (sym==NULL)
1.1330 - return error(17,st); /* undefined symbol */
1.1331 - if ((sym->usage & uDEFINE)==0)
1.1332 - return error(17,st); /* undefined symbol (symbol is in the table, but it is "used" only) */
1.1333 - tag=sym->tag;
1.1334 - } /* if */
1.1335 - if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
1.1336 - int level;
1.1337 - symbol *idxsym=NULL;
1.1338 - symbol *subsym=sym;
1.1339 - for (level=0; matchtoken('['); level++) {
1.1340 - idxsym=NULL;
1.1341 - if (subsym!=NULL && level==subsym->dim.array.level && matchtoken(tSYMBOL)) {
1.1342 - char *idxname;
1.1343 - int cmptag=subsym->x.tags.index;
1.1344 - tokeninfo(&val,&idxname);
1.1345 - if ((idxsym=findconst(idxname,&cmptag))==NULL)
1.1346 - error(80,idxname); /* unknown symbol, or non-constant */
1.1347 - else if (cmptag>1)
1.1348 - error(91,idxname); /* ambiguous constant */
1.1349 - } /* if */
1.1350 - needtoken(']');
1.1351 - if (subsym!=NULL)
1.1352 - subsym=finddepend(subsym);
1.1353 - } /* for */
1.1354 - if (level>sym->dim.array.level+1)
1.1355 - error(28,sym->name); /* invalid subscript */
1.1356 - else if (level==sym->dim.array.level+1 && idxsym!=NULL)
1.1357 - tag= idxsym->x.tags.index;
1.1358 - } /* if */
1.1359 - exporttag(tag);
1.1360 - clear_value(lval);
1.1361 - lval->ident=iCONSTEXPR;
1.1362 - lval->constval=tag | PUBLICTAG;
1.1363 - ldconst(lval->constval,sPRI);
1.1364 - while (paranthese--)
1.1365 - needtoken(')');
1.1366 - return FALSE;
1.1367 - case tSTATE: {
1.1368 - constvalue *automaton;
1.1369 - constvalue *state;
1.1370 - if (sc_getstateid(&automaton,&state)) {
1.1371 - assert(automaton!=NULL);
1.1372 - assert(automaton->index==0 && automaton->name[0]=='\0' || automaton->index>0);
1.1373 - loadreg(automaton->value,sALT);
1.1374 - assert(state!=NULL);
1.1375 - ldconst(state->value,sPRI);
1.1376 - ob_eq();
1.1377 - clear_value(lval);
1.1378 - lval->ident=iEXPRESSION;
1.1379 - lval->tag=pc_addtag("bool");
1.1380 - } /* if */
1.1381 - return FALSE;
1.1382 - } /* case */
1.1383 - default:
1.1384 - lexpush();
1.1385 - lvalue=hier1(lval);
1.1386 - /* check for postfix operators */
1.1387 - if (matchtoken(';')) {
1.1388 - /* Found a ';', do not look further for postfix operators */
1.1389 - lexpush(); /* push ';' back after successful match */
1.1390 - return lvalue;
1.1391 - } else if (matchtoken(tTERM)) {
1.1392 - /* Found a newline that ends a statement (this is the case when
1.1393 - * semicolons are optional). Note that an explicit semicolon was
1.1394 - * handled above. This case is similar, except that the token must
1.1395 - * not be pushed back.
1.1396 - */
1.1397 - return lvalue;
1.1398 - } else {
1.1399 - tok=lex(&val,&st);
1.1400 - switch (tok) {
1.1401 - case tINC: /* lval++ */
1.1402 - if (!lvalue)
1.1403 - return error(22); /* must be lvalue */
1.1404 - assert(lval->sym!=NULL);
1.1405 - if ((lval->sym->usage & uCONST)!=0)
1.1406 - return error(22); /* assignment to const argument */
1.1407 - /* on incrementing array cells, the address in PRI must be saved for
1.1408 - * incremening the value, whereas the current value must be in PRI
1.1409 - * on exit.
1.1410 - */
1.1411 - saveresult= (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR);
1.1412 - if (saveresult)
1.1413 - pushreg(sPRI); /* save address in PRI */
1.1414 - rvalue(lval); /* read current value into PRI */
1.1415 - if (saveresult)
1.1416 - swap1(); /* save PRI on the stack, restore address in PRI */
1.1417 - if (!check_userop(user_inc,lval->tag,0,1,lval,&lval->tag))
1.1418 - inc(lval); /* increase variable afterwards */
1.1419 - if (saveresult)
1.1420 - popreg(sPRI); /* restore PRI (result of rvalue()) */
1.1421 - sideeffect=TRUE;
1.1422 - return FALSE; /* result is no longer lvalue */
1.1423 - case tDEC: /* lval-- */
1.1424 - if (!lvalue)
1.1425 - return error(22); /* must be lvalue */
1.1426 - assert(lval->sym!=NULL);
1.1427 - if ((lval->sym->usage & uCONST)!=0)
1.1428 - return error(22); /* assignment to const argument */
1.1429 - saveresult= (lval->ident==iARRAYCELL || lval->ident==iARRAYCHAR);
1.1430 - if (saveresult)
1.1431 - pushreg(sPRI); /* save address in PRI */
1.1432 - rvalue(lval); /* read current value into PRI */
1.1433 - if (saveresult)
1.1434 - swap1(); /* save PRI on the stack, restore address in PRI */
1.1435 - if (!check_userop(user_dec,lval->tag,0,1,lval,&lval->tag))
1.1436 - dec(lval); /* decrease variable afterwards */
1.1437 - if (saveresult)
1.1438 - popreg(sPRI); /* restore PRI (result of rvalue()) */
1.1439 - sideeffect=TRUE;
1.1440 - return FALSE;
1.1441 - case tCHAR: /* char (compute required # of cells */
1.1442 - if (lval->ident==iCONSTEXPR) {
1.1443 - lval->constval *= sCHARBITS/8; /* from char to bytes */
1.1444 - lval->constval = (lval->constval + sizeof(cell)-1) / sizeof(cell);
1.1445 - } else {
1.1446 - if (lvalue)
1.1447 - rvalue(lval); /* fetch value if not already in PRI */
1.1448 - char2addr(); /* from characters to bytes */
1.1449 - addconst(sizeof(cell)-1); /* make sure the value is rounded up */
1.1450 - addr2cell(); /* truncate to number of cells */
1.1451 - } /* if */
1.1452 - return FALSE;
1.1453 - default:
1.1454 - lexpush();
1.1455 - return lvalue;
1.1456 - } /* switch */
1.1457 - } /* if */
1.1458 - } /* switch */
1.1459 -}
1.1460 -
1.1461 -/* hier1
1.1462 - *
1.1463 - * The highest hierarchy level: it looks for pointer and array indices
1.1464 - * and function calls.
1.1465 - * Generates code to fetch a pointer value if it is indexed and code to
1.1466 - * add to the pointer value or the array address (the address is already
1.1467 - * read at primary()). It also generates code to fetch a function address
1.1468 - * if that hasn't already been done at primary() (check lval[4]) and calls
1.1469 - * callfunction() to call the function.
1.1470 - */
1.1471 -static int hier1(value *lval1)
1.1472 -{
1.1473 - int lvalue,index,tok,symtok;
1.1474 - cell val,cidx;
1.1475 - value lval2={0};
1.1476 - char *st;
1.1477 - char close;
1.1478 - symbol *sym;
1.1479 - symbol dummysymbol,*cursym; /* for changing the index tags in case of enumerated pseudo-arrays */
1.1480 -
1.1481 - lvalue=primary(lval1);
1.1482 - symtok=tokeninfo(&val,&st); /* get token read by primary() */
1.1483 - cursym=lval1->sym;
1.1484 -restart:
1.1485 - sym=cursym;
1.1486 - if (matchtoken('[') || matchtoken('{') || matchtoken('(')) {
1.1487 - tok=tokeninfo(&val,&st); /* get token read by matchtoken() */
1.1488 - if (sym==NULL && symtok!=tSYMBOL) {
1.1489 - /* we do not have a valid symbol and we appear not to have read a valid
1.1490 - * symbol name (so it is unlikely that we would have read a name of an
1.1491 - * undefined symbol) */
1.1492 - error(29); /* expression error, assumed 0 */
1.1493 - lexpush(); /* analyse '(', '{' or '[' again later */
1.1494 - return FALSE;
1.1495 - } /* if */
1.1496 - if (tok=='[' || tok=='{') { /* subscript */
1.1497 - close = (char)((tok=='[') ? ']' : '}');
1.1498 - if (sym==NULL) { /* sym==NULL if lval is a constant or a literal */
1.1499 - error(28,"<no variable>"); /* cannot subscript */
1.1500 - needtoken(close);
1.1501 - return FALSE;
1.1502 - } else if (sym->ident!=iARRAY && sym->ident!=iREFARRAY){
1.1503 - error(28,sym->name); /* cannot subscript, variable is not an array */
1.1504 - needtoken(close);
1.1505 - return FALSE;
1.1506 - } else if (sym->dim.array.level>0 && close!=']') {
1.1507 - error(51); /* invalid subscript, must use [ ] */
1.1508 - needtoken(close);
1.1509 - return FALSE;
1.1510 - } /* if */
1.1511 - /* set the tag to match (enumeration fields as indices) */
1.1512 - lval2.cmptag=sym->x.tags.index;
1.1513 - stgget(&index,&cidx); /* mark position in code generator */
1.1514 - pushreg(sPRI); /* save base address of the array */
1.1515 - if (hier14(&lval2)) /* create expression for the array index */
1.1516 - rvalue(&lval2);
1.1517 - if (lval2.ident==iARRAY || lval2.ident==iREFARRAY)
1.1518 - error(33,lval2.sym->name); /* array must be indexed */
1.1519 - needtoken(close);
1.1520 - if (!matchtag(sym->x.tags.index,lval2.tag,TRUE))
1.1521 - error(213);
1.1522 - if (lval2.ident==iCONSTEXPR) { /* constant expression */
1.1523 - stgdel(index,cidx); /* scratch generated code */
1.1524 - if (lval1->arrayidx!=NULL) { /* keep constant index, for checking */
1.1525 - assert(sym->dim.array.level>=0 && sym->dim.array.level<sDIMEN_MAX);
1.1526 - lval1->arrayidx[sym->dim.array.level]=lval2.constval;
1.1527 - } /* if */
1.1528 - if (close==']') {
1.1529 - /* normal array index */
1.1530 - if (lval2.constval<0 || sym->dim.array.length!=0 && sym->dim.array.length<=lval2.constval)
1.1531 - error(32,sym->name); /* array index out of bounds */
1.1532 - if (lval2.constval!=0) {
1.1533 - /* don't add offsets for zero subscripts */
1.1534 - #if PAWN_CELL_SIZE==16
1.1535 - ldconst(lval2.constval<<1,sALT);
1.1536 - #elif PAWN_CELL_SIZE==32
1.1537 - ldconst(lval2.constval<<2,sALT);
1.1538 - #elif PAWN_CELL_SIZE==64
1.1539 - ldconst(lval2.constval<<3,sALT);
1.1540 - #else
1.1541 - #error Unsupported cell size
1.1542 - #endif
1.1543 - ob_add();
1.1544 - } /* if */
1.1545 - } else {
1.1546 - /* character index */
1.1547 - if (lval2.constval<0 || sym->dim.array.length!=0
1.1548 - && sym->dim.array.length*((8*sizeof(cell))/sCHARBITS)<=(ucell)lval2.constval)
1.1549 - error(32,sym->name); /* array index out of bounds */
1.1550 - if (lval2.constval!=0) {
1.1551 - /* don't add offsets for zero subscripts */
1.1552 - #if sCHARBITS==16
1.1553 - ldconst(lval2.constval<<1,sALT);/* 16-bit character */
1.1554 - #else
1.1555 - ldconst(lval2.constval,sALT); /* 8-bit character */
1.1556 - #endif
1.1557 - ob_add();
1.1558 - } /* if */
1.1559 - charalign(); /* align character index into array */
1.1560 - } /* if */
1.1561 - /* if the array index is a field from an enumeration, get the tag name
1.1562 - * from the field and save the size of the field too.
1.1563 - */
1.1564 - assert(lval2.sym==NULL || lval2.sym->dim.array.level==0);
1.1565 - if (lval2.sym!=NULL && lval2.sym->dim.array.length>0 && sym->dim.array.level==0) {
1.1566 - lval1->tag=lval2.sym->x.tags.index;
1.1567 - lval1->constval=lval2.sym->dim.array.length;
1.1568 - } /* if */
1.1569 - } else {
1.1570 - /* array index is not constant */
1.1571 - lval1->arrayidx=NULL; /* reset, so won't be checked */
1.1572 - if (close==']') {
1.1573 - if (sym->dim.array.length!=0)
1.1574 - ffbounds(sym->dim.array.length-1); /* run time check for array bounds */
1.1575 - cell2addr(); /* normal array index */
1.1576 - } else {
1.1577 - if (sym->dim.array.length!=0)
1.1578 - ffbounds(sym->dim.array.length*(32/sCHARBITS)-1);
1.1579 - char2addr(); /* character array index */
1.1580 - } /* if */
1.1581 - popreg(sALT);
1.1582 - ob_add(); /* base address was popped into secondary register */
1.1583 - if (close!=']')
1.1584 - charalign(); /* align character index into array */
1.1585 - } /* if */
1.1586 - /* the indexed item may be another array (multi-dimensional arrays) */
1.1587 - assert(cursym==sym && sym!=NULL); /* should still be set */
1.1588 - if (sym->dim.array.level>0) {
1.1589 - assert(close==']'); /* checked earlier */
1.1590 - assert(cursym==lval1->sym);
1.1591 - /* read the offset to the subarray and add it to the current address */
1.1592 - lval1->ident=iARRAYCELL;
1.1593 - pushreg(sPRI); /* the optimizer makes this to a MOVE.alt */
1.1594 - rvalue(lval1);
1.1595 - popreg(sALT);
1.1596 - ob_add();
1.1597 - /* adjust the "value" structure and find the referenced array */
1.1598 - lval1->ident=iREFARRAY;
1.1599 - lval1->sym=finddepend(sym);
1.1600 - assert(lval1->sym!=NULL);
1.1601 - assert(lval1->sym->dim.array.level==sym->dim.array.level-1);
1.1602 - cursym=lval1->sym;
1.1603 - /* try to parse subsequent array indices */
1.1604 - lvalue=FALSE; /* for now, a iREFARRAY is no lvalue */
1.1605 - goto restart;
1.1606 - } /* if */
1.1607 - assert(sym->dim.array.level==0);
1.1608 - /* set type to fetch... INDIRECTLY */
1.1609 - lval1->ident= (char)((close==']') ? iARRAYCELL : iARRAYCHAR);
1.1610 - /* if the array index is a field from an enumeration, get the tag name
1.1611 - * from the field and save the size of the field too. Otherwise, the
1.1612 - * tag is the one from the array symbol.
1.1613 - */
1.1614 - if (lval2.ident==iCONSTEXPR && lval2.sym!=NULL
1.1615 - && lval2.sym->dim.array.length>0 && sym->dim.array.level==0)
1.1616 - {
1.1617 - lval1->tag=lval2.sym->x.tags.index;
1.1618 - lval1->constval=lval2.sym->dim.array.length;
1.1619 - if (lval2.tag==sym->x.tags.index && lval1->constval>1 && matchtoken('[')) {
1.1620 - /* an array indexed with an enumeration field may be considered a sub-array */
1.1621 - lexpush();
1.1622 - lvalue=FALSE; /* for now, a iREFARRAY is no lvalue */
1.1623 - lval1->ident=iREFARRAY;
1.1624 - /* initialize a dummy symbol, which is a copy of the current symbol,
1.1625 - * but with an adjusted index tag
1.1626 - */
1.1627 - assert(sym!=NULL);
1.1628 - dummysymbol=*sym;
1.1629 - /* get the tag of the root of the enumeration */
1.1630 - assert(lval2.sym!=NULL);
1.1631 - dummysymbol.x.tags.index=lval2.sym->x.tags.field;
1.1632 - dummysymbol.dim.array.length=lval2.sym->dim.array.length;
1.1633 - cursym=&dummysymbol;
1.1634 - /* recurse */
1.1635 - goto restart;
1.1636 - } /* if */
1.1637 - } else {
1.1638 - assert(sym!=NULL);
1.1639 - if (cursym!=&dummysymbol)
1.1640 - lval1->tag=sym->tag;
1.1641 - lval1->constval=0;
1.1642 - } /* if */
1.1643 - /* a cell in an array is an lvalue, a character in an array is not
1.1644 - * always a *valid* lvalue */
1.1645 - return TRUE;
1.1646 - } else { /* tok=='(' -> function(...) */
1.1647 - assert(tok=='(');
1.1648 - if (sym==NULL
1.1649 - || (sym->ident!=iFUNCTN && sym->ident!=iREFFUNC))
1.1650 - {
1.1651 - if (sym==NULL && sc_status==statFIRST) {
1.1652 - /* could be a "use before declaration"; in that case, create a stub
1.1653 - * function so that the usage can be marked.
1.1654 - */
1.1655 - sym=fetchfunc(lastsymbol,0);
1.1656 - if (sym==NULL)
1.1657 - error(103); /* insufficient memory */
1.1658 - markusage(sym,uREAD);
1.1659 - } else {
1.1660 - return error(12); /* invalid function call */
1.1661 - } /* if */
1.1662 - } else if ((sym->usage & uMISSING)!=0) {
1.1663 - char symname[2*sNAMEMAX+16]; /* allow space for user defined operators */
1.1664 - funcdisplayname(symname,sym->name);
1.1665 - error(4,symname); /* function not defined */
1.1666 - } /* if */
1.1667 - callfunction(sym,lval1,TRUE);
1.1668 - return FALSE; /* result of function call is no lvalue */
1.1669 - } /* if */
1.1670 - } /* if */
1.1671 - if (sym!=NULL && lval1->ident==iFUNCTN) {
1.1672 - assert(sym->ident==iFUNCTN);
1.1673 - if (sc_allowproccall) {
1.1674 - callfunction(sym,lval1,FALSE);
1.1675 - } else {
1.1676 - int n=-1,iter=0;
1.1677 - for (sym=glbtab.next; sym!=NULL; sym=sym->next) {
1.1678 - if (sym->ident==iFUNCTN
1.1679 - && (sym->usage & uPUBLIC)!=0 && (sym->usage & uDEFINE)!=0)
1.1680 - {
1.1681 - assert(sym->vclass==sGLOBAL);
1.1682 - if (strcmp(sym->name, lval1->sym->name)==0) {
1.1683 - n = iter;
1.1684 - break;
1.1685 - }
1.1686 - iter++;
1.1687 - }
1.1688 - }
1.1689 - if (n!=-1) {
1.1690 - lval1->sym=NULL;
1.1691 - lval1->ident=iCONSTEXPR;
1.1692 - lval1->constval=n;
1.1693 - lval1->tag=pc_addtag("Function");
1.1694 - } else {
1.1695 - error(76); /* invalid function call, or syntax error */
1.1696 - } /* if */
1.1697 - return FALSE;
1.1698 - }
1.1699 - } /* if */
1.1700 - return lvalue;
1.1701 -}
1.1702 -
1.1703 -/* primary
1.1704 - *
1.1705 - * Returns 1 if the operand is an lvalue (everything except arrays, functions
1.1706 - * constants and -of course- errors).
1.1707 - * Generates code to fetch the address of arrays. Code for constants is
1.1708 - * already generated by constant().
1.1709 - * This routine first clears the entire lval array (all fields are set to 0).
1.1710 - *
1.1711 - * Global references: sc_intest (may be altered, but restored upon termination)
1.1712 - */
1.1713 -static int primary(value *lval)
1.1714 -{
1.1715 - char *st;
1.1716 - int lvalue,tok;
1.1717 - cell val;
1.1718 - symbol *sym;
1.1719 -
1.1720 - if (matchtoken('(')){ /* sub-expression - (expression,...) */
1.1721 - PUSHSTK_I(sc_intest);
1.1722 - PUSHSTK_I(sc_allowtags);
1.1723 -
1.1724 - sc_intest=FALSE; /* no longer in "test" expression */
1.1725 - sc_allowtags=TRUE; /* allow tagnames to be used in parenthesized expressions */
1.1726 - sc_allowproccall=FALSE;
1.1727 - do
1.1728 - lvalue=hier14(lval);
1.1729 - while (matchtoken(','));
1.1730 - needtoken(')');
1.1731 - lexclr(FALSE); /* clear lex() push-back, it should have been
1.1732 - * cleared already by needtoken() */
1.1733 - sc_allowtags=(short)POPSTK_I();
1.1734 - sc_intest=(short)POPSTK_I();
1.1735 - return lvalue;
1.1736 - } /* if */
1.1737 -
1.1738 - clear_value(lval); /* clear lval */
1.1739 - tok=lex(&val,&st);
1.1740 - if (tok==tSYMBOL) {
1.1741 - /* lastsymbol is char[sNAMEMAX+1], lex() should have truncated any symbol
1.1742 - * to sNAMEMAX significant characters */
1.1743 - assert(strlen(st)<sizeof lastsymbol);
1.1744 - strcpy(lastsymbol,st);
1.1745 - } /* if */
1.1746 - if (tok==tSYMBOL && !findconst(st,NULL)) {
1.1747 - /* first look for a local variable */
1.1748 - if ((sym=findloc(st))!=0) {
1.1749 - if (sym->ident==iLABEL) {
1.1750 - error(29); /* expression error, assumed 0 */
1.1751 - ldconst(0,sPRI); /* load 0 */
1.1752 - return FALSE; /* return 0 for labels (expression error) */
1.1753 - } /* if */
1.1754 - lval->sym=sym;
1.1755 - lval->ident=sym->ident;
1.1756 - lval->tag=sym->tag;
1.1757 - if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
1.1758 - address(sym,sPRI); /* get starting address in primary register */
1.1759 - return FALSE; /* return 0 for array (not lvalue) */
1.1760 - } else {
1.1761 - return TRUE; /* return 1 if lvalue (not label or array) */
1.1762 - } /* if */
1.1763 - } /* if */
1.1764 - /* now try a global variable */
1.1765 - if ((sym=findglb(st,sSTATEVAR))!=0) {
1.1766 - if (sym->ident==iFUNCTN || sym->ident==iREFFUNC) {
1.1767 - /* if the function is only in the table because it was inserted as a
1.1768 - * stub in the first pass (i.e. it was "used" but never declared or
1.1769 - * implemented, issue an error
1.1770 - */
1.1771 - if ((sym->usage & uPROTOTYPED)==0)
1.1772 - error(17,st);
1.1773 - } else {
1.1774 - if ((sym->usage & uDEFINE)==0)
1.1775 - error(17,st);
1.1776 - lval->sym=sym;
1.1777 - lval->ident=sym->ident;
1.1778 - lval->tag=sym->tag;
1.1779 - if (sym->ident==iARRAY || sym->ident==iREFARRAY) {
1.1780 - address(sym,sPRI); /* get starting address in primary register */
1.1781 - return FALSE; /* return 0 for array (not lvalue) */
1.1782 - } else {
1.1783 - return TRUE; /* return 1 if lvalue (not function or array) */
1.1784 - } /* if */
1.1785 - } /* if */
1.1786 - } else {
1.1787 - if (!sc_allowproccall)
1.1788 - return error(17,st); /* undefined symbol */
1.1789 - /* an unknown symbol, but used in a way compatible with the "procedure
1.1790 - * call" syntax. So assume that the symbol refers to a function.
1.1791 - */
1.1792 - assert(sc_status==statFIRST);
1.1793 - sym=fetchfunc(st,0);
1.1794 - if (sym==NULL)
1.1795 - error(103); /* insufficient memory */
1.1796 - } /* if */
1.1797 - assert(sym!=NULL);
1.1798 - assert(sym->ident==iFUNCTN || sym->ident==iREFFUNC);
1.1799 - lval->sym=sym;
1.1800 - lval->ident=sym->ident;
1.1801 - lval->tag=sym->tag;
1.1802 - return FALSE; /* return 0 for function (not an lvalue) */
1.1803 - } /* if */
1.1804 - lexpush(); /* push the token, it is analyzed by constant() */
1.1805 - if (constant(lval)==0) {
1.1806 - error(29); /* expression error, assumed 0 */
1.1807 - ldconst(0,sPRI); /* load 0 */
1.1808 - } /* if */
1.1809 - return FALSE; /* return 0 for constants (or errors) */
1.1810 -}
1.1811 -
1.1812 -static void clear_value(value *lval)
1.1813 -{
1.1814 - lval->sym=NULL;
1.1815 - lval->constval=0L;
1.1816 - lval->tag=0;
1.1817 - lval->ident=0;
1.1818 - lval->boolresult=FALSE;
1.1819 - /* do not clear lval->arrayidx, it is preset in hier14() */
1.1820 - /* do not clear lval->cmptag */
1.1821 -}
1.1822 -
1.1823 -static void setdefarray(cell *string,cell size,cell array_sz,cell *dataaddr,int fconst)
1.1824 -{
1.1825 - /* The routine must copy the default array data onto the heap, as to avoid
1.1826 - * that a function can change the default value. An optimization is that
1.1827 - * the default array data is "dumped" into the data segment only once (on the
1.1828 - * first use).
1.1829 - */
1.1830 - assert(string!=NULL);
1.1831 - assert(size>0);
1.1832 - /* check whether to dump the default array */
1.1833 - assert(dataaddr!=NULL);
1.1834 - if (sc_status==statWRITE && *dataaddr<0) {
1.1835 - int i;
1.1836 - *dataaddr=(litidx+glb_declared)*sizeof(cell);
1.1837 - for (i=0; i<size; i++)
1.1838 - litadd(*string++);
1.1839 - } /* if */
1.1840 -
1.1841 - /* if the function is known not to modify the array (meaning that it also
1.1842 - * does not modify the default value), directly pass the address of the
1.1843 - * array in the data segment.
1.1844 - */
1.1845 - if (fconst) {
1.1846 - ldconst(*dataaddr,sPRI);
1.1847 - } else {
1.1848 - /* Generate the code:
1.1849 - * CONST.pri dataaddr ;address of the default array data
1.1850 - * HEAP array_sz*sizeof(cell) ;heap address in ALT
1.1851 - * MOVS size*sizeof(cell) ;copy data from PRI to ALT
1.1852 - * MOVE.PRI ;PRI = address on the heap
1.1853 - */
1.1854 - ldconst(*dataaddr,sPRI);
1.1855 - /* "array_sz" is the size of the argument (the value between the brackets
1.1856 - * in the declaration), "size" is the size of the default array data.
1.1857 - */
1.1858 - assert(array_sz>=size);
1.1859 - modheap((int)array_sz*sizeof(cell));
1.1860 - /* ??? should perhaps fill with zeros first */
1.1861 - memcopy(size*sizeof(cell));
1.1862 - moveto1();
1.1863 - } /* if */
1.1864 -}
1.1865 -
1.1866 -static int findnamedarg(arginfo *arg,char *name)
1.1867 -{
1.1868 - int i;
1.1869 -
1.1870 - for (i=0; arg[i].ident!=0 && arg[i].ident!=iVARARGS; i++)
1.1871 - if (strcmp(arg[i].name,name)==0)
1.1872 - return i;
1.1873 - return -1;
1.1874 -}
1.1875 -
1.1876 -static int checktag(int tags[],int numtags,int exprtag)
1.1877 -{
1.1878 - int i;
1.1879 -
1.1880 - assert(tags!=0);
1.1881 - assert(numtags>0);
1.1882 - for (i=0; i<numtags; i++)
1.1883 - if (matchtag(tags[i],exprtag,TRUE))
1.1884 - return TRUE; /* matching tag */
1.1885 - return FALSE; /* no tag matched */
1.1886 -}
1.1887 -
1.1888 -enum {
1.1889 - ARG_UNHANDLED,
1.1890 - ARG_IGNORED,
1.1891 - ARG_DONE,
1.1892 -};
1.1893 -
1.1894 -/* callfunction
1.1895 - *
1.1896 - * Generates code to call a function. This routine handles default arguments
1.1897 - * and positional as well as named parameters.
1.1898 - */
1.1899 -static void callfunction(symbol *sym,value *lval_result,int matchparanthesis)
1.1900 -{
1.1901 -static long nest_stkusage=0L;
1.1902 -static int nesting=0;
1.1903 - int locheap;
1.1904 - int close,lvalue;
1.1905 - int argpos; /* index in the output stream (argpos==nargs if positional parameters) */
1.1906 - int argidx=0; /* index in "arginfo" list */
1.1907 - int nargs=0; /* number of arguments */
1.1908 - int heapalloc=0;
1.1909 - int namedparams=FALSE;
1.1910 - value lval = {0};
1.1911 - arginfo *arg;
1.1912 - char arglist[sMAXARGS];
1.1913 - constvalue arrayszlst = { NULL, "", 0, 0};/* array size list starts empty */
1.1914 - constvalue taglst = { NULL, "", 0, 0}; /* tag list starts empty */
1.1915 - symbol *symret;
1.1916 - cell lexval;
1.1917 - char *lexstr;
1.1918 -
1.1919 - assert(sym!=NULL);
1.1920 - lval_result->ident=iEXPRESSION; /* preset, may be changed later */
1.1921 - lval_result->constval=0;
1.1922 - lval_result->tag=sym->tag;
1.1923 - /* check whether this is a function that returns an array */
1.1924 - symret=finddepend(sym);
1.1925 - assert(symret==NULL || symret->ident==iREFARRAY);
1.1926 - if (symret!=NULL) {
1.1927 - int retsize;
1.1928 - /* allocate space on the heap for the array, and pass the pointer to the
1.1929 - * reserved memory block as a hidden parameter
1.1930 - */
1.1931 - retsize=(int)array_totalsize(symret);
1.1932 - assert(retsize>0);
1.1933 - modheap(retsize*sizeof(cell));/* address is in ALT */
1.1934 - pushreg(sALT); /* pass ALT as the last (hidden) parameter */
1.1935 - decl_heap+=retsize;
1.1936 - /* also mark the ident of the result as "array" */
1.1937 - lval_result->ident=iREFARRAY;
1.1938 - lval_result->sym=symret;
1.1939 - } /* if */
1.1940 - locheap=decl_heap;
1.1941 -
1.1942 - nesting++;
1.1943 - assert(nest_stkusage>=0);
1.1944 - #if !defined NDEBUG
1.1945 - if (nesting==1)
1.1946 - assert(nest_stkusage==0);
1.1947 - #endif
1.1948 - sc_allowproccall=FALSE; /* parameters may not use procedure call syntax */
1.1949 -
1.1950 - if ((sym->flags & flgDEPRICATED)!=0) {
1.1951 - char *ptr= (sym->documentation!=NULL) ? sym->documentation : "";
1.1952 - error(234,sym->name,ptr); /* depricated (probably a native function) */
1.1953 - } /* if */
1.1954 -
1.1955 - /* run through the arguments */
1.1956 - arg=sym->dim.arglist;
1.1957 - assert(arg!=NULL);
1.1958 - stgmark(sSTARTREORDER);
1.1959 - memset(arglist,ARG_UNHANDLED,sizeof arglist);
1.1960 - if (matchparanthesis) {
1.1961 - /* Opening brace was already parsed, if closing brace follows, this
1.1962 - * call passes no parameters.
1.1963 - */
1.1964 - close=matchtoken(')');
1.1965 - } else {
1.1966 - /* When we find an end of line here, it may be a function call passing
1.1967 - * no parameters, or it may be that the first parameter is on a line
1.1968 - * below. But as a parameter can be anything, this is difficult to check.
1.1969 - * The only simple check that we have is the use of "named parameters".
1.1970 - */
1.1971 - close=matchtoken(tTERM);
1.1972 - if (close) {
1.1973 - close=!matchtoken('.');
1.1974 - if (!close)
1.1975 - lexpush(); /* reset the '.' */
1.1976 - } /* if */
1.1977 - } /* if */
1.1978 - if (!close) {
1.1979 - do {
1.1980 - if (matchtoken('.')) {
1.1981 - namedparams=TRUE;
1.1982 - if (needtoken(tSYMBOL))
1.1983 - tokeninfo(&lexval,&lexstr);
1.1984 - else
1.1985 - lexstr="";
1.1986 - argpos=findnamedarg(arg,lexstr);
1.1987 - if (argpos<0) {
1.1988 - error(17,lexstr); /* undefined symbol */
1.1989 - break; /* exit loop, argpos is invalid */
1.1990 - } /* if */
1.1991 - needtoken('=');
1.1992 - argidx=argpos;
1.1993 - } else {
1.1994 - if (namedparams)
1.1995 - error(44); /* positional parameters must precede named parameters */
1.1996 - argpos=nargs;
1.1997 - } /* if */
1.1998 - /* the number of arguments this was already checked at the declaration
1.1999 - * of the function; check it again for functions with a variable
1.2000 - * argument list
1.2001 - */
1.2002 - if (argpos>=sMAXARGS)
1.2003 - error(45); /* too many function arguments */
1.2004 - stgmark((char)(sEXPRSTART+argpos));/* mark beginning of new expression in stage */
1.2005 - if (arglist[argpos]!=ARG_UNHANDLED)
1.2006 - error(58); /* argument already set */
1.2007 - if (matchtoken('_')) {
1.2008 - arglist[argpos]=ARG_IGNORED; /* flag argument as "present, but ignored" */
1.2009 - if (arg[argidx].ident==0 || arg[argidx].ident==iVARARGS) {
1.2010 - error(92); /* argument count mismatch */
1.2011 - } else if (!arg[argidx].hasdefault) {
1.2012 - error(34,nargs+1); /* argument has no default value */
1.2013 - } /* if */
1.2014 - if (arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS)
1.2015 - argidx++;
1.2016 - /* The rest of the code to handle default values is at the bottom
1.2017 - * of this routine where default values for unspecified parameters
1.2018 - * are (also) handled. Note that above, the argument is flagged as
1.2019 - * ARG_IGNORED.
1.2020 - */
1.2021 - } else {
1.2022 - arglist[argpos]=ARG_DONE; /* flag argument as "present" */
1.2023 - if (arg[argidx].numtags==1) /* set the expected tag, if any */
1.2024 - lval.cmptag=arg[argidx].tags[0];
1.2025 - lvalue=hier14(&lval);
1.2026 - assert(sc_status==statFIRST || arg[argidx].tags!=NULL);
1.2027 - switch (arg[argidx].ident) {
1.2028 - case 0:
1.2029 - error(92); /* argument count mismatch */
1.2030 - break;
1.2031 - case iVARARGS:
1.2032 - /* always pass by reference */
1.2033 - if (lval.ident==iVARIABLE || lval.ident==iREFERENCE) {
1.2034 - assert(lval.sym!=NULL);
1.2035 - if ((lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0) {
1.2036 - /* treat a "const" variable passed to a function with a non-const
1.2037 - * "variable argument list" as a constant here */
1.2038 - if (!lvalue) {
1.2039 - error(22); /* need lvalue */
1.2040 - } else {
1.2041 - rvalue(&lval); /* get value in PRI */
1.2042 - setheap_pri(); /* address of the value on the heap in PRI */
1.2043 - heapalloc++;
1.2044 - nest_stkusage++;
1.2045 - } /* if */
1.2046 - } else if (lvalue) {
1.2047 - address(lval.sym,sPRI);
1.2048 - } else {
1.2049 - setheap_pri(); /* address of the value on the heap in PRI */
1.2050 - heapalloc++;
1.2051 - nest_stkusage++;
1.2052 - } /* if */
1.2053 - } else if (lval.ident==iCONSTEXPR || lval.ident==iEXPRESSION
1.2054 - || lval.ident==iARRAYCHAR)
1.2055 - {
1.2056 - /* fetch value if needed */
1.2057 - if (lval.ident==iARRAYCHAR)
1.2058 - rvalue(&lval);
1.2059 - /* allocate a cell on the heap and store the
1.2060 - * value (already in PRI) there */
1.2061 - setheap_pri(); /* address of the value on the heap in PRI */
1.2062 - heapalloc++;
1.2063 - nest_stkusage++;
1.2064 - } /* if */
1.2065 - /* ??? handle const array passed by reference */
1.2066 - /* otherwise, the address is already in PRI */
1.2067 - if (lval.sym!=NULL)
1.2068 - markusage(lval.sym,uWRITTEN);
1.2069 - if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
1.2070 - error(213);
1.2071 - if (lval.tag!=0)
1.2072 - append_constval(&taglst,arg[argidx].name,lval.tag,0);
1.2073 - break;
1.2074 - case iVARIABLE:
1.2075 - if (lval.ident==iLABEL || lval.ident==iFUNCTN || lval.ident==iREFFUNC
1.2076 - || lval.ident==iARRAY || lval.ident==iREFARRAY)
1.2077 - error(35,argidx+1); /* argument type mismatch */
1.2078 - if (lvalue)
1.2079 - rvalue(&lval); /* get value (direct or indirect) */
1.2080 - /* otherwise, the expression result is already in PRI */
1.2081 - assert(arg[argidx].numtags>0);
1.2082 - check_userop(NULL,lval.tag,arg[argidx].tags[0],2,NULL,&lval.tag);
1.2083 - if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
1.2084 - error(213);
1.2085 - if (lval.tag!=0)
1.2086 - append_constval(&taglst,arg[argidx].name,lval.tag,0);
1.2087 - argidx++; /* argument done */
1.2088 - break;
1.2089 - case iREFERENCE:
1.2090 - if (!lvalue || lval.ident==iARRAYCHAR)
1.2091 - error(35,argidx+1); /* argument type mismatch */
1.2092 - if (lval.sym!=NULL && (lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0)
1.2093 - error(35,argidx+1); /* argument type mismatch */
1.2094 - if (lval.ident==iVARIABLE || lval.ident==iREFERENCE) {
1.2095 - if (lvalue) {
1.2096 - assert(lval.sym!=NULL);
1.2097 - address(lval.sym,sPRI);
1.2098 - } else {
1.2099 - setheap_pri(); /* address of the value on the heap in PRI */
1.2100 - heapalloc++;
1.2101 - nest_stkusage++;
1.2102 - } /* if */
1.2103 - } /* if */
1.2104 - /* otherwise, the address is already in PRI */
1.2105 - if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
1.2106 - error(213);
1.2107 - if (lval.tag!=0)
1.2108 - append_constval(&taglst,arg[argidx].name,lval.tag,0);
1.2109 - argidx++; /* argument done */
1.2110 - if (lval.sym!=NULL)
1.2111 - markusage(lval.sym,uWRITTEN);
1.2112 - break;
1.2113 - case iREFARRAY:
1.2114 - if (lval.ident!=iARRAY && lval.ident!=iREFARRAY
1.2115 - && lval.ident!=iARRAYCELL)
1.2116 - {
1.2117 - error(35,argidx+1); /* argument type mismatch */
1.2118 - break;
1.2119 - } /* if */
1.2120 - if (lval.sym!=NULL && (lval.sym->usage & uCONST)!=0 && (arg[argidx].usage & uCONST)==0)
1.2121 - error(35,argidx+1); /* argument type mismatch */
1.2122 - /* Verify that the dimensions match with those in arg[argidx].
1.2123 - * A literal array always has a single dimension.
1.2124 - * An iARRAYCELL parameter is also assumed to have a single dimension.
1.2125 - */
1.2126 - if (lval.sym==NULL || lval.ident==iARRAYCELL) {
1.2127 - if (arg[argidx].numdim!=1) {
1.2128 - error(48); /* array dimensions must match */
1.2129 - } else if (arg[argidx].dim[0]!=0) {
1.2130 - assert(arg[argidx].dim[0]>0);
1.2131 - if (lval.ident==iARRAYCELL) {
1.2132 - error(47); /* array sizes must match */
1.2133 - } else {
1.2134 - assert(lval.constval!=0); /* literal array must have a size */
1.2135 - /* A literal array must have exactly the same size as the
1.2136 - * function argument; a literal string may be smaller than
1.2137 - * the function argument.
1.2138 - */
1.2139 - if (lval.constval>0 && arg[argidx].dim[0]!=lval.constval
1.2140 - || lval.constval<0 && arg[argidx].dim[0] < -lval.constval)
1.2141 - error(47); /* array sizes must match */
1.2142 - } /* if */
1.2143 - } /* if */
1.2144 - if (lval.ident!=iARRAYCELL) {
1.2145 - /* save array size, for default values with uSIZEOF flag */
1.2146 - cell array_sz=lval.constval;
1.2147 - assert(array_sz!=0);/* literal array must have a size */
1.2148 - if (array_sz<0)
1.2149 - array_sz= -array_sz;
1.2150 - append_constval(&arrayszlst,arg[argidx].name,array_sz,0);
1.2151 - } /* if */
1.2152 - } else {
1.2153 - symbol *sym=lval.sym;
1.2154 - short level=0;
1.2155 - assert(sym!=NULL);
1.2156 - if (sym->dim.array.level+1!=arg[argidx].numdim)
1.2157 - error(48); /* array dimensions must match */
1.2158 - /* the lengths for all dimensions must match, unless the dimension
1.2159 - * length was defined at zero (which means "undefined")
1.2160 - */
1.2161 - while (sym->dim.array.level>0) {
1.2162 - assert(level<sDIMEN_MAX);
1.2163 - if (arg[argidx].dim[level]!=0 && sym->dim.array.length!=arg[argidx].dim[level])
1.2164 - error(47); /* array sizes must match */
1.2165 - else if (!matchtag(arg[argidx].idxtag[level],sym->x.tags.index,TRUE))
1.2166 - error(229,sym->name); /* index tag mismatch */
1.2167 - append_constval(&arrayszlst,arg[argidx].name,sym->dim.array.length,level);
1.2168 - sym=finddepend(sym);
1.2169 - assert(sym!=NULL);
1.2170 - level++;
1.2171 - } /* if */
1.2172 - /* the last dimension is checked too, again, unless it is zero */
1.2173 - assert(level<sDIMEN_MAX);
1.2174 - assert(sym!=NULL);
1.2175 - if (arg[argidx].dim[level]!=0 && sym->dim.array.length!=arg[argidx].dim[level])
1.2176 - error(47); /* array sizes must match */
1.2177 - else if (!matchtag(arg[argidx].idxtag[level],sym->x.tags.index,TRUE))
1.2178 - error(229,sym->name); /* index tag mismatch */
1.2179 - append_constval(&arrayszlst,arg[argidx].name,sym->dim.array.length,level);
1.2180 - } /* if */
1.2181 - /* address already in PRI */
1.2182 - if (!checktag(arg[argidx].tags,arg[argidx].numtags,lval.tag))
1.2183 - error(213);
1.2184 - if (lval.tag!=0)
1.2185 - append_constval(&taglst,arg[argidx].name,lval.tag,0);
1.2186 - // ??? set uWRITTEN?
1.2187 - argidx++; /* argument done */
1.2188 - break;
1.2189 - } /* switch */
1.2190 - pushreg(sPRI); /* store the function argument on the stack */
1.2191 - markexpr(sPARM,NULL,0); /* mark the end of a sub-expression */
1.2192 - nest_stkusage++;
1.2193 - } /* if */
1.2194 - assert(arglist[argpos]!=ARG_UNHANDLED);
1.2195 - nargs++;
1.2196 - if (matchparanthesis) {
1.2197 - close=matchtoken(')');
1.2198 - if (!close) /* if not paranthese... */
1.2199 - if (!needtoken(',')) /* ...should be comma... */
1.2200 - break; /* ...but abort loop if neither */
1.2201 - } else {
1.2202 - close=!matchtoken(',');
1.2203 - if (close) { /* if not comma... */
1.2204 - if (needtoken(tTERM)==1)/* ...must be end of statement */
1.2205 - lexpush(); /* push again, because end of statement is analised later */
1.2206 - } /* if */
1.2207 - } /* if */
1.2208 - } while (!close && freading && !matchtoken(tENDEXPR)); /* do */
1.2209 - } /* if */
1.2210 - /* check remaining function arguments (they may have default values) */
1.2211 - for (argidx=0; arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS; argidx++) {
1.2212 - if (arglist[argidx]==ARG_DONE)
1.2213 - continue; /* already seen and handled this argument */
1.2214 - /* in this first stage, we also skip the arguments with uSIZEOF and uTAGOF;
1.2215 - * these are handled last
1.2216 - */
1.2217 - if ((arg[argidx].hasdefault & uSIZEOF)!=0 || (arg[argidx].hasdefault & uTAGOF)!=0) {
1.2218 - assert(arg[argidx].ident==iVARIABLE);
1.2219 - continue;
1.2220 - } /* if */
1.2221 - stgmark((char)(sEXPRSTART+argidx));/* mark beginning of new expression in stage */
1.2222 - if (arg[argidx].hasdefault) {
1.2223 - if (arg[argidx].ident==iREFARRAY) {
1.2224 - short level;
1.2225 - setdefarray(arg[argidx].defvalue.array.data,
1.2226 - arg[argidx].defvalue.array.size,
1.2227 - arg[argidx].defvalue.array.arraysize,
1.2228 - &arg[argidx].defvalue.array.addr,
1.2229 - (arg[argidx].usage & uCONST)!=0);
1.2230 - if ((arg[argidx].usage & uCONST)==0) {
1.2231 - heapalloc+=arg[argidx].defvalue.array.arraysize;
1.2232 - nest_stkusage+=arg[argidx].defvalue.array.arraysize;
1.2233 - } /* if */
1.2234 - /* keep the lengths of all dimensions of a multi-dimensional default array */
1.2235 - assert(arg[argidx].numdim>0);
1.2236 - if (arg[argidx].numdim==1) {
1.2237 - append_constval(&arrayszlst,arg[argidx].name,arg[argidx].defvalue.array.arraysize,0);
1.2238 - } else {
1.2239 - for (level=0; level<arg[argidx].numdim; level++) {
1.2240 - assert(level<sDIMEN_MAX);
1.2241 - append_constval(&arrayszlst,arg[argidx].name,arg[argidx].dim[level],level);
1.2242 - } /* for */
1.2243 - } /* if */
1.2244 - } else if (arg[argidx].ident==iREFERENCE) {
1.2245 - setheap(arg[argidx].defvalue.val);
1.2246 - /* address of the value on the heap in PRI */
1.2247 - heapalloc++;
1.2248 - nest_stkusage++;
1.2249 - } else {
1.2250 - int dummytag=arg[argidx].tags[0];
1.2251 - ldconst(arg[argidx].defvalue.val,sPRI);
1.2252 - assert(arg[argidx].numtags>0);
1.2253 - check_userop(NULL,arg[argidx].defvalue_tag,arg[argidx].tags[0],2,NULL,&dummytag);
1.2254 - assert(dummytag==arg[argidx].tags[0]);
1.2255 - } /* if */
1.2256 - pushreg(sPRI); /* store the function argument on the stack */
1.2257 - markexpr(sPARM,NULL,0); /* mark the end of a sub-expression */
1.2258 - nest_stkusage++;
1.2259 - } else {
1.2260 - error(202,argidx); /* argument count mismatch */
1.2261 - } /* if */
1.2262 - if (arglist[argidx]==ARG_UNHANDLED)
1.2263 - nargs++;
1.2264 - arglist[argidx]=ARG_DONE;
1.2265 - } /* for */
1.2266 - /* now a second loop to catch the arguments with default values that are
1.2267 - * the "sizeof" or "tagof" of other arguments
1.2268 - */
1.2269 - for (argidx=0; arg[argidx].ident!=0 && arg[argidx].ident!=iVARARGS; argidx++) {
1.2270 - constvalue *asz;
1.2271 - cell array_sz;
1.2272 - if (arglist[argidx]==ARG_DONE)
1.2273 - continue; /* already seen and handled this argument */
1.2274 - stgmark((char)(sEXPRSTART+argidx));/* mark beginning of new expression in stage */
1.2275 - assert(arg[argidx].ident==iVARIABLE); /* if "sizeof", must be single cell */
1.2276 - /* if unseen, must be "sizeof" or "tagof" */
1.2277 - assert((arg[argidx].hasdefault & uSIZEOF)!=0 || (arg[argidx].hasdefault & uTAGOF)!=0);
1.2278 - if ((arg[argidx].hasdefault & uSIZEOF)!=0) {
1.2279 - /* find the argument; if it isn't found, the argument's default value
1.2280 - * was a "sizeof" of a non-array (a warning for this was already given
1.2281 - * when declaring the function)
1.2282 - */
1.2283 - asz=find_constval(&arrayszlst,arg[argidx].defvalue.size.symname,
1.2284 - arg[argidx].defvalue.size.level);
1.2285 - if (asz!=NULL) {
1.2286 - array_sz=asz->value;
1.2287 - if (array_sz==0)
1.2288 - error(224,arg[argidx].name); /* indeterminate array size in "sizeof" expression */
1.2289 - } else {
1.2290 - array_sz=1;
1.2291 - } /* if */
1.2292 - } else {
1.2293 - asz=find_constval(&taglst,arg[argidx].defvalue.size.symname,
1.2294 - arg[argidx].defvalue.size.level);
1.2295 - if (asz != NULL) {
1.2296 - exporttag(asz->value);
1.2297 - array_sz=asz->value | PUBLICTAG; /* must be set, because it just was exported */
1.2298 - } else {
1.2299 - array_sz=0;
1.2300 - } /* if */
1.2301 - } /* if */
1.2302 - ldconst(array_sz,sPRI);
1.2303 - pushreg(sPRI); /* store the function argument on the stack */
1.2304 - markexpr(sPARM,NULL,0);
1.2305 - nest_stkusage++;
1.2306 - if (arglist[argidx]==ARG_UNHANDLED)
1.2307 - nargs++;
1.2308 - arglist[argidx]=ARG_DONE;
1.2309 - } /* for */
1.2310 - stgmark(sENDREORDER); /* mark end of reversed evaluation */
1.2311 - pushval((cell)nargs*sizeof(cell));
1.2312 - nest_stkusage++;
1.2313 - ffcall(sym,NULL,nargs);
1.2314 - if (sc_status!=statSKIP)
1.2315 - markusage(sym,uREAD); /* do not mark as "used" when this call itself is skipped */
1.2316 - if ((sym->usage & uNATIVE)!=0 &&sym->x.lib!=NULL)
1.2317 - sym->x.lib->value += 1; /* increment "usage count" of the library */
1.2318 - modheap(-heapalloc*sizeof(cell));
1.2319 - if (symret!=NULL)
1.2320 - popreg(sPRI); /* pop hidden parameter as function result */
1.2321 - sideeffect=TRUE; /* assume functions carry out a side-effect */
1.2322 - delete_consttable(&arrayszlst); /* clear list of array sizes */
1.2323 - delete_consttable(&taglst); /* clear list of parameter tags */
1.2324 -
1.2325 - /* maintain max. amount of memory used */
1.2326 - {
1.2327 - long totalsize;
1.2328 - totalsize=declared+decl_heap+1; /* local variables & return value size,
1.2329 - * +1 for PROC opcode */
1.2330 - if (lval_result->ident==iREFARRAY)
1.2331 - totalsize++; /* add hidden parameter (on the stack) */
1.2332 - if ((sym->usage & uNATIVE)==0)
1.2333 - totalsize++; /* add "call" opcode */
1.2334 - totalsize+=nest_stkusage;
1.2335 - assert(curfunc!=NULL);
1.2336 - if (curfunc->x.stacksize<totalsize)
1.2337 - curfunc->x.stacksize=totalsize;
1.2338 - nest_stkusage-=nargs+heapalloc+1; /* stack/heap space, +1 for argcount param */
1.2339 - /* if there is a syntax error in the script, the stack calculation is
1.2340 - * probably incorrect; but we may not allow it to drop below zero
1.2341 - */
1.2342 - if (nest_stkusage<0)
1.2343 - nest_stkusage=0;
1.2344 - }
1.2345 -
1.2346 - /* scrap any arrays left on the heap, with the exception of the array that
1.2347 - * this function has as a result (in other words, scrap all arrays on the
1.2348 - * heap that caused by expressions in the function arguments)
1.2349 - */
1.2350 - assert(decl_heap>=locheap);
1.2351 - modheap((locheap-decl_heap)*sizeof(cell)); /* remove heap space, so negative delta */
1.2352 - decl_heap=locheap;
1.2353 - nesting--;
1.2354 -}
1.2355 -
1.2356 -/* dbltest
1.2357 - *
1.2358 - * Returns a non-zero value if lval1 an array and lval2 is not an array and
1.2359 - * the operation is addition or subtraction.
1.2360 - *
1.2361 - * Returns the "shift" count (1 for 16-bit, 2 for 32-bit) to align a cell
1.2362 - * to an array offset.
1.2363 - */
1.2364 -static int dbltest(void (*oper)(),value *lval1,value *lval2)
1.2365 -{
1.2366 - if ((oper!=ob_add) && (oper!=ob_sub))
1.2367 - return 0;
1.2368 - if (lval1->ident!=iARRAY)
1.2369 - return 0;
1.2370 - if (lval2->ident==iARRAY)
1.2371 - return 0;
1.2372 - return sizeof(cell)/2; /* 1 for 16-bit, 2 for 32-bit */
1.2373 -}
1.2374 -
1.2375 -/* commutative
1.2376 - *
1.2377 - * Test whether an operator is commutative, i.e. x oper y == y oper x.
1.2378 - * Commutative operators are: + (addition)
1.2379 - * * (multiplication)
1.2380 - * == (equality)
1.2381 - * != (inequality)
1.2382 - * & (bitwise and)
1.2383 - * ^ (bitwise xor)
1.2384 - * | (bitwise or)
1.2385 - *
1.2386 - * If in an expression, code for the left operand has been generated and
1.2387 - * the right operand is a constant and the operator is commutative, the
1.2388 - * precautionary "push" of the primary register is scrapped and the constant
1.2389 - * is read into the secondary register immediately.
1.2390 - */
1.2391 -static int commutative(void (*oper)())
1.2392 -{
1.2393 - return oper==ob_add || oper==os_mult
1.2394 - || oper==ob_eq || oper==ob_ne
1.2395 - || oper==ob_and || oper==ob_xor || oper==ob_or;
1.2396 -}
1.2397 -
1.2398 -/* constant
1.2399 - *
1.2400 - * Generates code to fetch a number, a literal character (which is returned
1.2401 - * by lex() as a number as well) or a literal string (lex() stores the
1.2402 - * strings in the literal queue). If the operand was a number, it is stored
1.2403 - * in lval->constval.
1.2404 - *
1.2405 - * The function returns 1 if the token was a constant or a string, 0
1.2406 - * otherwise.
1.2407 - */
1.2408 -static int constant(value *lval)
1.2409 -{
1.2410 - int tok,index,ident;
1.2411 - cell val,item,cidx;
1.2412 - char *st;
1.2413 - symbol *sym;
1.2414 - int cmptag=lval->cmptag;
1.2415 -
1.2416 - tok=lex(&val,&st);
1.2417 - if (tok==tSYMBOL && (sym=findconst(st,&cmptag))!=0) {
1.2418 - if (cmptag>1)
1.2419 - error(91,sym->name); /* ambiguity: multiple matching constants (different tags) */
1.2420 - lval->constval=sym->addr;
1.2421 - ldconst(lval->constval,sPRI);
1.2422 - lval->ident=iCONSTEXPR;
1.2423 - lval->tag=sym->tag;
1.2424 - lval->sym=sym;
1.2425 - markusage(sym,uREAD);
1.2426 - } else if (tok==tNUMBER) {
1.2427 - lval->constval=val;
1.2428 - ldconst(lval->constval,sPRI);
1.2429 - lval->ident=iCONSTEXPR;
1.2430 - } else if (tok==tRATIONAL) {
1.2431 - lval->constval=val;
1.2432 - ldconst(lval->constval,sPRI);
1.2433 - lval->ident=iCONSTEXPR;
1.2434 - lval->tag=sc_rationaltag;
1.2435 - } else if (tok==tSTRING) {
1.2436 - /* lex() stores starting index of string in the literal table in 'val' */
1.2437 - ldconst((val+glb_declared)*sizeof(cell),sPRI);
1.2438 - lval->ident=iARRAY; /* pretend this is a global array */
1.2439 - lval->constval=val-litidx; /* constval == the negative value of the
1.2440 - * size of the literal array; using a negative
1.2441 - * value distinguishes between literal arrays
1.2442 - * and literal strings (this was done for
1.2443 - * array assignment). */
1.2444 - } else if (tok=='{') {
1.2445 - int tag,lasttag=-1;
1.2446 - val=litidx;
1.2447 - do {
1.2448 - /* cannot call constexpr() here, because "staging" is already turned
1.2449 - * on at this point */
1.2450 - assert(staging);
1.2451 - stgget(&index,&cidx); /* mark position in code generator */
1.2452 - ident=expression(&item,&tag,NULL,FALSE);
1.2453 - stgdel(index,cidx); /* scratch generated code */
1.2454 - if (ident!=iCONSTEXPR)
1.2455 - error(8); /* must be constant expression */
1.2456 - if (lasttag<0)
1.2457 - lasttag=tag;
1.2458 - else if (!matchtag(lasttag,tag,FALSE))
1.2459 - error(213); /* tagname mismatch */
1.2460 - litadd(item); /* store expression result in literal table */
1.2461 - } while (matchtoken(','));
1.2462 - if (!needtoken('}'))
1.2463 - lexclr(FALSE);
1.2464 - ldconst((val+glb_declared)*sizeof(cell),sPRI);
1.2465 - lval->ident=iARRAY; /* pretend this is a global array */
1.2466 - lval->constval=litidx-val; /* constval == the size of the literal array */
1.2467 - } else {
1.2468 - return FALSE; /* no, it cannot be interpreted as a constant */
1.2469 - } /* if */
1.2470 - return TRUE; /* yes, it was a constant value */
1.2471 -}
1.2472 -
