home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Trees / V7 / usr / src / cmd / f77 / intr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1979-01-10  |  11.8 KB  |  561 lines
  1. #include "defs"
  2.  
  3. union
  4.     {
  5.     int ijunk;
  6.     struct intrpacked bits;
  7.     } packed;
  8.  
  9. struct intrbits
  10.     {
  11.     int intrgroup /* :3 */;
  12.     int intrstuff /* result type or number of generics */;
  13.     int intrno /* :7 */;
  14.     };
  15.  
  16. LOCAL struct intrblock
  17.     {
  18.     char intrfname[VL];
  19.     struct intrbits intrval;
  20.     } intrtab[ ] =
  21. {
  22. "int",         { INTRCONV, TYLONG },
  23. "real",     { INTRCONV, TYREAL },
  24. "dble",     { INTRCONV, TYDREAL },
  25. "cmplx",     { INTRCONV, TYCOMPLEX },
  26. "dcmplx",     { INTRCONV, TYDCOMPLEX },
  27. "ifix",     { INTRCONV, TYLONG },
  28. "idint",     { INTRCONV, TYLONG },
  29. "float",     { INTRCONV, TYREAL },
  30. "dfloat",    { INTRCONV, TYDREAL },
  31. "sngl",     { INTRCONV, TYREAL },
  32. "ichar",     { INTRCONV, TYLONG },
  33. "char",     { INTRCONV, TYCHAR },
  34.  
  35. "max",         { INTRMAX, TYUNKNOWN },
  36. "max0",     { INTRMAX, TYLONG },
  37. "amax0",     { INTRMAX, TYREAL },
  38. "max1",     { INTRMAX, TYLONG },
  39. "amax1",     { INTRMAX, TYREAL },
  40. "dmax1",     { INTRMAX, TYDREAL },
  41.  
  42. "and",        { INTRBOOL, TYUNKNOWN, OPBITAND },
  43. "or",        { INTRBOOL, TYUNKNOWN, OPBITOR },
  44. "xor",        { INTRBOOL, TYUNKNOWN, OPBITXOR },
  45. "not",        { INTRBOOL, TYUNKNOWN, OPBITNOT },
  46. "lshift",    { INTRBOOL, TYUNKNOWN, OPLSHIFT },
  47. "rshift",    { INTRBOOL, TYUNKNOWN, OPRSHIFT },
  48.  
  49. "min",         { INTRMIN, TYUNKNOWN },
  50. "min0",     { INTRMIN, TYLONG },
  51. "amin0",     { INTRMIN, TYREAL },
  52. "min1",     { INTRMIN, TYLONG },
  53. "amin1",     { INTRMIN, TYREAL },
  54. "dmin1",     { INTRMIN, TYDREAL },
  55.  
  56. "aint",     { INTRGEN, 2, 0 },
  57. "dint",     { INTRSPEC, TYDREAL, 1 },
  58.  
  59. "anint",     { INTRGEN, 2, 2 },
  60. "dnint",     { INTRSPEC, TYDREAL, 3 },
  61.  
  62. "nint",     { INTRGEN, 4, 4 },
  63. "idnint",     { INTRGEN, 2, 6 },
  64.  
  65. "abs",         { INTRGEN, 6, 8 },
  66. "iabs",     { INTRGEN, 2, 9 },
  67. "dabs",     { INTRSPEC, TYDREAL, 11 },
  68. "cabs",     { INTRSPEC, TYREAL, 12 },
  69. "zabs",     { INTRSPEC, TYDREAL, 13 },
  70.  
  71. "mod",         { INTRGEN, 4, 14 },
  72. "amod",     { INTRSPEC, TYREAL, 16 },
  73. "dmod",     { INTRSPEC, TYDREAL, 17 },
  74.  
  75. "sign",     { INTRGEN, 4, 18 },
  76. "isign",     { INTRGEN, 2, 19 },
  77. "dsign",     { INTRSPEC, TYDREAL, 21 },
  78.  
  79. "dim",         { INTRGEN, 4, 22 },
  80. "idim",     { INTRGEN, 2, 23 },
  81. "ddim",     { INTRSPEC, TYDREAL, 25 },
  82.  
  83. "dprod",     { INTRSPEC, TYDREAL, 26 },
  84.  
  85. "len",         { INTRSPEC, TYLONG, 27 },
  86. "index",     { INTRSPEC, TYLONG, 29 },
  87.  
  88. "imag",     { INTRGEN, 2, 31 },
  89. "aimag",     { INTRSPEC, TYREAL, 31 },
  90. "dimag",     { INTRSPEC, TYDREAL, 32 },
  91.  
  92. "conjg",     { INTRGEN, 2, 33 },
  93. "dconjg",     { INTRSPEC, TYDCOMPLEX, 34 },
  94.  
  95. "sqrt",     { INTRGEN, 4, 35 },
  96. "dsqrt",     { INTRSPEC, TYDREAL, 36 },
  97. "csqrt",     { INTRSPEC, TYCOMPLEX, 37 },
  98. "zsqrt",     { INTRSPEC, TYDCOMPLEX, 38 },
  99.  
  100. "exp",         { INTRGEN, 4, 39 },
  101. "dexp",     { INTRSPEC, TYDREAL, 40 },
  102. "cexp",     { INTRSPEC, TYCOMPLEX, 41 },
  103. "zexp",     { INTRSPEC, TYDCOMPLEX, 42 },
  104.  
  105. "log",         { INTRGEN, 4, 43 },
  106. "alog",     { INTRSPEC, TYREAL, 43 },
  107. "dlog",     { INTRSPEC, TYDREAL, 44 },
  108. "clog",     { INTRSPEC, TYCOMPLEX, 45 },
  109. "zlog",     { INTRSPEC, TYDCOMPLEX, 46 },
  110.  
  111. "log10",     { INTRGEN, 2, 47 },
  112. "alog10",     { INTRSPEC, TYREAL, 47 },
  113. "dlog10",     { INTRSPEC, TYDREAL, 48 },
  114.  
  115. "sin",         { INTRGEN, 4, 49 },
  116. "dsin",     { INTRSPEC, TYDREAL, 50 },
  117. "csin",     { INTRSPEC, TYCOMPLEX, 51 },
  118. "zsin",     { INTRSPEC, TYDCOMPLEX, 52 },
  119.  
  120. "cos",         { INTRGEN, 4, 53 },
  121. "dcos",     { INTRSPEC, TYDREAL, 54 },
  122. "ccos",     { INTRSPEC, TYCOMPLEX, 55 },
  123. "zcos",     { INTRSPEC, TYDCOMPLEX, 56 },
  124.  
  125. "tan",         { INTRGEN, 2, 57 },
  126. "dtan",     { INTRSPEC, TYDREAL, 58 },
  127.  
  128. "asin",     { INTRGEN, 2, 59 },
  129. "dasin",     { INTRSPEC, TYDREAL, 60 },
  130.  
  131. "acos",     { INTRGEN, 2, 61 },
  132. "dacos",     { INTRSPEC, TYDREAL, 62 },
  133.  
  134. "atan",     { INTRGEN, 2, 63 },
  135. "datan",     { INTRSPEC, TYDREAL, 64 },
  136.  
  137. "atan2",     { INTRGEN, 2, 65 },
  138. "datan2",     { INTRSPEC, TYDREAL, 66 },
  139.  
  140. "sinh",     { INTRGEN, 2, 67 },
  141. "dsinh",     { INTRSPEC, TYDREAL, 68 },
  142.  
  143. "cosh",     { INTRGEN, 2, 69 },
  144. "dcosh",     { INTRSPEC, TYDREAL, 70 },
  145.  
  146. "tanh",     { INTRGEN, 2, 71 },
  147. "dtanh",     { INTRSPEC, TYDREAL, 72 },
  148.  
  149. "lge",        { INTRSPEC, TYLOGICAL, 73},
  150. "lgt",        { INTRSPEC, TYLOGICAL, 75},
  151. "lle",        { INTRSPEC, TYLOGICAL, 77},
  152. "llt",        { INTRSPEC, TYLOGICAL, 79},
  153.  
  154. "" };
  155.  
  156.  
  157. LOCAL struct specblock
  158.     {
  159.     char atype;
  160.     char rtype;
  161.     char nargs;
  162.     char spxname[XL];
  163.     char othername;    /* index into callbyvalue table */
  164.     } spectab[ ] =
  165. {
  166.     { TYREAL,TYREAL,1,"r_int" },
  167.     { TYDREAL,TYDREAL,1,"d_int" },
  168.  
  169.     { TYREAL,TYREAL,1,"r_nint" },
  170.     { TYDREAL,TYDREAL,1,"d_nint" },
  171.  
  172.     { TYREAL,TYSHORT,1,"h_nint" },
  173.     { TYREAL,TYLONG,1,"i_nint" },
  174.  
  175.     { TYDREAL,TYSHORT,1,"h_dnnt" },
  176.     { TYDREAL,TYLONG,1,"i_dnnt" },
  177.  
  178.     { TYREAL,TYREAL,1,"r_abs" },
  179.     { TYSHORT,TYSHORT,1,"h_abs" },
  180.     { TYLONG,TYLONG,1,"i_abs" },
  181.     { TYDREAL,TYDREAL,1,"d_abs" },
  182.     { TYCOMPLEX,TYREAL,1,"c_abs" },
  183.     { TYDCOMPLEX,TYDREAL,1,"z_abs" },
  184.  
  185.     { TYSHORT,TYSHORT,2,"h_mod" },
  186.     { TYLONG,TYLONG,2,"i_mod" },
  187.     { TYREAL,TYREAL,2,"r_mod" },
  188.     { TYDREAL,TYDREAL,2,"d_mod" },
  189.  
  190.     { TYREAL,TYREAL,2,"r_sign" },
  191.     { TYSHORT,TYSHORT,2,"h_sign" },
  192.     { TYLONG,TYLONG,2,"i_sign" },
  193.     { TYDREAL,TYDREAL,2,"d_sign" },
  194.  
  195.     { TYREAL,TYREAL,2,"r_dim" },
  196.     { TYSHORT,TYSHORT,2,"h_dim" },
  197.     { TYLONG,TYLONG,2,"i_dim" },
  198.     { TYDREAL,TYDREAL,2,"d_dim" },
  199.  
  200.     { TYREAL,TYDREAL,2,"d_prod" },
  201.  
  202.     { TYCHAR,TYSHORT,1,"h_len" },
  203.     { TYCHAR,TYLONG,1,"i_len" },
  204.  
  205.     { TYCHAR,TYSHORT,2,"h_indx" },
  206.     { TYCHAR,TYLONG,2,"i_indx" },
  207.  
  208.     { TYCOMPLEX,TYREAL,1,"r_imag" },
  209.     { TYDCOMPLEX,TYDREAL,1,"d_imag" },
  210.     { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
  211.     { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
  212.  
  213.     { TYREAL,TYREAL,1,"r_sqrt", 1 },
  214.     { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
  215.     { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
  216.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
  217.  
  218.     { TYREAL,TYREAL,1,"r_exp", 2 },
  219.     { TYDREAL,TYDREAL,1,"d_exp", 2 },
  220.     { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
  221.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
  222.  
  223.     { TYREAL,TYREAL,1,"r_log", 3 },
  224.     { TYDREAL,TYDREAL,1,"d_log", 3 },
  225.     { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
  226.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
  227.  
  228.     { TYREAL,TYREAL,1,"r_lg10" },
  229.     { TYDREAL,TYDREAL,1,"d_lg10" },
  230.  
  231.     { TYREAL,TYREAL,1,"r_sin", 4 },
  232.     { TYDREAL,TYDREAL,1,"d_sin", 4 },
  233.     { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
  234.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
  235.  
  236.     { TYREAL,TYREAL,1,"r_cos", 5 },
  237.     { TYDREAL,TYDREAL,1,"d_cos", 5 },
  238.     { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
  239.     { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
  240.  
  241.     { TYREAL,TYREAL,1,"r_tan", 6 },
  242.     { TYDREAL,TYDREAL,1,"d_tan", 6 },
  243.  
  244.     { TYREAL,TYREAL,1,"r_asin", 7 },
  245.     { TYDREAL,TYDREAL,1,"d_asin", 7 },
  246.  
  247.     { TYREAL,TYREAL,1,"r_acos", 8 },
  248.     { TYDREAL,TYDREAL,1,"d_acos", 8 },
  249.  
  250.     { TYREAL,TYREAL,1,"r_atan", 9 },
  251.     { TYDREAL,TYDREAL,1,"d_atan", 9 },
  252.  
  253.     { TYREAL,TYREAL,2,"r_atn2", 10 },
  254.     { TYDREAL,TYDREAL,2,"d_atn2", 10 },
  255.  
  256.     { TYREAL,TYREAL,1,"r_sinh", 11 },
  257.     { TYDREAL,TYDREAL,1,"d_sinh", 11 },
  258.  
  259.     { TYREAL,TYREAL,1,"r_cosh", 12 },
  260.     { TYDREAL,TYDREAL,1,"d_cosh", 12 },
  261.  
  262.     { TYREAL,TYREAL,1,"r_tanh", 13 },
  263.     { TYDREAL,TYDREAL,1,"d_tanh", 13 },
  264.  
  265.     { TYCHAR,TYLOGICAL,2,"hl_ge" },
  266.     { TYCHAR,TYLOGICAL,2,"l_ge" },
  267.  
  268.     { TYCHAR,TYLOGICAL,2,"hl_gt" },
  269.     { TYCHAR,TYLOGICAL,2,"l_gt" },
  270.  
  271.     { TYCHAR,TYLOGICAL,2,"hl_le" },
  272.     { TYCHAR,TYLOGICAL,2,"l_le" },
  273.  
  274.     { TYCHAR,TYLOGICAL,2,"hl_lt" },
  275.     { TYCHAR,TYLOGICAL,2,"l_lt" }
  276. } ;
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283. char callbyvalue[ ][XL] =
  284.     {
  285.     "sqrt",
  286.     "exp",
  287.     "log",
  288.     "sin",
  289.     "cos",
  290.     "tan",
  291.     "asin",
  292.     "acos",
  293.     "atan",
  294.     "atan2",
  295.     "sinh",
  296.     "cosh",
  297.     "tanh"
  298.     };
  299.  
  300. struct exprblock *intrcall(np, argsp, nargs)
  301. struct nameblock *np;
  302. struct listblock *argsp;
  303. int nargs;
  304. {
  305. int i, rettype;
  306. struct addrblock *ap;
  307. register struct specblock *sp;
  308. struct exprblock *q, *inline();
  309. register chainp cp;
  310. struct constblock *mkcxcon();
  311. expptr ep;
  312. int mtype;
  313. int op;
  314.  
  315. packed.ijunk = np->vardesc.varno;
  316. if(nargs == 0)
  317.     goto badnargs;
  318.  
  319. mtype = 0;
  320. for(cp = argsp->listp ; cp ; cp = cp->nextp)
  321.     {
  322. /* TEMPORARY */ ep = cp->datap;
  323. /* TEMPORARY */    if( ISCONST(ep) && ep->vtype==TYSHORT )
  324. /* TEMPORARY */        cp->datap = mkconv(tyint, ep);
  325.     mtype = maxtype(mtype, ep->vtype);
  326.     }
  327.  
  328. switch(packed.bits.f1)
  329.     {
  330.     case INTRBOOL:
  331.         op = packed.bits.f3;
  332.         if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
  333.             goto badtype;
  334.         if(op == OPBITNOT)
  335.             {
  336.             if(nargs != 1)
  337.                 goto badnargs;
  338.             q = mkexpr(OPBITNOT, argsp->listp->datap, NULL);
  339.             }
  340.         else
  341.             {
  342.             if(nargs != 2)
  343.                 goto badnargs;
  344.             q = mkexpr(op, argsp->listp->datap,
  345.                 argsp->listp->nextp->datap);
  346.             }
  347.         frchain( &(argsp->listp) );
  348.         free(argsp);
  349.         return(q);
  350.  
  351.     case INTRCONV:
  352.         rettype = packed.bits.f2;
  353.         if(rettype == TYLONG)
  354.             rettype = tyint;
  355.         if( ISCOMPLEX(rettype) && nargs==2)
  356.             {
  357.             expptr qr, qi;
  358.             qr = argsp->listp->datap;
  359.             qi = argsp->listp->nextp->datap;
  360.             if(ISCONST(qr) && ISCONST(qi))
  361.                 q = mkcxcon(qr,qi);
  362.             else    q = mkexpr(OPCONV,mkconv(rettype-2,qr),
  363.                     mkconv(rettype-2,qi));
  364.             }
  365.         else if(nargs == 1)
  366.             q = mkconv(rettype, argsp->listp->datap);
  367.         else goto badnargs;
  368.  
  369.         q->vtype = rettype;
  370.         frchain(&(argsp->listp));
  371.         free(argsp);
  372.         return(q);
  373.  
  374.  
  375.     case INTRGEN:
  376.         sp = spectab + packed.bits.f3;
  377.         for(i=0; i<packed.bits.f2 ; ++i)
  378.             if(sp->atype == mtype)
  379.                 goto specfunct;
  380.             else
  381.                 ++sp;
  382.         goto badtype;
  383.  
  384.     case INTRSPEC:
  385.         sp = spectab + packed.bits.f3;
  386.         if(tyint==TYLONG && sp->rtype==TYSHORT)
  387.             ++sp;
  388.  
  389.     specfunct:
  390.         if(nargs != sp->nargs)
  391.             goto badnargs;
  392.         if(mtype != sp->atype)
  393.             goto badtype;
  394.         fixargs(YES, argsp);
  395.         if(q = inline(sp-spectab, mtype, argsp->listp))
  396.             {
  397.             frchain( &(argsp->listp) );
  398.             free(argsp);
  399.             }
  400.         else if(sp->othername)
  401.             {
  402.             ap = builtin(sp->rtype,
  403.                 varstr(XL, callbyvalue[sp->othername-1]) );
  404.             q = fixexpr( mkexpr(OPCCALL, ap, argsp) );
  405.             }
  406.         else
  407.             {
  408.             ap = builtin(sp->rtype, varstr(XL, sp->spxname) );
  409.             q = fixexpr( mkexpr(OPCALL, ap, argsp) );
  410.             }
  411.         return(q);
  412.  
  413.     case INTRMIN:
  414.     case INTRMAX:
  415.         if(nargs < 2)
  416.             goto badnargs;
  417.         if( ! ONEOF(mtype, MSKINT|MSKREAL) )
  418.             goto badtype;
  419.         argsp->vtype = mtype;
  420.         q = mkexpr( (packed.bits.f1==INTRMIN ? OPMIN : OPMAX), argsp, NULL);
  421.  
  422.         q->vtype = mtype;
  423.         rettype = packed.bits.f2;
  424.         if(rettype == TYLONG)
  425.             rettype = tyint;
  426.         else if(rettype == TYUNKNOWN)
  427.             rettype = mtype;
  428.         return( mkconv(rettype, q) );
  429.  
  430.     default:
  431.         fatal1("intrcall: bad intrgroup %d", packed.bits.f1);
  432.     }
  433. badnargs:
  434.     err1("bad number of arguments to intrinsic %s",
  435.         varstr(VL,np->varname) );
  436.     goto bad;
  437.  
  438. badtype:
  439.     err1("bad argument type to intrinsic %s", varstr(VL, np->varname) );
  440.  
  441. bad:
  442.     return( errnode() );
  443. }
  444.  
  445.  
  446.  
  447.  
  448. intrfunct(s)
  449. char s[VL];
  450. {
  451. register struct intrblock *p;
  452. char nm[VL];
  453. register int i;
  454.  
  455. for(i = 0 ; i<VL ; ++s)
  456.     nm[i++] = (*s==' ' ? '\0' : *s);
  457.  
  458. for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
  459.     {
  460.     if( eqn(VL, nm, p->intrfname) )
  461.         {
  462.         packed.bits.f1 = p->intrval.intrgroup;
  463.         packed.bits.f2 = p->intrval.intrstuff;
  464.         packed.bits.f3 = p->intrval.intrno;
  465.         return(packed.ijunk);
  466.         }
  467.     }
  468.  
  469. return(0);
  470. }
  471.  
  472.  
  473.  
  474.  
  475.  
  476. struct addrblock *intraddr(np)
  477. struct nameblock *np;
  478. {
  479. struct addrblock *q;
  480. struct specblock *sp;
  481.  
  482. if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
  483.     fatal1("intraddr: %s is not intrinsic", varstr(VL,np->varname));
  484. packed.ijunk = np->vardesc.varno;
  485.  
  486. switch(packed.bits.f1)
  487.     {
  488.     case INTRGEN:
  489.         /* imag, log, and log10 arent specific functions */
  490.         if(packed.bits.f3==31 || packed.bits.f3==43 || packed.bits.f3==47)
  491.             goto bad;
  492.  
  493.     case INTRSPEC:
  494.         sp = spectab + packed.bits.f3;
  495.         if(tyint==TYLONG && sp->rtype==TYSHORT)
  496.             ++sp;
  497.         q = builtin(sp->rtype, varstr(XL,sp->spxname) );
  498.         return(q);
  499.  
  500.     case INTRCONV:
  501.     case INTRMIN:
  502.     case INTRMAX:
  503.     case INTRBOOL:
  504.     bad:
  505.         err1("cannot pass %s as actual",
  506.             varstr(VL,np->varname));
  507.         return( errnode() );
  508.     }
  509. fatal1("intraddr: impossible f1=%d\n", packed.bits.f1);
  510. /* NOTREACHED */
  511. }
  512.  
  513.  
  514.  
  515.  
  516.  
  517. struct exprblock *inline(fno, type, args)
  518. int fno;
  519. int type;
  520. chainp args;
  521. {
  522. register struct exprblock *q, *t, *t1;
  523.  
  524. switch(fno)
  525.     {
  526.     case 8:    /* real abs */
  527.     case 9:    /* short int abs */
  528.     case 10:    /* long int abs */
  529.     case 11:    /* double precision abs */
  530.         if( addressable(q = args->datap) )
  531.             {
  532.             t = q;
  533.             q = NULL;
  534.             }
  535.         else
  536.             t = mktemp(type);
  537.         t1 = mkexpr(OPQUEST,  mkexpr(OPLE, mkconv(type,ICON(0)), cpexpr(t)),
  538.             mkexpr(OPCOLON, cpexpr(t),
  539.                 mkexpr(OPNEG, cpexpr(t), NULL) ));
  540.         if(q)
  541.             t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
  542.         frexpr(t);
  543.         return(t1);
  544.  
  545.     case 26:    /* dprod */
  546.         q = mkexpr(OPSTAR, args->datap, args->nextp->datap);
  547.         q->vtype = TYDREAL;
  548.         return(q);
  549.  
  550.     case 27:    /* len of character string */
  551.         q = cpexpr(args->datap->vleng);
  552.         frexpr(args->datap);
  553.         return(q);
  554.  
  555.     case 14:    /* half-integer mod */
  556.     case 15:    /* mod */
  557.         return( mkexpr(OPMOD, args->datap, args->nextp->datap) );
  558.     }
  559. return(NULL);
  560. }
  561.