projects / unix-history / blobdiff
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
BSD 4_3 release
[unix-history] / usr / src / usr.bin / f77 / src / f77pass1 / intr.c
diff --git a/usr/src/usr.bin/f77/src/f77pass1/intr.c b/usr/src/usr.bin/f77/src/f77pass1/intr.c
index 92fe680..4ebe42a 100644 (file)
--- a/usr/src/usr.bin/f77/src/f77pass1/intr.c
+++ b/usr/src/usr.bin/f77/src/f77pass1/intr.c
@@ -1,3 +1,44 @@
+/*
+ * Copyright (c) 1980 Regents of the University of California.
+ * All rights reserved.  The Berkeley software License Agreement
+ * specifies the terms and conditions for redistribution.
+ */
+
+#ifndef lint
+static char sccsid[] = "@(#)intr.c     5.2 (Berkeley) 8/29/85";
+#endif not lint
+
+/*
+ * intr.c
+ *
+ * Routines for handling intrinsic functions, f77 compiler pass 1, 4.2 BSD.
+ *
+ * University of Utah CS Dept modification history:
+ *
+ * $Log:       intr.c,v $
+ * Revision 5.2  85/08/10  04:39:23  donn
+ * Various changes from Jerry Berkman.  We now call the new builtin log10()
+ * instead of the f77 library emulations; we figure out that builtins will
+ * return type double instead of type float; we get rid of lots of
+ * undocumented material; we ifdef 66 code and handle -r8/double flag.
+ * 
+ * Revision 5.1  85/08/10  03:47:37  donn
+ * 4.3 alpha
+ * 
+ * Revision 1.4  85/02/22  00:54:59  donn
+ * Mark intrinsic functions as having storage class STGINTR.  builtin()
+ * always returns STGEXT nodes.  Notice that the reference to the function
+ * in the external symbol table still uses STGEXT...  I hope this is right.
+ * 
+ * Revision 1.3  85/01/15  21:05:40  donn
+ * Changes to distinguish explicit from implicit conversions with intrconv().
+ * 
+ * Revision 1.2  84/12/15  01:02:33  donn
+ * Added a case for an integer*4 result from len() in inline().  Previously
+ * only -i2 provoked len() inline, sigh.
+ * 
+ */
+
 #include "defs.h"
 
 extern ftnint intcon[14];
 #include "defs.h"
 
 extern ftnint intcon[14];
@@ -12,7 +53,7 @@ union
 struct Intrbits
        {
        int intrgroup /* :3 */;
 struct Intrbits
        {
        int intrgroup /* :3 */;
-       int intrstuff /* result type or number of generics */;
+       int intrstuff /* result type or number of specifics */;
        int intrno /* :7 */;
        };
 
        int intrno /* :7 */;
        };
 
@@ -34,9 +75,7 @@ LOCAL struct Intrblock
 "dfloat",      { INTRCONV, TYDREAL },
 "sngl",        { INTRCONV, TYREAL },
 "ichar",       { INTRCONV, TYLONG },
 "dfloat",      { INTRCONV, TYDREAL },
 "sngl",        { INTRCONV, TYREAL },
 "ichar",       { INTRCONV, TYLONG },
-"iachar",      { INTRCONV, TYLONG },
 "char",        { INTRCONV, TYCHAR },
 "char",        { INTRCONV, TYCHAR },
-"achar",       { INTRCONV, TYCHAR },
 
 "max",                 { INTRMAX, TYUNKNOWN },
 "max0",        { INTRMAX, TYLONG },
 
 "max",                 { INTRMAX, TYUNKNOWN },
 "max0",        { INTRMAX, TYLONG },
@@ -163,22 +202,7 @@ LOCAL struct Intrblock
 "lle",         { INTRSPEC, TYLOGICAL, 77},
 "llt",         { INTRSPEC, TYLOGICAL, 79},
 
 "lle",         { INTRSPEC, TYLOGICAL, 77},
 "llt",         { INTRSPEC, TYLOGICAL, 79},
 
