#include "defs.h"#include "output.h"#include "names.h"Include dependency graph for expr.c:
Go to the source code of this file.
| #define ICONEQ | ( | z, | |||
| c | ) | (ISICON(z) && z->constblock.Const.ci==c) |
| static void adjust_arginfo | ( | Namep | np | ) | [static] |
Definition at line 1029 of file expr.c.
References Extsym::arginfo, Entrypoint::arglist, args, Entrypoint::entnextp, entries, Entrypoint::entryname, and Argtypes::nargs.
Referenced by mkfunct().
01034 { 01035 struct Entrypoint *ep; 01036 chainp args; 01037 Argtypes *at; 01038 01039 for(ep = entries; ep; ep = ep->entnextp) 01040 for(args = ep->arglist; args; args = args->nextp) 01041 if (np == (Namep)args->datap 01042 && (at = ep->entryname->arginfo)) 01043 --at->nargs; 01044 }
Here is the caller graph for this function:
Definition at line 666 of file expr.c.
References err, errstr(), p, TADDR, and UNAM_NAME.
Referenced by cplenexpr(), and putcheq().
00668 { 00669 if (!p->headblock.vleng) { 00670 if (p->headblock.tag == TADDR 00671 && p->addrblock.uname_tag == UNAM_NAME) 00672 errstr("bad use of character*(*) variable %.60s", 00673 p->addrblock.user.name->fvarname); 00674 else 00675 err("Bad use of character*(*)"); 00676 return 1; 00677 } 00678 return 0; 00679 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 2456 of file expr.c.
References badop(), err, ERR, error, 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, TYADDR, TYCHAR, TYERROR, TYLOGICAL, TYLONG, TYQUAD, and TYUNKNOWN.
Referenced by fixexpr(), mkexpr(), and setdata().
02458 { 02459 char *errs; 02460 02461 if(lt==TYERROR || rt==TYERROR) 02462 goto error1; 02463 02464 if(lt==TYUNKNOWN) 02465 return(TYUNKNOWN); 02466 if(rt==TYUNKNOWN) 02467 02468 /* If not unary operation, return UNKNOWN */ 02469 02470 if(!is_unary_op (op) && op != OPCALL && op != OPCCALL) 02471 return(TYUNKNOWN); 02472 02473 switch(op) 02474 { 02475 case OPPLUS: 02476 case OPMINUS: 02477 case OPSTAR: 02478 case OPSLASH: 02479 case OPPOWER: 02480 case OPMOD: 02481 if( ISNUMERIC(lt) && ISNUMERIC(rt) ) 02482 return( maxtype(lt, rt) ); 02483 ERR("nonarithmetic operand of arithmetic operator") 02484 02485 case OPNEG: 02486 case OPNEG1: 02487 if( ISNUMERIC(lt) ) 02488 return(lt); 02489 ERR("nonarithmetic operand of negation") 02490 02491 case OPNOT: 02492 if(ISLOGICAL(lt)) 02493 return(lt); 02494 ERR("NOT of nonlogical") 02495 02496 case OPAND: 02497 case OPOR: 02498 case OPEQV: 02499 case OPNEQV: 02500 if(ISLOGICAL(lt) && ISLOGICAL(rt)) 02501 return( maxtype(lt, rt) ); 02502 ERR("nonlogical operand of logical operator") 02503 02504 case OPLT: 02505 case OPGT: 02506 case OPLE: 02507 case OPGE: 02508 case OPEQ: 02509 case OPNE: 02510 if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) 02511 { 02512 if(lt != rt){ 02513 if (htype 02514 && (lt == TYCHAR && ISNUMERIC(rt) 02515 || rt == TYCHAR && ISNUMERIC(lt))) 02516 return TYLOGICAL; 02517 ERR("illegal comparison") 02518 } 02519 } 02520 02521 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) ) 02522 { 02523 if(op!=OPEQ && op!=OPNE) 02524 ERR("order comparison of complex data") 02525 } 02526 02527 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) ) 02528 ERR("comparison of nonarithmetic data") 02529 case OPBITTEST: 02530 return(TYLOGICAL); 02531 02532 case OPCONCAT: 02533 if(lt==TYCHAR && rt==TYCHAR) 02534 return(TYCHAR); 02535 ERR("concatenation of nonchar data") 02536 02537 case OPCALL: 02538 case OPCCALL: 02539 case OPIDENTITY: 02540 return(lt); 02541 02542 case OPADDR: 02543 case OPCHARCAST: 02544 return(TYADDR); 02545 02546 case OPCONV: 02547 if(rt == 0) 02548 return(0); 02549 if(lt==TYCHAR && ISINT(rt) ) 02550 return(TYCHAR); 02551 if (ISLOGICAL(lt) && ISLOGICAL(rt) 02552 || ISINT(lt) && rt == TYCHAR) 02553 return lt; 02554 case OPASSIGN: 02555 case OPASSIGNI: 02556 case OPMINUSEQ: 02557 case OPPLUSEQ: 02558 case OPSTAREQ: 02559 case OPSLASHEQ: 02560 case OPMODEQ: 02561 case OPLSHIFTEQ: 02562 case OPRSHIFTEQ: 02563 case OPBITANDEQ: 02564 case OPBITXOREQ: 02565 case OPBITOREQ: 02566 if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN) 02567 return lt; 02568 if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) 02569 if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ) 02570 || (lt!=rt)) 02571 { 02572 ERR("impossible conversion") 02573 } 02574 return(lt); 02575 02576 case OPMIN: 02577 case OPMAX: 02578 case OPDMIN: 02579 case OPDMAX: 02580 case OPMIN2: 02581 case OPMAX2: 02582 case OPBITOR: 02583 case OPBITAND: 02584 case OPBITXOR: 02585 case OPBITNOT: 02586 case OPLSHIFT: 02587 case OPRSHIFT: 02588 case OPWHATSIN: 02589 case OPABS: 02590 case OPDABS: 02591 return(lt); 02592 02593 case OPBITCLR: 02594 case OPBITSET: 02595 #ifdef TYQUAD0 02596 case OPQBITCLR: 02597 case OPQBITSET: 02598 #endif 02599 if (lt < TYLONG) 02600 lt = TYLONG; 02601 return(lt); 02602 #ifndef NO_LONG_LONG 02603 case OPQBITCLR: 02604 case OPQBITSET: 02605 return TYQUAD; 02606 #endif 02607 02608 case OPCOMMA: 02609 case OPCOMMA_ARG: 02610 case OPQUEST: 02611 case OPCOLON: /* Only checks the rightmost type because 02612 of C language definition (rightmost 02613 comma-expr is the value of the expr) */ 02614 return(rt); 02615 02616 case OPDOT: 02617 case OPARROW: 02618 return (lt); 02619 default: 02620 badop("cktype", op); 02621 } 02622 error: 02623 err(errs); 02624 error1: 02625 return(TYERROR); 02626 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 3236 of file expr.c.
References a, b, Constant::cd, Constant::cds, Constant::ci, Constblock::Const, Constant::cq, Fatal(), intovfl(), ISCOMPLEX, ISINT, MSKCOMPLEX, MSKREAL, ONEOF, OPDMAX, OPDMIN, OPEQ, OPGE, OPGT, OPLE, OPLT, OPMAX2, OPMIN2, OPMINUS, OPMOD, OPNE, OPPLUS, OPSLASH, OPSTAR, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, TYLOGICAL, TYLONG, TYQUAD, TYREAL, TYSHORT, Constblock::vstg, and zdiv().
Referenced by conspower(), and fold().
03238 { 03239 union Constant *ap = &app->Const, 03240 *bp = &bpp->Const, 03241 *cp = &cpp->Const; 03242 ftnint k; 03243 double ad[2], bd[2], temp; 03244 ftnint a, b; 03245 #ifndef NO_LONG_LONG 03246 Llong aL, bL; 03247 #endif 03248 03249 cpp->vstg = 0; 03250 03251 if (ONEOF(type, MSKREAL|MSKCOMPLEX)) { 03252 ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0]; 03253 bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0]; 03254 if (ISCOMPLEX(type)) { 03255 ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1]; 03256 bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1]; 03257 } 03258 } 03259 switch(opcode) 03260 { 03261 case OPPLUS: 03262 switch(type) 03263 { 03264 case TYINT1: 03265 case TYSHORT: 03266 case TYLONG: 03267 #ifdef TYQUAD0 03268 case TYQUAD: 03269 #endif 03270 cp->ci = ap->ci + bp->ci; 03271 if (ap->ci != cp->ci - bp->ci) 03272 intovfl(); 03273 break; 03274 #ifndef NO_LONG_LONG 03275 case TYQUAD: 03276 cp->cq = ap->cq + bp->cq; 03277 if (ap->cq != cp->cq - bp->cq) 03278 intovfl(); 03279 break; 03280 #endif 03281 case TYCOMPLEX: 03282 case TYDCOMPLEX: 03283 cp->cd[1] = ad[1] + bd[1]; 03284 case TYREAL: 03285 case TYDREAL: 03286 cp->cd[0] = ad[0] + bd[0]; 03287 break; 03288 } 03289 break; 03290 03291 case OPMINUS: 03292 switch(type) 03293 { 03294 case TYINT1: 03295 case TYSHORT: 03296 case TYLONG: 03297 #ifdef TYQUAD0 03298 case TYQUAD: 03299 #endif 03300 cp->ci = ap->ci - bp->ci; 03301 if (ap->ci != bp->ci + cp->ci) 03302 intovfl(); 03303 break; 03304 #ifndef NO_LONG_LONG 03305 case TYQUAD: 03306 cp->cq = ap->cq - bp->cq; 03307 if (ap->cq != bp->cq + cp->cq) 03308 intovfl(); 03309 break; 03310 #endif 03311 case TYCOMPLEX: 03312 case TYDCOMPLEX: 03313 cp->cd[1] = ad[1] - bd[1]; 03314 case TYREAL: 03315 case TYDREAL: 03316 cp->cd[0] = ad[0] - bd[0]; 03317 break; 03318 } 03319 break; 03320 03321 case OPSTAR: 03322 switch(type) 03323 { 03324 case TYINT1: 03325 case TYSHORT: 03326 case TYLONG: 03327 #ifdef TYQUAD0 03328 case TYQUAD: 03329 #endif 03330 cp->ci = (a = ap->ci) * (b = bp->ci); 03331 if (a && cp->ci / a != b) 03332 intovfl(); 03333 break; 03334 #ifndef NO_LONG_LONG 03335 case TYQUAD: 03336 cp->cq = (aL = ap->cq) * (bL = bp->cq); 03337 if (aL && cp->cq / aL != bL) 03338 intovfl(); 03339 break; 03340 #endif 03341 case TYREAL: 03342 case TYDREAL: 03343 cp->cd[0] = ad[0] * bd[0]; 03344 break; 03345 case TYCOMPLEX: 03346 case TYDCOMPLEX: 03347 temp = ad[0] * bd[0] - ad[1] * bd[1] ; 03348 cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ; 03349 cp->cd[0] = temp; 03350 break; 03351 } 03352 break; 03353 case OPSLASH: 03354 switch(type) 03355 { 03356 case TYINT1: 03357 case TYSHORT: 03358 case TYLONG: 03359 #ifdef TYQUAD0 03360 case TYQUAD: 03361 #endif 03362 cp->ci = ap->ci / bp->ci; 03363 break; 03364 #ifndef NO_LONG_LONG 03365 case TYQUAD: 03366 cp->cq = ap->cq / bp->cq; 03367 break; 03368 #endif 03369 case TYREAL: 03370 case TYDREAL: 03371 cp->cd[0] = ad[0] / bd[0]; 03372 break; 03373 case TYCOMPLEX: 03374 case TYDCOMPLEX: 03375 zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd); 03376 break; 03377 } 03378 break; 03379 03380 case OPMOD: 03381 if( ISINT(type) ) 03382 { 03383 #ifndef NO_LONG_LONG 03384 if (type == TYQUAD) 03385 cp->cq = ap->cq % bp->cq; 03386 else 03387 #endif 03388 cp->ci = ap->ci % bp->ci; 03389 break; 03390 } 03391 else 03392 Fatal("inline mod of noninteger"); 03393 03394 case OPMIN2: 03395 case OPDMIN: 03396 switch(type) 03397 { 03398 case TYINT1: 03399 case TYSHORT: 03400 case TYLONG: 03401 #ifdef TYQUAD0 03402 case TYQUAD: 03403 #endif 03404 cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci; 03405 break; 03406 #ifndef NO_LONG_LONG 03407 case TYQUAD: 03408 cp->cq = ap->cq <= bp->cq ? ap->cq : bp->cq; 03409 break; 03410 #endif 03411 case TYREAL: 03412 case TYDREAL: 03413 cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0]; 03414 break; 03415 default: 03416 Fatal("inline min of exected type"); 03417 } 03418 break; 03419 03420 case OPMAX2: 03421 case OPDMAX: 03422 switch(type) 03423 { 03424 case TYINT1: 03425 case TYSHORT: 03426 case TYLONG: 03427 #ifdef TYQUAD0 03428 case TYQUAD: 03429 #endif 03430 cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci; 03431 break; 03432 #ifndef NO_LONG_LONG 03433 case TYQUAD: 03434 cp->cq = ap->cq >= bp->cq ? ap->cq : bp->cq; 03435 break; 03436 #endif 03437 case TYREAL: 03438 case TYDREAL: 03439 cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0]; 03440 break; 03441 default: 03442 Fatal("inline max of exected type"); 03443 } 03444 break; 03445 03446 default: /* relational ops */ 03447 switch(type) 03448 { 03449 case TYINT1: 03450 case TYSHORT: 03451 case TYLONG: 03452 #ifdef TYQUAD0 03453 case TYQUAD: 03454 #endif 03455 if(ap->ci < bp->ci) 03456 k = -1; 03457 else if(ap->ci == bp->ci) 03458 k = 0; 03459 else k = 1; 03460 break; 03461 #ifndef NO_LONG_LONG 03462 case TYQUAD: 03463 if(ap->cq < bp->cq) 03464 k = -1; 03465 else if(ap->cq == bp->cq) 03466 k = 0; 03467 else k = 1; 03468 break; 03469 #endif 03470 case TYREAL: 03471 case TYDREAL: 03472 if(ad[0] < bd[0]) 03473 k = -1; 03474 else if(ad[0] == bd[0]) 03475 k = 0; 03476 else k = 1; 03477 break; 03478 case TYCOMPLEX: 03479 case TYDCOMPLEX: 03480 if(ad[0] == bd[0] && 03481 ad[1] == bd[1] ) 03482 k = 0; 03483 else k = 1; 03484 break; 03485 case TYLOGICAL: 03486 k = ap->ci - bp->ci; 03487 } 03488 03489 switch(opcode) 03490 { 03491 case OPEQ: 03492 cp->ci = (k == 0); 03493 break; 03494 case OPNE: 03495 cp->ci = (k != 0); 03496 break; 03497 case OPGT: 03498 cp->ci = (k == 1); 03499 break; 03500 case OPLT: 03501 cp->ci = (k == -1); 03502 break; 03503 case OPGE: 03504 cp->ci = (k >= 0); 03505 break; 03506 case OPLE: 03507 cp->ci = (k <= 0); 03508 break; 03509 } 03510 break; 03511 } 03512 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 2955 of file expr.c.
References Constant::blanks, Constant::ccp1, Constant::cd, cds(), Constant::ci, ckalloc(), CNULL, Constblock::Const, Constant::cq, ISCOMPLEX, ISINT, ISREAL, lc, memcpy(), MSKCOMPLEX, MSKREAL, ONEOF, TYCHAR, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, TYLOGICAL, TYLOGICAL1, TYLOGICAL2, TYLONG, TYQUAD, TYREAL, TYSHORT, Constblock::vstg, and Constblock::vtype.
Referenced by fold(), mkconv(), and setdata().
02957 { 02958 int rt = rc->vtype; 02959 union Constant *lv = &lc->Const, *rv = &rc->Const; 02960 02961 lc->vtype = lt; 02962 if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) { 02963 memcpy((char *)lv, (char *)rv, sizeof(union Constant)); 02964 lc->vstg = rc->vstg; 02965 if (ISCOMPLEX(lt) && ISREAL(rt)) { 02966 if (rc->vstg) 02967 lv->cds[1] = cds("0",CNULL); 02968 else 02969 lv->cd[1] = 0.; 02970 } 02971 return; 02972 } 02973 lc->vstg = 0; 02974 02975 switch(lt) 02976 { 02977 02978 /* Casting to character means just copying the first sizeof (character) 02979 bytes into a new 1 character string. This is weird. */ 02980 02981 case TYCHAR: 02982 *(lv->ccp = (char *) ckalloc(1)) = (char)rv->ci; 02983 lv->ccp1.blanks = 0; 02984 break; 02985 02986 case TYINT1: 02987 case TYSHORT: 02988 case TYLONG: 02989 #ifdef TYQUAD0 02990 case TYQUAD: 02991 #endif 02992 if(rt == TYCHAR) 02993 lv->ci = rv->ccp[0]; 02994 else if( ISINT(rt) ) { 02995 #ifndef NO_LONG_LONG 02996 if (rt == TYQUAD) 02997 lv->ci = (ftnint)(rv->cq); 02998 else 02999 #endif 03000 lv->ci = rv->ci; 03001 } 03002 else lv->ci = (ftnint)(rc->vstg 03003 ? atof(rv->cds[0]) : rv->cd[0]); 03004 03005 break; 03006 #ifndef NO_LONG_LONG 03007 case TYQUAD: 03008 if(rt == TYCHAR) 03009 lv->cq = rv->ccp[0]; 03010 else if( ISINT(rt) ) { 03011 if (rt == TYQUAD) 03012 lv->cq = rv->cq; 03013 else 03014 lv->cq = rv->ci; 03015 } 03016 else lv->cq = (ftnint)(rc->vstg 03017 ? atof(rv->cds[0]) : rv->cd[0]); 03018 03019 break; 03020 #endif 03021 03022 case TYCOMPLEX: 03023 case TYDCOMPLEX: 03024 lv->cd[1] = 0.; 03025 03026 case TYREAL: 03027 case TYDREAL: 03028 #ifndef NO_LONG_LONG 03029 if (rt == TYQUAD) 03030 lv->cd[0] = (double)(rv->cq); 03031 else 03032 #endif 03033 lv->cd[0] = rv->ci; 03034 break; 03035 03036 case TYLOGICAL: 03037 case TYLOGICAL1: 03038 case TYLOGICAL2: 03039 lv->ci = rv->ci; 03040 break; 03041 } 03042 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void consnegop | ( | Constp | p | ) |
Definition at line 3053 of file expr.c.
References badtype(), intovfl(), ISCOMPLEX, L, p, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, TYLONG, TYQUAD, TYREAL, and TYSHORT.
Referenced by fold(), mkexpr(), and yyparse().
03055 { 03056 char *s; 03057 ftnint L; 03058 #ifndef NO_LONG_LONG 03059 Llong LL; 03060 #endif 03061 03062 if (p->vstg) { 03063 /* 20010820: comment out "*s == '0' ? s :" to preserve */ 03064 /* the sign of zero */ 03065 if (ISCOMPLEX(p->vtype)) { 03066 s = p->Const.cds[1]; 03067 p->Const.cds[1] = *s == '-' ? s+1 03068 : /* *s == '0' ? s : */ s-1; 03069 } 03070 s = p->Const.cds[0]; 03071 p->Const.cds[0] = *s == '-' ? s+1 03072 : /* *s == '0' ? s : */ s-1; 03073 return; 03074 } 03075 switch(p->vtype) 03076 { 03077 case TYINT1: 03078 case TYSHORT: 03079 case TYLONG: 03080 #ifdef TYQUAD0 03081 case TYQUAD: 03082 #endif 03083 p->Const.ci = -(L = p->Const.ci); 03084 if (L != -p->Const.ci) 03085 intovfl(); 03086 break; 03087 #ifndef NO_LONG_LONG 03088 case TYQUAD: 03089 p->Const.cq = -(LL = p->Const.cq); 03090 if (LL != -p->Const.cq) 03091 intovfl(); 03092 break; 03093 #endif 03094 case TYCOMPLEX: 03095 case TYDCOMPLEX: 03096 p->Const.cd[1] = - p->Const.cd[1]; 03097 /* fall through and do the real parts */ 03098 case TYREAL: 03099 case TYDREAL: 03100 p->Const.cd[0] = - p->Const.cd[0]; 03101 break; 03102 default: 03103 badtype("consnegop", p->vtype); 03104 } 03105 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 3118 of file expr.c.
References badtype(), Constant::cd, Constant::cds, Constant::ci, consbinop(), Constblock::Const, Constant::cq, err, ISCOMPLEX, ISINT, memcpy(), OPSLASH, OPSTAR, p, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, TYLONG, TYQUAD, TYREAL, TYSHORT, Constblock::vstg, and Constblock::vtype.
Referenced by fold().
03120 { 03121 union Constant *powp = &p->Const; 03122 int type; 03123 struct Constblock x, x0; 03124 03125 if (n == 1) { 03126 memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const)); 03127 return; 03128 } 03129 03130 switch(type = ap->vtype) /* pow = 1 */ 03131 { 03132 case TYINT1: 03133 case TYSHORT: 03134 case TYLONG: 03135 #ifdef TYQUAD0 03136 case TYQUAD: 03137 #endif 03138 powp->ci = 1; 03139 break; 03140 #ifndef NO_LONG_LONG 03141 case TYQUAD: 03142 powp->cq = 1; 03143 break; 03144 #endif 03145 case TYCOMPLEX: 03146 case TYDCOMPLEX: 03147 powp->cd[1] = 0; 03148 case TYREAL: 03149 case TYDREAL: 03150 powp->cd[0] = 1; 03151 break; 03152 default: 03153 badtype("conspower", type); 03154 } 03155 03156 if(n == 0) 03157 return; 03158 switch(type) /* x0 = ap */ 03159 { 03160 case TYINT1: 03161 case TYSHORT: 03162 case TYLONG: 03163 #ifdef TYQUAD0 03164 case TYQUAD: 03165 #endif 03166 x0.Const.ci = ap->Const.ci; 03167 break; 03168 #ifndef NO_LONG_LONG 03169 case TYQUAD: 03170 x0.Const.cq = ap->Const.cq; 03171 break; 03172 #endif 03173 case TYCOMPLEX: 03174 case TYDCOMPLEX: 03175 x0.Const.cd[1] = 03176 ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1]; 03177 case TYREAL: 03178 case TYDREAL: 03179 x0.Const.cd[0] = 03180 ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0]; 03181 break; 03182 } 03183 x0.vtype = type; 03184 x0.vstg = 0; 03185 if(n < 0) 03186 { 03187 n = -n; 03188 if( ISINT(type) ) 03189 { 03190 switch(ap->Const.ci) { 03191 case 0: 03192 err("0 ** negative number"); 03193 return; 03194 case 1: 03195 case -1: 03196 goto mult; 03197 } 03198 err("integer ** negative number"); 03199 return; 03200 } 03201 else if (!x0.Const.cd[0] 03202 && (!ISCOMPLEX(type) || !x0.Const.cd[1])) { 03203 err("0.0 ** negative number"); 03204 return; 03205 } 03206 consbinop(OPSLASH, type, &x, p, &x0); 03207 } 03208 else 03209 mult: consbinop(OPSTAR, type, &x, p, &x0); 03210 03211 for( ; ; ) 03212 { 03213 if(n & 01) 03214 consbinop(OPSTAR, type, p, p, &x); 03215 if(n >>= 1) 03216 consbinop(OPSTAR, type, &x, &x, &x); 03217 else 03218 break; 03219 } 03220 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 3523 of file expr.c.
References badtype(), Fatal(), ISCONST, p, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, TYLONG, TYQUAD, TYREAL, and TYSHORT.
Referenced by exdo().
03525 { 03526 char *s; 03527 03528 if( ! ISCONST(p) ) 03529 Fatal( "sgn(nonconstant)" ); 03530 03531 switch(p->headblock.vtype) 03532 { 03533 case TYINT1: 03534 case TYSHORT: 03535 case TYLONG: 03536 #ifdef TYQUAD0 03537 case TYQUAD: 03538 #endif 03539 if(p->constblock.Const.ci > 0) return(1); 03540 if(p->constblock.Const.ci < 0) return(-1); 03541 return(0); 03542 #ifndef NO_LONG_LONG 03543 case TYQUAD: 03544 if(p->constblock.Const.cq > 0) return(1); 03545 if(p->constblock.Const.cq < 0) return(-1); 03546 return(0); 03547 #endif 03548 03549 case TYREAL: 03550 case TYDREAL: 03551 if (p->constblock.vstg) { 03552 s = p->constblock.Const.cds[0]; 03553 if (*s == '-') 03554 return -1; 03555 if (*s == '0') 03556 return 0; 03557 return 1; 03558 } 03559 if(p->constblock.Const.cd[0] > 0) return(1); 03560 if(p->constblock.Const.cd[0] < 0) return(-1); 03561 return(0); 03562 03563 03564 /* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */ 03565 03566 case TYCOMPLEX: 03567 case TYDCOMPLEX: 03568 if (p->constblock.vstg) 03569 return *p->constblock.Const.cds[0] != '0' 03570 && *p->constblock.Const.cds[1] != '0'; 03571 return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0); 03572 03573 default: 03574 badtype( "conssgn", p->constblock.vtype); 03575 } 03576 /* NOT REACHED */ return 0; 03577 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 425 of file expr.c.
References Expression::addrblock, Primblock::argsp, badtag(), CHNULL, Constant::ci, Constblock::Const, Expression::constblock, copyn(), cpblock(), Expression::exprblock, Primblock::fcharp, frexpr(), Addrblock::istemp, Primblock::lcharp, Exprblock::leftp, Expression::listblock, Listblock::listp, Addrblock::memoffset, mkchain(), Chain::nextp, NO, NULL, p, pp, Expression::primblock, Exprblock::rightp, TADDR, Errorblock::tag, TCONST, TERROR, TEXPR, TLIST, TNAME, TPRIM, TYCHAR, 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(), mkscalar(), mktmp(), nextdata(), p1_const(), p1_subr_ret(), prolog(), putcall(), putcat(), putch1(), putconst(), putct1(), putcx1(), putiocall(), putmnmx(), putop(), putpower(), putsteq(), realpart(), ref_defs(), retval(), startrw(), stfcall(), subcheck(), suboffset(), subskept(), and yyparse().
00427 { 00428 tagptr e; 00429 int tag; 00430 chainp ep, pp; 00431 00432 /* This table depends on the ordering of the T macros, e.g. TNAME */ 00433 00434 static int blksize[ ] = 00435 { 00436 0, 00437 sizeof(struct Nameblock), 00438 sizeof(struct Constblock), 00439 sizeof(struct Exprblock), 00440 sizeof(struct Addrblock), 00441 sizeof(struct Primblock), 00442 sizeof(struct Listblock), 00443 sizeof(struct Impldoblock), 00444 sizeof(struct Errorblock) 00445 }; 00446 00447 if(p == NULL) 00448 return(NULL); 00449 00450 /* TNAMEs are special, and don't get copied. Each name in the current 00451 symbol table has a unique TNAME structure. */ 00452 00453 if( (tag = p->tag) == TNAME) 00454 return(p); 00455 00456 e = cpblock(blksize[p->tag], (char *)p); 00457 00458 switch(tag) 00459 { 00460 case TCONST: 00461 if(e->constblock.vtype == TYCHAR) 00462 { 00463 e->constblock.Const.ccp = 00464 copyn((int)e->constblock.vleng->constblock.Const.ci+1, 00465 e->constblock.Const.ccp); 00466 e->constblock.vleng = 00467 (expptr) cpexpr(e->constblock.vleng); 00468 } 00469 case TERROR: 00470 break; 00471 00472 case TEXPR: 00473 e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp); 00474 e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp); 00475 break; 00476 00477 case TLIST: 00478 if(pp = p->listblock.listp) 00479 { 00480 ep = e->listblock.listp = 00481 mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL); 00482 for(pp = pp->nextp ; pp ; pp = pp->nextp) 00483 ep = ep->nextp = 00484 mkchain((char *)cpexpr((tagptr)pp->datap), 00485 CHNULL); 00486 } 00487 break; 00488 00489 case TADDR: 00490 e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng); 00491 e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset); 00492 e->addrblock.istemp = NO; 00493 break; 00494 00495 case TPRIM: 00496 e->primblock.argsp = (struct Listblock *) 00497 cpexpr((expptr)e->primblock.argsp); 00498 e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp); 00499 e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp); 00500 break; 00501 00502 default: 00503 badtag("cpexpr", tag); 00504 } 00505 00506 return(e); 00507 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 687 of file expr.c.
References badchleng(), Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), ICON, ISCONST, p, and TYCHAR.
Referenced by fixexpr().
00689 { 00690 expptr rv; 00691 00692 if (badchleng(p)) 00693 return ICON(1); 00694 rv = cpexpr(p->headblock.vleng); 00695 if (ISCONST(p) && p->constblock.vtype == TYCHAR) 00696 rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks; 00697 return rv; 00698 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void deregister | ( | Namep | np | ) |
| expptr errnode | ( | Void | ) |
Definition at line 931 of file expr.c.
References Primblock::argsp, CLPROC, Primblock::fcharp, fixtype(), Primblock::lcharp, Listblock::listp, memversion(), mkaddr(), mkscalar(), Primblock::namep, NULL, p, Expression::primblock, PTHISPROC, putconst(), sserr(), t, Expression::tag, TCONST, TPRIM, TYCHAR, Nameblock::vclass, Nameblock::vdim, Nameblock::vdovar, Nameblock::vprocclass, and Nameblock::vtype.
Referenced by intrcall(), and mkfunct().
00934 { 00935 chainp p; 00936 tagptr q, t; 00937 int qtag, nargs; 00938 00939 nargs = 0; 00940 if(p0) 00941 for(p = p0->listp ; p ; p = p->nextp) 00942 { 00943 ++nargs; 00944 q = (tagptr)p->datap; 00945 qtag = q->tag; 00946 if(qtag == TCONST) 00947 { 00948 00949 /* Call putconst() to store values in a constant table. Since even 00950 constants must be passed by reference, this can optimize on the storage 00951 required */ 00952 00953 p->datap = doput ? (char *)putconst((Constp)q) 00954 : (char *)q; 00955 continue; 00956 } 00957 00958 /* Take a function name and turn it into an Addr. This only happens when 00959 nothing else has figured out the function beforehand */ 00960 00961 if (qtag == TPRIM && q->primblock.argsp == 0) { 00962 if (q->primblock.namep->vclass==CLPROC 00963 && q->primblock.namep->vprocclass != PTHISPROC) { 00964 p->datap = (char *)mkaddr(q->primblock.namep); 00965 continue; 00966 } 00967 00968 if (q->primblock.namep->vdim != NULL) { 00969 p->datap = (char *)mkscalar(q->primblock.namep); 00970 if ((q->primblock.fcharp||q->primblock.lcharp) 00971 && (q->primblock.namep->vtype != TYCHAR 00972 || q->primblock.namep->vdim)) 00973 sserr(q->primblock.namep); 00974 continue; 00975 } 00976 00977 if (q->primblock.namep->vdovar 00978 && (t = (tagptr) memversion(q->primblock.namep))) { 00979 p->datap = (char *)fixtype(t); 00980 continue; 00981 } 00982 } 00983 p->datap = (char *)fixtype(q); 00984 } 00985 return(nargs); 00986 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 710 of file expr.c.
References badtag(), call2(), cktype(), Expression::constblock, cplenexpr(), err, errnode, Fatal(), fixtype(), free(), frexpr(), halign, Expression::headblock, ISCOMPLEX, ISCONST, ISERROR, ISLOGICAL, ISREAL, lp, mkconv(), mkexpr(), mkpower(), MSKADDR, MSKINT, NULL, ONEOF, OPABS, OPADDR, OPASSIGN, 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, p, putconst(), TADDR, Constblock::tag, TEXPR, TYCHAR, TYCOMPLEX, TYDREAL, TYERROR, typesize, TYREAL, Headblock::vtype, and Constblock::vtype.
Referenced by fixtype(), intrcall(), make_param(), mkpower(), putassign(), putcxcmp(), putiocall(), putmnmx(), and putsteq().
00712 { 00713 expptr lp, rp, q; 00714 char *hsave; 00715 int opcode, ltype, rtype, ptype, mtype; 00716 00717 if( ISERROR(p) || p->typefixed ) 00718 return( (expptr) p ); 00719 else if(p->tag != TEXPR) 00720 badtag("fixexpr", p->tag); 00721 opcode = p->opcode; 00722 00723 /* First set the types of the left and right subexpressions */ 00724 00725 lp = p->leftp; 00726 if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR) 00727 lp = p->leftp = fixtype(lp); 00728 ltype = lp->headblock.vtype; 00729 00730 if(opcode==OPASSIGN && lp->tag!=TADDR) 00731 { 00732 err("left side of assignment must be variable"); 00733 eret: 00734 frexpr((expptr)p); 00735 return( errnode() ); 00736 } 00737 00738 if(rp = p->rightp) 00739 { 00740 if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR) 00741 rp = p->rightp = fixtype(rp); 00742 rtype = rp->headblock.vtype; 00743 } 00744 else 00745 rtype = 0; 00746 00747 if(ltype==TYERROR || rtype==TYERROR) 00748 goto eret; 00749 00750 /* Now work on the whole expression */ 00751 00752 /* force folding if possible */ 00753 00754 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) ) 00755 { 00756 q = opcode == OPCONV && lp->constblock.vtype == p->vtype 00757 ? lp : mkexpr(opcode, lp, rp); 00758 00759 /* mkexpr is expected to reduce constant expressions */ 00760 00761 if( ISCONST(q) ) { 00762 p->leftp = p->rightp = 0; 00763 frexpr((expptr)p); 00764 return(q); 00765 } 00766 free( (charptr) q ); /* constants did not fold */ 00767 } 00768 00769 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) 00770 goto eret; 00771 00772 if (ltype == TYCHAR && ISCONST(lp)) { 00773 if (opcode == OPCONV) { 00774 hsave = halign; 00775 halign = 0; 00776 lp = (expptr)putconst((Constp)lp); 00777 halign = hsave; 00778 } 00779 else 00780 lp = (expptr)putconst((Constp)lp); 00781 p->leftp = lp; 00782 } 00783 if (rtype == TYCHAR && ISCONST(rp)) 00784 p->rightp = rp = (expptr)putconst((Constp)rp); 00785 00786 switch(opcode) 00787 { 00788 case OPCONCAT: 00789 if(p->vleng == NULL) 00790 p->vleng = mkexpr(OPPLUS, cplenexpr(lp), 00791 cplenexpr(rp) ); 00792 break; 00793 00794 case OPASSIGN: 00795 if (rtype == TYREAL || ISLOGICAL(ptype) 00796 || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp)) 00797 break; 00798 case OPPLUSEQ: 00799 case OPSTAREQ: 00800 if(ltype == rtype) 00801 break; 00802 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) ) 00803 break; 00804 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) 00805 break; 00806 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) 00807 && typesize[ltype]>=typesize[rtype] ) 00808 break; 00809 00810 /* Cast the right hand side to match the type of the expression */ 00811 00812 p->rightp = fixtype( mkconv(ptype, rp) ); 00813 break; 00814 00815 case OPSLASH: 00816 if( ISCOMPLEX(rtype) ) 00817 { 00818 p = (Exprp) call2(ptype, 00819 00820 /* Handle double precision complex variables */ 00821 00822 (char*)(ptype == TYCOMPLEX ? "c_div" : "z_div"), 00823 mkconv(ptype, lp), mkconv(ptype, rp) ); 00824 break; 00825 } 00826 case OPPLUS: 00827 case OPMINUS: 00828 case OPSTAR: 00829 case OPMOD: 00830 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) || 00831 (rtype==TYREAL && ! ISCONST(rp) ) )) 00832 break; 00833 if( ISCOMPLEX(ptype) ) 00834 break; 00835 00836 /* Cast both sides of the expression to match the type of the whole 00837 expression. */ 00838 00839 if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL)) 00840 p->leftp = fixtype(mkconv(ptype,lp)); 00841 if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL)) 00842 p->rightp = fixtype(mkconv(ptype,rp)); 00843 break; 00844 00845 case OPPOWER: 00846 rp = mkpower((expptr)p); 00847 if (rp->tag == TEXPR) 00848 rp->exprblock.typefixed = 1; 00849 return rp; 00850 00851 case OPLT: 00852 case OPLE: 00853 case OPGT: 00854 case OPGE: 00855 case OPEQ: 00856 case OPNE: 00857 if(ltype == rtype) 00858 break; 00859 if (htype) { 00860 if (ltype == TYCHAR) { 00861 p->leftp = fixtype(mkconv(rtype,lp)); 00862 break; 00863 } 00864 if (rtype == TYCHAR) { 00865 p->rightp = fixtype(mkconv(ltype,rp)); 00866 break; 00867 } 00868 } 00869 mtype = cktype(OPMINUS, ltype, rtype); 00870 if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL)) 00871 break; 00872 if( ISCOMPLEX(mtype) ) 00873 break; 00874 if(ltype != mtype) 00875 p->leftp = fixtype(mkconv(mtype,lp)); 00876 if(rtype != mtype) 00877 p->rightp = fixtype(mkconv(mtype,rp)); 00878 break; 00879 00880 case OPCONV: 00881 ptype = cktype(OPCONV, p->vtype, ltype); 00882 if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA 00883 && !ISCOMPLEX(ptype)) 00884 { 00885 lp->exprblock.rightp = 00886 fixtype( mkconv(ptype, lp->exprblock.rightp) ); 00887 free( (charptr) p ); 00888 p = (Exprp) lp; 00889 } 00890 break; 00891 00892 case OPADDR: 00893 if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR) 00894 Fatal("addr of addr"); 00895 break; 00896 00897 case OPCOMMA: 00898 case OPQUEST: 00899 case OPCOLON: 00900 break; 00901 00902 case OPMIN: 00903 case OPMAX: 00904 case OPMIN2: 00905 case OPMAX2: 00906 case OPDMIN: 00907 case OPDMAX: 00908 case OPABS: 00909 case OPDABS: 00910 ptype = p->vtype; 00911 break; 00912 00913 default: 00914 break; 00915 } 00916 00917 p->vtype = ptype; 00918 p->typefixed = 1; 00919 return((expptr) p); 00920 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 601 of file expr.c.
References badtag(), CLVAR, err, errnode, fixexpr(), keepsubs, mkfunct(), mklhs(), MSKADDR, MSKINT, MSKLOGICAL, MSKREAL, ONEOF, p, putconst(), TADDR, TCONST, TERROR, TEXPR, TLIST, TPRIM, TYSUBR, and wronginf().
Referenced by dim_finish(), doiolist(), exar2(), exarif(), excall(), exdo(), exequals(), exreturn(), fixargs(), fixexpr(), ioclause(), iosetc(), make_param(), mkexpr(), mklhs(), nextdata(), prolog(), putaddr(), putexpr(), putif(), putio(), putwhile(), retval(), startrw(), stfcall(), suboffset(), subskept(), and yyparse().
00603 { 00604 00605 if(p == 0) 00606 return(0); 00607 00608 switch(p->tag) 00609 { 00610 case TCONST: 00611 if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR| 00612 MSKREAL) ) 00613 return( (expptr) p); 00614 00615 return( (expptr) putconst((Constp)p) ); 00616 00617 case TADDR: 00618 p->addrblock.memoffset = fixtype(p->addrblock.memoffset); 00619 return( (expptr) p); 00620 00621 case TERROR: 00622 return( (expptr) p); 00623 00624 default: 00625 badtag("fixtype", p->tag); 00626 00627 /* This case means that fixexpr can't call fixtype with any expr, 00628 only a subexpr of its parameter. */ 00629 00630 case TEXPR: 00631 if (((Exprp)p)->typefixed) 00632 return (expptr)p; 00633 return( fixexpr((Exprp)p) ); 00634 00635 case TLIST: 00636 return( (expptr) p ); 00637 00638 case TPRIM: 00639 if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR) 00640 { 00641 if(p->primblock.namep->vtype == TYSUBR) 00642 { 00643 err("function invocation of subroutine"); 00644 return( errnode() ); 00645 } 00646 else { 00647 if (p->primblock.namep->vinftype) 00648 wronginf(p->primblock.namep); 00649 return( mkfunct(p) ); 00650 } 00651 } 00652 00653 /* The lack of args makes p a function name, substring reference 00654 or variable name. */ 00655 00656 else return mklhs((struct Primblock *) p, keepsubs); 00657 } 00658 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 2659 of file expr.c.
References ALLOC, badop(), Constant::blanks, Constant::ccp1, Constant::ci, ckalloc(), cmpstr(), consbinop(), consconv(), consnegop(), conspower(), Constblock::Const, Expression::constblock, Expression::exprblock, free(), frexpr(), Expression::headblock, i, ICON, int, intovfl(), ISINT, L, Exprblock::leftp, lp, lr, LRget(), 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, p, Exprblock::rightp, TCONST, TYCHAR, TYCOMPLEX, TYDCOMPLEX, TYDREAL, tyint, TYINT1, TYLONG, TYQUAD, TYREAL, TYSHORT, Constblock::vleng, Exprblock::vleng, Headblock::vtype, Exprblock::vtype, and zeroconst().
Referenced by mkexpr(), and putop().
02661 { 02662 Constp p; 02663 expptr lp, rp; 02664 int etype, mtype, ltype, rtype, opcode; 02665 ftnint i, bl, ll, lr; 02666 char *q, *s; 02667 struct Constblock lcon, rcon; 02668 ftnint L; 02669 double d; 02670 #ifndef NO_LONG_LONG 02671 Llong LL, LR; 02672 #endif 02673 02674 opcode = e->exprblock.opcode; 02675 etype = e->exprblock.vtype; 02676 02677 lp = e->exprblock.leftp; 02678 ltype = lp->headblock.vtype; 02679 rp = e->exprblock.rightp; 02680 02681 if(rp == 0) 02682 switch(opcode) 02683 { 02684 case OPNOT: 02685 #ifndef NO_LONG_LONG 02686 if (ltype == TYQUAD) 02687 lp->constblock.Const.cq = ! lp->constblock.Const.cq; 02688 else 02689 #endif 02690 lp->constblock.Const.ci = ! lp->constblock.Const.ci; 02691 retlp: 02692 e->exprblock.leftp = 0; 02693 frexpr(e); 02694 return(lp); 02695 02696 case OPBITNOT: 02697 #ifndef NO_LONG_LONG 02698 if (ltype == TYQUAD) 02699 lp->constblock.Const.cq = ~ lp->constblock.Const.cq; 02700 else 02701 #endif 02702 lp->constblock.Const.ci = ~ lp->constblock.Const.ci; 02703 goto retlp; 02704 02705 case OPNEG: 02706 case OPNEG1: 02707 consnegop((Constp)lp); 02708 goto retlp; 02709 02710 case OPCONV: 02711 case OPADDR: 02712 return(e); 02713 02714 case OPABS: 02715 case OPDABS: 02716 switch(ltype) { 02717 case TYINT1: 02718 case TYSHORT: 02719 case TYLONG: 02720 if ((L = lp->constblock.Const.ci) < 0) { 02721 lp->constblock.Const.ci = -L; 02722 if (L != -lp->constblock.Const.ci) 02723 intovfl(); 02724 } 02725 goto retlp; 02726 #ifndef NO_LONG_LONG 02727 case TYQUAD: 02728 if ((LL = lp->constblock.Const.cq) < 0) { 02729 lp->constblock.Const.cq = -LL; 02730 if (LL != -lp->constblock.Const.cq) 02731 intovfl(); 02732 } 02733 goto retlp; 02734 #endif 02735 case TYREAL: 02736 case TYDREAL: 02737 if (lp->constblock.vstg) { 02738 s = lp->constblock.Const.cds[0]; 02739 if (*s == '-') 02740 lp->constblock.Const.cds[0] = s + 1; 02741 goto retlp; 02742 } 02743 if ((d = lp->constblock.Const.cd[0]) < 0.) 02744 lp->constblock.Const.cd[0] = -d; 02745 case TYCOMPLEX: 02746 case TYDCOMPLEX: 02747 return e; /* lazy way out */ 02748 } 02749 default: 02750 badop("fold", opcode); 02751 } 02752 02753 rtype = rp->headblock.vtype; 02754 02755 p = ALLOC(Constblock); 02756 p->tag = TCONST; 02757 p->vtype = etype; 02758 p->vleng = e->exprblock.vleng; 02759 02760 switch(opcode) 02761 { 02762 case OPCOMMA: 02763 case OPCOMMA_ARG: 02764 case OPQUEST: 02765 case OPCOLON: 02766 goto ereturn; 02767 02768 case OPAND: 02769 p->Const.ci = lp->constblock.Const.ci && 02770 rp->constblock.Const.ci; 02771 break; 02772 02773 case OPOR: 02774 p->Const.ci = lp->constblock.Const.ci || 02775 rp->constblock.Const.ci; 02776 break; 02777 02778 case OPEQV: 02779 p->Const.ci = lp->constblock.Const.ci == 02780 rp->constblock.Const.ci; 02781 break; 02782 02783 case OPNEQV: 02784 p->Const.ci = lp->constblock.Const.ci != 02785 rp->constblock.Const.ci; 02786 break; 02787 02788 case OPBITAND: 02789 #ifndef NO_LONG_LONG 02790 if (etype == TYQUAD) { 02791 LRget(&LL, &LR, lp, rp); 02792 p->Const.cq = LL & LR; 02793 } 02794 else 02795 #endif 02796 p->Const.ci = lp->constblock.Const.ci & 02797 rp->constblock.Const.ci; 02798 break; 02799 02800 case OPBITOR: 02801 #ifndef NO_LONG_LONG 02802 if (etype == TYQUAD) { 02803 LRget(&LL, &LR, lp, rp); 02804 p->Const.cq = LL | LR; 02805 } 02806 else 02807 #endif 02808 p->Const.ci = lp->constblock.Const.ci | 02809 rp->constblock.Const.ci; 02810 break; 02811 02812 case OPBITXOR: 02813 #ifndef NO_LONG_LONG 02814 if (etype == TYQUAD) { 02815 LRget(&LL, &LR, lp, rp); 02816 p->Const.cq = LL ^ LR; 02817 } 02818 else 02819 #endif 02820 p->Const.ci = lp->constblock.Const.ci ^ 02821 rp->constblock.Const.ci; 02822 break; 02823 02824 case OPLSHIFT: 02825 #ifndef NO_LONG_LONG 02826 if (etype == TYQUAD) { 02827 LRget(&LL, &LR, lp, rp); 02828 p->Const.cq = LL << (int)LR; 02829 if (p->Const.cq >> (int)LR != LL) 02830 intovfl(); 02831 break; 02832 } 02833 #endif 02834 p->Const.ci = lp->constblock.Const.ci << 02835 rp->constblock.Const.ci; 02836 if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci) 02837 != lp->constblock.Const.ci) 02838 intovfl(); 02839 break; 02840 02841 case OPRSHIFT: 02842 #ifndef NO_LONG_LONG 02843 if (etype == TYQUAD) { 02844 LRget(&LL, &LR, lp, rp); 02845 p->Const.cq = LL >> (int)LR; 02846 } 02847 else 02848 #endif 02849 p->Const.ci = (unsigned long)lp->constblock.Const.ci >> 02850 rp->constblock.Const.ci; 02851 break; 02852 02853 case OPBITTEST: 02854 #ifndef NO_LONG_LONG 02855 if (ltype == TYQUAD) 02856 p->Const.ci = (lp->constblock.Const.cq & 02857 1LL << rp->constblock.Const.ci) != 0; 02858 else 02859 #endif 02860 p->Const.ci = (lp->constblock.Const.ci & 02861 1L << rp->constblock.Const.ci) != 0; 02862 break; 02863 02864 case OPBITCLR: 02865 #ifndef NO_LONG_LONG 02866 if (etype == TYQUAD) { 02867 LRget(&LL, &LR, lp, rp); 02868 p->Const.cq = LL & ~(1LL << (int)LR); 02869 } 02870 else 02871 #endif 02872 p->Const.ci = lp->constblock.Const.ci & 02873 ~(1L << rp->constblock.Const.ci); 02874 break; 02875 02876 case OPBITSET: 02877 #ifndef NO_LONG_LONG 02878 if (etype == TYQUAD) { 02879 LRget(&LL, &LR, lp, rp); 02880 p->Const.cq = LL | (1LL << (int)LR); 02881 } 02882 else 02883 #endif 02884 p->Const.ci = lp->constblock.Const.ci | 02885 1L << rp->constblock.Const.ci; 02886 break; 02887 02888 case OPCONCAT: 02889 ll = lp->constblock.vleng->constblock.Const.ci; 02890 lr = rp->constblock.vleng->constblock.Const.ci; 02891 bl = lp->constblock.Const.ccp1.blanks; 02892 p->Const.ccp = q = (char *) ckalloc(ll+lr+bl); 02893 p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks; 02894 p->vleng = ICON(ll+lr+bl); 02895 s = lp->constblock.Const.ccp; 02896 for(i = 0 ; i < ll ; ++i) 02897 *q++ = *s++; 02898 for(i = 0 ; i < bl ; i++) 02899 *q++ = ' '; 02900 s = rp->constblock.Const.ccp; 02901 for(i = 0; i < lr; ++i) 02902 *q++ = *s++; 02903 break; 02904 02905 02906 case OPPOWER: 02907 if( !ISINT(rtype) 02908 || rp->constblock.Const.ci < 0 && zeroconst(lp)) 02909 goto ereturn; 02910 conspower(p, (Constp)lp, rp->constblock.Const.ci); 02911 break; 02912 02913 case OPSLASH: 02914 if (zeroconst(rp)) 02915 goto ereturn; 02916 /* no break */ 02917 02918 default: 02919 if(ltype == TYCHAR) 02920 { 02921 lcon.Const.ci = cmpstr(lp->constblock.Const.ccp, 02922 rp->constblock.Const.ccp, 02923 lp->constblock.vleng->constblock.Const.ci, 02924 rp->constblock.vleng->constblock.Const.ci); 02925 rcon.Const.ci = 0; 02926 mtype = tyint; 02927 } 02928 else { 02929 mtype = maxtype(ltype, rtype); 02930 consconv(mtype, &lcon, &lp->constblock); 02931 consconv(mtype, &rcon, &rp->constblock); 02932 } 02933 consbinop(opcode, mtype, p, &lcon, &rcon); 02934 break; 02935 } 02936 02937 frexpr(e); 02938 return( (expptr) p ); 02939 ereturn: 02940 free((char *)p); 02941 return e; 02942 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void frexpr | ( | tagptr | p | ) |
Definition at line 516 of file expr.c.
References badtag(), Chain::datap, frchain(), free(), ISCHAR, Chain::nextp, NULL, p, TADDR, TCONST, TERROR, TEXPR, TLIST, TNAME, TPRIM, and TYERROR.
Referenced by cpexpr(), dataval(), doequiv(), doiolist(), enddo(), endio(), endioctl(), exarif(), excall(), exdo(), exequals(), expr_out(), exstop(), fixexpr(), fold(), foldminmax(), frdata(), freetemps(), frexchain(), hashclear(), inferdcl(), Inline(), ioset(), list_decls(), make_param(), mkconv(), mkcxcon(), mkexpr(), mkfunct(), mklhs(), mkpower(), mkprim(), mkscalar(), nextdata(), procinit(), putaddr(), putch1(), putcheq(), putconst(), putct1(), putcx1(), putcxeq(), putmnmx(), putop(), putpower(), putx(), settype(), startrw(), subcheck(), wr_globals(), and wr_nv_ident_help().
00518 { 00519 chainp q; 00520 00521 if(p == NULL) 00522 return; 00523 00524 switch(p->tag) 00525 { 00526 case TCONST: 00527 if( ISCHAR(p) ) 00528 { 00529 free( (charptr) (p->constblock.Const.ccp) ); 00530 frexpr(p->constblock.vleng); 00531 } 00532 break; 00533 00534 case TADDR: 00535 if (p->addrblock.vtype > TYERROR) /* i/o block */ 00536 break; 00537 frexpr(p->addrblock.vleng); 00538 frexpr(p->addrblock.memoffset); 00539 break; 00540 00541 case TERROR: 00542 break; 00543 00544 /* TNAME blocks don't get free'd - probably because they're pointed to in 00545 the hash table. 14-Jun-88 -- mwm */ 00546 00547 case TNAME: 00548 return; 00549 00550 case TPRIM: 00551 frexpr((expptr)p->primblock.argsp); 00552 frexpr(p->primblock.fcharp); 00553 frexpr(p->primblock.lcharp); 00554 break; 00555 00556 case TEXPR: 00557 frexpr(p->exprblock.leftp); 00558 if(p->exprblock.rightp) 00559 frexpr(p->exprblock.rightp); 00560 break; 00561 00562 case TLIST: 00563 for(q = p->listblock.listp ; q ; q = q->nextp) 00564 frexpr((tagptr)q->datap); 00565 frchain( &(p->listblock.listp) ); 00566 break; 00567 00568 default: 00569 badtag("frexpr", p->tag); 00570 } 00571 00572 free( (charptr) p ); 00573 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void impldcl | ( | Namep | p | ) |
Definition at line 1979 of file expr.c.
References CLPROC, dclerr(), implleng, impltype, letter, p, PINTRINSIC, settype(), and TYUNKNOWN.
Referenced by doentry(), make_param(), mkfunct(), mkstfunct(), save_argtypes(), and vardcl().
01981 { 01982 int k; 01983 int type; 01984 ftnint leng; 01985 01986 if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) ) 01987 return; 01988 if(p->vtype == TYUNKNOWN) 01989 { 01990 k = letter(p->fvarname[0]); 01991 type = impltype[ k ]; 01992 leng = implleng[ k ]; 01993 if(type == TYUNKNOWN) 01994 { 01995 if(p->vclass == CLPROC) 01996 return; 01997 dclerr("attempt to use undefined variable", p); 01998 type = dflttype[k]; 01999 leng = 0; 02000 } 02001 settype(p, type, leng); 02002 p->vimpltype = 1; 02003 } 02004 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 2012 of file expr.c.
References frexpr(), Nameblock::fvarname, impltype, letter, Nameblock::vimpltype, Nameblock::vinfproc, Nameblock::vinftype, Nameblock::vleng, and Nameblock::vtype.
Referenced by mkaddr(), and typekludge().
02014 { 02015 int k = impltype[letter(np->fvarname[0])]; 02016 if (k != type) { 02017 np->vinftype = 1; 02018 np->vtype = type; 02019 frexpr(np->vleng); 02020 np->vleng = 0; 02021 } 02022 np->vimpltype = 0; 02023 np->vinfproc = 1; 02024 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1555 of file expr.c.
References i, nregvar, regnamep, and regnum.
Referenced by memversion().
01557 { 01558 int i; 01559 01560 for(i = 0 ; i < nregvar ; ++i) 01561 if(regnamep[i] == np) 01562 return( regnum[i] ); 01563 return(-1); 01564 }
Here is the caller graph for this function:
| static void intovfl | ( | Void | ) | [static] |
Definition at line 2629 of file expr.c.
References err.
Referenced by consbinop(), consnegop(), and fold().
02630 { err("overflow simplifying integer constants."); }
Here is the caller graph for this function:
Definition at line 2637 of file expr.c.
References Constant::ci, Constblock::Const, Expression::constblock, Constant::cq, Expression::headblock, lp, TYQUAD, and Headblock::vtype.
Referenced by fold().
02639 { 02640 if (lp->headblock.vtype == TYQUAD) 02641 *Lp = lp->constblock.Const.cq; 02642 else 02643 *Lp = lp->constblock.Const.ci; 02644 if (rp->headblock.vtype == TYQUAD) 02645 *Rp = rp->constblock.Const.cq; 02646 else 02647 *Rp = rp->constblock.Const.ci; 02648 }
Here is the caller graph for this function:
Definition at line 1533 of file expr.c.
References inregister(), mkplace(), NO, NULL, s, Nameblock::vdovar, and YES.
Referenced by doiolist(), enddo(), and fixargs().
01535 { 01536 Addrp s; 01537 01538 if(np->vdovar==NO || (inregister(np)<0) ) 01539 return(NULL); 01540 np->vdovar = NO; 01541 s = mkplace(np); 01542 np->vdovar = YES; 01543 return(s); 01544 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 104 of file expr.c.
References mkconst(), p, and TYADDR.
Referenced by startrw().
00106 { 00107 Constp p; 00108 00109 p = mkconst(TYADDR); 00110 p->Const.ci = l; 00111 return( (expptr) p ); 00112 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1726 of file expr.c.
References addunder(), ALLOC, badstg(), CLPROC, cpexpr(), errstr(), Extsym::exproto, Extsym::extstg, extsymtab, Extsym::extype, ICON, inferdcl(), infertypes, intraddr(), ISICON, mkext(), p, PEXTERNAL, PTHISPROC, putconst(), STGARG, STGAUTO, STGBSS, STGCOMMON, STGEQUIV, STGEXT, STGINIT, STGINTR, STGLENG, STGSTFUNCT, STGUNKNOWN, t, TADDR, TYUNKNOWN, UNAM_NAME, and xretslot.
Referenced by fixargs(), mkfunct(), mkscalar(), and nextdata().
01728 { 01729 Extsym *extp; 01730 Addrp t; 01731 int k; 01732 01733 switch( p->vstg) 01734 { 01735 case STGAUTO: 01736 if(p->vclass == CLPROC && p->vprocclass == PTHISPROC) 01737 return (Addrp) cpexpr((expptr)xretslot[p->vtype]); 01738 goto other; 01739 01740 case STGUNKNOWN: 01741 if(p->vclass != CLPROC) 01742 break; /* Error */ 01743 extp = mkext(p->fvarname, addunder(p->cvarname)); 01744 extp->extstg = STGEXT; 01745 p->vstg = STGEXT; 01746 p->vardesc.varno = extp - extsymtab; 01747 p->vprocclass = PEXTERNAL; 01748 if ((extp->exproto || infertypes) 01749 && (p->vtype == TYUNKNOWN || p->vimpltype) 01750 && (k = extp->extype)) 01751 inferdcl(p, k); 01752 01753 01754 case STGCOMMON: 01755 case STGEXT: 01756 case STGBSS: 01757 case STGINIT: 01758 case STGEQUIV: 01759 case STGARG: 01760 case STGLENG: 01761 other: 01762 t = ALLOC(Addrblock); 01763 t->tag = TADDR; 01764 01765 t->vclass = p->vclass; 01766 t->vtype = p->vtype; 01767 t->vstg = p->vstg; 01768 t->memno = p->vardesc.varno; 01769 t->memoffset = ICON(p->voffset); 01770 if (p->vdim) 01771 t->isarray = 1; 01772 if(p->vleng) 01773 { 01774 t->vleng = (expptr) cpexpr(p->vleng); 01775 if( ISICON(t->vleng) ) 01776 t->varleng = t->vleng->constblock.Const.ci; 01777 } 01778 01779 /* Keep the original name around for the C code generation */ 01780 01781 t -> uname_tag = UNAM_NAME; 01782 t -> user.name = p; 01783 return(t); 01784 01785 case STGINTR: 01786 01787 return ( intraddr (p)); 01788 01789 case STGSTFUNCT: 01790 01791 errstr("invalid use of statement function %.64s.", p->fvarname); 01792 return putconst((Constp)ICON(0)); 01793 } 01794 badstg("mkaddr", p->vstg); 01795 /* NOT REACHED */ return 0; 01796 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1811 of file expr.c.
References ALLOC, CLVAR, p, STGARG, STGLENG, TADDR, and TYLENG.
Referenced by doentry().
01813 { 01814 Addrp p; 01815 01816 p = ALLOC(Addrblock); 01817 p->tag = TADDR; 01818 p->vtype = type; 01819 p->vclass = CLVAR; 01820 01821 /* TYLENG is the type of the field holding the length of a character string */ 01822 01823 p->vstg = (type==TYLENG ? STGLENG : STGARG); 01824 p->memno = argno; 01825 return(p); 01826 }
Here is the caller graph for this function:
Definition at line 149 of file expr.c.
References allow_i8c, err, ff, hextoi, len, m, mkconst(), p, TYLONG, TYQUAD, x, y, and z.
Referenced by yyparse().
00151 { 00152 Constp p; 00153 unsigned long m, ovfl, x, y, z; 00154 int L32, len; 00155 char buff[100], *s0 = s; 00156 #ifndef NO_LONG_LONG 00157 ULlong u; 00158 #endif 00159 static char *kind[3] = { "Binary", "Hex", "Octal" }; 00160 00161 p = mkconst(TYLONG); 00162 /* Song and dance to convert to TYQUAD only if ftnint is too small. */ 00163 m = x = y = ovfl = 0; 00164 /* Older C compilers may not know about */ 00165 /* UL suffixes on hex constants... */ 00166 while(--leng >= 0) 00167 if(*s != ' ') { 00168 if (!m) { 00169 z = x; 00170 x = ((x << shift) | hextoi(*s++)) & ff; 00171 if (!((x >> shift) - z)) 00172 continue; 00173 m = (ff << (L32 = 32 - shift)) & ff; 00174 --s; 00175 x = z; 00176 } 00177 ovfl |= y & m; 00178 y = y << shift | (x >> L32); 00179 x = ((x << shift) | hextoi(*s++)) & ff; 00180 } 00181 /* Don't change the type to short for short constants, as 00182 * that is dangerous -- there is no syntax for long constants 00183 * with small values. 00184 */ 00185 p->Const.ci = (ftnint)x; 00186 #ifndef NO_LONG_LONG 00187 if (m) { 00188 if (allow_i8c) { 00189 u = y; 00190 p->Const.ucq = (u << 32) | x; 00191 p->vtype = TYQUAD; 00192 } 00193 else 00194 ovfl = 1; 00195 } 00196 #else 00197 ovfl |= m; 00198 #endif 00199 if (ovfl) { 00200 if (--shift == 3) 00201 shift = 1; 00202 if ((len = (int)leng) > 60) 00203 sprintf(buff, "%s constant '%.60s' truncated.", 00204 kind[shift], s0); 00205 else 00206 sprintf(buff, "%s constant '%.*s' truncated.", 00207 kind[shift], len, s0); 00208 err(buff); 00209 } 00210 return( (expptr) p ); 00211 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 46 of file expr.c.
References ALLOC, p, and TCONST.
Referenced by make_param(), mkaddcon(), mkbitcon(), mkconv(), mkcxcon(), mkintcon(), mkintqcon(), mklogcon(), mkrealcon(), and mkstrcon().
00048 { 00049 Constp p; 00050 00051 p = ALLOC(Constblock); 00052 p->tag = TCONST; 00053 p->vtype = t; 00054 return(p); 00055 }
Here is the caller graph for this function:
Definition at line 326 of file expr.c.
References badtype(), consconv(), Expression::constblock, frexpr(), halign, ICON, ISCONST, ISINT, ISREAL, mkconst(), opconv(), p, pt, TADDR, TYADDR, TYCHAR, TYERROR, TYQUAD, TYUNKNOWN, UNAM_CONST, Constblock::vleng, Constblock::vstg, and warn().
Referenced by cast_args(), exdo(), exreturn(), fixexpr(), foldminmax(), Inline(), intrcall(), make_param(), mkpower(), putio(), putmnmx(), putop(), putx(), retval(), stfcall(), subcheck(), and suboffset().
00328 { 00329 expptr q; 00330 int pt, charwarn = 1; 00331 00332 if (t >= 100) { 00333 t -= 100; 00334 charwarn = 0; 00335 } 00336 if(t==TYUNKNOWN || t==TYERROR) 00337 badtype("mkconv", t); 00338 pt = p->headblock.vtype; 00339 00340 /* Casting to the same type is a no-op */ 00341 00342 if(t == pt) 00343 return(p); 00344 00345 /* If we're casting a constant which is not in the literal table ... */ 00346 00347 else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR 00348 || p->tag == TADDR && p->addrblock.uname_tag == UNAM_CONST) 00349 { 00350 #ifndef NO_LONG_LONG 00351 if (t != TYQUAD && pt != TYQUAD) /*20010820*/ 00352 #endif 00353 if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) { 00354 /* avoid trouble with -i2 */ 00355 p->headblock.vtype = t; 00356 return p; 00357 } 00358 q = (expptr) mkconst(t); 00359 consconv(t, &q->constblock, &p->constblock ); 00360 if (p->tag == TADDR) 00361 q->constblock.vstg = p->addrblock.user.kludge.vstg1; 00362 frexpr(p); 00363 } 00364 else { 00365 if (pt == TYCHAR && t != TYADDR && charwarn 00366 && (!halign || p->tag != TADDR 00367 || p->addrblock.uname_tag != UNAM_CONST)) 00368 warn( 00369 "ichar([first char. of] char. string) assumed for conversion to numeric"); 00370 q = opconv(p, t); 00371 } 00372 00373 if(t == TYCHAR) 00374 q->constblock.vleng = ICON(1); 00375 return(q); 00376 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 253 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(), tycomplex, TYDCOMPLEX, TYDREAL, Constblock::vstg, and Headblock::vtype.
Referenced by intrcall(), and yyparse().
00255 { 00256 int rtype, itype; 00257 Constp p; 00258 00259 rtype = realp->headblock.vtype; 00260 itype = imagp->headblock.vtype; 00261 00262 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) ) 00263 { 00264 p = mkconst( (rtype==TYDREAL||itype==TYDREAL) 00265 ? TYDCOMPLEX : tycomplex); 00266 if (realp->constblock.vstg || imagp->constblock.vstg) { 00267 p->vstg = 1; 00268 p->Const.cds[0] = ISINT(rtype) 00269 ? string_num("", realp->constblock.Const.ci) 00270 : realp->constblock.vstg 00271 ? realp->constblock.Const.cds[0] 00272 : dtos(realp->constblock.Const.cd[0]); 00273 p->Const.cds[1] = ISINT(itype) 00274 ? string_num("", imagp->constblock.Const.ci) 00275 : imagp->constblock.vstg 00276 ? imagp->constblock.Const.cds[0] 00277 : dtos(imagp->constblock.Const.cd[0]); 00278 } 00279 else { 00280 p->Const.cd[0] = ISINT(rtype) 00281 ? realp->constblock.Const.ci 00282 : realp->constblock.Const.cd[0]; 00283 p->Const.cd[1] = ISINT(itype) 00284 ? imagp->constblock.Const.ci 00285 : imagp->constblock.Const.cd[0]; 00286 } 00287 } 00288 else 00289 { 00290 err("invalid complex constant"); 00291 p = (Constp)errnode(); 00292 } 00293 00294 frexpr(realp); 00295 frexpr(imagp); 00296 return( (expptr) p ); 00297 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 2094 of file expr.c.
References ALLOC, Primblock::argsp, badop(), Constant::ci, cktype(), COMMUTE, consnegop(), Constblock::Const, Expression::constblock, ENULL, errnode, error, Expression::exprblock, fixtype(), fold(), free(), frexpr(), Expression::headblock, ICON, ICONEQ, INEXEC, is_negatable(), ISCONST, ISICON, ISINT, ISPLUSOP, L, Exprblock::leftp, lineno, lp, Primblock::namep, NULL, 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, paren_used(), parstate, Expression::primblock, Exprblock::rightp, Exprblock::tag, Constblock::tag, Expression::tag, TCONST, TEXPR, TPRIM, TYERROR, TYUNKNOWN, Exprblock::vtype, Headblock::vtype, warn(), and zeroconst().
Referenced by addrfix(), addrof(), callk(), cktype1(), 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(), putch1(), putchcmp(), putcheq(), putct1(), putcx1(), putcxcmp(), putcxeq(), puteq(), putio(), putiocall(), putmnmx(), putop(), putpower(), putsteq(), ref_defs(), stfcall(), subcheck(), suboffset(), subskept(), and yyparse().
02096 { 02097 expptr e, e1; 02098 int etype; 02099 int ltype, rtype; 02100 int ltag, rtag; 02101 long L; 02102 static long divlineno; 02103 02104 if (parstate < INEXEC) { 02105 02106 /* Song and dance to get statement functions right */ 02107 /* while catching incorrect type combinations in the */ 02108 /* first executable statement. */ 02109 02110 ltype = lp->headblock.vtype; 02111 ltag = lp->tag; 02112 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 02113 { 02114 rtype = rp->headblock.vtype; 02115 rtag = rp->tag; 02116 } 02117 else rtype = 0; 02118 02119 etype = cktype(opcode, ltype, rtype); 02120 if(etype == TYERROR) 02121 goto error; 02122 goto no_fold; 02123 } 02124 02125 ltype = lp->headblock.vtype; 02126 if (ltype == TYUNKNOWN) { 02127 lp = fixtype(lp); 02128 ltype = lp->headblock.vtype; 02129 } 02130 ltag = lp->tag; 02131 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 02132 { 02133 rtype = rp->headblock.vtype; 02134 if (rtype == TYUNKNOWN) { 02135 rp = fixtype(rp); 02136 rtype = rp->headblock.vtype; 02137 } 02138 rtag = rp->tag; 02139 } 02140 else rtype = 0; 02141 02142 etype = cktype(opcode, ltype, rtype); 02143 if(etype == TYERROR) 02144 goto error; 02145 02146 switch(opcode) 02147 { 02148 /* check for multiplication by 0 and 1 and addition to 0 */ 02149 02150 case OPSTAR: 02151 if( ISCONST(lp) ) 02152 COMMUTE 02153 02154 if( ISICON(rp) ) 02155 { 02156 if(rp->constblock.Const.ci == 0) 02157 goto retright; 02158 goto mulop; 02159 } 02160 break; 02161 02162 case OPSLASH: 02163 case OPMOD: 02164 if( zeroconst(rp) && lineno != divlineno ) { 02165 warn("attempted division by zero"); 02166 divlineno = lineno; 02167 } 02168 if(opcode == OPMOD) 02169 break; 02170 02171 /* Handle multiplying or dividing by 1, -1 */ 02172 02173 mulop: 02174 if( ISICON(rp) ) 02175 { 02176 if(rp->constblock.Const.ci == 1) 02177 goto retleft; 02178 02179 if(rp->constblock.Const.ci == -1) 02180 { 02181 frexpr(rp); 02182 return( mkexpr(OPNEG, lp, ENULL) ); 02183 } 02184 } 02185 02186 /* Group all constants together. In particular, 02187 02188 (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2) 02189 (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2) 02190 */ 02191 02192 if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp 02193 || !ISICON(lp->exprblock.rightp)) 02194 break; 02195 02196 if (lp->exprblock.opcode == OPLSHIFT) { 02197 L = 1 << lp->exprblock.rightp->constblock.Const.ci; 02198 if (opcode == OPSTAR || ISICON(rp) && 02199 !(L % rp->constblock.Const.ci)) { 02200 lp->exprblock.opcode = OPSTAR; 02201 lp->exprblock.rightp->constblock.Const.ci = L; 02202 } 02203 } 02204 02205 if (lp->exprblock.opcode == OPSTAR) { 02206 if(opcode == OPSTAR) 02207 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp); 02208 else if(ISICON(rp) && 02209 (lp->exprblock.rightp->constblock.Const.ci % 02210 rp->constblock.Const.ci) == 0) 02211 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp); 02212 else break; 02213 02214 e1 = lp->exprblock.leftp; 02215 free( (charptr) lp ); 02216 return( mkexpr(OPSTAR, e1, e) ); 02217 } 02218 break; 02219 02220 02221 case OPPLUS: 02222 if( ISCONST(lp) ) 02223 COMMUTE 02224 goto addop; 02225 02226 case OPMINUS: 02227 if( ICONEQ(lp, 0) ) 02228 { 02229 frexpr(lp); 02230 return( mkexpr(OPNEG, rp, ENULL) ); 02231 } 02232 02233 if( ISCONST(rp) && is_negatable((Constp)rp)) 02234 { 02235 opcode = OPPLUS; 02236 consnegop((Constp)rp); 02237 } 02238 02239 /* Group constants in an addition expression (also subtraction, since the 02240 subtracted value was negated above). In particular, 02241 02242 (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2) 02243 */ 02244 02245 addop: 02246 if( ISICON(rp) ) 02247 { 02248 if(rp->constblock.Const.ci == 0) 02249 goto retleft; 02250 if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) ) 02251 { 02252 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp); 02253 e1 = lp->exprblock.leftp; 02254 free( (charptr) lp ); 02255 return( mkexpr(OPPLUS, e1, e) ); 02256 } 02257 } 02258 if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) { 02259 /* check for (i [+const]) - (i [+const]) */ 02260 if (lp->tag == TPRIM) 02261 e = lp; 02262 else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS 02263 && lp->exprblock.rightp->tag == TCONST) { 02264 e = lp->exprblock.leftp; 02265 if (e->tag != TPRIM) 02266 break; 02267 } 02268 else 02269 break; 02270 if (e->primblock.argsp) 02271 break; 02272 if (rp->tag == TPRIM) 02273 e1 = rp; 02274 else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS 02275 && rp->exprblock.rightp->tag == TCONST) { 02276 e1 = rp->exprblock.leftp; 02277 if (e1->tag != TPRIM) 02278 break; 02279 } 02280 else 02281 break; 02282 if (e->primblock.namep != e1->primblock.namep 02283 || e1->primblock.argsp) 02284 break; 02285 L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci; 02286 if (e1 != rp) 02287 L -= rp->exprblock.rightp->constblock.Const.ci; 02288 frexpr(lp); 02289 frexpr(rp); 02290 return ICON(L); 02291 } 02292 02293 break; 02294 02295 02296 case OPPOWER: 02297 break; 02298 02299 /* Eliminate outermost double negations */ 02300 02301 case OPNEG: 02302 case OPNEG1: 02303 if(ltag==TEXPR && lp->exprblock.opcode==OPNEG) 02304 { 02305 e = lp->exprblock.leftp; 02306 free( (charptr) lp ); 02307 return(e); 02308 } 02309 break; 02310 02311 /* Eliminate outermost double NOTs */ 02312 02313 case OPNOT: 02314 if(ltag==TEXPR && lp->exprblock.opcode==OPNOT) 02315 { 02316 e = lp->exprblock.leftp; 02317 free( (charptr) lp ); 02318 return(e); 02319 } 02320 break; 02321 02322 case OPCALL: 02323 case OPCCALL: 02324 etype = ltype; 02325 if(rp!=NULL && rp->listblock.listp==NULL) 02326 { 02327 free( (charptr) rp ); 02328 rp = NULL; 02329 } 02330 break; 02331 02332 case OPAND: 02333 case OPOR: 02334 if( ISCONST(lp) ) 02335 COMMUTE 02336 02337 if( ISCONST(rp) ) 02338 { 02339 if(rp->constblock.Const.ci == 0) 02340 if(opcode == OPOR) 02341 goto retleft; 02342 else 02343 goto retright; 02344 else if(opcode == OPOR) 02345 goto retright; 02346 else 02347 goto retleft; 02348 } 02349 case OPEQV: 02350 case OPNEQV: 02351 02352 case OPBITAND: 02353 case OPBITOR: 02354 case OPBITXOR: 02355 case OPBITNOT: 02356 case OPLSHIFT: 02357 case OPRSHIFT: 02358 case OPBITTEST: 02359 case OPBITCLR: 02360 case OPBITSET: 02361 #ifdef TYQUAD 02362 case OPQBITCLR: 02363 case OPQBITSET: 02364 #endif 02365 02366 case OPLT: 02367 case OPGT: 02368 case OPLE: 02369 case OPGE: 02370 case OPEQ: 02371 case OPNE: 02372 02373 case OPCONCAT: 02374 break; 02375 case OPMIN: 02376 case OPMAX: 02377 case OPMIN2: 02378 case OPMAX2: 02379 case OPDMIN: 02380 case OPDMAX: 02381 02382 case OPASSIGN: 02383 case OPASSIGNI: 02384 case OPPLUSEQ: 02385 case OPSTAREQ: 02386 case OPMINUSEQ: 02387 case OPSLASHEQ: 02388 case OPMODEQ: 02389 case OPLSHIFTEQ: 02390 case OPRSHIFTEQ: 02391 case OPBITANDEQ: 02392 case OPBITXOREQ: 02393 case OPBITOREQ: 02394 02395 case OPCONV: 02396 case OPADDR: 02397 case OPWHATSIN: 02398 02399 case OPCOMMA: 02400 case OPCOMMA_ARG: 02401 case OPQUEST: 02402 case OPCOLON: 02403 case OPDOT: 02404 case OPARROW: 02405 case OPIDENTITY: 02406 case OPCHARCAST: 02407 case OPABS: 02408 case OPDABS: 02409 break; 02410 02411 default: 02412 badop("mkexpr", opcode); 02413 } 02414 02415 no_fold: 02416 e = (expptr) ALLOC(Exprblock); 02417 e->exprblock.tag = TEXPR; 02418 e->exprblock.opcode = opcode; 02419 e->exprblock.vtype = etype; 02420 e->exprblock.leftp = lp; 02421 e->exprblock.rightp = rp; 02422 if(ltag==TCONST && (rp==0 || rtag==TCONST) ) 02423 e = fold(e); 02424 return(e); 02425 02426 retleft: 02427 frexpr(rp); 02428 if (lp->tag == TPRIM) 02429 paren_used(&lp->primblock); 02430 return(lp); 02431 02432 retright: 02433 frexpr(lp); 02434 if (rp->tag == TPRIM) 02435 paren_used(&rp->primblock); 02436 return(rp); 02437 02438 error: 02439 frexpr(lp); 02440 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 02441 frexpr(rp); 02442 return( errnode() ); 02443 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1052 of file expr.c.
References addunder(), adjust_arginfo(), builtin(), Extsym::cextname, CLPROC, CLUNKNOWN, cpexpr(), Nameblock::cvarname, dclerr(), dcomplex_seen, Entrypoint::enamep, Entrypoint::entnextp, entries, Entrypoint::entryname, err, errnode, error, errstr(), Expression::exprblock, Extsym::extseen, Extsym::extstg, extsymtab, Fatal(), fatali(), fatalstr(), fixargs(), free(), frexpr(), Nameblock::fvarname, impldcl(), intrcall(), intrfunct(), letter, mkaddr(), mkchain(), mkexpr(), mkext(), new_procs, NULL, OPCALL, p, PEXTERNAL, PINTRINSIC, PSTFUNCT, PTHISPROC, stfcall(), STGARG, STGCOMMON, STGEXT, STGINTR, STGUNKNOWN, TPRIM, TYCHAR, TYSUBR, TYUNKNOWN, Nameblock::vardesc, Nameblock::varno, Nameblock::vcalled, Nameblock::vclass, Nameblock::vimpltype, Exprblock::vleng, Nameblock::vleng, Nameblock::vprocclass, Nameblock::vstg, Exprblock::vtype, Nameblock::vtype, warn(), and zflag.
Referenced by excall(), and fixtype().
01054 { 01055 struct Primblock *p = (struct Primblock *)p0; 01056 struct Entrypoint *ep; 01057 Addrp ap; 01058 Extsym *extp; 01059 Namep np; 01060 expptr q; 01061 extern chainp new_procs; 01062 int k, nargs; 01063 int vclass; 01064 01065 if(p->tag != TPRIM) 01066 return( errnode() ); 01067 01068 np = p->namep; 01069 vclass = np->vclass; 01070 01071 01072 if(vclass == CLUNKNOWN) 01073 { 01074 np->vclass = vclass = CLPROC; 01075 if(np->vstg == STGUNKNOWN) 01076 { 01077 if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname)) 01078 && (zflag || !(*(struct Intrpacked *)&k).f4 01079 || dcomplex_seen)) 01080 { 01081 np->vstg = STGINTR; 01082 np->vardesc.varno = k; 01083 np->vprocclass = PINTRINSIC; 01084 } 01085 else 01086 { 01087 extp = mkext(np->fvarname, 01088 addunder(np->cvarname)); 01089 extp->extstg = STGEXT; 01090 np->vstg = STGEXT; 01091 np->vardesc.varno = extp - extsymtab; 01092 np->vprocclass = PEXTERNAL; 01093 } 01094 } 01095 else if(np->vstg==STGARG) 01096 { 01097 if(np->vtype == TYCHAR) { 01098 adjust_arginfo(np); 01099 if (np->vpassed) { 01100 char wbuf[160], *who; 01101 who = np->fvarname; 01102 sprintf(wbuf, "%s%s%s\n\t%s%s%s", 01103 "Character-valued dummy procedure ", 01104 who, " not declared EXTERNAL.", 01105 "Code may be wrong for previous function calls having ", 01106 who, " as a parameter."); 01107 warn(wbuf); 01108 } 01109 } 01110 np->vprocclass = PEXTERNAL; 01111 } 01112 } 01113 01114 if(vclass != CLPROC) { 01115 if (np->vstg == STGCOMMON) 01116 fatalstr( 01117 "Cannot invoke common variable %.50s as a function.", 01118 np->fvarname); 01119 errstr("%.80s cannot be called.", np->fvarname); 01120 goto error; 01121 } 01122 01123 /* F77 doesn't allow subscripting of function calls */ 01124 01125 if(p->fcharp || p->lcharp) 01126 { 01127 err("no substring of function call"); 01128 goto error; 01129 } 01130 impldcl(np); 01131 np->vimpltype = 0; /* invoking as function ==> inferred type */ 01132 np->vcalled = 1; 01133 nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp); 01134 01135 switch(np->vprocclass) 01136 { 01137 case PEXTERNAL: 01138 if(np->vtype == TYUNKNOWN) 01139 { 01140 dclerr("attempt to use untyped function", np); 01141 np->vtype = dflttype[letter(np->fvarname[0])]; 01142 } 01143 ap = mkaddr(np); 01144 if (!extsymtab[np->vardesc.varno].extseen) { 01145 new_procs = mkchain((char *)np, new_procs); 01146 extsymtab[np->vardesc.varno].extseen = 1; 01147 } 01148 call: 01149 q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp); 01150 q->exprblock.vtype = np->vtype; 01151 if(np->vleng) 01152 q->exprblock.vleng = (expptr) cpexpr(np->vleng); 01153 break; 01154 01155 case PINTRINSIC: 01156 q = intrcall(np, p->argsp, nargs); 01157 break; 01158 01159 case PSTFUNCT: 01160 q = stfcall(np, p->argsp); 01161 break; 01162 01163 case PTHISPROC: 01164 warn("recursive call"); 01165 01166 /* entries is the list of multiple entry points */ 01167 01168 for(ep = entries ; ep ; ep = ep->entnextp) 01169 if(ep->enamep == np) 01170 break; 01171 if(ep == NULL) 01172 Fatal("mkfunct: impossible recursion"); 01173 01174 ap = builtin(np->vtype, ep->entryname->cextname, -2); 01175 /* the negative last arg prevents adding */ 01176 /* this name to the list of used builtins */ 01177 goto call; 01178 01179 default: 01180 fatali("mkfunct: impossible vprocclass %d", 01181 (int) (np->vprocclass) ); 01182 } 01183 free( (charptr) p ); 01184 return(q); 01185 01186 error: 01187 frexpr((expptr)p); 01188 return( errnode() ); 01189 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 84 of file expr.c.
References mkconst(), p, and tyint.
Referenced by exassign(), intrcall(), mkintqcon(), nextdata(), out_addr(), and putcx1().
00086 { 00087 Constp p; 00088 00089 p = mkconst(tyint); 00090 p->Const.ci = l; 00091 return( (expptr) p ); 00092 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1430 of file expr.c.
References Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), fixtype(), free(), frexpr(), ICON, ISCONST, mkexpr(), mkplace(), Dimblock::ndim, NULL, OPMINUS, OPPLUS, p, s, sserr(), STGREG, suboffset(), subskept(), substrerr(), TADDR, TPRIM, TYCHAR, Nameblock::vdim, Nameblock::vleng, and Nameblock::vtype.
Referenced by exequals(), fixtype(), and nextdata().
01432 { 01433 Addrp s; 01434 Namep np; 01435 01436 if(p->tag != TPRIM) 01437 return( (expptr) p ); 01438 np = p->namep; 01439 01440 replaced = 0; 01441 s = mkplace(np); 01442 if(s->tag!=TADDR || s->vstg==STGREG) 01443 { 01444 free( (charptr) p ); 01445 return( (expptr) s ); 01446 } 01447 s->parenused = p->parenused; 01448 01449 /* compute the address modified by subscripts */ 01450 01451 if (!replaced) 01452 s->memoffset = (subkeep && np->vdim && p->argsp 01453 && (np->vdim->ndim > 1 || np->vtype == TYCHAR 01454 && (!ISCONST(np->vleng) 01455 || np->vleng->constblock.Const.ci != 1))) 01456 ? subskept(p,s) 01457 : mkexpr(OPPLUS, s->memoffset, suboffset(p) ); 01458 frexpr((expptr)p->argsp); 01459 p->argsp = NULL; 01460 01461 /* now do substring part */ 01462 01463 if(p->fcharp || p->lcharp) 01464 { 01465 if(np->vtype != TYCHAR) 01466 sserr(np); 01467 else { 01468 if(p->lcharp == NULL) 01469 p->lcharp = (expptr)( 01470 /* s->vleng == 0 only with errors */ 01471 s->vleng ? cpexpr(s->vleng) : ICON(1)); 01472 else if (ISCONST(p->lcharp) 01473 && ISCONST(np->vleng) 01474 && p->lcharp->constblock.Const.ci 01475 > np->vleng->constblock.Const.ci) 01476 substrerr(np); 01477 if(p->fcharp) { 01478 doing_vleng = 1; 01479 s->vleng = fixtype(mkexpr(OPMINUS, 01480 p->lcharp, 01481 mkexpr(OPMINUS, p->fcharp, ICON(1) ))); 01482 doing_vleng = 0; 01483 } 01484 else { 01485 frexpr(s->vleng); 01486 s->vleng = p->lcharp; 01487 } 01488 if (s->memoffset 01489 && ISCONST(s->memoffset) 01490 && s->memoffset->constblock.Const.ci < 0) 01491 substrerr(np); 01492 } 01493 } 01494 01495 s->vleng = fixtype( s->vleng ); 01496 s->memoffset = fixtype( s->memoffset ); 01497 free( (charptr) p ); 01498 return( (expptr) s ); 01499 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1330 of file expr.c.
References cpexpr(), rpllist, Rplblock::rplnextp, Rplblock::rplnp, Rplblock::rpltag, Rplblock::rplvp, and TNAME.
Referenced by enddo(), exasgoto(), exassign(), exdo(), memversion(), and mklhs().
01332 { 01333 Addrp s; 01334 struct Rplblock *rp; 01335 int regn; 01336 01337 /* is name on the replace list? */ 01338 01339 for(rp = rpllist ; rp ; rp = rp->rplnextp) 01340 { 01341 if(np == rp->rplnp) 01342 { 01343 replaced = 1; 01344 if(rp->rpltag == TNAME) 01345 { 01346 np = (Namep) (rp->rplvp); 01347 break; 01348 } 01349 else return( (Addrp) cpexpr(rp->rplvp) ); 01350 } 01351 } 01352 01353 /* is variable a DO index in a register ? */ 01354 01355 if(np->vdovar && ( (regn = inregister(np)) >= 0) ) 01356 if(np->vtype == TYERROR) 01357 return((Addrp) errnode() ); 01358 else 01359 { 01360 s = ALLOC(Addrblock); 01361 s->tag = TADDR; 01362 s->vstg = STGREG; 01363 s->vtype = TYIREG; 01364 s->memno = regn; 01365 s->memoffset = ICON(0); 01366 s -> uname_tag = UNAM_NAME; 01367 s -> user.name = np; 01368 return(s); 01369 } 01370 01371 if (np->vclass == CLPROC && np->vprocclass != PTHISPROC) 01372 errstr("external %.60s used as a variable", np->fvarname); 01373 vardcl(np); 01374 return(mkaddr(np)); 01375 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 3591 of file expr.c.
References Expression::addrblock, call2(), callk_kludge, Constant::ci, Constblock::Const, Expression::constblock, err, errnode, fixexpr(), free(), frexpr(), Expression::headblock, ICON, ISCONST, ISICON, ISINT, ISREAL, lp, M, maxtype(), mkconv(), mkexpr(), MSKINT, MSKREAL, ONEOF, OPSLASH, p, Addrblock::parenused, putconst(), TADDR, Expression::tag, TYCOMPLEX, TYDCOMPLEX, TYDREAL, tyint, TYINT1, TYLONG, TYQUAD, TYSHORT, and Headblock::vtype.
Referenced by fixexpr().
03593 { 03594 expptr q, lp, rp; 03595 int ltype, rtype, mtype, tyi; 03596 03597 lp = p->exprblock.leftp; 03598 rp = p->exprblock.rightp; 03599 ltype = lp->headblock.vtype; 03600 rtype = rp->headblock.vtype; 03601 03602 if (lp->tag == TADDR) 03603 lp->addrblock.parenused = 0; 03604 03605 if (rp->tag == TADDR) 03606 rp->addrblock.parenused = 0; 03607 03608 if(ISICON(rp)) 03609 { 03610 if(rp->constblock.Const.ci == 0) 03611 { 03612 frexpr(p); 03613 if( ISINT(ltype) ) 03614 return( ICON(1) ); 03615 else if (ISREAL (ltype)) 03616 return mkconv (ltype, ICON (1)); 03617 else 03618 return( (expptr) putconst((Constp) 03619 mkconv(ltype, ICON(1))) ); 03620 } 03621 if(rp->constblock.Const.ci < 0) 03622 { 03623 if( ISINT(ltype) ) 03624 { 03625 frexpr(p); 03626 err("integer**negative"); 03627 return( errnode() ); 03628 } 03629 rp->constblock.Const.ci = - rp->constblock.Const.ci; 03630 p->exprblock.leftp = lp 03631 = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp)); 03632 } 03633 if(rp->constblock.Const.ci == 1) 03634 { 03635 frexpr(rp); 03636 free( (charptr) p ); 03637 return(lp); 03638 } 03639 03640 if( ONEOF(ltype, MSKINT|MSKREAL) ) { 03641 p->exprblock.vtype = ltype; 03642 return(p); 03643 } 03644 } 03645 if( ISINT(rtype) ) 03646 { 03647 if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) ) 03648 q = call2(TYSHORT, "pow_hh", lp, rp); 03649 else { 03650 if(ONEOF(ltype,M(TYINT1)|M(TYSHORT))) 03651 { 03652 ltype = TYLONG; 03653 lp = mkconv(TYLONG,lp); 03654 } 03655 #ifdef TYQUAD 03656 if (ltype == TYQUAD) 03657 rp = mkconv(TYQUAD,rp); 03658 else 03659 #endif 03660 rp = mkconv(TYLONG,rp); 03661 if (ISCONST(rp)) { 03662 tyi = tyint; 03663 tyint = TYLONG; 03664 rp = (expptr)putconst((Constp)rp); 03665 tyint = tyi; 03666 } 03667 q = call2(ltype, powint[ltype-TYLONG], lp, rp); 03668 } 03669 } 03670 else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) { 03671 extern int callk_kludge; 03672 callk_kludge = TYDREAL; 03673 q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp)); 03674 callk_kludge = 0; 03675 } 03676 else { 03677 q = call2(TYDCOMPLEX, "pow_zz", 03678 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp)); 03679 if(mtype == TYCOMPLEX) 03680 q = mkconv(TYCOMPLEX, q); 03681 } 03682 free( (charptr) p ); 03683 return(q); 03684 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1844 of file expr.c.
References ALLOC, args, CLPARAM, cpexpr(), Chain::datap, errnode, errstr(), frchain(), frexpr(), Chain::nextp, p, and TPRIM.
Referenced by excall(), and yyparse().
01846 { 01847 typedef union { 01848 struct Paramblock paramblock; 01849 struct Nameblock nameblock; 01850 struct Headblock headblock; 01851 } *Primu; 01852 Primu v = (Primu)v0; 01853 struct Primblock *p; 01854 01855 if(v->headblock.vclass == CLPARAM) 01856 { 01857 01858 /* v is to be a Paramblock */ 01859 01860 if(args || substr) 01861 { 01862 errstr("no qualifiers on parameter name %s", 01863 v->paramblock.fvarname); 01864 frexpr((expptr)args); 01865 if(substr) 01866 { 01867 frexpr((tagptr)substr->datap); 01868 frexpr((tagptr)substr->nextp->datap); 01869 frchain(&substr); 01870 } 01871 frexpr((expptr)v); 01872 return( errnode() ); 01873 } 01874 return( (expptr) cpexpr(v->paramblock.paramval) ); 01875 } 01876 01877 p = ALLOC(Primblock); 01878 p->tag = TPRIM; 01879 p->vtype = v->nameblock.vtype; 01880 01881 /* v is to be a Nameblock */ 01882 01883 p->namep = (Namep) v; 01884 p->argsp = args; 01885 if(substr) 01886 { 01887 p->fcharp = (expptr) substr->datap; 01888 p->lcharp = (expptr) substr->nextp->datap; 01889 frchain(&substr); 01890 } 01891 return( (expptr) p); 01892 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 125 of file expr.c.
References cds(), CNULL, mkconst(), and p.
Referenced by imagpart(), intrcall(), putcx1(), realpart(), and yyparse().
00127 { 00128 Constp p; 00129 00130 p = mkconst(t); 00131 p->Const.cds[0] = cds(d,CNULL); 00132 p->vstg = 1; 00133 return( (expptr) p ); 00134 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 998 of file expr.c.
References Dimblock::baseoffset, checksubs, cpexpr(), frexpr(), ICON, Addrblock::memoffset, mkaddr(), mkexpr(), OPSTAR, STGARG, TYCHAR, typesize, vardcl(), Nameblock::vdim, Nameblock::vleng, Nameblock::vstg, and Nameblock::vtype.
Referenced by doiolist(), fixargs(), and startrw().
01000 { 01001 Addrp ap; 01002 01003 vardcl(np); 01004 ap = mkaddr(np); 01005 01006 /* The prolog causes array arguments to point to the 01007 * (0,...,0) element, unless subscript checking is on. 01008 */ 01009 if( !checksubs && np->vstg==STGARG) 01010 { 01011 struct Dimblock *dp; 01012 dp = np->vdim; 01013 frexpr(ap->memoffset); 01014 ap->memoffset = mkexpr(OPSTAR, 01015 (np->vtype==TYCHAR ? 01016 cpexpr(np->vleng) : 01017 (tagptr)ICON(typesize[np->vtype]) ), 01018 cpexpr(dp->baseoffset) ); 01019 } 01020 return(ap); 01021 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 226 of file expr.c.
References ckalloc(), ICON, mkconst(), p, and TYCHAR.
Referenced by exstop(), subcheck(), and yyparse().
00228 { 00229 Constp p; 00230 char *s; 00231 00232 p = mkconst(TYCHAR); 00233 p->vleng = ICON(l); 00234 p->Const.ccp = s = (char *) ckalloc(l+1); 00235 p->Const.ccp1.blanks = 0; 00236 while(--l >= 0) 00237 *s++ = *v++; 00238 *s = '\0'; 00239 return( (expptr) p ); 00240 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 389 of file expr.c.
References ENULL, err, Expression::headblock, mkexpr(), OPCONV, p, TYSUBR, and Headblock::vtype.
Referenced by mkconv().
00391 { 00392 expptr q; 00393 00394 if (t == TYSUBR) 00395 err("illegal use of subroutine name"); 00396 q = mkexpr(OPCONV, p, ENULL); 00397 q->headblock.vtype = t; 00398 return(q); 00399 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void paren_used | ( | struct Primblock * | p | ) |
Definition at line 2069 of file expr.c.
References Nameblock::fvarname, p, Nameblock::vdim, and warn1().
Referenced by mkexpr(), and yyparse().
02071 { 02072 Namep np; 02073 02074 p->parenused = 1; 02075 if (!p->argsp && (np = p->namep) && np->vdim) 02076 warn1("inappropriate operation on unsubscripted array %.50s", 02077 np->fvarname); 02078 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void sserr | ( | Namep | np | ) |
Definition at line 3732 of file expr.c.
References errstr(), Nameblock::fvarname, TYCHAR, and Nameblock::vtype.
Referenced by fixargs(), mklhs(), and yyparse().
03734 { 03735 errstr(np->vtype == TYCHAR 03736 ? "substring of character array %.70s" 03737 : "substring of noncharacter %.73s", np->fvarname); 03738 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1199 of file expr.c.
References ALLOC, Nameblock::arginfo, Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), Chain::datap, dclerr(), done, err, errstr(), Expression::exprblock, fixtype(), free(), Nameblock::fvarname, Expression::headblock, ICON, letter, mkconv(), mkexpr(), mktmp(), Chain::nextp, NULL, OPASSIGN, putexpr(), rhs, rpllist, Rplblock::rplnextp, Rplblock::rplnp, Rplblock::rpltag, Rplblock::rplvp, Rplblock::rplxp, TADDR, Expression::tag, TCONST, TERROR, TYCHAR, type, TYUNKNOWN, Nameblock::varxptr, Exprblock::vleng, Nameblock::vleng, Nameblock::vstfdesc, Headblock::vtype, and Nameblock::vtype.
Referenced by mkfunct().
01201 { 01202 chainp actuals; 01203 int nargs; 01204 chainp oactp, formals; 01205 int type; 01206 expptr Ln, Lq, q, q1, rhs, ap; 01207 Namep tnp; 01208 struct Rplblock *rp; 01209 struct Rplblock *tlist; 01210 01211 if (np->arginfo) { 01212 errstr("statement function %.66s calls itself.", 01213 np->fvarname); 01214 return ICON(0); 01215 } 01216 np->arginfo = (Argtypes *)np; /* arbitrary nonzero value */ 01217 if(actlist) 01218 { 01219 actuals = actlist->listp; 01220 free( (charptr) actlist); 01221 } 01222 else 01223 actuals = NULL; 01224 oactp = actuals; 01225 01226 nargs = 0; 01227 tlist = NULL; 01228 if( (type = np->vtype) == TYUNKNOWN) 01229 { 01230 dclerr("attempt to use untyped statement function", np); 01231 type = np->vtype = dflttype[letter(np->fvarname[0])]; 01232 } 01233 formals = (chainp) np->varxptr.vstfdesc->datap; 01234 rhs = (expptr) (np->varxptr.vstfdesc->nextp); 01235 01236 /* copy actual arguments into temporaries */ 01237 while(actuals!=NULL && formals!=NULL) 01238 { 01239 if (!(tnp = (Namep) formals->datap)) { 01240 /* buggy statement function declaration */ 01241 q = ICON(1); 01242 goto done; 01243 } 01244 rp = ALLOC(Rplblock); 01245 rp->rplnp = tnp; 01246 ap = fixtype((tagptr)actuals->datap); 01247 if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR 01248 && (ap->tag==TCONST || ap->tag==TADDR) ) 01249 { 01250 01251 /* If actuals are constants or variable names, no temporaries are required */ 01252 rp->rplvp = (expptr) ap; 01253 rp->rplxp = NULL; 01254 rp->rpltag = ap->tag; 01255 } 01256 else { 01257 rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng); 01258 rp -> rplxp = NULL; 01259 putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap)); 01260 if((rp->rpltag = rp->rplvp->tag) == TERROR) 01261 err("disagreement of argument types in statement function call"); 01262 } 01263 rp->rplnextp = tlist; 01264 tlist = rp; 01265 actuals = actuals->nextp; 01266 formals = formals->nextp; 01267 ++nargs; 01268 } 01269 01270 if(actuals!=NULL || formals!=NULL) 01271 err("statement function definition and argument list differ"); 01272 01273 /* 01274 now push down names involved in formal argument list, then 01275 evaluate rhs of statement function definition in this environment 01276 */ 01277 01278 if(tlist) /* put tlist in front of the rpllist */ 01279 { 01280 for(rp = tlist; rp->rplnextp; rp = rp->rplnextp) 01281 ; 01282 rp->rplnextp = rpllist; 01283 rpllist = tlist; 01284 } 01285 01286 /* So when the expression finally gets evaled, that evaluator must read 01287 from the globl rpllist 14-jun-88 mwm */ 01288 01289 q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) ); 01290 01291 /* get length right of character-valued statement functions... */ 01292 if (type == TYCHAR 01293 && (Ln = np->vleng) 01294 && q->tag != TERROR 01295 && (Lq = q->exprblock.vleng) 01296 && (Lq->tag != TCONST 01297 || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) { 01298 q1 = (expptr) mktmp(type, Ln); 01299 putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q)); 01300 q = q1; 01301 } 01302 01303 /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */ 01304 while(--nargs >= 0) 01305 { 01306 if(rpllist->rplxp) 01307 q = mkexpr(OPCOMMA, rpllist->rplxp, q); 01308 rp = rpllist->rplnextp; 01309 frexpr(rpllist->rplvp); 01310 free((char *)rpllist); 01311 rpllist = rp; 01312 } 01313 done: 01314 frchain( &oactp ); 01315 np->arginfo = 0; 01316 return(q); 01317 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1655 of file expr.c.
References call4(), Constant::ci, Constblock::Const, Expression::constblock, cpexpr(), ENULL, errstr(), Expression::exprblock, frexpr(), Nameblock::fvarname, ICON, ISICON, lineno, mkconv(), mkexpr(), mkstrcon(), mktmp(), Dimblock::nelt, NULL, OPAND, OPASSIGN, OPCCALL, Exprblock::opcode, OPCOLON, OPLE, OPLT, OPQUEST, p, procname, STGREG, t, TADDR, TYLONG, Nameblock::vdim, and Nameblock::vlastdim.
Referenced by suboffset().
01657 { 01658 struct Dimblock *dimp; 01659 expptr t, checkvar, checkcond, badcall; 01660 01661 dimp = np->vdim; 01662 if(dimp->nelt == NULL) 01663 return(p); /* don't check arrays with * bounds */ 01664 np->vlastdim = 0; 01665 if( ISICON(p) ) 01666 { 01667 01668 /* check for negative (constant) offset */ 01669 01670 if(p->constblock.Const.ci < 0) 01671 goto badsub; 01672 if( ISICON(dimp->nelt) ) 01673 01674 /* see if constant offset exceeds the array declaration */ 01675 01676 if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci) 01677 return(p); 01678 else 01679 goto badsub; 01680 } 01681 01682 /* We know that the subscript offset p or dimp -> nelt is not a constant. 01683 Now find a register to use for run-time bounds checking */ 01684 01685 if(p->tag==TADDR && p->addrblock.vstg==STGREG) 01686 { 01687 checkvar = (expptr) cpexpr(p); 01688 t = p; 01689 } 01690 else { 01691 checkvar = (expptr) mktmp(TYLONG, ENULL); 01692 t = mkexpr(OPASSIGN, cpexpr(checkvar), p); 01693 } 01694 checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) ); 01695 if( ! ISICON(p) ) 01696 checkcond = mkexpr(OPAND, checkcond, 01697 mkexpr(OPLE, ICON(0), cpexpr(checkvar)) ); 01698 01699 /* Construct the actual test */ 01700 01701 badcall = call4(p->headblock.vtype, "s_rnge", 01702 mkstrcon(strlen(np->fvarname), np->fvarname), 01703 mkconv(TYLONG, cpexpr(checkvar)), 01704 mkstrcon(strlen(procname), procname), 01705 ICON(lineno) ); 01706 badcall->exprblock.opcode = OPCCALL; 01707 p = mkexpr(OPQUEST, checkcond, 01708 mkexpr(OPCOLON, checkvar, badcall)); 01709 01710 return(p); 01711 01712 badsub: 01713 frexpr(p); 01714 errstr("subscript on variable %s out of range", np->fvarname); 01715 return ( ICON(0) ); 01716 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1576 of file expr.c.
References Primblock::argsp, Dimblock::baseoffset, checksubs, cpexpr(), Chain::datap, Dimblock::dims, Dimblock::dimsize, ENULL, erri(), errstr(), fixtype(), Nameblock::fvarname, ICON, ISCONST, ISINT, maxdim, MAXDIM, mkconv(), mkexpr(), mktmp(), n, Dimblock::ndim, Chain::nextp, NOEXT, NULL, OPMINUS, OPPLUS, OPSTAR, p, Expression::primblock, prod(), putassign(), putout(), si, size, STGARG, subcheck(), Expression::tag, TPRIM, TYCHAR, TYLONG, typesize, Nameblock::vdim, Nameblock::vleng, Nameblock::vstg, and Nameblock::vtype.
Referenced by doequiv(), and mklhs().
01578 { 01579 int n; 01580 expptr si, size; 01581 chainp cp; 01582 expptr e, e1, offp, prod; 01583 struct Dimblock *dimp; 01584 expptr sub[MAXDIM+1]; 01585 Namep np; 01586 01587 np = p->namep; 01588 offp = ICON(0); 01589 n = 0; 01590 if(p->argsp) 01591 for(cp = p->argsp->listp ; cp ; cp = cp->nextp) 01592 { 01593 si = fixtype(cpexpr((tagptr)cp->datap)); 01594 if (!ISINT(si->headblock.vtype)) { 01595 NOEXT("non-integer subscript"); 01596 si = mkconv(TYLONG, si); 01597 } 01598 sub[n++] = si; 01599 if(n > maxdim) 01600 { 01601 erri("more than %d subscripts", maxdim); 01602 break; 01603 } 01604 } 01605 01606 dimp = np->vdim; 01607 if(n>0 && dimp==NULL) 01608 errstr("subscripts on scalar variable %.68s", np->fvarname); 01609 else if(dimp && dimp->ndim!=n) 01610 errstr("wrong number of subscripts on %.68s", np->fvarname); 01611 else if(n > 0) 01612 { 01613 prod = sub[--n]; 01614 while( --n >= 0) 01615 prod = mkexpr(OPPLUS, sub[n], 01616 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); 01617 if(checksubs || np->vstg!=STGARG) 01618 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); 01619 01620 /* Add in the run-time bounds check */ 01621 01622 if(checksubs) 01623 prod = subcheck(np, prod); 01624 size = np->vtype == TYCHAR ? 01625 (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]); 01626 prod = mkexpr(OPSTAR, prod, size); 01627 offp = mkexpr(OPPLUS, offp, prod); 01628 } 01629 01630 /* Check for substring indicator */ 01631 01632 if(p->fcharp && np->vtype==TYCHAR) { 01633 e = p->fcharp; 01634 e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1)); 01635 if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) { 01636 e = (expptr)mktmp(TYLONG, ENULL); 01637 putout(putassign(cpexpr(e), e1)); 01638 p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1)); 01639 e1 = e; 01640 } 01641 offp = mkexpr(OPPLUS, offp, e1); 01642 } 01643 return(offp); 01644 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 1383 of file expr.c.
References a, cpexpr(), Chain::datap, erri(), fixtype(), ICON, Listblock::listp, mkchain(), mkexpr(), Chain::nextp, OPMINUS, p, putx(), TYCHAR, UNAM_NAME, and UNAM_REF.
Referenced by mklhs().
01385 { 01386 expptr ep; 01387 struct Listblock *Lb; 01388 chainp cp; 01389 01390 if (a->uname_tag != UNAM_NAME) 01391 erri("subskept: uname_tag %d", a->uname_tag); 01392 a->user.name->vrefused = 1; 01393 a->user.name->visused = 1; 01394 a->uname_tag = UNAM_REF; 01395 Lb = (struct Listblock *)cpexpr((tagptr)p->argsp); 01396 for(cp = Lb->listp; cp; cp = cp->nextp) 01397 cp->datap = (char *)putx(fixtype((tagptr)cp->datap)); 01398 if (a->vtype == TYCHAR) { 01399 ep = p->fcharp ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1)) 01400 : ICON(0); 01401 Lb->listp = mkchain((char *)ep, Lb->listp); 01402 } 01403 return (expptr)Lb; 01404 }
Here is the call graph for this function:
Here is the caller graph for this function:
| static void substrerr | ( | Namep | np | ) | [static] |
Definition at line 1410 of file expr.c.
References Argdcl, checksubs, errstr(), f(), Nameblock::fvarname, void(), and warn1().
Referenced by mklhs().
01412 { 01413 void (*f) Argdcl((const char*, const char*)); 01414 f = checksubs ? errstr : warn1; 01415 (*f)("substring of %.65s is out of bounds.", np->fvarname); 01416 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void vardcl | ( | Namep | v | ) |
Definition at line 1905 of file expr.c.
References CLNAMELIST, CLPROC, CLUNKNOWN, CLVAR, dclerr(), doing_stmtfcn, impldcl(), implstg, ISCONST, lastvarno, letter, PTHISPROC, STGAUTO, STGBSS, STGUNKNOWN, t, TYUNKNOWN, v, and YES.
Referenced by docommon(), doequiv(), doiolist(), ioclause(), mkscalar(), namelist(), startrw(), and yyparse().
01907 { 01908 struct Dimblock *t; 01909 expptr neltp; 01910 extern int doing_stmtfcn; 01911 01912 if(v->vclass == CLUNKNOWN) { 01913 v->vclass = CLVAR; 01914 if (v->vinftype) { 01915 v->vtype = TYUNKNOWN; 01916 if (v->vdcldone) { 01917 v->vdcldone = 0; 01918 impldcl(v); 01919 } 01920 } 01921 } 01922 if(v->vdcldone) 01923 return; 01924 if(v->vclass == CLNAMELIST) 01925 return; 01926 01927 if(v->vtype == TYUNKNOWN) 01928 impldcl(v); 01929 else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC) 01930 { 01931 dclerr("used as variable", v); 01932 return; 01933 } 01934 if(v->vstg==STGUNKNOWN) { 01935 if (doing_stmtfcn) { 01936 /* neither declare this variable if its only use */ 01937 /* is in defining a stmt function, nor complain */ 01938 /* that it is never used */ 01939 v->vimpldovar = 1; 01940 return; 01941 } 01942 v->vstg = implstg[ letter(v->fvarname[0]) ]; 01943 v->vimplstg = 1; 01944 } 01945 01946 /* Compute the actual storage location, i.e. offsets from base addresses, 01947 possibly the stack pointer */ 01948 01949 switch(v->vstg) 01950 { 01951 case STGBSS: 01952 v->vardesc.varno = ++lastvarno; 01953 break; 01954 case STGAUTO: 01955 if(v->vclass==CLPROC && v->vprocclass==PTHISPROC) 01956 break; 01957 if(t = v->vdim) 01958 if( (neltp = t->nelt) && ISCONST(neltp) ) ; 01959 else 01960 dclerr("adjustable automatic array", v); 01961 break; 01962 01963 default: 01964 break; 01965 } 01966 v->vdcldone = YES; 01967 }
Here is the call graph for this function:
Here is the caller graph for this function:
| void wronginf | ( | Namep | np | ) |
Definition at line 580 of file expr.c.
References Nameblock::fvarname, ICON, implleng, impltype, letter, TYCHAR, Nameblock::vinftype, Nameblock::vleng, Nameblock::vtype, and warn1().
Referenced by fixtype().
00582 { 00583 int c; 00584 ftnint k; 00585 warn1("fixing wrong type inferred for %.65s", np->fvarname); 00586 np->vinftype = 0; 00587 c = letter(np->fvarname[0]); 00588 if ((np->vtype = impltype[c]) == TYCHAR 00589 && (k = implleng[c])) 00590 np->vleng = ICON(k); 00591 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 3698 of file expr.c.
References a, b, dcomplex::dimag, dcomplex::dreal, and Fatal().
Referenced by consbinop().
03700 { 03701 double ratio, den; 03702 double abr, abi; 03703 03704 if( (abr = b->dreal) < 0.) 03705 abr = - abr; 03706 if( (abi = b->dimag) < 0.) 03707 abi = - abi; 03708 if( abr <= abi ) 03709 { 03710 if(abi == 0) 03711 Fatal("complex division by zero"); 03712 ratio = b->dreal / b->dimag ; 03713 den = b->dimag * (1 + ratio*ratio); 03714 c->dreal = (a->dreal*ratio + a->dimag) / den; 03715 c->dimag = (a->dimag*ratio - a->dreal) / den; 03716 } 03717 03718 else 03719 { 03720 ratio = b->dimag / b->dreal ; 03721 den = b->dreal * (1 + ratio*ratio); 03722 c->dreal = (a->dreal + a->dimag*ratio) / den; 03723 c->dimag = (a->dimag - a->dreal*ratio) / den; 03724 } 03725 }
Here is the call graph for this function:
Here is the caller graph for this function:
Definition at line 2031 of file expr.c.
References Constant::cd, Constant::cds, Constant::ci, Constblock::Const, Constant::cq, Constblock::tag, TCONST, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, TYLONG, TYQUAD, TYREAL, TYSHORT, Constblock::vstg, and Constblock::vtype.
Referenced by fold(), and mkexpr().
02033 { 02034 Constp c = (Constp) e; 02035 if (c->tag == TCONST) 02036 switch(c->vtype) { 02037 case TYINT1: 02038 case TYSHORT: 02039 case TYLONG: 02040 #ifdef TYQUAD0 02041 case TYQUAD: 02042 #endif 02043 return c->Const.ci == 0; 02044 #ifndef NO_LONG_LONG 02045 case TYQUAD: 02046 return c->Const.cq == 0; 02047 #endif 02048 02049 case TYREAL: 02050 case TYDREAL: 02051 if (c->vstg == 1) 02052 return !strcmp(c->Const.cds[0],"0."); 02053 return c->Const.cd[0] == 0.; 02054 02055 case TYCOMPLEX: 02056 case TYDCOMPLEX: 02057 if (c->vstg == 1) 02058 return !strcmp(c->Const.cds[0],"0.") 02059 && !strcmp(c->Const.cds[1],"0."); 02060 return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.; 02061 } 02062 return 0; 02063 }
Here is the caller graph for this function:
| char dflttype[26] |
int doing_vleng [static] |
| char* powint[] |
1.5.1
