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(). |
|
|
|