-"epbase",      { INTRCNST, 4, 0 },
-"epprec",      { INTRCNST, 4, 4 },
-"epemin",      { INTRCNST, 2, 8 },
-"epemax",      { INTRCNST, 2, 10 },
-"eptiny",      { INTRCNST, 2, 12 },
-"ephuge",      { INTRCNST, 4, 14 },
-"epmrsp",      { INTRCNST, 2, 18 },
-
-"fpexpn",      { INTRGEN, 4, 81 },
-"fpabsp",      { INTRGEN, 2, 85 },
-"fprrsp",      { INTRGEN, 2, 87 },
-"fpfrac",      { INTRGEN, 2, 89 },
-"fpmake",      { INTRGEN, 2, 91 },
-"fpscal",      { INTRGEN, 2, 93 },
-
-"" };
+"",            { INTREND, 0, 0} };
 \f
 
 LOCAL struct Specblock
 \f
 
 LOCAL struct Specblock
@@ -252,8 +276,8 @@ LOCAL struct Specblock
        { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
        { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
 
        { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
        { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
 
-       { TYREAL,TYREAL,1,"r_lg10" },
-       { TYDREAL,TYDREAL,1,"d_lg10" },
+       { TYREAL,TYREAL,1,"r_lg10", 14 },
+       { TYDREAL,TYDREAL,1,"d_lg10", 14 },
 
        { TYREAL,TYREAL,1,"r_sin", 4 },
        { TYDREAL,TYDREAL,1,"d_sin", 4 },
 
        { TYREAL,TYREAL,1,"r_sin", 4 },
        { TYDREAL,TYDREAL,1,"d_sin", 4 },
@@ -301,90 +325,9 @@ LOCAL struct Specblock
        { TYCHAR,TYLOGICAL,2,"hl_lt" },
        { TYCHAR,TYLOGICAL,2,"l_lt" },
 
        { TYCHAR,TYLOGICAL,2,"hl_lt" },
        { TYCHAR,TYLOGICAL,2,"l_lt" },
 
-       { TYREAL,TYSHORT,1,"hr_expn" },
-       { TYREAL,TYLONG,1,"ir_expn" },
-       { TYDREAL,TYSHORT,1,"hd_expn" },
-       { TYDREAL,TYLONG,1,"id_expn" },
-
-       { TYREAL,TYREAL,1,"r_absp" },
-       { TYDREAL,TYDREAL,1,"d_absp" },
-
-       { TYREAL,TYDREAL,1,"r_rrsp" },
-       { TYDREAL,TYDREAL,1,"d_rrsp" },
-
-       { TYREAL,TYREAL,1,"r_frac" },
-       { TYDREAL,TYDREAL,1,"d_frac" },
-
-       { TYREAL,TYREAL,2,"r_make" },
-       { TYDREAL,TYDREAL,2,"d_make" },
-
-       { TYREAL,TYREAL,2,"r_scal" },
-       { TYDREAL,TYDREAL,2,"d_scal" }
+       { TYDREAL,TYDREAL,2,"d_dprod"}  /* dprod() with dblflag */
 } ;
 \f
 } ;
 \f
-LOCAL struct Incstblock
-       {
-       char atype;
-       char rtype;
-       char constno;
-       } consttab[ ] =
-{
-       { TYSHORT, TYLONG, 0 },
-       { TYLONG, TYLONG, 1 },
-       { TYREAL, TYLONG, 2 },
-       { TYDREAL, TYLONG, 3 },
-
-       { TYSHORT, TYLONG, 4 },
-       { TYLONG, TYLONG, 5 },
-       { TYREAL, TYLONG, 6 },
-       { TYDREAL, TYLONG, 7 },
-
-       { TYREAL, TYLONG, 8 },
-       { TYDREAL, TYLONG, 9 },
-
-       { TYREAL, TYLONG, 10 },
-       { TYDREAL, TYLONG, 11 },
-
-       { TYREAL, TYREAL, 0 },
-       { TYDREAL, TYDREAL, 1 },
-
-       { TYSHORT, TYLONG, 12 },
-       { TYLONG, TYLONG, 13 },
-       { TYREAL, TYREAL, 2 },
-       { TYDREAL, TYDREAL, 3 },
-
-       { TYREAL, TYREAL, 4 },
-       { TYDREAL, TYDREAL, 5 }
-};
-
-/* For each machine, two arrays must be initialized.
-intcon contains
-       radix for short int
-       radix for long int
-       radix for single precision
-       radix for double precision
-       precision for short int
-       precision for long int
-       precision for single precision
-       precision for double precision
-       emin for single precision
-       emin for double precision
-       emax for single precision
-       emax for double prcision
-       largest short int
-       largest long int
-
-realcon contains
-       tiny for single precision
-       tiny for double precision
-       huge for single precision
-       huge for double precision
-       mrsp (epsilon) for single precision
-       mrsp (epsilon) for double precision
-
-the realcons should probably be filled in in binary if TARGET==HERE
-*/
-\f
 char callbyvalue[ ][XL] =
        {
        "sqrt",
 char callbyvalue[ ][XL] =
        {
        "sqrt",
@@ -399,7 +342,8 @@ char callbyvalue[ ][XL] =
        "atan2",
        "sinh",
        "cosh",
        "atan2",
        "sinh",
        "cosh",
-       "tanh"
+       "tanh",
+       "log10"
        };
 \f
 expptr intrcall(np, argsp, nargs)
        };
 \f
 expptr intrcall(np, argsp, nargs)
@@ -412,7 +356,6 @@ Addrp ap;
 register struct Specblock *sp;
 register struct Chain *cp;
 expptr inline(), mkcxcon(), mkrealcon();
 register struct Specblock *sp;
 register struct Chain *cp;
 expptr inline(), mkcxcon(), mkrealcon();
-register struct Incstblock *cstp;
 expptr q, ep;
 int mtype;
 int op;
 expptr q, ep;
 int mtype;
 int op;
@@ -482,20 +425,29 @@ switch(f1field)
                                }
                        }
                rettype = f2field;
                                }
                        }
                rettype = f2field;
