Doxygen Source Code Documentation
intr.c File Reference
#include "defs.h"#include "names.h"Go to the source code of this file.
Data Structures | |
| struct | Intrbits |
| struct | Intrblock |
| struct | Specblock |
Functions | |
| void | r8fix (Void) |
| expptr | intrcall (Namep np, struct Listblock *argsp, int nargs) |
| int | intrfunct (char *s) |
| Addrp | intraddr (Namep np) |
| void | cast_args (int maxtype, chainp args) |
| expptr | Inline (int fno, int type, struct Chain *args) |
Variables | |
| union { | |
| int ijunk | |
| Intrpacked bits | |
| } | packed |
| LOCAL struct Intrblock | intrtab |
| LOCAL struct Specblock | spectab |
| char * | callbyvalue [] |
Function Documentation
|
||||||||||||
|
Definition at line 910 of file intr.c. References cpexpr(), Chain::datap, ENULL, maxtype(), mkconv(), mktmp(), puteq(), and TCONST. Referenced by intrcall().
00912 {
00913 for (; args; args = args -> nextp) {
00914 expptr e = (expptr) args->datap;
00915 if (e -> headblock.vtype != maxtype)
00916 if (e -> tag == TCONST)
00917 args->datap = (char *) mkconv(maxtype, e);
00918 else {
00919 Addrp temp = mktmp(maxtype, ENULL);
00920
00921 puteq(cpexpr((expptr)temp), e);
00922 args->datap = (char *)temp;
00923 } /* else */
00924 } /* for */
00925 } /* cast_args */
|
|
||||||||||||||||
|
Definition at line 936 of file intr.c. References addressable(), cpexpr(), Chain::datap, ENULL, frexpr(), mkconv(), mkexpr(), mktmp(), Chain::nextp, OPABS, OPASSIGN, OPCOMMA, OPDABS, OPMOD, OPSTAR, and q. Referenced by intrcall().
00938 {
00939 register expptr q, t, t1;
00940
00941 switch(fno)
00942 {
00943 case 8: /* real abs */
00944 case 9: /* short int abs */
00945 case 10: /* long int abs */
00946 case 11: /* double precision abs */
00947 if( addressable(q = (expptr) args->datap) )
00948 {
00949 t = q;
00950 q = NULL;
00951 }
00952 else
00953 t = (expptr) mktmp(type,ENULL);
00954 t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
00955 cpexpr(t), ENULL);
00956 if(q)
00957 t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
00958 frexpr(t);
00959 return(t1);
00960
00961 case 26: /* dprod */
00962 q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
00963 (expptr)args->nextp->datap);
00964 return(q);
00965
00966 case 27: /* len of character string */
00967 q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
00968 frexpr((expptr)args->datap);
00969 return mkconv(tyioint, q);
00970
00971 case 14: /* half-integer mod */
00972 case 15: /* mod */
00973 return mkexpr(OPMOD, (expptr) args->datap,
00974 (expptr) args->nextp->datap);
00975 }
00976 return(NULL);
00977 }
|
|
|
Definition at line 860 of file intr.c. References builtin(), CLPROC, errnode, errstr(), fatali(), fatalstr(), INTRBGEN, INTRBOOL, INTRCNST, INTRCONV, INTRGEN, INTRMAX, INTRMIN, INTRSPEC, Specblock::othername, packed, PINTRINSIC, q, Specblock::rtype, spectab, and Specblock::spxname. Referenced by mkaddr().
00862 {
00863 Addrp q;
00864 register struct Specblock *sp;
00865 int f3field;
00866
00867 if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
00868 fatalstr("intraddr: %s is not intrinsic", np->fvarname);
00869 packed.ijunk = np->vardesc.varno;
00870 f3field = packed.bits.f3;
00871
00872 switch(packed.bits.f1)
00873 {
00874 case INTRGEN:
00875 /* imag, log, and log10 arent specific functions */
00876 if(f3field==31 || f3field==43 || f3field==47)
00877 goto bad;
00878
00879 case INTRSPEC:
00880 sp = spectab + f3field;
00881 if (tyint == TYLONG
00882 && (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL))
00883 ++sp;
00884 q = builtin(sp->rtype, sp->spxname,
00885 sp->othername ? 1 : 0);
00886 return(q);
00887
00888 case INTRCONV:
00889 case INTRMIN:
00890 case INTRMAX:
00891 case INTRBOOL:
00892 case INTRCNST:
00893 case INTRBGEN:
00894 bad:
00895 errstr("cannot pass %s as actual", np->fvarname);
00896 return((Addrp)errnode());
00897 }
00898 fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
00899 /* NOT REACHED */ return 0;
00900 }
|
|
||||||||||||||||
|
Definition at line 505 of file intr.c. References Specblock::atype, badtype(), builtin(), callbyvalue, cast_args(), charptr, Chain::datap, ENULL, ep, err66(), errnode, errstr(), Fatal(), fatali(), fixargs(), fixexpr(), frchain(), free, Expression::headblock, i, ICON, Inline(), INTRBGEN, INTRBOOL, INTRCNST, INTRCONV, INTRGEN, INTRMAX, INTRMIN, INTRSPEC, ISCOMPLEX, ISCONST, Listblock::listp, M, maxtype(), mkchain(), mkconv(), mkcxcon(), mkexpr(), mkintcon(), mkrealcon(), MSKINT, MSKLOGICAL, MSKREAL, Specblock::nargs, Chain::nextp, NO, ONEOF, OPBITBITS, OPBITNOT, OPBITSH, OPBITTEST, OPCALL, OPCCALL, OPCONV, OPLSHIFT, OPMAX, OPMIN, OPRSHIFT, Specblock::othername, packed, q, Specblock::rtype, spectab, Specblock::spxname, TADDR, TYQUAD, Listblock::vtype, Headblock::vtype, warn1(), and YES. Referenced by mkfunct().
00507 {
00508 int i, rettype;
00509 Addrp ap;
00510 register struct Specblock *sp;
00511 register struct Chain *cp;
00512 expptr q, ep;
00513 int mtype;
00514 int op;
00515 int f1field, f2field, f3field;
00516 char *s;
00517 static char bit_bits[] = "?bit_bits",
00518 bit_shift[] = "?bit_shift",
00519 bit_cshift[] = "?bit_cshift";
00520 static char *bitop[3] = { bit_bits, bit_shift, bit_cshift };
00521 static int t_pref[2] = { 'l', 'q' };
00522
00523 packed.ijunk = np->vardesc.varno;
00524 f1field = packed.bits.f1;
00525 f2field = packed.bits.f2;
00526 f3field = packed.bits.f3;
00527 if(nargs == 0)
00528 goto badnargs;
00529
00530 mtype = 0;
00531 for(cp = argsp->listp ; cp ; cp = cp->nextp)
00532 {
00533 ep = (expptr)cp->datap;
00534 if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
00535 cp->datap = (char *) mkconv(tyint, ep);
00536 mtype = maxtype(mtype, ep->headblock.vtype);
00537 }
00538
00539 switch(f1field)
00540 {
00541 case INTRBGEN:
00542 op = f3field;
00543 if( ! ONEOF(mtype, MSKINT) )
00544 goto badtype;
00545 if (op < OPBITBITS) {
00546 if(nargs != 2)
00547 goto badnargs;
00548 if (op != OPBITTEST) {
00549 #ifdef TYQUAD
00550 if (mtype == TYQUAD)
00551 op += 2;
00552 #endif
00553 goto intrbool2;
00554 }
00555 q = mkexpr(op, (expptr)argsp->listp->datap,
00556 (expptr)argsp->listp->nextp->datap);
00557 q->exprblock.vtype = TYLOGICAL;
00558 goto intrbool2a;
00559 }
00560 if (nargs != 2 && (nargs != 3 || op == OPBITSH))
00561 goto badnargs;
00562 cp = argsp->listp;
00563 ep = (expptr)cp->datap;
00564 if (ep->headblock.vtype < TYLONG)
00565 cp->datap = (char *)mkconv(TYLONG, ep);
00566 while(cp->nextp) {
00567 cp = cp->nextp;
00568 ep = (expptr)cp->datap;
00569 if (ep->headblock.vtype != TYLONG)
00570 cp->datap = (char *)mkconv(TYLONG, ep);
00571 }
00572 if (op == OPBITSH) {
00573 ep = (expptr)argsp->listp->nextp->datap;
00574 if (ISCONST(ep)) {
00575 if ((i = ep->constblock.Const.ci) < 0) {
00576 q = (expptr)argsp->listp->datap;
00577 if (ISCONST(q)) {
00578 ep->constblock.Const.ci = -i;
00579 op = OPRSHIFT;
00580 goto intrbool2;
00581 }
00582 }
00583 else {
00584 op = OPLSHIFT;
00585 goto intrbool2;
00586 }
00587 }
00588 }
00589 else if (nargs == 2) {
00590 if (op == OPBITBITS)
00591 goto badnargs;
00592 cp->nextp = mkchain((char*)ICON(-1), 0);
00593 }
00594 ep = (expptr)argsp->listp->datap;
00595 i = ep->headblock.vtype;
00596 s = bitop[op - OPBITBITS];
00597 *s = t_pref[i - TYLONG];
00598 ap = builtin(i, s, 1);
00599 return fixexpr((Exprp)
00600 mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
00601
00602 case INTRBOOL:
00603 op = f3field;
00604 if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
00605 goto badtype;
00606 if(op == OPBITNOT)
00607 {
00608 if(nargs != 1)
00609 goto badnargs;
00610 q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
00611 }
00612 else
00613 {
00614 if(nargs != 2)
00615 goto badnargs;
00616 intrbool2:
00617 q = mkexpr(op, (expptr)argsp->listp->datap,
00618 (expptr)argsp->listp->nextp->datap);
00619 }
00620 intrbool2a:
00621 frchain( &(argsp->listp) );
00622 free( (charptr) argsp);
00623 return(q);
00624
00625 case INTRCONV:
00626 rettype = f2field;
00627 switch(rettype) {
00628 case TYLONG:
00629 rettype = tyint;
00630 break;
00631 case TYLOGICAL:
00632 rettype = tylog;
00633 }
00634 if( ISCOMPLEX(rettype) && nargs==2)
00635 {
00636 expptr qr, qi;
00637 qr = (expptr) argsp->listp->datap;
00638 qi = (expptr) argsp->listp->nextp->datap;
00639 if (qr->headblock.vtype == TYDREAL
00640 || qi->headblock.vtype == TYDREAL)
00641 rettype = TYDCOMPLEX;
00642 if(ISCONST(qr) && ISCONST(qi))
00643 q = mkcxcon(qr,qi);
00644 else q = mkexpr(OPCONV,mkconv(rettype-2,qr),
00645 mkconv(rettype-2,qi));
00646 }
00647 else if(nargs == 1) {
00648 if (f3field && ((Exprp)argsp->listp->datap)->vtype
00649 == TYDCOMPLEX)
00650 rettype = TYDREAL;
00651 q = mkconv(rettype+100, (expptr)argsp->listp->datap);
00652 if (q->tag == TADDR)
00653 q->addrblock.parenused = 1;
00654 }
00655 else goto badnargs;
00656
00657 q->headblock.vtype = rettype;
00658 frchain(&(argsp->listp));
00659 free( (charptr) argsp);
00660 return(q);
00661
00662
00663 #if 0
00664 case INTRCNST:
00665
00666 /* Machine-dependent f77 stuff that f2c omits:
00667
00668 intcon contains
00669 radix for short int
00670 radix for long int
00671 radix for single precision
00672 radix for double precision
00673 precision for short int
00674 precision for long int
00675 precision for single precision
00676 precision for double precision
00677 emin for single precision
00678 emin for double precision
00679 emax for single precision
00680 emax for double prcision
00681 largest short int
00682 largest long int
00683
00684 realcon contains
00685 tiny for single precision
00686 tiny for double precision
00687 huge for single precision
00688 huge for double precision
00689 mrsp (epsilon) for single precision
00690 mrsp (epsilon) for double precision
00691 */
00692 { register struct Incstblock *cstp;
00693 extern ftnint intcon[14];
00694 extern double realcon[6];
00695
00696 cstp = consttab + f3field;
00697 for(i=0 ; i<f2field ; ++i)
00698 if(cstp->atype == mtype)
00699 goto foundconst;
00700 else
00701 ++cstp;
00702 goto badtype;
00703
00704 foundconst:
00705 switch(cstp->rtype)
00706 {
00707 case TYLONG:
00708 return(mkintcon(intcon[cstp->constno]));
00709
00710 case TYREAL:
00711 case TYDREAL:
00712 return(mkrealcon(cstp->rtype,
00713 realcon[cstp->constno]) );
00714
00715 default:
00716 Fatal("impossible intrinsic constant");
00717 }
00718 }
00719 #endif
00720
00721 case INTRGEN:
00722 sp = spectab + f3field;
00723 if(no66flag)
00724 if(sp->atype == mtype)
00725 goto specfunct;
00726 else err66("generic function");
00727
00728 for(i=0; i<f2field ; ++i)
00729 if(sp->atype == mtype)
00730 goto specfunct;
00731 else
00732 ++sp;
00733 warn1 ("bad argument type to intrinsic %s", np->fvarname);
00734
00735 /* Made this a warning rather than an error so things like "log (5) ==>
00736 log (5.0)" can be accommodated. When none of these cases matches, the
00737 argument is cast up to the first type in the spectab list; this first
00738 type is assumed to be the "smallest" type, e.g. REAL before DREAL
00739 before COMPLEX, before DCOMPLEX */
00740
00741 sp = spectab + f3field;
00742 mtype = sp -> atype;
00743 goto specfunct;
00744
00745 case INTRSPEC:
00746 sp = spectab + f3field;
00747 specfunct:
00748 if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
00749 && (sp+1)->atype==sp->atype)
00750 ++sp;
00751
00752 if(nargs != sp->nargs)
00753 goto badnargs;
00754 if(mtype != sp->atype)
00755 goto badtype;
00756
00757 /* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in
00758 the inline expression wouldn't get put into the constant table */
00759
00760 fixargs (NO, argsp);
00761 cast_args (mtype, argsp -> listp);
00762
00763 if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
00764 {
00765 frchain( &(argsp->listp) );
00766 free( (charptr) argsp);
00767 } else {
00768
00769 if(sp->othername) {
00770 /* C library routines that return double... */
00771 /* sp->rtype might be TYREAL */
00772 ap = builtin(sp->rtype,
00773 callbyvalue[sp->othername], 1);
00774 q = fixexpr((Exprp)
00775 mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
00776 } else {
00777 fixargs(YES, argsp);
00778 ap = builtin(sp->rtype, sp->spxname, 0);
00779 q = fixexpr((Exprp)
00780 mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
00781 } /* else */
00782 } /* else */
00783 return(q);
00784
00785 case INTRMIN:
00786 case INTRMAX:
00787 if(nargs < 2)
00788 goto badnargs;
00789 if( ! ONEOF(mtype, MSKINT|MSKREAL) )
00790 goto badtype;
00791 argsp->vtype = mtype;
00792 q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
00793
00794 q->headblock.vtype = mtype;
00795 rettype = f2field;
00796 if(rettype == TYLONG)
00797 rettype = tyint;
00798 else if(rettype == TYUNKNOWN)
00799 rettype = mtype;
00800 return( mkconv(rettype, q) );
00801
00802 default:
00803 fatali("intrcall: bad intrgroup %d", f1field);
00804 }
00805 badnargs:
00806 errstr("bad number of arguments to intrinsic %s", np->fvarname);
00807 goto bad;
00808
00809 badtype:
00810 errstr("bad argument type to intrinsic %s", np->fvarname);
00811
00812 bad:
00813 return( errnode() );
00814 }
|
|
|
Definition at line 823 of file intr.c. References Intrbits::dblcmplx, errext(), Intrbits::extflag, i, intr_omit, INTREND, Intrblock::intrfname, Intrbits::intrgroup, Intrbits::intrno, Intrbits::intrstuff, intrtab, Intrblock::intrval, and packed. Referenced by mkfunct(), and setintr().
00825 {
00826 register struct Intrblock *p;
00827 int i;
00828 extern int intr_omit;
00829
00830 for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
00831 {
00832 if( !strcmp(s, p->intrfname) )
00833 {
00834 if (i = p->intrval.extflag) {
00835 if (i & intr_omit)
00836 return 0;
00837 if (noextflag)
00838 errext(s);
00839 }
00840 packed.bits.f1 = p->intrval.intrgroup;
00841 packed.bits.f2 = p->intrval.intrstuff;
00842 packed.bits.f3 = p->intrval.intrno;
00843 packed.bits.f4 = p->intrval.dblcmplx;
00844 return(packed.ijunk);
00845 }
00846 }
00847
00848 return(0);
00849 }
|
|
|
Definition at line 427 of file intr.c. References Specblock::atype, Intrbits::dblcmplx, Intrbits::dblintrno, Fatal(), Intrblock::intrfname, INTRGEN, Intrbits::intrgroup, Intrbits::intrno, Intrbits::intrstuff, intrtab, Intrblock::intrval, Specblock::rtype, spectab, and Specblock::spxname. Referenced by set_externs().
00428 {
00429 register struct Intrblock *I;
00430 register struct Specblock *S;
00431
00432 for(I = intrtab; I->intrfname[0]; I++)
00433 if (I->intrval.intrgroup != INTRGEN)
00434 switch(I->intrval.intrstuff) {
00435 case TYREAL:
00436 I->intrval.intrstuff = TYDREAL;
00437 I->intrval.intrno = I->intrval.dblintrno;
00438 break;
00439 case TYCOMPLEX:
00440 I->intrval.intrstuff = TYDCOMPLEX;
00441 I->intrval.intrno = I->intrval.dblintrno;
00442 I->intrval.dblcmplx = 1;
00443 }
00444
00445 for(S = spectab; S->atype; S++)
00446 switch(S->atype) {
00447 case TYCOMPLEX:
00448 S->atype = TYDCOMPLEX;
00449 if (S->rtype == TYREAL)
00450 S->rtype = TYDREAL;
00451 else if (S->rtype == TYCOMPLEX)
00452 S->rtype = TYDCOMPLEX;
00453 switch(S->spxname[0]) {
00454 case 'r':
00455 S->spxname[0] = 'd';
00456 break;
00457 case 'c':
00458 S->spxname[0] = 'z';
00459 break;
00460 default:
00461 Fatal("r8fix bug");
00462 }
00463 break;
00464 case TYREAL:
00465 S->atype = TYDREAL;
00466 switch(S->rtype) {
00467 case TYREAL:
00468 S->rtype = TYDREAL;
00469 if (S->spxname[0] != 'r')
00470 Fatal("r8fix bug");
00471 S->spxname[0] = 'd';
00472 case TYDREAL: /* d_prod */
00473 break;
00474
00475 case TYSHORT:
00476 if (!strcmp(S->spxname, "hr_expn"))
00477 S->spxname[1] = 'd';
00478 else if (!strcmp(S->spxname, "h_nint"))
00479 strcpy(S->spxname, "h_dnnt");
00480 else Fatal("r8fix bug");
00481 break;
00482
00483 case TYLONG:
00484 if (!strcmp(S->spxname, "ir_expn"))
00485 S->spxname[1] = 'd';
00486 else if (!strcmp(S->spxname, "i_nint"))
00487 strcpy(S->spxname, "i_dnnt");
00488 else Fatal("r8fix bug");
00489 break;
00490
00491 default:
00492 Fatal("r8fix bug");
00493 }
00494 }
00495 }
|
Variable Documentation
|
|
|
|
|
Initial value:
{0,
"sqrt",
"exp",
"log",
"sin",
"cos",
"tan",
"asin",
"acos",
"atan",
"atan2",
"sinh",
"cosh",
"tanh"
}Definition at line 409 of file intr.c. Referenced by intrcall(). |
|
|
|
|
|
Referenced by intrfunct(), and r8fix(). |
|
|
|
Referenced by intraddr(), intrcall(), and r8fix(). |
