Doxygen Source Code Documentation
expr.c File Reference
#include "defs.h"
#include "output.h"
#include "names.h"
Go to the source code of this file.
Data Structures | |
struct | dcomplex |
Defines | |
#define | ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c) |
#define | COMMUTE { e = lp; lp = rp; rp = e; } |
#define | ERR(s) { errs = s; goto error; } |
Functions | |
void consbinop | Argdcl ((int, int, Constp, Constp, Constp)) |
void conspower | Argdcl ((Constp, Constp, long int)) |
void zdiv | Argdcl ((dcomplex *, dcomplex *, dcomplex *)) |
tagptr mkpower | Argdcl ((tagptr)) |
tagptr stfcall | Argdcl ((Namep, struct Listblock *)) |
Constp | mkconst (register int t) |
expptr | mklogcon (register int l) |
expptr | mkintcon (ftnint l) |
expptr | mkaddcon (register long l) |
expptr | mkrealcon (register int t, char *d) |
expptr | mkbitcon (int shift, int leng, char *s) |
expptr | mkstrcon (int l, register char *v) |
expptr | mkcxcon (register expptr realp, register expptr imagp) |
expptr | mkconv (register int t, register expptr p) |
expptr | opconv (expptr p, int t) |
expptr | addrof (expptr p) |
tagptr | cpexpr (register tagptr p) |
void | frexpr (register tagptr p) |
void | wronginf (Namep np) |
expptr | fixtype (register tagptr p) |
int | badchleng (register expptr p) |
expptr | cplenexpr (expptr p) |
expptr | fixexpr (register Exprp p) |
int | fixargs (int doput, struct Listblock *p0) |
Addrp | mkscalar (register Namep np) |
void | adjust_arginfo (register Namep np) |
expptr | mkfunct (expptr p0) |
expptr | stfcall (Namep np, struct Listblock *actlist) |
Addrp | mkplace (register Namep np) |
expptr | subskept (struct Primblock *p, Addrp a) |
expptr | mklhs (register struct Primblock *p, int subkeep) |
void | deregister (Namep np) |
Addrp | memversion (register Namep np) |
int | inregister (register Namep np) |
expptr | suboffset (register struct Primblock *p) |
expptr | subcheck (Namep np, register expptr p) |
Addrp | mkaddr (register Namep p) |
Addrp | mkarg (int type, int argno) |
expptr | mkprim (Namep v0, struct Listblock *args, chainp substr) |
void | vardcl (register Namep v) |
void | impldcl (register Namep p) |
void | inferdcl (Namep np, int type) |
LOCAL int | zeroconst (expptr e) |
expptr | mkexpr (int opcode, register expptr lp, register expptr rp) |
cktype (register int op, register int lt, register int rt) | |
void | intovfl (Void) |
expptr | fold (register expptr e) |
void | consconv (int lt, register Constp lc, register Constp rc) |
void | consnegop (register Constp p) |
LOCAL void | conspower (Constp p, Constp ap, ftnint n) |
LOCAL void | consbinop (int opcode, int type, Constp cpp, Constp app, Constp bpp) |
conssgn (register expptr p) | |
LOCAL expptr | mkpower (register expptr p) |
LOCAL void | zdiv (register dcomplex *c, register dcomplex *a, register dcomplex *b) |
void | sserr (Namep np) |
Variables | |
char | dflttype [26] |
int | htype |
expptr | errnode (Void) |
int | replaced |
int | doing_vleng |
char * | powint [] |
Define Documentation
|
Definition at line 2014 of file expr.c. Referenced by mkexpr(). |
|
|
|
Definition at line 2013 of file expr.c. Referenced by mkexpr(). |
Function Documentation
|
Definition at line 380 of file expr.c. References ENULL, mkexpr(), and OPADDR. Referenced by ioseta(), iosetc(), iosetip(), and putct1().
|
|
Definition at line 1001 of file expr.c. References Extsym::arginfo, Entrypoint::arglist, args, Entrypoint::entnextp, Entrypoint::entryname, and Argtypes::nargs. Referenced by mkfunct().
|
|
|
|
|
|
|
|
|
|
|
|
Definition at line 635 of file expr.c. References Expression::addrblock, err, errstr(), Expression::headblock, TADDR, Headblock::tag, UNAM_NAME, Addrblock::uname_tag, Addrblock::user, and Headblock::vleng. Referenced by cplenexpr(), and putcheq().
00637 { 00638 if (!p->headblock.vleng) { 00639 if (p->headblock.tag == TADDR 00640 && p->addrblock.uname_tag == UNAM_NAME) 00641 errstr("bad use of character*(*) variable %.60s", 00642 p->addrblock.user.name->fvarname); 00643 else 00644 err("Bad use of character*(*)"); 00645 return 1; 00646 } 00647 return 0; 00648 } |
|
Definition at line 2358 of file expr.c. References badop(), err, ERR, htype, is_unary_op, ISCOMPLEX, ISINT, ISLOGICAL, ISNUMERIC, maxtype(), OPABS, OPADDR, OPAND, OPARROW, OPASSIGN, OPASSIGNI, OPBITAND, OPBITANDEQ, OPBITCLR, OPBITNOT, OPBITOR, OPBITOREQ, OPBITSET, OPBITTEST, OPBITXOR, OPBITXOREQ, OPCALL, OPCCALL, OPCHARCAST, OPCOLON, OPCOMMA, OPCOMMA_ARG, OPCONCAT, OPCONV, OPDABS, OPDMAX, OPDMIN, OPDOT, OPEQ, OPEQV, OPGE, OPGT, OPIDENTITY, OPLE, OPLSHIFT, OPLSHIFTEQ, OPLT, OPMAX, OPMAX2, OPMIN, OPMIN2, OPMINUS, OPMINUSEQ, OPMOD, OPMODEQ, OPNE, OPNEG, OPNEG1, OPNEQV, OPNOT, OPOR, OPPLUS, OPPLUSEQ, OPPOWER, OPQBITCLR, OPQBITSET, OPQUEST, OPRSHIFT, OPRSHIFTEQ, OPSLASH, OPSLASHEQ, OPSTAR, OPSTAREQ, OPWHATSIN, TYERROR, and TYQUAD. Referenced by fixexpr(), mkexpr(), and setdata().
02360 { 02361 char *errs; 02362 02363 if(lt==TYERROR || rt==TYERROR) 02364 goto error1; 02365 02366 if(lt==TYUNKNOWN) 02367 return(TYUNKNOWN); 02368 if(rt==TYUNKNOWN) 02369 02370 /* If not unary operation, return UNKNOWN */ 02371 02372 if(!is_unary_op (op) && op != OPCALL && op != OPCCALL) 02373 return(TYUNKNOWN); 02374 02375 switch(op) 02376 { 02377 case OPPLUS: 02378 case OPMINUS: 02379 case OPSTAR: 02380 case OPSLASH: 02381 case OPPOWER: 02382 case OPMOD: 02383 if( ISNUMERIC(lt) && ISNUMERIC(rt) ) 02384 return( maxtype(lt, rt) ); 02385 ERR("nonarithmetic operand of arithmetic operator") 02386 02387 case OPNEG: 02388 case OPNEG1: 02389 if( ISNUMERIC(lt) ) 02390 return(lt); 02391 ERR("nonarithmetic operand of negation") 02392 02393 case OPNOT: 02394 if(ISLOGICAL(lt)) 02395 return(lt); 02396 ERR("NOT of nonlogical") 02397 02398 case OPAND: 02399 case OPOR: 02400 case OPEQV: 02401 case OPNEQV: 02402 if(ISLOGICAL(lt) && ISLOGICAL(rt)) 02403 return( maxtype(lt, rt) ); 02404 ERR("nonlogical operand of logical operator") 02405 02406 case OPLT: 02407 case OPGT: 02408 case OPLE: 02409 case OPGE: 02410 case OPEQ: 02411 case OPNE: 02412 if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) 02413 { 02414 if(lt != rt){ 02415 if (htype 02416 && (lt == TYCHAR && ISNUMERIC(rt) 02417 || rt == TYCHAR && ISNUMERIC(lt))) 02418 return TYLOGICAL; 02419 ERR("illegal comparison") 02420 } 02421 } 02422 02423 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) ) 02424 { 02425 if(op!=OPEQ && op!=OPNE) 02426 ERR("order comparison of complex data") 02427 } 02428 02429 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) ) 02430 ERR("comparison of nonarithmetic data") 02431 case OPBITTEST: 02432 return(TYLOGICAL); 02433 02434 case OPCONCAT: 02435 if(lt==TYCHAR && rt==TYCHAR) 02436 return(TYCHAR); 02437 ERR("concatenation of nonchar data") 02438 02439 case OPCALL: 02440 case OPCCALL: 02441 case OPIDENTITY: 02442 return(lt); 02443 02444 case OPADDR: 02445 case OPCHARCAST: 02446 return(TYADDR); 02447 02448 case OPCONV: 02449 if(rt == 0) 02450 return(0); 02451 if(lt==TYCHAR && ISINT(rt) ) 02452 return(TYCHAR); 02453 if (ISLOGICAL(lt) && ISLOGICAL(rt)) 02454 return lt; 02455 case OPASSIGN: 02456 case OPASSIGNI: 02457 case OPMINUSEQ: 02458 case OPPLUSEQ: 02459 case OPSTAREQ: 02460 case OPSLASHEQ: 02461 case OPMODEQ: 02462 case OPLSHIFTEQ: 02463 case OPRSHIFTEQ: 02464 case OPBITANDEQ: 02465 case OPBITXOREQ: 02466 case OPBITOREQ: 02467 if( ISINT(lt) && rt==TYCHAR) 02468 return(lt); 02469 if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN) 02470 return lt; 02471 if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) 02472 if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ) 02473 || (lt!=rt)) 02474 { 02475 ERR("impossible conversion") 02476 } 02477 return(lt); 02478 02479 case OPMIN: 02480 case OPMAX: 02481 case OPDMIN: 02482 case OPDMAX: 02483 case OPMIN2: 02484 case OPMAX2: 02485 case OPBITOR: 02486 case OPBITAND: 02487 case OPBITXOR: 02488 case OPBITNOT: 02489 case OPLSHIFT: 02490 case OPRSHIFT: 02491 case OPWHATSIN: 02492 case OPABS: 02493 case OPDABS: 02494 return(lt); 02495 02496 case OPBITCLR: 02497 case OPBITSET: 02498 if (lt < TYLONG) 02499 lt = TYLONG; 02500 return(lt); 02501 #ifdef TYQUAD 02502 case OPQBITCLR: 02503 case OPQBITSET: 02504 return TYQUAD; 02505 #endif 02506 02507 case OPCOMMA: 02508 case OPCOMMA_ARG: 02509 case OPQUEST: 02510 case OPCOLON: /* Only checks the rightmost type because 02511 of C language definition (rightmost 02512 comma-expr is the value of the expr) */ 02513 return(rt); 02514 02515 case OPDOT: 02516 case OPARROW: 02517 return (lt); 02518 default: 02519 badop("cktype", op); 02520 } 02521 error: 02522 err(errs); 02523 error1: 02524 return(TYERROR); 02525 } |
|
Definition at line 2994 of file expr.c. References a, Constant::cd, Constant::cds, Constant::ci, Constblock::Const, Fatal(), intovfl(), ISCOMPLEX, ISINT, MSKCOMPLEX, MSKREAL, ONEOF, OPDMAX, OPDMIN, OPEQ, OPGE, OPGT, OPLE, OPLT, OPMAX2, OPMIN2, OPMINUS, OPMOD, OPNE, OPPLUS, OPSLASH, OPSTAR, TYQUAD, Constblock::vstg, and zdiv(). Referenced by conspower(), and fold().
02996 { 02997 register union Constant *ap = &app->Const, 02998 *bp = &bpp->Const, 02999 *cp = &cpp->Const; 03000 int k; 03001 double ad[2], bd[2], temp; 03002 ftnint a, b; 03003 03004 cpp->vstg = 0; 03005 03006 if (ONEOF(type, MSKREAL|MSKCOMPLEX)) { 03007 ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0]; 03008 bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0]; 03009 if (ISCOMPLEX(type)) { 03010 ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1]; 03011 bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1]; 03012 } 03013 } 03014 switch(opcode) 03015 { 03016 case OPPLUS: 03017 switch(type) 03018 { 03019 case TYINT1: 03020 case TYSHORT: 03021 case TYLONG: 03022 #ifdef TYQUAD 03023 case TYQUAD: 03024 #endif 03025 cp->ci = ap->ci + bp->ci; 03026 if (ap->ci != cp->ci - bp->ci) 03027 intovfl(); 03028 break; 03029 case TYCOMPLEX: 03030 case TYDCOMPLEX: 03031 cp->cd[1] = ad[1] + bd[1]; 03032 case TYREAL: 03033 case TYDREAL: 03034 cp->cd[0] = ad[0] + bd[0]; 03035 break; 03036 } 03037 break; 03038 03039 case OPMINUS: 03040 switch(type) 03041 { 03042 case TYINT1: 03043 case TYSHORT: 03044 case TYLONG: 03045 #ifdef TYQUAD 03046 case TYQUAD: 03047 #endif 03048 cp->ci = ap->ci - bp->ci; 03049 if (ap->ci != bp->ci + cp->ci) 03050 intovfl(); 03051 break; 03052 case TYCOMPLEX: 03053 case TYDCOMPLEX: 03054 cp->cd[1] = ad[1] - bd[1]; 03055 case TYREAL: 03056 case TYDREAL: 03057 cp->cd[0] = ad[0] - bd[0]; 03058 break; 03059 } 03060 break; 03061 03062 case OPSTAR: 03063 switch(type) 03064 { 03065 case TYINT1: 03066 case TYSHORT: 03067 case TYLONG: 03068 #ifdef TYQUAD 03069 case TYQUAD: 03070 #endif 03071 cp->ci = (a = ap->ci) * (b = bp->ci); 03072 if (a && cp->ci / a != b) 03073 intovfl(); 03074 break; 03075 case TYREAL: 03076 case TYDREAL: 03077 cp->cd[0] = ad[0] * bd[0]; 03078 break; 03079 case TYCOMPLEX: 03080 case TYDCOMPLEX: 03081 temp = ad[0] * bd[0] - ad[1] * bd[1] ; 03082 cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ; 03083 cp->cd[0] = temp; 03084 break; 03085 } 03086 break; 03087 case OPSLASH: 03088 switch(type) 03089 { 03090 case TYINT1: 03091 case TYSHORT: 03092 case TYLONG: 03093 #ifdef TYQUAD 03094 case TYQUAD: 03095 #endif 03096 cp->ci = ap->ci / bp->ci; 03097 break; 03098 case TYREAL: 03099 case TYDREAL: 03100 cp->cd[0] = ad[0] / bd[0]; 03101 break; 03102 case TYCOMPLEX: 03103 case TYDCOMPLEX: 03104 zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd); 03105 break; 03106 } 03107 break; 03108 03109 case OPMOD: 03110 if( ISINT(type) ) 03111 { 03112 cp->ci = ap->ci % bp->ci; 03113 break; 03114 } 03115 else 03116 Fatal("inline mod of noninteger"); 03117 03118 case OPMIN2: 03119 case OPDMIN: 03120 switch(type) 03121 { 03122 case TYINT1: 03123 case TYSHORT: 03124 case TYLONG: 03125 #ifdef TYQUAD 03126 case TYQUAD: 03127 #endif 03128 cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci; 03129 break; 03130 case TYREAL: 03131 case TYDREAL: 03132 cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0]; 03133 break; 03134 default: 03135 Fatal("inline min of exected type"); 03136 } 03137 break; 03138 03139 case OPMAX2: 03140 case OPDMAX: 03141 switch(type) 03142 { 03143 case TYINT1: 03144 case TYSHORT: 03145 case TYLONG: 03146 #ifdef TYQUAD 03147 case TYQUAD: 03148 #endif 03149 cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci; 03150 break; 03151 case TYREAL: 03152 case TYDREAL: 03153 cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0]; 03154 break; 03155 default: 03156 Fatal("inline max of exected type"); 03157 } 03158 break; 03159 03160 default: /* relational ops */ 03161 switch(type) 03162 { 03163 case TYINT1: 03164 case TYSHORT: 03165 case TYLONG: 03166 #ifdef TYQUAD 03167 case TYQUAD: 03168 #endif 03169 if(ap->ci < bp->ci) 03170 k = -1; 03171 else if(ap->ci == bp->ci) 03172 k = 0; 03173 else k = 1; 03174 break; 03175 case TYREAL: 03176 case TYDREAL: 03177 if(ad[0] < bd[0]) 03178 k = -1; 03179 else if(ad[0] == bd[0]) 03180 k = 0; 03181 else k = 1; 03182 break; 03183 case TYCOMPLEX: 03184 case TYDCOMPLEX: 03185 if(ad[0] == bd[0] && 03186 ad[1] == bd[1] ) 03187 k = 0; 03188 else k = 1; 03189 break; 03190 case TYLOGICAL: 03191 k = ap->ci - bp->ci; 03192 } 03193 03194 switch(opcode) 03195 { 03196 case OPEQ: 03197 cp->ci = (k == 0); 03198 break; 03199 case OPNE: 03200 cp->ci = (k != 0); 03201 break; 03202 case OPGT: 03203 cp->ci = (k == 1); 03204 break; 03205 case OPLT: 03206 cp->ci = (k == -1); 03207 break; 03208 case OPGE: 03209 cp->ci = (k >= 0); 03210 break; 03211 case OPLE: 03212 cp->ci = (k <= 0); 03213 break; 03214 } 03215 break; 03216 } 03217 } |
|
Definition at line 2759 of file expr.c. References Constant::ccp1, Constant::cd, cds(), Constant::cds, Constant::ci, ckalloc(), CNULL, Constblock::Const, ISCOMPLEX, ISINT, ISREAL, MSKCOMPLEX, MSKREAL, ONEOF, TYQUAD, Constblock::vstg, and Constblock::vtype. Referenced by fold(), mkconv(), and setdata().
02761 { 02762 int rt = rc->vtype; 02763 register union Constant *lv = &lc->Const, *rv = &rc->Const; 02764 02765 lc->vtype = lt; 02766 if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) { 02767 memcpy((char *)lv, (char *)rv, sizeof(union Constant)); 02768 lc->vstg = rc->vstg; 02769 if (ISCOMPLEX(lt) && ISREAL(rt)) { 02770 if (rc->vstg) 02771 lv->cds[1] = cds("0",CNULL); 02772 else 02773 lv->cd[1] = 0.; 02774 } 02775 return; 02776 } 02777 lc->vstg = 0; 02778 02779 switch(lt) 02780 { 02781 02782 /* Casting to character means just copying the first sizeof (character) 02783 bytes into a new 1 character string. This is weird. */ 02784 02785 case TYCHAR: 02786 *(lv->ccp = (char *) ckalloc(1)) = rv->ci; 02787 lv->ccp1.blanks = 0; 02788 break; 02789 02790 case TYINT1: 02791 case TYSHORT: 02792 case TYLONG: 02793 #ifdef TYQUAD 02794 case TYQUAD: 02795 #endif 02796 if(rt == TYCHAR) 02797 lv->ci = rv->ccp[0]; 02798 else if( ISINT(rt) ) 02799 lv->ci = rv->ci; 02800 else lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0]; 02801 02802 break; 02803 02804 case TYCOMPLEX: 02805 case TYDCOMPLEX: 02806 lv->cd[1] = 0.; 02807 lv->cd[0] = rv->ci; 02808 break; 02809 02810 case TYREAL: 02811 case TYDREAL: 02812 lv->cd[0] = rv->ci; 02813 break; 02814 02815 case TYLOGICAL: 02816 case TYLOGICAL1: 02817 case TYLOGICAL2: 02818 lv->ci = rv->ci; 02819 break; 02820 } 02821 } |
|
Definition at line 2832 of file expr.c. References badtype(), intovfl(), ISCOMPLEX, L, and TYQUAD. Referenced by fold(), mkexpr(), and yyparse().
02834 { 02835 register char *s; 02836 ftnint L; 02837 02838 if (p->vstg) { 02839 if (ISCOMPLEX(p->vtype)) { 02840 s = p->Const.cds[1]; 02841 p->Const.cds[1] = *s == '-' ? s+1 02842 : *s == '0' ? s : s-1; 02843 } 02844 s = p->Const.cds[0]; 02845 p->Const.cds[0] = *s == '-' ? s+1 02846 : *s == '0' ? s : s-1; 02847 return; 02848 } 02849 switch(p->vtype) 02850 { 02851 case TYINT1: 02852 case TYSHORT: 02853 case TYLONG: 02854 #ifdef TYQUAD 02855 case TYQUAD: 02856 #endif 02857 p->Const.ci = -(L = p->Const.ci); 02858 if (L != -p->Const.ci) 02859 intovfl(); 02860 break; 02861 02862 case TYCOMPLEX: 02863 case TYDCOMPLEX: 02864 p->Const.cd[1] = - p->Const.cd[1]; 02865 /* fall through and do the real parts */ 02866 case TYREAL: 02867 case TYDREAL: 02868 p->Const.cd[0] = - p->Const.cd[0]; 02869 break; 02870 default: 02871 badtype("consnegop", p->vtype); 02872 } 02873 } |
|
Definition at line 2886 of file expr.c. References badtype(), Constant::cd, Constant::cds, Constant::ci, consbinop(), Constblock::Const, err, ISCOMPLEX, ISINT, OPSLASH, OPSTAR, TYQUAD, Constblock::vstg, and Constblock::vtype. Referenced by fold().
02888 { 02889 register union Constant *powp = &p->Const; 02890 register int type; 02891 struct Constblock x, x0; 02892 02893 if (n == 1) { 02894 memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const)); 02895 return; 02896 } 02897 02898 switch(type = ap->vtype) /* pow = 1 */ 02899 { 02900 case TYINT1: 02901 case TYSHORT: 02902 case TYLONG: 02903 #ifdef TYQUAD 02904 case TYQUAD: 02905 #endif 02906 powp->ci = 1; 02907 break; 02908 case TYCOMPLEX: 02909 case TYDCOMPLEX: 02910 powp->cd[1] = 0; 02911 case TYREAL: 02912 case TYDREAL: 02913 powp->cd[0] = 1; 02914 break; 02915 default: 02916 badtype("conspower", type); 02917 } 02918 02919 if(n == 0) 02920 return; 02921 switch(type) /* x0 = ap */ 02922 { 02923 case TYINT1: 02924 case TYSHORT: 02925 case TYLONG: 02926 #ifdef TYQUAD 02927 case TYQUAD: 02928 #endif 02929 x0.Const.ci = ap->Const.ci; 02930 break; 02931 case TYCOMPLEX: 02932 case TYDCOMPLEX: 02933 x0.Const.cd[1] = 02934 ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1]; 02935 case TYREAL: 02936 case TYDREAL: 02937 x0.Const.cd[0] = 02938 ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0]; 02939 break; 02940 } 02941 x0.vtype = type; 02942 x0.vstg = 0; 02943 if(n < 0) 02944 { 02945 n = -n; 02946 if( ISINT(type) ) 02947 { 02948 switch(ap->Const.ci) { 02949 case 0: 02950 err("0 ** negative number"); 02951 return; 02952 case 1: 02953 case -1: 02954 goto mult; 02955 } 02956 err("integer ** negative number"); 02957 return; 02958 } 02959 else if (!x0.Const.cd[0] 02960 && (!ISCOMPLEX(type) || !x0.Const.cd[1])) { 02961 err("0.0 ** negative number"); 02962 return; 02963 } 02964 consbinop(OPSLASH, type, &x, p, &x0); 02965 } 02966 else 02967 mult: consbinop(OPSTAR, type, &x, p, &x0); 02968 02969 for( ; ; ) 02970 { 02971 if(n & 01) 02972 consbinop(OPSTAR, type, p, p, &x); 02973 if(n >>= 1) 02974 consbinop(OPSTAR, type, &x, &x, &x); 02975 else 02976 break; 02977 } 02978 } |
|
Definition at line 3227 of file expr.c. References badtype(), Constant::cd, Constant::cds, Constant::ci, Constblock::Const, Expression::constblock, Fatal(), Expression::headblock, ISCONST, TYQUAD, Constblock::vstg, Constblock::vtype, and Headblock::vtype. Referenced by exdo().
03229 { 03230 register char *s; 03231 03232 if( ! ISCONST(p) ) 03233 Fatal( "sgn(nonconstant)" ); 03234 03235 switch(p->headblock.vtype) 03236 { 03237 case TYINT1: 03238 case TYSHORT: 03239 case TYLONG: 03240 #ifdef TYQUAD 03241 case TYQUAD: 03242 #endif 03243 if(p->constblock.Const.ci > 0) return(1); 03244 if(p->constblock.Const.ci < 0) return(-1); 03245 return(0); 03246 03247 case TYREAL: 03248 case TYDREAL: 03249 if (p->constblock.vstg) { 03250 s = p->constblock.Const.cds[0]; 03251 if (*s == '-') 03252 return -1; 03253 if (*s == '0') 03254 return 0; 03255 return 1; 03256 } 03257 if(p->constblock.Const.cd[0] > 0) return(1); 03258 if(p->constblock.Const.cd[0] < 0) return(-1); 03259 return(0); 03260 03261 03262 /* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */ 03263 03264 case TYCOMPLEX: 03265 case TYDCOMPLEX: 03266 if (p->constblock.vstg) 03267 return *p->constblock.Const.cds[0] != '0' 03268 && *p->constblock.Const.cds[1] != '0'; 03269 return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0); 03270 03271 default: 03272 badtype( "conssgn", p->constblock.vtype); 03273 } 03274 /* NOT REACHED */ return 0; 03275 } |
|
Definition at line 395 of file expr.c. References Expression::addrblock, Primblock::argsp, badtag(), CHNULL, Constant::ci, Constblock::Const, Expression::constblock, copyn(), cpblock(), Chain::datap, ep, Expression::exprblock, frexpr(), Addrblock::istemp, Exprblock::leftp, Expression::listblock, Listblock::listp, Addrblock::memoffset, mkchain(), Chain::nextp, NO, Expression::primblock, Exprblock::rightp, TADDR, Expression::tag, TCONST, TERROR, TEXPR, TLIST, TNAME, TPRIM, Addrblock::vleng, Constblock::vleng, and Constblock::vtype. Referenced by add_extern_to_list(), cast_args(), copy_data(), cplenexpr(), declare_new_addr(), dofclose(), dofinquire(), dofmove(), dofopen(), doiolist(), endio(), exarif(), exdo(), imagpart(), Inline(), intdouble(), iosetc(), iosetip(), iosetlc(), krput(), mkaddr(), mkfunct(), mklhs(), mkplace(), mkprim(), mktmp(), nextdata(), p1_const(), p1_subr_ret(), prolog(), putcall(), putcat(), putch1(), putconst(), putct1(), putcx1(), putiocall(), putmnmx(), putop(), putpower(), putsteq(), realpart(), retval(), setbound(), startrw(), stfcall(), subcheck(), suboffset(), subskept(), and yyparse().
00397 { 00398 register tagptr e; 00399 int tag; 00400 register chainp ep, pp; 00401 00402 /* This table depends on the ordering of the T macros, e.g. TNAME */ 00403 00404 static int blksize[ ] = 00405 { 00406 0, 00407 sizeof(struct Nameblock), 00408 sizeof(struct Constblock), 00409 sizeof(struct Exprblock), 00410 sizeof(struct Addrblock), 00411 sizeof(struct Primblock), 00412 sizeof(struct Listblock), 00413 sizeof(struct Impldoblock), 00414 sizeof(struct Errorblock) 00415 }; 00416 00417 if(p == NULL) 00418 return(NULL); 00419 00420 /* TNAMEs are special, and don't get copied. Each name in the current 00421 symbol table has a unique TNAME structure. */ 00422 00423 if( (tag = p->tag) == TNAME) 00424 return(p); 00425 00426 e = cpblock(blksize[p->tag], (char *)p); 00427 00428 switch(tag) 00429 { 00430 case TCONST: 00431 if(e->constblock.vtype == TYCHAR) 00432 { 00433 e->constblock.Const.ccp = 00434 copyn((int)e->constblock.vleng->constblock.Const.ci+1, 00435 e->constblock.Const.ccp); 00436 e->constblock.vleng = 00437 (expptr) cpexpr(e->constblock.vleng); 00438 } 00439 case TERROR: 00440 break; 00441 00442 case TEXPR: 00443 e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp); 00444 e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp); 00445 break; 00446 00447 case TLIST: 00448 if(pp = p->listblock.listp) 00449 { 00450 ep = e->listblock.listp = 00451 mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL); 00452 for(pp = pp->nextp ; pp ; pp = pp->nextp) 00453 ep = ep->nextp = 00454 mkchain((char *)cpexpr((tagptr)pp->datap), 00455 CHNULL); 00456 } 00457 break; 00458 00459 case TADDR: 00460 e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng); 00461 e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset); 00462 e->addrblock.istemp = NO; 00463 break; 00464 00465 case TPRIM: 00466 e->primblock.argsp = (struct Listblock *) 00467 cpexpr((expptr)e->primblock.argsp); 00468 e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp); 00469 e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp); 00470 break; 00471 00472 default: 00473 badtag("cpexpr", tag); 00474 } 00475 00476 return(e); 00477 } |
|
Definition at line 656 of file expr.c. References badchleng(), Constant::ccp1, Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), Expression::headblock, ICON, ISCONST, Headblock::vleng, and Constblock::vtype. Referenced by fixexpr().
00658 { 00659 expptr rv; 00660 00661 if (badchleng(p)) 00662 return ICON(1); 00663 rv = cpexpr(p->headblock.vleng); 00664 if (ISCONST(p) && p->constblock.vtype == TYCHAR) 00665 rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks; 00666 return rv; 00667 } |
|
Definition at line 1464 of file expr.c. Referenced by enddo().
01466 {
01467 if(nregvar>0 && regnamep[nregvar-1]==np)
01468 {
01469 --nregvar;
01470 }
01471 }
|
|
Definition at line 902 of file expr.c. References Primblock::argsp, CLPROC, Chain::datap, Primblock::fcharp, fixtype(), Primblock::lcharp, Listblock::listp, memversion(), mkaddr(), mkscalar(), Primblock::namep, Chain::nextp, Expression::primblock, PTHISPROC, putconst(), q, sserr(), Expression::tag, TCONST, TPRIM, Nameblock::vclass, Nameblock::vdim, Nameblock::vdovar, Nameblock::vprocclass, and Nameblock::vtype. Referenced by intrcall(), and mkfunct().
00905 { 00906 register chainp p; 00907 register tagptr q, t; 00908 register int qtag; 00909 int nargs; 00910 00911 nargs = 0; 00912 if(p0) 00913 for(p = p0->listp ; p ; p = p->nextp) 00914 { 00915 ++nargs; 00916 q = (tagptr)p->datap; 00917 qtag = q->tag; 00918 if(qtag == TCONST) 00919 { 00920 00921 /* Call putconst() to store values in a constant table. Since even 00922 constants must be passed by reference, this can optimize on the storage 00923 required */ 00924 00925 p->datap = doput ? (char *)putconst((Constp)q) 00926 : (char *)q; 00927 continue; 00928 } 00929 00930 /* Take a function name and turn it into an Addr. This only happens when 00931 nothing else has figured out the function beforehand */ 00932 00933 if (qtag == TPRIM && q->primblock.argsp == 0) { 00934 if (q->primblock.namep->vclass==CLPROC 00935 && q->primblock.namep->vprocclass != PTHISPROC) { 00936 p->datap = (char *)mkaddr(q->primblock.namep); 00937 continue; 00938 } 00939 00940 if (q->primblock.namep->vdim != NULL) { 00941 p->datap = (char *)mkscalar(q->primblock.namep); 00942 if ((q->primblock.fcharp||q->primblock.lcharp) 00943 && (q->primblock.namep->vtype != TYCHAR 00944 || q->primblock.namep->vdim)) 00945 sserr(q->primblock.namep); 00946 continue; 00947 } 00948 00949 if (q->primblock.namep->vdovar 00950 && (t = (tagptr) memversion(q->primblock.namep))) { 00951 p->datap = (char *)fixtype(t); 00952 continue; 00953 } 00954 } 00955 p->datap = (char *)fixtype(q); 00956 } 00957 return(nargs); 00958 } |
|
Definition at line 679 of file expr.c. References badtag(), call2(), charptr, cktype(), Expression::constblock, cplenexpr(), err, errnode, Expression::exprblock, Fatal(), fixtype(), free, frexpr(), Expression::headblock, ISCOMPLEX, ISCONST, ISERROR, ISLOGICAL, ISREAL, mkconv(), mkexpr(), mkpower(), MSKADDR, MSKINT, ONEOF, OPABS, OPADDR, OPASSIGN, Exprblock::opcode, OPCOLON, OPCOMMA, OPCONCAT, OPCONV, OPDABS, OPDMAX, OPDMIN, OPEQ, OPGE, OPGT, OPLE, OPLT, OPMAX, OPMAX2, OPMIN, OPMIN2, OPMINUS, OPMOD, OPNE, OPPLUS, OPPLUSEQ, OPPOWER, OPQUEST, OPSLASH, OPSTAR, OPSTAREQ, putconst(), q, Exprblock::rightp, TADDR, Expression::tag, TEXPR, TYERROR, Exprblock::typefixed, Headblock::vtype, and Constblock::vtype. Referenced by fixtype(), intrcall(), make_param(), mkpower(), putassign(), putcxcmp(), putiocall(), putmnmx(), and putsteq().
00681 { 00682 expptr lp; 00683 register expptr rp; 00684 register expptr q; 00685 char *hsave; 00686 int opcode, ltype, rtype, ptype, mtype; 00687 00688 if( ISERROR(p) || p->typefixed ) 00689 return( (expptr) p ); 00690 else if(p->tag != TEXPR) 00691 badtag("fixexpr", p->tag); 00692 opcode = p->opcode; 00693 00694 /* First set the types of the left and right subexpressions */ 00695 00696 lp = p->leftp; 00697 if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR) 00698 lp = p->leftp = fixtype(lp); 00699 ltype = lp->headblock.vtype; 00700 00701 if(opcode==OPASSIGN && lp->tag!=TADDR) 00702 { 00703 err("left side of assignment must be variable"); 00704 eret: 00705 frexpr((expptr)p); 00706 return( errnode() ); 00707 } 00708 00709 if(rp = p->rightp) 00710 { 00711 if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR) 00712 rp = p->rightp = fixtype(rp); 00713 rtype = rp->headblock.vtype; 00714 } 00715 else 00716 rtype = 0; 00717 00718 if(ltype==TYERROR || rtype==TYERROR) 00719 goto eret; 00720 00721 /* Now work on the whole expression */ 00722 00723 /* force folding if possible */ 00724 00725 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) ) 00726 { 00727 q = opcode == OPCONV && lp->constblock.vtype == p->vtype 00728 ? lp : mkexpr(opcode, lp, rp); 00729 00730 /* mkexpr is expected to reduce constant expressions */ 00731 00732 if( ISCONST(q) ) { 00733 p->leftp = p->rightp = 0; 00734 frexpr((expptr)p); 00735 return(q); 00736 } 00737 free( (charptr) q ); /* constants did not fold */ 00738 } 00739 00740 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) 00741 goto eret; 00742 00743 if (ltype == TYCHAR && ISCONST(lp)) { 00744 if (opcode == OPCONV) { 00745 hsave = halign; 00746 halign = 0; 00747 lp = (expptr)putconst((Constp)lp); 00748 halign = hsave; 00749 } 00750 else 00751 lp = (expptr)putconst((Constp)lp); 00752 p->leftp = lp; 00753 } 00754 if (rtype == TYCHAR && ISCONST(rp)) 00755 p->rightp = rp = (expptr)putconst((Constp)rp); 00756 00757 switch(opcode) 00758 { 00759 case OPCONCAT: 00760 if(p->vleng == NULL) 00761 p->vleng = mkexpr(OPPLUS, cplenexpr(lp), 00762 cplenexpr(rp) ); 00763 break; 00764 00765 case OPASSIGN: 00766 if (rtype == TYREAL || ISLOGICAL(ptype) 00767 || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp)) 00768 break; 00769 case OPPLUSEQ: 00770 case OPSTAREQ: 00771 if(ltype == rtype) 00772 break; 00773 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) ) 00774 break; 00775 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) 00776 break; 00777 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) 00778 && typesize[ltype]>=typesize[rtype] ) 00779 break; 00780 00781 /* Cast the right hand side to match the type of the expression */ 00782 00783 p->rightp = fixtype( mkconv(ptype, rp) ); 00784 break; 00785 00786 case OPSLASH: 00787 if( ISCOMPLEX(rtype) ) 00788 { 00789 p = (Exprp) call2(ptype, 00790 00791 /* Handle double precision complex variables */ 00792 00793 ptype == TYCOMPLEX ? "c_div" : "z_div", 00794 mkconv(ptype, lp), mkconv(ptype, rp) ); 00795 break; 00796 } 00797 case OPPLUS: 00798 case OPMINUS: 00799 case OPSTAR: 00800 case OPMOD: 00801 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) || 00802 (rtype==TYREAL && ! ISCONST(rp) ) )) 00803 break; 00804 if( ISCOMPLEX(ptype) ) 00805 break; 00806 00807 /* Cast both sides of the expression to match the type of the whole 00808 expression. */ 00809 00810 if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL)) 00811 p->leftp = fixtype(mkconv(ptype,lp)); 00812 if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL)) 00813 p->rightp = fixtype(mkconv(ptype,rp)); 00814 break; 00815 00816 case OPPOWER: 00817 rp = mkpower((expptr)p); 00818 if (rp->tag == TEXPR) 00819 rp->exprblock.typefixed = 1; 00820 return rp; 00821 00822 case OPLT: 00823 case OPLE: 00824 case OPGT: 00825 case OPGE: 00826 case OPEQ: 00827 case OPNE: 00828 if(ltype == rtype) 00829 break; 00830 if (htype) { 00831 if (ltype == TYCHAR) { 00832 p->leftp = fixtype(mkconv(rtype,lp)); 00833 break; 00834 } 00835 if (rtype == TYCHAR) { 00836 p->rightp = fixtype(mkconv(ltype,rp)); 00837 break; 00838 } 00839 } 00840 mtype = cktype(OPMINUS, ltype, rtype); 00841 if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL)) 00842 break; 00843 if( ISCOMPLEX(mtype) ) 00844 break; 00845 if(ltype != mtype) 00846 p->leftp = fixtype(mkconv(mtype,lp)); 00847 if(rtype != mtype) 00848 p->rightp = fixtype(mkconv(mtype,rp)); 00849 break; 00850 00851 case OPCONV: 00852 ptype = cktype(OPCONV, p->vtype, ltype); 00853 if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA 00854 && !ISCOMPLEX(ptype)) 00855 { 00856 lp->exprblock.rightp = 00857 fixtype( mkconv(ptype, lp->exprblock.rightp) ); 00858 free( (charptr) p ); 00859 p = (Exprp) lp; 00860 } 00861 break; 00862 00863 case OPADDR: 00864 if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR) 00865 Fatal("addr of addr"); 00866 break; 00867 00868 case OPCOMMA: 00869 case OPQUEST: 00870 case OPCOLON: 00871 break; 00872 00873 case OPMIN: 00874 case OPMAX: 00875 case OPMIN2: 00876 case OPMAX2: 00877 case OPDMIN: 00878 case OPDMAX: 00879 case OPABS: 00880 case OPDABS: 00881 ptype = p->vtype; 00882 break; 00883 00884 default: 00885 break; 00886 } 00887 00888 p->vtype = ptype; 00889 p->typefixed = 1; 00890 return((expptr) p); 00891 } |
|
Definition at line 570 of file expr.c. References Expression::addrblock, Primblock::argsp, badtag(), CLVAR, Expression::constblock, err, errnode, fixexpr(), Addrblock::memoffset, mkfunct(), mklhs(), MSKADDR, MSKINT, MSKLOGICAL, MSKREAL, Primblock::namep, ONEOF, Expression::primblock, putconst(), TADDR, Expression::tag, TCONST, TERROR, TEXPR, TLIST, TPRIM, Nameblock::vclass, Nameblock::vinftype, Nameblock::vtype, Constblock::vtype, and wronginf(). Referenced by dim_finish(), doiolist(), exar2(), exarif(), excall(), exdo(), exequals(), exreturn(), fixargs(), fixexpr(), ioclause(), iosetc(), make_param(), mklhs(), nextdata(), prolog(), putaddr(), putcall(), putexpr(), putif(), putio(), putwhile(), retval(), startrw(), stfcall(), suboffset(), subskept(), and yyparse().
00572 { 00573 00574 if(p == 0) 00575 return(0); 00576 00577 switch(p->tag) 00578 { 00579 case TCONST: 00580 if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR| 00581 MSKREAL) ) 00582 return( (expptr) p); 00583 00584 return( (expptr) putconst((Constp)p) ); 00585 00586 case TADDR: 00587 p->addrblock.memoffset = fixtype(p->addrblock.memoffset); 00588 return( (expptr) p); 00589 00590 case TERROR: 00591 return( (expptr) p); 00592 00593 default: 00594 badtag("fixtype", p->tag); 00595 00596 /* This case means that fixexpr can't call fixtype with any expr, 00597 only a subexpr of its parameter. */ 00598 00599 case TEXPR: 00600 if (((Exprp)p)->typefixed) 00601 return (expptr)p; 00602 return( fixexpr((Exprp)p) ); 00603 00604 case TLIST: 00605 return( (expptr) p ); 00606 00607 case TPRIM: 00608 if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR) 00609 { 00610 if(p->primblock.namep->vtype == TYSUBR) 00611 { 00612 err("function invocation of subroutine"); 00613 return( errnode() ); 00614 } 00615 else { 00616 if (p->primblock.namep->vinftype) 00617 wronginf(p->primblock.namep); 00618 return( mkfunct(p) ); 00619 } 00620 } 00621 00622 /* The lack of args makes p a function name, substring reference 00623 or variable name. */ 00624 00625 else return mklhs((struct Primblock *) p, keepsubs); 00626 } 00627 } |
|
Definition at line 2539 of file expr.c. References ALLOC, badop(), Constant::ccp1, Constant::cd, Constant::cds, Constant::ci, ckalloc(), cmpstr(), consbinop(), consconv(), consnegop(), conspower(), Constblock::Const, Expression::constblock, Expression::exprblock, free, frexpr(), Expression::headblock, i, ICON, intovfl(), ISINT, L, Exprblock::leftp, maxtype(), OPABS, OPADDR, OPAND, OPBITAND, OPBITCLR, OPBITNOT, OPBITOR, OPBITSET, OPBITTEST, OPBITXOR, Exprblock::opcode, OPCOLON, OPCOMMA, OPCOMMA_ARG, OPCONCAT, OPCONV, OPDABS, OPEQV, OPLSHIFT, OPNEG, OPNEG1, OPNEQV, OPNOT, OPOR, OPPOWER, OPQUEST, OPRSHIFT, OPSLASH, q, Exprblock::rightp, Constblock::tag, TCONST, TYQUAD, Exprblock::vleng, Constblock::vleng, Constblock::vstg, Constblock::vtype, Headblock::vtype, Exprblock::vtype, and zeroconst(). Referenced by coarsen(), eval_registration(), main(), mkexpr(), putop(), and THD_copy_file().
02541 { 02542 Constp p; 02543 register expptr lp, rp; 02544 int etype, mtype, ltype, rtype, opcode; 02545 int i, bl, ll, lr; 02546 char *q, *s; 02547 struct Constblock lcon, rcon; 02548 ftnint L; 02549 double d; 02550 02551 opcode = e->exprblock.opcode; 02552 etype = e->exprblock.vtype; 02553 02554 lp = e->exprblock.leftp; 02555 ltype = lp->headblock.vtype; 02556 rp = e->exprblock.rightp; 02557 02558 if(rp == 0) 02559 switch(opcode) 02560 { 02561 case OPNOT: 02562 lp->constblock.Const.ci = ! lp->constblock.Const.ci; 02563 retlp: 02564 e->exprblock.leftp = 0; 02565 frexpr(e); 02566 return(lp); 02567 02568 case OPBITNOT: 02569 lp->constblock.Const.ci = ~ lp->constblock.Const.ci; 02570 goto retlp; 02571 02572 case OPNEG: 02573 case OPNEG1: 02574 consnegop((Constp)lp); 02575 goto retlp; 02576 02577 case OPCONV: 02578 case OPADDR: 02579 return(e); 02580 02581 case OPABS: 02582 case OPDABS: 02583 switch(ltype) { 02584 case TYINT1: 02585 case TYSHORT: 02586 case TYLONG: 02587 #ifdef TYQUAD 02588 case TYQUAD: 02589 #endif 02590 if ((L = lp->constblock.Const.ci) < 0) { 02591 lp->constblock.Const.ci = -L; 02592 if (L != -lp->constblock.Const.ci) 02593 intovfl(); 02594 } 02595 goto retlp; 02596 case TYREAL: 02597 case TYDREAL: 02598 if (lp->constblock.vstg) { 02599 s = lp->constblock.Const.cds[0]; 02600 if (*s == '-') 02601 lp->constblock.Const.cds[0] = s + 1; 02602 goto retlp; 02603 } 02604 if ((d = lp->constblock.Const.cd[0]) < 0.) 02605 lp->constblock.Const.cd[0] = -d; 02606 case TYCOMPLEX: 02607 case TYDCOMPLEX: 02608 return e; /* lazy way out */ 02609 } 02610 default: 02611 badop("fold", opcode); 02612 } 02613 02614 rtype = rp->headblock.vtype; 02615 02616 p = ALLOC(Constblock); 02617 p->tag = TCONST; 02618 p->vtype = etype; 02619 p->vleng = e->exprblock.vleng; 02620 02621 switch(opcode) 02622 { 02623 case OPCOMMA: 02624 case OPCOMMA_ARG: 02625 case OPQUEST: 02626 case OPCOLON: 02627 goto ereturn; 02628 02629 case OPAND: 02630 p->Const.ci = lp->constblock.Const.ci && 02631 rp->constblock.Const.ci; 02632 break; 02633 02634 case OPOR: 02635 p->Const.ci = lp->constblock.Const.ci || 02636 rp->constblock.Const.ci; 02637 break; 02638 02639 case OPEQV: 02640 p->Const.ci = lp->constblock.Const.ci == 02641 rp->constblock.Const.ci; 02642 break; 02643 02644 case OPNEQV: 02645 p->Const.ci = lp->constblock.Const.ci != 02646 rp->constblock.Const.ci; 02647 break; 02648 02649 case OPBITAND: 02650 p->Const.ci = lp->constblock.Const.ci & 02651 rp->constblock.Const.ci; 02652 break; 02653 02654 case OPBITOR: 02655 p->Const.ci = lp->constblock.Const.ci | 02656 rp->constblock.Const.ci; 02657 break; 02658 02659 case OPBITXOR: 02660 p->Const.ci = lp->constblock.Const.ci ^ 02661 rp->constblock.Const.ci; 02662 break; 02663 02664 case OPLSHIFT: 02665 p->Const.ci = lp->constblock.Const.ci << 02666 rp->constblock.Const.ci; 02667 if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci) 02668 != lp->constblock.Const.ci) 02669 intovfl(); 02670 break; 02671 02672 case OPRSHIFT: 02673 p->Const.ci = (unsigned long)lp->constblock.Const.ci >> 02674 rp->constblock.Const.ci; 02675 break; 02676 02677 case OPBITTEST: 02678 p->Const.ci = (lp->constblock.Const.ci & 02679 1L << rp->constblock.Const.ci) != 0; 02680 break; 02681 02682 case OPBITCLR: 02683 p->Const.ci = lp->constblock.Const.ci & 02684 ~(1L << rp->constblock.Const.ci); 02685 break; 02686 02687 case OPBITSET: 02688 p->Const.ci = lp->constblock.Const.ci | 02689 1L << rp->constblock.Const.ci; 02690 break; 02691 02692 case OPCONCAT: 02693 ll = lp->constblock.vleng->constblock.Const.ci; 02694 lr = rp->constblock.vleng->constblock.Const.ci; 02695 bl = lp->constblock.Const.ccp1.blanks; 02696 p->Const.ccp = q = (char *) ckalloc(ll+lr+bl); 02697 p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks; 02698 p->vleng = ICON(ll+lr+bl); 02699 s = lp->constblock.Const.ccp; 02700 for(i = 0 ; i < ll ; ++i) 02701 *q++ = *s++; 02702 for(i = 0 ; i < bl ; i++) 02703 *q++ = ' '; 02704 s = rp->constblock.Const.ccp; 02705 for(i = 0; i < lr; ++i) 02706 *q++ = *s++; 02707 break; 02708 02709 02710 case OPPOWER: 02711 if( !ISINT(rtype) 02712 || rp->constblock.Const.ci < 0 && zeroconst(lp)) 02713 goto ereturn; 02714 conspower(p, (Constp)lp, rp->constblock.Const.ci); 02715 break; 02716 02717 case OPSLASH: 02718 if (zeroconst(rp)) 02719 goto ereturn; 02720 /* no break */ 02721 02722 default: 02723 if(ltype == TYCHAR) 02724 { 02725 lcon.Const.ci = cmpstr(lp->constblock.Const.ccp, 02726 rp->constblock.Const.ccp, 02727 lp->constblock.vleng->constblock.Const.ci, 02728 rp->constblock.vleng->constblock.Const.ci); 02729 rcon.Const.ci = 0; 02730 mtype = tyint; 02731 } 02732 else { 02733 mtype = maxtype(ltype, rtype); 02734 consconv(mtype, &lcon, &lp->constblock); 02735 consconv(mtype, &rcon, &rp->constblock); 02736 } 02737 consbinop(opcode, mtype, p, &lcon, &rcon); 02738 break; 02739 } 02740 02741 frexpr(e); 02742 return( (expptr) p ); 02743 ereturn: 02744 free((char *)p); 02745 return e; 02746 } |
|
Definition at line 486 of file expr.c. References Expression::addrblock, Primblock::argsp, badtag(), charptr, Constblock::Const, Expression::constblock, Chain::datap, Expression::exprblock, Primblock::fcharp, frchain(), free, ISCHAR, Primblock::lcharp, Exprblock::leftp, Expression::listblock, Listblock::listp, Addrblock::memoffset, Chain::nextp, Expression::primblock, q, Exprblock::rightp, TADDR, Expression::tag, TCONST, TERROR, TEXPR, TLIST, TNAME, TPRIM, TYERROR, Addrblock::vleng, Constblock::vleng, and Addrblock::vtype. Referenced by cpexpr(), dataval(), doequiv(), doiolist(), enddo(), endio(), endioctl(), exarif(), excall(), exdo(), exequals(), expr_out(), exstop(), fixexpr(), fold(), frdata(), freetemps(), frexchain(), hashclear(), inferdcl(), Inline(), ioset(), make_param(), mkconv(), mkcxcon(), mkexpr(), mkfunct(), mklhs(), mkpower(), mkprim(), mkscalar(), nextdata(), procinit(), putaddr(), putcall(), putch1(), putcheq(), putconst(), putct1(), putcx1(), putcxeq(), putmnmx(), putop(), putpower(), putx(), setbound(), settype(), startrw(), stfcall(), subcheck(), wr_globals(), and wr_nv_ident_help().
00488 { 00489 register chainp q; 00490 00491 if(p == NULL) 00492 return; 00493 00494 switch(p->tag) 00495 { 00496 case TCONST: 00497 if( ISCHAR(p) ) 00498 { 00499 free( (charptr) (p->constblock.Const.ccp) ); 00500 frexpr(p->constblock.vleng); 00501 } 00502 break; 00503 00504 case TADDR: 00505 if (p->addrblock.vtype > TYERROR) /* i/o block */ 00506 break; 00507 frexpr(p->addrblock.vleng); 00508 frexpr(p->addrblock.memoffset); 00509 break; 00510 00511 case TERROR: 00512 break; 00513 00514 /* TNAME blocks don't get free'd - probably because they're pointed to in 00515 the hash table. 14-Jun-88 -- mwm */ 00516 00517 case TNAME: 00518 return; 00519 00520 case TPRIM: 00521 frexpr((expptr)p->primblock.argsp); 00522 frexpr(p->primblock.fcharp); 00523 frexpr(p->primblock.lcharp); 00524 break; 00525 00526 case TEXPR: 00527 frexpr(p->exprblock.leftp); 00528 if(p->exprblock.rightp) 00529 frexpr(p->exprblock.rightp); 00530 break; 00531 00532 case TLIST: 00533 for(q = p->listblock.listp ; q ; q = q->nextp) 00534 frexpr((tagptr)q->datap); 00535 frchain( &(p->listblock.listp) ); 00536 break; 00537 00538 default: 00539 badtag("frexpr", p->tag); 00540 } 00541 00542 free( (charptr) p ); 00543 } |
|
Definition at line 1930 of file expr.c. References CLPROC, dclerr(), dflttype, letter, PINTRINSIC, and settype(). Referenced by doentry(), make_param(), mkfunct(), mkstfunct(), save_argtypes(), and vardcl().
01932 { 01933 register int k; 01934 int type; 01935 ftnint leng; 01936 01937 if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) ) 01938 return; 01939 if(p->vtype == TYUNKNOWN) 01940 { 01941 k = letter(p->fvarname[0]); 01942 type = impltype[ k ]; 01943 leng = implleng[ k ]; 01944 if(type == TYUNKNOWN) 01945 { 01946 if(p->vclass == CLPROC) 01947 return; 01948 dclerr("attempt to use undefined variable", p); 01949 type = dflttype[k]; 01950 leng = 0; 01951 } 01952 settype(p, type, leng); 01953 p->vimpltype = 1; 01954 } 01955 } |
|
Definition at line 1963 of file expr.c. References frexpr(), and letter. Referenced by mkaddr(), and typekludge().
|
|
Definition at line 1506 of file expr.c. References i. Referenced by memversion(), and mkplace().
|
|
Definition at line 2528 of file expr.c. References err. Referenced by consbinop(), consnegop(), and fold().
02529 { err("overflow simplifying integer constants."); } |
|
Definition at line 1484 of file expr.c. References inregister(), mkplace(), NO, and YES. Referenced by doiolist(), enddo(), and fixargs().
|
|
Definition at line 104 of file expr.c. References Constant::ci, Constblock::Const, l, mkconst(), and p. Referenced by startrw().
|
|
Definition at line 1677 of file expr.c. References addunder(), ALLOC, badstg(), Constant::ci, CLPROC, Constblock::Const, Expression::constblock, cpexpr(), errstr(), Extsym::exproto, Extsym::extstg, Extsym::extype, ICON, inferdcl(), intraddr(), Addrblock::isarray, ISICON, Addrblock::memno, Addrblock::memoffset, mkext(), Addrblock::name, PEXTERNAL, PTHISPROC, putconst(), STGARG, STGAUTO, STGBSS, STGCOMMON, STGEQUIV, STGEXT, STGINIT, STGINTR, STGLENG, STGSTFUNCT, STGUNKNOWN, TADDR, Addrblock::tag, UNAM_NAME, Addrblock::varleng, Addrblock::vclass, Addrblock::vleng, Addrblock::vstg, and Addrblock::vtype. Referenced by fixargs(), mkfunct(), mkplace(), mkscalar(), and nextdata().
01679 { 01680 Extsym *extp; 01681 register Addrp t; 01682 int k; 01683 01684 switch( p->vstg) 01685 { 01686 case STGAUTO: 01687 if(p->vclass == CLPROC && p->vprocclass == PTHISPROC) 01688 return (Addrp) cpexpr((expptr)xretslot[p->vtype]); 01689 goto other; 01690 01691 case STGUNKNOWN: 01692 if(p->vclass != CLPROC) 01693 break; /* Error */ 01694 extp = mkext(p->fvarname, addunder(p->cvarname)); 01695 extp->extstg = STGEXT; 01696 p->vstg = STGEXT; 01697 p->vardesc.varno = extp - extsymtab; 01698 p->vprocclass = PEXTERNAL; 01699 if ((extp->exproto || infertypes) 01700 && (p->vtype == TYUNKNOWN || p->vimpltype) 01701 && (k = extp->extype)) 01702 inferdcl(p, k); 01703 01704 01705 case STGCOMMON: 01706 case STGEXT: 01707 case STGBSS: 01708 case STGINIT: 01709 case STGEQUIV: 01710 case STGARG: 01711 case STGLENG: 01712 other: 01713 t = ALLOC(Addrblock); 01714 t->tag = TADDR; 01715 01716 t->vclass = p->vclass; 01717 t->vtype = p->vtype; 01718 t->vstg = p->vstg; 01719 t->memno = p->vardesc.varno; 01720 t->memoffset = ICON(p->voffset); 01721 if (p->vdim) 01722 t->isarray = 1; 01723 if(p->vleng) 01724 { 01725 t->vleng = (expptr) cpexpr(p->vleng); 01726 if( ISICON(t->vleng) ) 01727 t->varleng = t->vleng->constblock.Const.ci; 01728 } 01729 01730 /* Keep the original name around for the C code generation */ 01731 01732 t -> uname_tag = UNAM_NAME; 01733 t -> user.name = p; 01734 return(t); 01735 01736 case STGINTR: 01737 01738 return ( intraddr (p)); 01739 01740 case STGSTFUNCT: 01741 01742 errstr("invalid use of statement function %.64s.", p->fvarname); 01743 return putconst((Constp)ICON(0)); 01744 } 01745 badstg("mkaddr", p->vstg); 01746 /* NOT REACHED */ return 0; 01747 } |
|
Definition at line 1762 of file expr.c. References ALLOC, CLVAR, Addrblock::memno, STGARG, STGLENG, TADDR, Addrblock::tag, TYLENG, Addrblock::vclass, Addrblock::vstg, and Addrblock::vtype. Referenced by doentry().
01764 { 01765 register Addrp p; 01766 01767 p = ALLOC(Addrblock); 01768 p->tag = TADDR; 01769 p->vtype = type; 01770 p->vclass = CLVAR; 01771 01772 /* TYLENG is the type of the field holding the length of a character string */ 01773 01774 p->vstg = (type==TYLENG ? STGLENG : STGARG); 01775 p->memno = argno; 01776 return(p); 01777 } |
|
Definition at line 150 of file expr.c. References Constant::ci, Constblock::Const, err, hextoi, mkconst(), and p. Referenced by yyparse().
00152 { 00153 register Constp p; 00154 register long x, y, z; 00155 int len; 00156 char buff[100], *fmt, *s0 = s; 00157 static char *kind[3] = { "Binary", "Hex", "Octal" }; 00158 00159 p = mkconst(TYLONG); 00160 x = y = 0; 00161 while(--leng >= 0) 00162 if(*s != ' ') { 00163 z = x; 00164 x = (x << shift) | hextoi(*s++); 00165 y |= (((unsigned long)x) >> shift) - z; 00166 } 00167 /* Don't change the type to short for short constants, as 00168 * that is dangerous -- there is no syntax for long constants 00169 * with small values. 00170 */ 00171 p->Const.ci = x; 00172 if (y) { 00173 if (--shift == 3) 00174 shift = 1; 00175 if ((len = (int)leng) > 60) 00176 sprintf(buff, "%s constant '%.60s' truncated.", 00177 kind[shift], s0); 00178 else 00179 sprintf(buff, "%s constant '%.*s' truncated.", 00180 kind[shift], len, s0); 00181 err(buff); 00182 } 00183 return( (expptr) p ); 00184 } |
|
Definition at line 46 of file expr.c. References ALLOC, p, Constblock::tag, TCONST, and Constblock::vtype. Referenced by make_param(), mkaddcon(), mkbitcon(), mkconv(), mkcxcon(), mkintcon(), mklogcon(), mkrealcon(), and mkstrcon().
|
|
Definition at line 299 of file expr.c. References Expression::addrblock, badtype(), consconv(), Expression::constblock, frexpr(), Expression::headblock, ICON, ISCONST, ISINT, ISREAL, mkconst(), opconv(), q, TADDR, Expression::tag, TYERROR, UNAM_CONST, Addrblock::uname_tag, Addrblock::user, Constblock::vleng, Constblock::vstg, Headblock::vtype, and warn(). Referenced by cast_args(), exdo(), exreturn(), fixexpr(), Inline(), intrcall(), make_param(), mkpower(), prolog(), putcall(), putio(), putmnmx(), putop(), putx(), retval(), setbound(), stfcall(), and suboffset().
00301 { 00302 register expptr q; 00303 register int pt, charwarn = 1; 00304 00305 if (t >= 100) { 00306 t -= 100; 00307 charwarn = 0; 00308 } 00309 if(t==TYUNKNOWN || t==TYERROR) 00310 badtype("mkconv", t); 00311 pt = p->headblock.vtype; 00312 00313 /* Casting to the same type is a no-op */ 00314 00315 if(t == pt) 00316 return(p); 00317 00318 /* If we're casting a constant which is not in the literal table ... */ 00319 00320 else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR 00321 || p->tag == TADDR && p->addrblock.uname_tag == UNAM_CONST) 00322 { 00323 if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) { 00324 /* avoid trouble with -i2 */ 00325 p->headblock.vtype = t; 00326 return p; 00327 } 00328 q = (expptr) mkconst(t); 00329 consconv(t, &q->constblock, &p->constblock ); 00330 if (p->tag == TADDR) 00331 q->constblock.vstg = p->addrblock.user.kludge.vstg1; 00332 frexpr(p); 00333 } 00334 else { 00335 if (pt == TYCHAR && t != TYADDR && charwarn 00336 && (!halign || p->tag != TADDR 00337 || p->addrblock.uname_tag != UNAM_CONST)) 00338 warn( 00339 "ichar([first char. of] char. string) assumed for conversion to numeric"); 00340 q = opconv(p, t); 00341 } 00342 00343 if(t == TYCHAR) 00344 q->constblock.vleng = ICON(1); 00345 return(q); 00346 } |
|
Definition at line 226 of file expr.c. References Constant::cd, Constant::cds, Constant::ci, Constblock::Const, Expression::constblock, dtos(), err, errnode, frexpr(), Expression::headblock, ISCONST, ISINT, ISNUMERIC, mkconst(), p, string_num(), Constblock::vstg, and Headblock::vtype. Referenced by intrcall(), and yyparse().
00228 { 00229 int rtype, itype; 00230 register Constp p; 00231 00232 rtype = realp->headblock.vtype; 00233 itype = imagp->headblock.vtype; 00234 00235 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) ) 00236 { 00237 p = mkconst( (rtype==TYDREAL||itype==TYDREAL) 00238 ? TYDCOMPLEX : tycomplex); 00239 if (realp->constblock.vstg || imagp->constblock.vstg) { 00240 p->vstg = 1; 00241 p->Const.cds[0] = ISINT(rtype) 00242 ? string_num("", realp->constblock.Const.ci) 00243 : realp->constblock.vstg 00244 ? realp->constblock.Const.cds[0] 00245 : dtos(realp->constblock.Const.cd[0]); 00246 p->Const.cds[1] = ISINT(itype) 00247 ? string_num("", imagp->constblock.Const.ci) 00248 : imagp->constblock.vstg 00249 ? imagp->constblock.Const.cds[0] 00250 : dtos(imagp->constblock.Const.cd[0]); 00251 } 00252 else { 00253 p->Const.cd[0] = ISINT(rtype) 00254 ? realp->constblock.Const.ci 00255 : realp->constblock.Const.cd[0]; 00256 p->Const.cd[1] = ISINT(itype) 00257 ? imagp->constblock.Const.ci 00258 : imagp->constblock.Const.cd[0]; 00259 } 00260 } 00261 else 00262 { 00263 err("invalid complex constant"); 00264 p = (Constp)errnode(); 00265 } 00266 00267 frexpr(realp); 00268 frexpr(imagp); 00269 return( (expptr) p ); 00270 } |
|
Definition at line 2027 of file expr.c. References ALLOC, Primblock::argsp, badop(), charptr, Constant::ci, cktype(), COMMUTE, consnegop(), Constblock::Const, Expression::constblock, doing_vleng, ENULL, errnode, Expression::exprblock, fold(), free, frexpr(), Expression::headblock, ICON, ICONEQ, is_negatable(), ISCONST, ISICON, ISINT, ISPLUSOP, L, Exprblock::leftp, Expression::listblock, Listblock::listp, Primblock::namep, OPABS, OPADDR, OPAND, OPARROW, OPASSIGN, OPASSIGNI, OPBITAND, OPBITANDEQ, OPBITCLR, OPBITNOT, OPBITOR, OPBITOREQ, OPBITSET, OPBITTEST, OPBITXOR, OPBITXOREQ, OPCALL, OPCCALL, OPCHARCAST, Exprblock::opcode, OPCOLON, OPCOMMA, OPCOMMA_ARG, OPCONCAT, OPCONV, OPDABS, OPDMAX, OPDMIN, OPDOT, OPEQ, OPEQV, OPGE, OPGT, OPIDENTITY, OPLE, OPLSHIFT, OPLSHIFTEQ, OPLT, OPMAX, OPMAX2, OPMIN, OPMIN2, OPMINUS, OPMINUSEQ, OPMOD, OPMODEQ, OPNE, OPNEG, OPNEG1, OPNEQV, OPNOT, OPOR, OPPLUS, OPPLUSEQ, OPPOWER, OPQBITCLR, OPQBITSET, OPQUEST, OPRSHIFT, OPRSHIFTEQ, OPSLASH, OPSLASHEQ, OPSTAR, OPSTAREQ, OPWHATSIN, Primblock::parenused, Expression::primblock, Exprblock::rightp, Exprblock::tag, Expression::tag, TCONST, TEXPR, TPRIM, TYERROR, Exprblock::vtype, Headblock::vtype, warn(), and zeroconst(). Referenced by addrfix(), addrof(), callk(), endio(), exar2(), exarif(), exassign(), exdo(), fixexpr(), Inline(), intrcall(), ioset(), ioseta(), make_int_expr(), mkfunct(), mklhs(), mkpower(), mkscalar(), nextdata(), opconv(), opconv_fudge(), out_addr(), prolog(), putassign(), putcall(), putch1(), putchcmp(), putcheq(), putct1(), putcx1(), putcxcmp(), putcxeq(), puteq(), putio(), putiocall(), putmnmx(), putop(), putpower(), putsteq(), setbound(), stfcall(), subcheck(), suboffset(), subskept(), and yyparse().
02029 { 02030 register expptr e, e1; 02031 int etype; 02032 int ltype, rtype; 02033 int ltag, rtag; 02034 long L; 02035 static long divlineno; 02036 02037 ltype = lp->headblock.vtype; 02038 ltag = lp->tag; 02039 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 02040 { 02041 rtype = rp->headblock.vtype; 02042 rtag = rp->tag; 02043 } 02044 else rtype = 0; 02045 02046 etype = cktype(opcode, ltype, rtype); 02047 if(etype == TYERROR) 02048 goto error; 02049 02050 switch(opcode) 02051 { 02052 /* check for multiplication by 0 and 1 and addition to 0 */ 02053 02054 case OPSTAR: 02055 if( ISCONST(lp) ) 02056 COMMUTE 02057 02058 if( ISICON(rp) ) 02059 { 02060 if(rp->constblock.Const.ci == 0) 02061 goto retright; 02062 goto mulop; 02063 } 02064 break; 02065 02066 case OPSLASH: 02067 case OPMOD: 02068 if( zeroconst(rp) && lineno != divlineno ) { 02069 warn("attempted division by zero"); 02070 divlineno = lineno; 02071 } 02072 if(opcode == OPMOD) 02073 break; 02074 02075 /* Handle multiplying or dividing by 1, -1 */ 02076 02077 mulop: 02078 if( ISICON(rp) ) 02079 { 02080 if(rp->constblock.Const.ci == 1) 02081 goto retleft; 02082 02083 if(rp->constblock.Const.ci == -1) 02084 { 02085 frexpr(rp); 02086 return( mkexpr(OPNEG, lp, ENULL) ); 02087 } 02088 } 02089 02090 /* Group all constants together. In particular, 02091 02092 (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2) 02093 (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2) 02094 */ 02095 02096 if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp 02097 || !ISICON(lp->exprblock.rightp)) 02098 break; 02099 02100 if (lp->exprblock.opcode == OPLSHIFT) { 02101 L = 1 << lp->exprblock.rightp->constblock.Const.ci; 02102 if (opcode == OPSTAR || ISICON(rp) && 02103 !(L % rp->constblock.Const.ci)) { 02104 lp->exprblock.opcode = OPSTAR; 02105 lp->exprblock.rightp->constblock.Const.ci = L; 02106 } 02107 } 02108 02109 if (lp->exprblock.opcode == OPSTAR) { 02110 if(opcode == OPSTAR) 02111 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp); 02112 else if(ISICON(rp) && 02113 (lp->exprblock.rightp->constblock.Const.ci % 02114 rp->constblock.Const.ci) == 0) 02115 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp); 02116 else break; 02117 02118 e1 = lp->exprblock.leftp; 02119 free( (charptr) lp ); 02120 return( mkexpr(OPSTAR, e1, e) ); 02121 } 02122 break; 02123 02124 02125 case OPPLUS: 02126 if( ISCONST(lp) ) 02127 COMMUTE 02128 goto addop; 02129 02130 case OPMINUS: 02131 if( ICONEQ(lp, 0) ) 02132 { 02133 frexpr(lp); 02134 return( mkexpr(OPNEG, rp, ENULL) ); 02135 } 02136 02137 if( ISCONST(rp) && is_negatable((Constp)rp)) 02138 { 02139 opcode = OPPLUS; 02140 consnegop((Constp)rp); 02141 } 02142 02143 /* Group constants in an addition expression (also subtraction, since the 02144 subtracted value was negated above). In particular, 02145 02146 (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2) 02147 */ 02148 02149 addop: 02150 if( ISICON(rp) ) 02151 { 02152 if(rp->constblock.Const.ci == 0) 02153 goto retleft; 02154 if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) ) 02155 { 02156 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp); 02157 e1 = lp->exprblock.leftp; 02158 free( (charptr) lp ); 02159 return( mkexpr(OPPLUS, e1, e) ); 02160 } 02161 } 02162 if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) { 02163 /* check for (i [+const]) - (i [+const]) */ 02164 if (lp->tag == TPRIM) 02165 e = lp; 02166 else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS 02167 && lp->exprblock.rightp->tag == TCONST) { 02168 e = lp->exprblock.leftp; 02169 if (e->tag != TPRIM) 02170 break; 02171 } 02172 else 02173 break; 02174 if (e->primblock.argsp) 02175 break; 02176 if (rp->tag == TPRIM) 02177 e1 = rp; 02178 else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS 02179 && rp->exprblock.rightp->tag == TCONST) { 02180 e1 = rp->exprblock.leftp; 02181 if (e1->tag != TPRIM) 02182 break; 02183 } 02184 else 02185 break; 02186 if (e->primblock.namep != e1->primblock.namep 02187 || e1->primblock.argsp) 02188 break; 02189 L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci; 02190 if (e1 != rp) 02191 L -= rp->exprblock.rightp->constblock.Const.ci; 02192 frexpr(lp); 02193 frexpr(rp); 02194 return ICON(L); 02195 } 02196 02197 break; 02198 02199 02200 case OPPOWER: 02201 break; 02202 02203 /* Eliminate outermost double negations */ 02204 02205 case OPNEG: 02206 case OPNEG1: 02207 if(ltag==TEXPR && lp->exprblock.opcode==OPNEG) 02208 { 02209 e = lp->exprblock.leftp; 02210 free( (charptr) lp ); 02211 return(e); 02212 } 02213 break; 02214 02215 /* Eliminate outermost double NOTs */ 02216 02217 case OPNOT: 02218 if(ltag==TEXPR && lp->exprblock.opcode==OPNOT) 02219 { 02220 e = lp->exprblock.leftp; 02221 free( (charptr) lp ); 02222 return(e); 02223 } 02224 break; 02225 02226 case OPCALL: 02227 case OPCCALL: 02228 etype = ltype; 02229 if(rp!=NULL && rp->listblock.listp==NULL) 02230 { 02231 free( (charptr) rp ); 02232 rp = NULL; 02233 } 02234 break; 02235 02236 case OPAND: 02237 case OPOR: 02238 if( ISCONST(lp) ) 02239 COMMUTE 02240 02241 if( ISCONST(rp) ) 02242 { 02243 if(rp->constblock.Const.ci == 0) 02244 if(opcode == OPOR) 02245 goto retleft; 02246 else 02247 goto retright; 02248 else if(opcode == OPOR) 02249 goto retright; 02250 else 02251 goto retleft; 02252 } 02253 case OPEQV: 02254 case OPNEQV: 02255 02256 case OPBITAND: 02257 case OPBITOR: 02258 case OPBITXOR: 02259 case OPBITNOT: 02260 case OPLSHIFT: 02261 case OPRSHIFT: 02262 case OPBITTEST: 02263 case OPBITCLR: 02264 case OPBITSET: 02265 #ifdef TYQUAD 02266 case OPQBITCLR: 02267 case OPQBITSET: 02268 #endif 02269 02270 case OPLT: 02271 case OPGT: 02272 case OPLE: 02273 case OPGE: 02274 case OPEQ: 02275 case OPNE: 02276 02277 case OPCONCAT: 02278 break; 02279 case OPMIN: 02280 case OPMAX: 02281 case OPMIN2: 02282 case OPMAX2: 02283 case OPDMIN: 02284 case OPDMAX: 02285 02286 case OPASSIGN: 02287 case OPASSIGNI: 02288 case OPPLUSEQ: 02289 case OPSTAREQ: 02290 case OPMINUSEQ: 02291 case OPSLASHEQ: 02292 case OPMODEQ: 02293 case OPLSHIFTEQ: 02294 case OPRSHIFTEQ: 02295 case OPBITANDEQ: 02296 case OPBITXOREQ: 02297 case OPBITOREQ: 02298 02299 case OPCONV: 02300 case OPADDR: 02301 case OPWHATSIN: 02302 02303 case OPCOMMA: 02304 case OPCOMMA_ARG: 02305 case OPQUEST: 02306 case OPCOLON: 02307 case OPDOT: 02308 case OPARROW: 02309 case OPIDENTITY: 02310 case OPCHARCAST: 02311 case OPABS: 02312 case OPDABS: 02313 break; 02314 02315 default: 02316 badop("mkexpr", opcode); 02317 } 02318 02319 e = (expptr) ALLOC(Exprblock); 02320 e->exprblock.tag = TEXPR; 02321 e->exprblock.opcode = opcode; 02322 e->exprblock.vtype = etype; 02323 e->exprblock.leftp = lp; 02324 e->exprblock.rightp = rp; 02325 if(ltag==TCONST && (rp==0 || rtag==TCONST) ) 02326 e = fold(e); 02327 return(e); 02328 02329 retleft: 02330 frexpr(rp); 02331 if (lp->tag == TPRIM) 02332 lp->primblock.parenused = 1; 02333 return(lp); 02334 02335 retright: 02336 frexpr(lp); 02337 if (rp->tag == TPRIM) 02338 rp->primblock.parenused = 1; 02339 return(rp); 02340 02341 error: 02342 frexpr(lp); 02343 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 02344 frexpr(rp); 02345 return( errnode() ); 02346 } |
|
Definition at line 1024 of file expr.c. References addunder(), adjust_arginfo(), Primblock::argsp, builtin(), Extsym::cextname, charptr, CLPROC, CLUNKNOWN, cpexpr(), Nameblock::cvarname, dclerr(), dflttype, Entrypoint::enamep, Entrypoint::entnextp, Entrypoint::entryname, err, errnode, errstr(), Expression::exprblock, Extsym::extstg, Fatal(), fatali(), fatalstr(), Primblock::fcharp, fixargs(), free, frexpr(), Nameblock::fvarname, impldcl(), intrcall(), intrfunct(), Primblock::lcharp, letter, mkaddr(), mkchain(), mkexpr(), mkext(), Primblock::namep, new_procs, OPCALL, PEXTERNAL, PINTRINSIC, PSTFUNCT, PTHISPROC, q, stfcall(), STGARG, STGCOMMON, STGEXT, STGINTR, STGUNKNOWN, Primblock::tag, TPRIM, Nameblock::vardesc, Nameblock::vcalled, Nameblock::vclass, Nameblock::vimpltype, Exprblock::vleng, Nameblock::vleng, Nameblock::vpassed, Nameblock::vprocclass, Nameblock::vstg, Exprblock::vtype, Nameblock::vtype, and warn(). Referenced by excall(), and fixtype().
01026 { 01027 register struct Primblock *p = (struct Primblock *)p0; 01028 struct Entrypoint *ep; 01029 Addrp ap; 01030 Extsym *extp; 01031 register Namep np; 01032 register expptr q; 01033 extern chainp new_procs; 01034 int k, nargs; 01035 int classKRH; 01036 01037 if(p->tag != TPRIM) 01038 return( errnode() ); 01039 01040 np = p->namep; 01041 classKRH = np->vclass; 01042 01043 01044 if(classKRH == CLUNKNOWN) 01045 { 01046 np->vclass = classKRH = CLPROC; 01047 if(np->vstg == STGUNKNOWN) 01048 { 01049 if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname)) 01050 && (zflag || !(*(struct Intrpacked *)&k).f4 01051 || dcomplex_seen)) 01052 { 01053 np->vstg = STGINTR; 01054 np->vardesc.varno = k; 01055 np->vprocclass = PINTRINSIC; 01056 } 01057 else 01058 { 01059 extp = mkext(np->fvarname, 01060 addunder(np->cvarname)); 01061 extp->extstg = STGEXT; 01062 np->vstg = STGEXT; 01063 np->vardesc.varno = extp - extsymtab; 01064 np->vprocclass = PEXTERNAL; 01065 } 01066 } 01067 else if(np->vstg==STGARG) 01068 { 01069 if(np->vtype == TYCHAR) { 01070 adjust_arginfo(np); 01071 if (np->vpassed) { 01072 char wbuf[160], *who; 01073 who = np->fvarname; 01074 sprintf(wbuf, "%s%s%s\n\t%s%s%s", 01075 "Character-valued dummy procedure ", 01076 who, " not declared EXTERNAL.", 01077 "Code may be wrong for previous function calls having ", 01078 who, " as a parameter."); 01079 warn(wbuf); 01080 } 01081 } 01082 np->vprocclass = PEXTERNAL; 01083 } 01084 } 01085 01086 if(classKRH != CLPROC) { 01087 if (np->vstg == STGCOMMON) 01088 fatalstr( 01089 "Cannot invoke common variable %.50s as a function.", 01090 np->fvarname); 01091 errstr("%.80s cannot be called.", np->fvarname); 01092 goto error; 01093 } 01094 01095 /* F77 doesn't allow subscripting of function calls */ 01096 01097 if(p->fcharp || p->lcharp) 01098 { 01099 err("no substring of function call"); 01100 goto error; 01101 } 01102 impldcl(np); 01103 np->vimpltype = 0; /* invoking as function ==> inferred type */ 01104 np->vcalled = 1; 01105 nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp); 01106 01107 switch(np->vprocclass) 01108 { 01109 case PEXTERNAL: 01110 if(np->vtype == TYUNKNOWN) 01111 { 01112 dclerr("attempt to use untyped function", np); 01113 np->vtype = dflttype[letter(np->fvarname[0])]; 01114 } 01115 ap = mkaddr(np); 01116 if (!extsymtab[np->vardesc.varno].extseen) { 01117 new_procs = mkchain((char *)np, new_procs); 01118 extsymtab[np->vardesc.varno].extseen = 1; 01119 } 01120 call: 01121 q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp); 01122 q->exprblock.vtype = np->vtype; 01123 if(np->vleng) 01124 q->exprblock.vleng = (expptr) cpexpr(np->vleng); 01125 break; 01126 01127 case PINTRINSIC: 01128 q = intrcall(np, p->argsp, nargs); 01129 break; 01130 01131 case PSTFUNCT: 01132 q = stfcall(np, p->argsp); 01133 break; 01134 01135 case PTHISPROC: 01136 warn("recursive call"); 01137 01138 /* entries is the list of multiple entry points */ 01139 01140 for(ep = entries ; ep ; ep = ep->entnextp) 01141 if(ep->enamep == np) 01142 break; 01143 if(ep == NULL) 01144 Fatal("mkfunct: impossible recursion"); 01145 01146 ap = builtin(np->vtype, ep->entryname->cextname, -2); 01147 /* the negative last arg prevents adding */ 01148 /* this name to the list of used builtins */ 01149 goto call; 01150 01151 default: 01152 fatali("mkfunct: impossible vprocclass %d", 01153 (int) (np->vprocclass) ); 01154 } 01155 free( (charptr) p ); 01156 return(q); 01157 01158 error: 01159 frexpr((expptr)p); 01160 return( errnode() ); 01161 } |
|
Definition at line 84 of file expr.c. References Constant::ci, Constblock::Const, l, mkconst(), and p. Referenced by exassign(), intrcall(), nextdata(), out_addr(), putcx1(), and yyparse().
|
|
Definition at line 1390 of file expr.c. References Primblock::argsp, charptr, Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), doing_vleng, Primblock::fcharp, fixtype(), free, frexpr(), ICON, ISCONST, Primblock::lcharp, Addrblock::memoffset, mkexpr(), mkplace(), Primblock::namep, Dimblock::ndim, OPMINUS, OPPLUS, Primblock::parenused, Addrblock::parenused, replaced, sserr(), STGREG, suboffset(), subskept(), TADDR, Addrblock::tag, Primblock::tag, TPRIM, Nameblock::vdim, Addrblock::vleng, Nameblock::vleng, Addrblock::vstg, and Nameblock::vtype. Referenced by exequals(), fixtype(), and nextdata().
01392 { 01393 register Addrp s; 01394 Namep np; 01395 01396 if(p->tag != TPRIM) 01397 return( (expptr) p ); 01398 np = p->namep; 01399 01400 replaced = 0; 01401 s = mkplace(np); 01402 if(s->tag!=TADDR || s->vstg==STGREG) 01403 { 01404 free( (charptr) p ); 01405 return( (expptr) s ); 01406 } 01407 s->parenused = p->parenused; 01408 01409 /* compute the address modified by subscripts */ 01410 01411 if (!replaced) 01412 s->memoffset = (subkeep && np->vdim 01413 && (np->vdim->ndim > 1 || np->vtype == TYCHAR 01414 && (!ISCONST(np->vleng) 01415 || np->vleng->constblock.Const.ci != 1))) 01416 ? subskept(p,s) 01417 : mkexpr(OPPLUS, s->memoffset, suboffset(p) ); 01418 frexpr((expptr)p->argsp); 01419 p->argsp = NULL; 01420 01421 /* now do substring part */ 01422 01423 if(p->fcharp || p->lcharp) 01424 { 01425 if(np->vtype != TYCHAR) 01426 sserr(np); 01427 else { 01428 if(p->lcharp == NULL) 01429 p->lcharp = (expptr)( 01430 /* s->vleng == 0 only with errors */ 01431 s->vleng ? cpexpr(s->vleng) : ICON(1)); 01432 if(p->fcharp) { 01433 doing_vleng = 1; 01434 s->vleng = fixtype(mkexpr(OPMINUS, 01435 p->lcharp, 01436 mkexpr(OPMINUS, p->fcharp, ICON(1) ))); 01437 doing_vleng = 0; 01438 } 01439 else { 01440 frexpr(s->vleng); 01441 s->vleng = p->lcharp; 01442 } 01443 } 01444 } 01445 01446 s->vleng = fixtype( s->vleng ); 01447 s->memoffset = fixtype( s->memoffset ); 01448 free( (charptr) p ); 01449 return( (expptr) s ); 01450 } |
|
Definition at line 65 of file expr.c. References Constant::ci, Constblock::Const, l, mkconst(), and p. Referenced by yyparse().
|
|
Definition at line 1302 of file expr.c. References ALLOC, CLPROC, cpexpr(), errnode, errstr(), ICON, inregister(), Addrblock::memno, Addrblock::memoffset, mkaddr(), Addrblock::name, PTHISPROC, replaced, Rplblock::rplnextp, Rplblock::rplnp, Rplblock::rpltag, Rplblock::rplvp, STGREG, TADDR, Addrblock::tag, TNAME, TYERROR, TYIREG, UNAM_NAME, vardcl(), Addrblock::vstg, and Addrblock::vtype. Referenced by enddo(), exasgoto(), exassign(), exdo(), memversion(), and mklhs().
01304 { 01305 register Addrp s; 01306 register struct Rplblock *rp; 01307 int regn; 01308 01309 /* is name on the replace list? */ 01310 01311 for(rp = rpllist ; rp ; rp = rp->rplnextp) 01312 { 01313 if(np == rp->rplnp) 01314 { 01315 replaced = 1; 01316 if(rp->rpltag == TNAME) 01317 { 01318 np = (Namep) (rp->rplvp); 01319 break; 01320 } 01321 else return( (Addrp) cpexpr(rp->rplvp) ); 01322 } 01323 } 01324 01325 /* is variable a DO index in a register ? */ 01326 01327 if(np->vdovar && ( (regn = inregister(np)) >= 0) ) 01328 if(np->vtype == TYERROR) 01329 return((Addrp) errnode() ); 01330 else 01331 { 01332 s = ALLOC(Addrblock); 01333 s->tag = TADDR; 01334 s->vstg = STGREG; 01335 s->vtype = TYIREG; 01336 s->memno = regn; 01337 s->memoffset = ICON(0); 01338 s -> uname_tag = UNAM_NAME; 01339 s -> user.name = np; 01340 return(s); 01341 } 01342 01343 if (np->vclass == CLPROC && np->vprocclass != PTHISPROC) 01344 errstr("external %.60s used as a variable", np->fvarname); 01345 vardcl(np); 01346 return(mkaddr(np)); 01347 } |
|
Definition at line 3289 of file expr.c. References Expression::addrblock, call2(), callk_kludge, charptr, Constant::ci, Constblock::Const, Expression::constblock, err, errnode, Expression::exprblock, fixexpr(), free, frexpr(), Expression::headblock, ICON, ISCONST, ISICON, ISINT, ISREAL, Exprblock::leftp, M, maxtype(), mkconv(), mkexpr(), MSKINT, MSKREAL, ONEOF, OPSLASH, Addrblock::parenused, powint, putconst(), q, Exprblock::rightp, TADDR, Expression::tag, TYQUAD, Exprblock::vtype, and Headblock::vtype. Referenced by fixexpr().
03291 { 03292 register expptr q, lp, rp; 03293 int ltype, rtype, mtype, tyi; 03294 03295 lp = p->exprblock.leftp; 03296 rp = p->exprblock.rightp; 03297 ltype = lp->headblock.vtype; 03298 rtype = rp->headblock.vtype; 03299 03300 if (lp->tag == TADDR) 03301 lp->addrblock.parenused = 0; 03302 03303 if (rp->tag == TADDR) 03304 rp->addrblock.parenused = 0; 03305 03306 if(ISICON(rp)) 03307 { 03308 if(rp->constblock.Const.ci == 0) 03309 { 03310 frexpr(p); 03311 if( ISINT(ltype) ) 03312 return( ICON(1) ); 03313 else if (ISREAL (ltype)) 03314 return mkconv (ltype, ICON (1)); 03315 else 03316 return( (expptr) putconst((Constp) 03317 mkconv(ltype, ICON(1))) ); 03318 } 03319 if(rp->constblock.Const.ci < 0) 03320 { 03321 if( ISINT(ltype) ) 03322 { 03323 frexpr(p); 03324 err("integer**negative"); 03325 return( errnode() ); 03326 } 03327 rp->constblock.Const.ci = - rp->constblock.Const.ci; 03328 p->exprblock.leftp = lp 03329 = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp)); 03330 } 03331 if(rp->constblock.Const.ci == 1) 03332 { 03333 frexpr(rp); 03334 free( (charptr) p ); 03335 return(lp); 03336 } 03337 03338 if( ONEOF(ltype, MSKINT|MSKREAL) ) { 03339 p->exprblock.vtype = ltype; 03340 return(p); 03341 } 03342 } 03343 if( ISINT(rtype) ) 03344 { 03345 if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) ) 03346 q = call2(TYSHORT, "pow_hh", lp, rp); 03347 else { 03348 if(ONEOF(ltype,M(TYINT1)|M(TYSHORT))) 03349 { 03350 ltype = TYLONG; 03351 lp = mkconv(TYLONG,lp); 03352 } 03353 #ifdef TYQUAD 03354 if (ltype == TYQUAD) 03355 rp = mkconv(TYQUAD,rp); 03356 else 03357 #endif 03358 rp = mkconv(TYLONG,rp); 03359 if (ISCONST(rp)) { 03360 tyi = tyint; 03361 tyint = TYLONG; 03362 rp = (expptr)putconst((Constp)rp); 03363 tyint = tyi; 03364 } 03365 q = call2(ltype, powint[ltype-TYLONG], lp, rp); 03366 } 03367 } 03368 else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) { 03369 extern int callk_kludge; 03370 callk_kludge = TYDREAL; 03371 q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp)); 03372 callk_kludge = 0; 03373 } 03374 else { 03375 q = call2(TYDCOMPLEX, "pow_zz", 03376 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp)); 03377 if(mtype == TYCOMPLEX) 03378 q = mkconv(TYCOMPLEX, q); 03379 } 03380 free( (charptr) p ); 03381 return(q); 03382 } |
|
Definition at line 1795 of file expr.c. References ALLOC, Primblock::argsp, CLPARAM, cpexpr(), errnode, errstr(), Primblock::fcharp, frchain(), frexpr(), Primblock::lcharp, Primblock::namep, Primblock::tag, TPRIM, v, and Primblock::vtype. Referenced by excall(), and yyparse().
01797 { 01798 typedef union { 01799 struct Paramblock paramblock; 01800 struct Nameblock nameblock; 01801 struct Headblock headblock; 01802 } *Primu; 01803 register Primu v = (Primu)v0; 01804 register struct Primblock *p; 01805 01806 if(v->headblock.vclass == CLPARAM) 01807 { 01808 01809 /* v is to be a Paramblock */ 01810 01811 if(args || substr) 01812 { 01813 errstr("no qualifiers on parameter name %s", 01814 v->paramblock.fvarname); 01815 frexpr((expptr)args); 01816 if(substr) 01817 { 01818 frexpr((tagptr)substr->datap); 01819 frexpr((tagptr)substr->nextp->datap); 01820 frchain(&substr); 01821 } 01822 frexpr((expptr)v); 01823 return( errnode() ); 01824 } 01825 return( (expptr) cpexpr(v->paramblock.paramval) ); 01826 } 01827 01828 p = ALLOC(Primblock); 01829 p->tag = TPRIM; 01830 p->vtype = v->nameblock.vtype; 01831 01832 /* v is to be a Nameblock */ 01833 01834 p->namep = (Namep) v; 01835 p->argsp = args; 01836 if(substr) 01837 { 01838 p->fcharp = (expptr) substr->datap; 01839 p->lcharp = (expptr) substr->nextp->datap; 01840 frchain(&substr); 01841 } 01842 return( (expptr) p); 01843 } |
|
Definition at line 125 of file expr.c. References cds(), Constant::cds, CNULL, Constblock::Const, mkconst(), p, and Constblock::vstg. Referenced by imagpart(), intrcall(), putcx1(), realpart(), and yyparse().
|
|
Definition at line 970 of file expr.c. References Dimblock::baseoffset, frexpr(), ICON, Addrblock::memoffset, mkaddr(), mkexpr(), OPSTAR, STGARG, and vardcl(). Referenced by doiolist(), fixargs(), and startrw().
00972 { 00973 register Addrp ap; 00974 00975 vardcl(np); 00976 ap = mkaddr(np); 00977 00978 /* The prolog causes array arguments to point to the 00979 * (0,...,0) element, unless subscript checking is on. 00980 */ 00981 if( !checksubs && np->vstg==STGARG) 00982 { 00983 register struct Dimblock *dp; 00984 dp = np->vdim; 00985 frexpr(ap->memoffset); 00986 ap->memoffset = mkexpr(OPSTAR, 00987 (np->vtype==TYCHAR ? 00988 cpexpr(np->vleng) : 00989 (tagptr)ICON(typesize[np->vtype]) ), 00990 cpexpr(dp->baseoffset) ); 00991 } 00992 return(ap); 00993 } |
|
Definition at line 199 of file expr.c. References Constant::ccp1, ckalloc(), Constblock::Const, ICON, l, mkconst(), p, v, and Constblock::vleng. Referenced by exstop(), subcheck(), and yyparse().
|
|
Definition at line 359 of file expr.c. References ENULL, err, Expression::headblock, mkexpr(), OPCONV, q, and Headblock::vtype. Referenced by mkconv().
|
|
Definition at line 3430 of file expr.c. References errstr(). Referenced by fixargs(), mklhs(), and yyparse().
|
|
Definition at line 1171 of file expr.c. References ALLOC, charptr, Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), Chain::datap, dclerr(), dflttype, err, errstr(), Expression::exprblock, fixtype(), frchain(), free, frexpr(), Expression::headblock, ICON, letter, Listblock::listp, mkconv(), mkexpr(), mktmp(), Chain::nextp, OPASSIGN, OPCOMMA, putexpr(), q, Rplblock::rplnextp, Rplblock::rplnp, Rplblock::rpltag, Rplblock::rplvp, Rplblock::rplxp, TADDR, Expression::tag, TCONST, TERROR, Exprblock::vleng, Nameblock::vleng, Headblock::vtype, and Nameblock::vtype. Referenced by mkfunct().
01173 { 01174 register chainp actuals; 01175 int nargs; 01176 chainp oactp, formals; 01177 int type; 01178 expptr Ln, Lq, q, q1, rhs, ap; 01179 Namep tnp; 01180 register struct Rplblock *rp; 01181 struct Rplblock *tlist; 01182 01183 if (np->arginfo) { 01184 errstr("statement function %.66s calls itself.", 01185 np->fvarname); 01186 return ICON(0); 01187 } 01188 np->arginfo = (Argtypes *)np; /* arbitrary nonzero value */ 01189 if(actlist) 01190 { 01191 actuals = actlist->listp; 01192 free( (charptr) actlist); 01193 } 01194 else 01195 actuals = NULL; 01196 oactp = actuals; 01197 01198 nargs = 0; 01199 tlist = NULL; 01200 if( (type = np->vtype) == TYUNKNOWN) 01201 { 01202 dclerr("attempt to use untyped statement function", np); 01203 type = np->vtype = dflttype[letter(np->fvarname[0])]; 01204 } 01205 formals = (chainp) np->varxptr.vstfdesc->datap; 01206 rhs = (expptr) (np->varxptr.vstfdesc->nextp); 01207 01208 /* copy actual arguments into temporaries */ 01209 while(actuals!=NULL && formals!=NULL) 01210 { 01211 if (!(tnp = (Namep) formals->datap)) { 01212 /* buggy statement function declaration */ 01213 q = ICON(1); 01214 goto done; 01215 } 01216 rp = ALLOC(Rplblock); 01217 rp->rplnp = tnp; 01218 ap = fixtype((tagptr)actuals->datap); 01219 if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR 01220 && (ap->tag==TCONST || ap->tag==TADDR) ) 01221 { 01222 01223 /* If actuals are constants or variable names, no temporaries are required */ 01224 rp->rplvp = (expptr) ap; 01225 rp->rplxp = NULL; 01226 rp->rpltag = ap->tag; 01227 } 01228 else { 01229 rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng); 01230 rp -> rplxp = NULL; 01231 putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap)); 01232 if((rp->rpltag = rp->rplvp->tag) == TERROR) 01233 err("disagreement of argument types in statement function call"); 01234 } 01235 rp->rplnextp = tlist; 01236 tlist = rp; 01237 actuals = actuals->nextp; 01238 formals = formals->nextp; 01239 ++nargs; 01240 } 01241 01242 if(actuals!=NULL || formals!=NULL) 01243 err("statement function definition and argument list differ"); 01244 01245 /* 01246 now push down names involved in formal argument list, then 01247 evaluate rhs of statement function definition in this environment 01248 */ 01249 01250 if(tlist) /* put tlist in front of the rpllist */ 01251 { 01252 for(rp = tlist; rp->rplnextp; rp = rp->rplnextp) 01253 ; 01254 rp->rplnextp = rpllist; 01255 rpllist = tlist; 01256 } 01257 01258 /* So when the expression finally gets evaled, that evaluator must read 01259 from the globl rpllist 14-jun-88 mwm */ 01260 01261 q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) ); 01262 01263 /* get length right of character-valued statement functions... */ 01264 if (type == TYCHAR 01265 && (Ln = np->vleng) 01266 && q->tag != TERROR 01267 && (Lq = q->exprblock.vleng) 01268 && (Lq->tag != TCONST 01269 || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) { 01270 q1 = (expptr) mktmp(type, Ln); 01271 putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q)); 01272 q = q1; 01273 } 01274 01275 /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */ 01276 while(--nargs >= 0) 01277 { 01278 if(rpllist->rplxp) 01279 q = mkexpr(OPCOMMA, rpllist->rplxp, q); 01280 rp = rpllist->rplnextp; 01281 frexpr(rpllist->rplvp); 01282 free((char *)rpllist); 01283 rpllist = rp; 01284 } 01285 done: 01286 frchain( &oactp ); 01287 np->arginfo = 0; 01288 return(q); 01289 } |
|
Definition at line 1606 of file expr.c. References Expression::addrblock, call4(), Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), ENULL, errstr(), frexpr(), Expression::headblock, ICON, ISICON, mkexpr(), mkstrcon(), mktmp(), Dimblock::nelt, OPAND, OPASSIGN, OPCCALL, OPCOLON, OPLE, OPLT, OPQUEST, STGREG, TADDR, Expression::tag, Addrblock::vstg, and Headblock::vtype. Referenced by suboffset().
01608 { 01609 struct Dimblock *dimp; 01610 expptr t, checkvar, checkcond, badcall; 01611 01612 dimp = np->vdim; 01613 if(dimp->nelt == NULL) 01614 return(p); /* don't check arrays with * bounds */ 01615 np->vlastdim = 0; 01616 if( ISICON(p) ) 01617 { 01618 01619 /* check for negative (constant) offset */ 01620 01621 if(p->constblock.Const.ci < 0) 01622 goto badsub; 01623 if( ISICON(dimp->nelt) ) 01624 01625 /* see if constant offset exceeds the array declaration */ 01626 01627 if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci) 01628 return(p); 01629 else 01630 goto badsub; 01631 } 01632 01633 /* We know that the subscript offset p or dimp -> nelt is not a constant. 01634 Now find a register to use for run-time bounds checking */ 01635 01636 if(p->tag==TADDR && p->addrblock.vstg==STGREG) 01637 { 01638 checkvar = (expptr) cpexpr(p); 01639 t = p; 01640 } 01641 else { 01642 checkvar = (expptr) mktmp(p->headblock.vtype, ENULL); 01643 t = mkexpr(OPASSIGN, cpexpr(checkvar), p); 01644 } 01645 checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) ); 01646 if( ! ISICON(p) ) 01647 checkcond = mkexpr(OPAND, checkcond, 01648 mkexpr(OPLE, ICON(0), cpexpr(checkvar)) ); 01649 01650 /* Construct the actual test */ 01651 01652 badcall = call4(p->headblock.vtype, "s_rnge", 01653 mkstrcon(strlen(np->fvarname), np->fvarname), 01654 mkconv(TYLONG, cpexpr(checkvar)), 01655 mkstrcon(strlen(procname), procname), 01656 ICON(lineno) ); 01657 badcall->exprblock.opcode = OPCCALL; 01658 p = mkexpr(OPQUEST, checkcond, 01659 mkexpr(OPCOLON, checkvar, badcall)); 01660 01661 return(p); 01662 01663 badsub: 01664 frexpr(p); 01665 errstr("subscript on variable %s out of range", np->fvarname); 01666 return ( ICON(0) ); 01667 } |
|
Definition at line 1527 of file expr.c. References Primblock::argsp, Dimblock::baseoffset, cpexpr(), Chain::datap, Dimblock::dims, ENULL, erri(), errstr(), Primblock::fcharp, fixtype(), Nameblock::fvarname, Expression::headblock, ICON, ISCONST, ISINT, Listblock::listp, mkconv(), mkexpr(), mktmp(), Primblock::namep, Dimblock::ndim, Chain::nextp, NOEXT, OPMINUS, OPPLUS, OPSTAR, Expression::primblock, putassign(), putout(), STGARG, subcheck(), Expression::tag, TPRIM, Nameblock::vdim, Nameblock::vleng, Nameblock::vstg, Nameblock::vtype, and Headblock::vtype. Referenced by doequiv(), and mklhs().
01529 { 01530 int n; 01531 expptr si, size; 01532 chainp cp; 01533 expptr e, e1, offp, prod; 01534 struct Dimblock *dimp; 01535 expptr sub[MAXDIM+1]; 01536 register Namep np; 01537 01538 np = p->namep; 01539 offp = ICON(0); 01540 n = 0; 01541 if(p->argsp) 01542 for(cp = p->argsp->listp ; cp ; cp = cp->nextp) 01543 { 01544 si = fixtype(cpexpr((tagptr)cp->datap)); 01545 if (!ISINT(si->headblock.vtype)) { 01546 NOEXT("non-integer subscript"); 01547 si = mkconv(TYLONG, si); 01548 } 01549 sub[n++] = si; 01550 if(n > maxdim) 01551 { 01552 erri("more than %d subscripts", maxdim); 01553 break; 01554 } 01555 } 01556 01557 dimp = np->vdim; 01558 if(n>0 && dimp==NULL) 01559 errstr("subscripts on scalar variable %.68s", np->fvarname); 01560 else if(dimp && dimp->ndim!=n) 01561 errstr("wrong number of subscripts on %.68s", np->fvarname); 01562 else if(n > 0) 01563 { 01564 prod = sub[--n]; 01565 while( --n >= 0) 01566 prod = mkexpr(OPPLUS, sub[n], 01567 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); 01568 if(checksubs || np->vstg!=STGARG) 01569 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); 01570 01571 /* Add in the run-time bounds check */ 01572 01573 if(checksubs) 01574 prod = subcheck(np, prod); 01575 size = np->vtype == TYCHAR ? 01576 (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]); 01577 prod = mkexpr(OPSTAR, prod, size); 01578 offp = mkexpr(OPPLUS, offp, prod); 01579 } 01580 01581 /* Check for substring indicator */ 01582 01583 if(p->fcharp && np->vtype==TYCHAR) { 01584 e = p->fcharp; 01585 e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1)); 01586 if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) { 01587 e = (expptr)mktmp(TYLONG, ENULL); 01588 putout(putassign(cpexpr(e), e1)); 01589 p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1)); 01590 e1 = e; 01591 } 01592 offp = mkexpr(OPPLUS, offp, e1); 01593 } 01594 return(offp); 01595 } |
|
Definition at line 1355 of file expr.c. References a, cpexpr(), erri(), fixtype(), ICON, Listblock::listp, mkchain(), mkexpr(), Chain::nextp, OPMINUS, putx(), UNAM_NAME, and UNAM_REF. Referenced by mklhs().
01357 { 01358 expptr ep; 01359 struct Listblock *Lb; 01360 chainp cp; 01361 01362 if (a->uname_tag != UNAM_NAME) 01363 erri("subskept: uname_tag %d", a->uname_tag); 01364 a->user.name->vrefused = 1; 01365 a->user.name->visused = 1; 01366 a->uname_tag = UNAM_REF; 01367 Lb = (struct Listblock *)cpexpr((tagptr)p->argsp); 01368 for(cp = Lb->listp; cp; cp = cp->nextp) 01369 cp->datap = (char *)putx(fixtype((tagptr)cp->datap)); 01370 if (a->vtype == TYCHAR) { 01371 ep = p->fcharp ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1)) 01372 : ICON(0); 01373 Lb->listp = mkchain((char *)ep, Lb->listp); 01374 } 01375 return (expptr)Lb; 01376 } |
|
Definition at line 1856 of file expr.c. References CLNAMELIST, CLPROC, CLUNKNOWN, CLVAR, dclerr(), doing_stmtfcn, impldcl(), ISCONST, letter, Dimblock::nelt, PTHISPROC, STGAUTO, STGBSS, STGUNKNOWN, v, and YES. Referenced by docommon(), doequiv(), doiolist(), ioclause(), mkplace(), mkscalar(), mkstfunct(), namelist(), startrw(), and yyparse().
01858 { 01859 struct Dimblock *t; 01860 expptr neltp; 01861 extern int doing_stmtfcn; 01862 01863 if(v->vclass == CLUNKNOWN) { 01864 v->vclass = CLVAR; 01865 if (v->vinftype) { 01866 v->vtype = TYUNKNOWN; 01867 if (v->vdcldone) { 01868 v->vdcldone = 0; 01869 impldcl(v); 01870 } 01871 } 01872 } 01873 if(v->vdcldone) 01874 return; 01875 if(v->vclass == CLNAMELIST) 01876 return; 01877 01878 if(v->vtype == TYUNKNOWN) 01879 impldcl(v); 01880 else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC) 01881 { 01882 dclerr("used as variable", v); 01883 return; 01884 } 01885 if(v->vstg==STGUNKNOWN) { 01886 if (doing_stmtfcn) { 01887 /* neither declare this variable if its only use */ 01888 /* is in defining a stmt function, nor complain */ 01889 /* that it is never used */ 01890 v->vimpldovar = 1; 01891 return; 01892 } 01893 v->vstg = implstg[ letter(v->fvarname[0]) ]; 01894 v->vimplstg = 1; 01895 } 01896 01897 /* Compute the actual storage location, i.e. offsets from base addresses, 01898 possibly the stack pointer */ 01899 01900 switch(v->vstg) 01901 { 01902 case STGBSS: 01903 v->vardesc.varno = ++lastvarno; 01904 break; 01905 case STGAUTO: 01906 if(v->vclass==CLPROC && v->vprocclass==PTHISPROC) 01907 break; 01908 if(t = v->vdim) 01909 if( (neltp = t->nelt) && ISCONST(neltp) ) ; 01910 else 01911 dclerr("adjustable automatic array", v); 01912 break; 01913 01914 default: 01915 break; 01916 } 01917 v->vdcldone = YES; 01918 } |
|
Definition at line 550 of file expr.c. References c, ICON, letter, and warn1(). Referenced by fixtype().
|
|
Definition at line 3396 of file expr.c. References c, dcomplex::dimag, dcomplex::dreal, and Fatal(). Referenced by consbinop().
03398 { 03399 double ratio, den; 03400 double abr, abi; 03401 03402 if( (abr = b->dreal) < 0.) 03403 abr = - abr; 03404 if( (abi = b->dimag) < 0.) 03405 abi = - abi; 03406 if( abr <= abi ) 03407 { 03408 if(abi == 0) 03409 Fatal("complex division by zero"); 03410 ratio = b->dreal / b->dimag ; 03411 den = b->dimag * (1 + ratio*ratio); 03412 c->dreal = (a->dreal*ratio + a->dimag) / den; 03413 c->dimag = (a->dimag*ratio - a->dreal) / den; 03414 } 03415 03416 else 03417 { 03418 ratio = b->dimag / b->dreal ; 03419 den = b->dreal * (1 + ratio*ratio); 03420 c->dreal = (a->dreal + a->dimag*ratio) / den; 03421 c->dimag = (a->dimag - a->dreal*ratio) / den; 03422 } 03423 } |
|
Definition at line 1982 of file expr.c. References c, Constant::cd, Constant::cds, Constant::ci, Constblock::Const, Constblock::tag, TCONST, TYQUAD, Constblock::vstg, and Constblock::vtype. Referenced by fold(), and mkexpr().
01984 { 01985 register Constp c = (Constp) e; 01986 if (c->tag == TCONST) 01987 switch(c->vtype) { 01988 case TYINT1: 01989 case TYSHORT: 01990 case TYLONG: 01991 #ifdef TYQUAD 01992 case TYQUAD: 01993 #endif 01994 return c->Const.ci == 0; 01995 01996 case TYREAL: 01997 case TYDREAL: 01998 if (c->vstg == 1) 01999 return !strcmp(c->Const.cds[0],"0."); 02000 return c->Const.cd[0] == 0.; 02001 02002 case TYCOMPLEX: 02003 case TYDCOMPLEX: 02004 if (c->vstg == 1) 02005 return !strcmp(c->Const.cds[0],"0.") 02006 && !strcmp(c->Const.cds[1],"0."); 02007 return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.; 02008 } 02009 return 0; 02010 } |
Variable Documentation
|
Definition at line 36 of file expr.c. Referenced by fileinit(), impldcl(), mkfunct(), and stfcall(). |
|
|
|
Definition at line 276 of file expr.c. Referenced by fixexpr(), fixtype(), intraddr(), intrcall(), mkcxcon(), mkexpr(), mkfunct(), mkplace(), mkpower(), mkprim(), mktmpn(), and putx().
00277 { 00278 struct Errorblock *p; 00279 p = ALLOC(Errorblock); 00280 p->tag = TERROR; 00281 p->vtype = TYERROR; 00282 return( (expptr) p ); 00283 } |
|
Definition at line 37 of file expr.c. Referenced by cktype(), and set_externs(). |
|
Initial value: { "pow_ii", "pow_qq", "pow_ri", "pow_di", "pow_ci", "pow_zi" } Definition at line 3277 of file expr.c. Referenced by mkpower(). |
|
|