-               if(rettype == TYLONG)
-                       rettype = tyint;
                if( ISCOMPLEX(rettype) && nargs==2)
                        {
                        expptr qr, qi;
                if( ISCOMPLEX(rettype) && nargs==2)
                        {
                        expptr qr, qi;
+                       if(dblflag) rettype = TYDCOMPLEX;
                        qr = (expptr) (argsp->listp->datap);
                        qi = (expptr) (argsp->listp->nextp->datap);
                        if(ISCONST(qr) && ISCONST(qi))
                                q = mkcxcon(qr,qi);
                        qr = (expptr) (argsp->listp->datap);
                        qi = (expptr) (argsp->listp->nextp->datap);
                        if(ISCONST(qr) && ISCONST(qi))
                                q = mkcxcon(qr,qi);
-                       else    q = mkexpr(OPCONV,mkconv(rettype-2,qr),
-                                       mkconv(rettype-2,qi));
+                       else    q = mkexpr(OPCONV,intrconv(rettype-2,qr),
+                                       intrconv(rettype-2,qi));
                        }
                else if(nargs == 1)
                        }
                else if(nargs == 1)
-                       q = mkconv(rettype, argsp->listp->datap);
+                       {
+                       if(rettype == TYLONG) rettype = tyint;
+                       else if( dblflag )
+                               {
+                               if ( rettype == TYREAL )
+                                       rettype = TYDREAL;
+                               else if( rettype == TYCOMPLEX )
+                                       rettype = TYDCOMPLEX;
+                               }
+                       q = intrconv(rettype, argsp->listp->datap);
+                       }
                else goto badnargs;
 
                q->headblock.vtype = rettype;
                else goto badnargs;
 
                q->headblock.vtype = rettype;
@@ -503,37 +455,14 @@ switch(f1field)
                free( (charptr) argsp);
                return(q);
 
                free( (charptr) argsp);
                return(q);
 
-
-       case INTRCNST:
-               cstp = consttab + f3field;
-               for(i=0 ; i<f2field ; ++i)
-                       if(cstp->atype == mtype)
-                               goto foundconst;
-                       else
-                               ++cstp;
-               goto badtype;
-
-       foundconst:
-               switch(cstp->rtype)
-                       {
-                       case TYLONG:
-                               return(mkintcon(intcon[cstp->constno]));
-
-                       case TYREAL:
-                       case TYDREAL:
-                               return(mkrealcon(cstp->rtype,
-                                       realcon[cstp->constno]) );
-
-                       default:
-                               fatal("impossible intrinsic constant");
-                       }
-
        case INTRGEN:
                sp = spectab + f3field;
        case INTRGEN:
                sp = spectab + f3field;
+#ifdef ONLY66
                if(no66flag)
                        if(sp->atype == mtype)
                                goto specfunct;
                        else err66("generic function");
                if(no66flag)
                        if(sp->atype == mtype)
                                goto specfunct;
                        else err66("generic function");
+#endif
 
                for(i=0; i<f2field ; ++i)
                        if(sp->atype == mtype)
 
                for(i=0; i<f2field ; ++i)
                        if(sp->atype == mtype)
@@ -544,6 +473,18 @@ switch(f1field)
 
        case INTRSPEC:
                sp = spectab + f3field;
 
        case INTRSPEC:
                sp = spectab + f3field;
+               if( dblflag )
+                       {
+                       /* convert specific complex functions to double complex:
+                        *       cabs,csqrt,cexp,clog,csin,ccos, aimag
+                        * and convert real specifics to double:
+                        *       amod,alog,alog10
+                        * (sqrt,cos,sin,... o.k. since go through INTRGEN)
+                        */
+                       if( (sp->atype==TYCOMPLEX && (sp+1)->atype==TYDCOMPLEX)
+                               ||(sp->atype==TYREAL && (sp+1)->atype==TYDREAL))
+                                       sp++;
+                       }
        specfunct:
                if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
                        && (sp+1)->atype==sp->atype)
        specfunct:
                if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
                        && (sp+1)->atype==sp->atype)
@@ -551,8 +492,9 @@ switch(f1field)
 
                if(nargs != sp->nargs)
                        goto badnargs;
 
                if(nargs != sp->nargs)
                        goto badnargs;
-               if(mtype != sp->atype)
-                       goto badtype;
+               if(mtype != sp->atype
+                       && (!dblflag || f3field != 26 || mtype != TYDREAL ) )
+                               goto badtype;
                fixargs(YES, argsp);
                if(q = inline(sp-spectab, mtype, argsp->listp))
                        {
                fixargs(YES, argsp);
                if(q = inline(sp-spectab, mtype, argsp->listp))
                        {
@@ -561,13 +503,17 @@ switch(f1field)
                        }
                else if(sp->othername)
                        {
                        }
                else if(sp->othername)
                        {
-                       ap = builtin(sp->rtype,
+                       ap = builtin(TYDREAL,
                                varstr(XL, callbyvalue[sp->othername-1]) );
                                varstr(XL, callbyvalue[sp->othername-1]) );
+                       ap->vstg = STGINTR;
                        q = fixexpr( mkexpr(OPCCALL, ap, argsp) );
                        q = fixexpr( mkexpr(OPCCALL, ap, argsp) );
+                       if( sp->rtype != TYDREAL )
+                               q = mkconv( sp->rtype, q );
                        }
                else
                        {
                        ap = builtin(sp->rtype, varstr(XL, sp->spxname) );
                        }
                else
                        {
                        ap = builtin(sp->rtype, varstr(XL, sp->spxname) );
+                       ap->vstg = STGINTR;
                        q = fixexpr( mkexpr(OPCALL, ap, argsp) );
                        }
                return(q);
                        q = fixexpr( mkexpr(OPCALL, ap, argsp) );
                        }
                return(q);
@@ -587,7 +533,9 @@ switch(f1field)
                        rettype = tyint;
                else if(rettype == TYUNKNOWN)
                        rettype = mtype;
                        rettype = tyint;
                else if(rettype == TYUNKNOWN)
                        rettype = mtype;
-               return( mkconv(rettype, q) );
+               else if( dblflag && rettype == TYREAL )
+                       rettype = TYDREAL;
+               return( intrconv(rettype, q) );
 
        default:
                fatali("intrcall: bad intrgroup %d", f1field);
 
        default:
                fatali("intrcall: bad intrgroup %d", f1field);
@@ -656,16 +604,29 @@ switch(packed.bits.f1)
 
        case INTRSPEC:
                sp = spectab + f3field;
 
        case INTRSPEC:
                sp = spectab + f3field;
+               if( dblflag )
+                       {
+                       if((sp->atype==TYCOMPLEX && (sp+1)->atype==TYDCOMPLEX)
+                               ||(sp->atype==TYREAL && (sp+1)->atype==TYDREAL))
+                                       sp++;
+                       else if( f3field==4 )
+                                       sp += 2;  /* h_nint -> h_dnnt */
+                       else if( f3field==8 || f3field==18 || f3field==22)
+                                       sp += 3;  /* r_{abs,sign,dim} ->d_... */
+                       else if( f3field==26 )
+                                       sp = spectab + 81; /* dprod */
+
+                       }
                if(tyint==TYLONG && sp->rtype==TYSHORT)
                        ++sp;
                q = builtin(sp->rtype, varstr(XL,sp->spxname) );
                if(tyint==TYLONG && sp->rtype==TYSHORT)
                        ++sp;
                q = builtin(sp->rtype, varstr(XL,sp->spxname) );
+               q->vstg = STGINTR;
                return(q);
 
        case INTRCONV:
        case INTRMIN:
        case INTRMAX:
        case INTRBOOL:
                return(q);
 
        case INTRCONV:
        case INTRMIN:
        case INTRMAX:
        case INTRBOOL:
-       case INTRCNST:
        bad:
                errstr("cannot pass %s as actual",
                        varstr(VL,np->varname));
        bad:
                errstr("cannot pass %s as actual",
                        varstr(VL,np->varname));
@@ -700,7 +661,7 @@ switch(fno)
                else
                        t = (expptr) mktemp(type,PNULL);
                t1 = mkexpr(OPQUEST,
                else
                        t = (expptr) mktemp(type,PNULL);
                t1 = mkexpr(OPQUEST,
-                       mkexpr(OPLE, mkconv(type,ICON(0)), cpexpr(t)),
+                       mkexpr(OPLE, intrconv(type,ICON(0)), cpexpr(t)),
                        mkexpr(OPCOLON, cpexpr(t),
                                mkexpr(OPNEG, cpexpr(t), ENULL) ));
                if(q)
                        mkexpr(OPCOLON, cpexpr(t),
                                mkexpr(OPNEG, cpexpr(t), ENULL) ));
                if(q)
@@ -709,10 +670,11 @@ switch(fno)
                return(t1);
 
        case 26:        /* dprod */
                return(t1);
 
        case 26:        /* dprod */
-               q = mkexpr(OPSTAR, mkconv(TYDREAL,args->datap), args->nextp->datap);
+               q = mkexpr(OPSTAR, intrconv(TYDREAL,args->datap), args->nextp->datap);
                return(q);
 
        case 27:        /* len of character string */
                return(q);
 
        case 27:        /* len of character string */
+       case 28:
                q = (expptr) cpexpr(args->datap->headblock.vleng);
                frexpr(args->datap);
                return(q);
                q = (expptr) cpexpr(args->datap->headblock.vleng);
                frexpr(args->datap);
                return(q);
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.