extern ftnint intcon
[14];
extern double realcon
[6];
int intrstuff
/* result type or number of generics */;
"int", { INTRCONV
, TYLONG
},
"real", { INTRCONV
, TYREAL
},
"dble", { INTRCONV
, TYDREAL
},
"dreal", { INTRCONV
, TYDREAL
},
"cmplx", { INTRCONV
, TYCOMPLEX
},
"dcmplx", { INTRCONV
, TYDCOMPLEX
},
"ifix", { INTRCONV
, TYLONG
},
"idint", { INTRCONV
, TYLONG
},
"float", { INTRCONV
, TYREAL
},
"dfloat", { INTRCONV
, TYDREAL
},
"sngl", { INTRCONV
, TYREAL
},
"ichar", { INTRCONV
, TYLONG
},
"iachar", { INTRCONV
, TYLONG
},
"char", { INTRCONV
, TYCHAR
},
"achar", { INTRCONV
, TYCHAR
},
"max", { INTRMAX
, TYUNKNOWN
},
"max0", { INTRMAX
, TYLONG
},
"amax0", { INTRMAX
, TYREAL
},
"max1", { INTRMAX
, TYLONG
},
"amax1", { INTRMAX
, TYREAL
},
"dmax1", { INTRMAX
, TYDREAL
},
"and", { INTRBOOL
, TYUNKNOWN
, OPBITAND
},
"or", { INTRBOOL
, TYUNKNOWN
, OPBITOR
},
"xor", { INTRBOOL
, TYUNKNOWN
, OPBITXOR
},
"not", { INTRBOOL
, TYUNKNOWN
, OPBITNOT
},
"lshift", { INTRBOOL
, TYUNKNOWN
, OPLSHIFT
},
"rshift", { INTRBOOL
, TYUNKNOWN
, OPRSHIFT
},
"min", { INTRMIN
, TYUNKNOWN
},
"min0", { INTRMIN
, TYLONG
},
"amin0", { INTRMIN
, TYREAL
},
"min1", { INTRMIN
, TYLONG
},
"amin1", { INTRMIN
, TYREAL
},
"dmin1", { INTRMIN
, TYDREAL
},
"aint", { INTRGEN
, 2, 0 },
"dint", { INTRSPEC
, TYDREAL
, 1 },
"anint", { INTRGEN
, 2, 2 },
"dnint", { INTRSPEC
, TYDREAL
, 3 },
"nint", { INTRGEN
, 4, 4 },
"idnint", { INTRGEN
, 2, 6 },
"abs", { INTRGEN
, 6, 8 },
"iabs", { INTRGEN
, 2, 9 },
"dabs", { INTRSPEC
, TYDREAL
, 11 },
"cabs", { INTRSPEC
, TYREAL
, 12 },
"zabs", { INTRSPEC
, TYDREAL
, 13 },
"cdabs", { INTRSPEC
, TYDREAL
, 13 },
"mod", { INTRGEN
, 4, 14 },
"amod", { INTRSPEC
, TYREAL
, 16 },
"dmod", { INTRSPEC
, TYDREAL
, 17 },
"sign", { INTRGEN
, 4, 18 },
"isign", { INTRGEN
, 2, 19 },
"dsign", { INTRSPEC
, TYDREAL
, 21 },
"dim", { INTRGEN
, 4, 22 },
"idim", { INTRGEN
, 2, 23 },
"ddim", { INTRSPEC
, TYDREAL
, 25 },
"dprod", { INTRSPEC
, TYDREAL
, 26 },
"len", { INTRSPEC
, TYLONG
, 27 },
"index", { INTRSPEC
, TYLONG
, 29 },
"imag", { INTRGEN
, 2, 31 },
"aimag", { INTRSPEC
, TYREAL
, 31 },
"dimag", { INTRSPEC
, TYDREAL
, 32 },
"conjg", { INTRGEN
, 2, 33 },
"dconjg", { INTRSPEC
, TYDCOMPLEX
, 34 },
"sqrt", { INTRGEN
, 4, 35 },
"dsqrt", { INTRSPEC
, TYDREAL
, 36 },
"csqrt", { INTRSPEC
, TYCOMPLEX
, 37 },
"zsqrt", { INTRSPEC
, TYDCOMPLEX
, 38 },
"cdsqrt", { INTRSPEC
, TYDCOMPLEX
, 38 },
"exp", { INTRGEN
, 4, 39 },
"dexp", { INTRSPEC
, TYDREAL
, 40 },
"cexp", { INTRSPEC
, TYCOMPLEX
, 41 },
"zexp", { INTRSPEC
, TYDCOMPLEX
, 42 },
"cdexp", { INTRSPEC
, TYDCOMPLEX
, 42 },
"log", { INTRGEN
, 4, 43 },
"alog", { INTRSPEC
, TYREAL
, 43 },
"dlog", { INTRSPEC
, TYDREAL
, 44 },
"clog", { INTRSPEC
, TYCOMPLEX
, 45 },
"zlog", { INTRSPEC
, TYDCOMPLEX
, 46 },
"cdlog", { INTRSPEC
, TYDCOMPLEX
, 46 },
"log10", { INTRGEN
, 2, 47 },
"alog10", { INTRSPEC
, TYREAL
, 47 },
"dlog10", { INTRSPEC
, TYDREAL
, 48 },
"sin", { INTRGEN
, 4, 49 },
"dsin", { INTRSPEC
, TYDREAL
, 50 },
"csin", { INTRSPEC
, TYCOMPLEX
, 51 },
"zsin", { INTRSPEC
, TYDCOMPLEX
, 52 },
"cdsin", { INTRSPEC
, TYDCOMPLEX
, 52 },
"cos", { INTRGEN
, 4, 53 },
"dcos", { INTRSPEC
, TYDREAL
, 54 },
"ccos", { INTRSPEC
, TYCOMPLEX
, 55 },
"zcos", { INTRSPEC
, TYDCOMPLEX
, 56 },
"cdcos", { INTRSPEC
, TYDCOMPLEX
, 56 },
"tan", { INTRGEN
, 2, 57 },
"dtan", { INTRSPEC
, TYDREAL
, 58 },
"asin", { INTRGEN
, 2, 59 },
"dasin", { INTRSPEC
, TYDREAL
, 60 },
"acos", { INTRGEN
, 2, 61 },
"dacos", { INTRSPEC
, TYDREAL
, 62 },
"atan", { INTRGEN
, 2, 63 },
"datan", { INTRSPEC
, TYDREAL
, 64 },
"atan2", { INTRGEN
, 2, 65 },
"datan2", { INTRSPEC
, TYDREAL
, 66 },
"sinh", { INTRGEN
, 2, 67 },
"dsinh", { INTRSPEC
, TYDREAL
, 68 },
"cosh", { INTRGEN
, 2, 69 },
"dcosh", { INTRSPEC
, TYDREAL
, 70 },
"tanh", { INTRGEN
, 2, 71 },
"dtanh", { INTRSPEC
, TYDREAL
, 72 },
"lge", { INTRSPEC
, TYLOGICAL
, 73},
"lgt", { INTRSPEC
, TYLOGICAL
, 75},
"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 },
char othername
; /* index into callbyvalue table */
{ TYREAL
,TYREAL
,1,"r_int" },
{ TYDREAL
,TYDREAL
,1,"d_int" },
{ TYREAL
,TYREAL
,1,"r_nint" },
{ TYDREAL
,TYDREAL
,1,"d_nint" },
{ TYREAL
,TYSHORT
,1,"h_nint" },
{ TYREAL
,TYLONG
,1,"i_nint" },
{ TYDREAL
,TYSHORT
,1,"h_dnnt" },
{ TYDREAL
,TYLONG
,1,"i_dnnt" },
{ TYREAL
,TYREAL
,1,"r_abs" },
{ TYSHORT
,TYSHORT
,1,"h_abs" },
{ TYLONG
,TYLONG
,1,"i_abs" },
{ TYDREAL
,TYDREAL
,1,"d_abs" },
{ TYCOMPLEX
,TYREAL
,1,"c_abs" },
{ TYDCOMPLEX
,TYDREAL
,1,"z_abs" },
{ TYSHORT
,TYSHORT
,2,"h_mod" },
{ TYLONG
,TYLONG
,2,"i_mod" },
{ TYREAL
,TYREAL
,2,"r_mod" },
{ TYDREAL
,TYDREAL
,2,"d_mod" },
{ TYREAL
,TYREAL
,2,"r_sign" },
{ TYSHORT
,TYSHORT
,2,"h_sign" },
{ TYLONG
,TYLONG
,2,"i_sign" },
{ TYDREAL
,TYDREAL
,2,"d_sign" },
{ TYREAL
,TYREAL
,2,"r_dim" },
{ TYSHORT
,TYSHORT
,2,"h_dim" },
{ TYLONG
,TYLONG
,2,"i_dim" },
{ TYDREAL
,TYDREAL
,2,"d_dim" },
{ TYREAL
,TYDREAL
,2,"d_prod" },
{ TYCHAR
,TYSHORT
,1,"h_len" },
{ TYCHAR
,TYLONG
,1,"i_len" },
{ TYCHAR
,TYSHORT
,2,"h_indx" },
{ TYCHAR
,TYLONG
,2,"i_indx" },
{ TYCOMPLEX
,TYREAL
,1,"r_imag" },
{ TYDCOMPLEX
,TYDREAL
,1,"d_imag" },
{ TYCOMPLEX
,TYCOMPLEX
,1,"r_cnjg" },
{ TYDCOMPLEX
,TYDCOMPLEX
,1,"d_cnjg" },
{ TYREAL
,TYREAL
,1,"r_sqrt", 1 },
{ TYDREAL
,TYDREAL
,1,"d_sqrt", 1 },
{ TYCOMPLEX
,TYCOMPLEX
,1,"c_sqrt" },
{ TYDCOMPLEX
,TYDCOMPLEX
,1,"z_sqrt" },
{ TYREAL
,TYREAL
,1,"r_exp", 2 },
{ TYDREAL
,TYDREAL
,1,"d_exp", 2 },
{ TYCOMPLEX
,TYCOMPLEX
,1,"c_exp" },
{ TYDCOMPLEX
,TYDCOMPLEX
,1,"z_exp" },
{ TYREAL
,TYREAL
,1,"r_log", 3 },
{ TYDREAL
,TYDREAL
,1,"d_log", 3 },
{ TYCOMPLEX
,TYCOMPLEX
,1,"c_log" },
{ TYDCOMPLEX
,TYDCOMPLEX
,1,"z_log" },
{ TYREAL
,TYREAL
,1,"r_lg10" },
{ TYDREAL
,TYDREAL
,1,"d_lg10" },
{ TYREAL
,TYREAL
,1,"r_sin", 4 },
{ TYDREAL
,TYDREAL
,1,"d_sin", 4 },
{ TYCOMPLEX
,TYCOMPLEX
,1,"c_sin" },
{ TYDCOMPLEX
,TYDCOMPLEX
,1,"z_sin" },
{ TYREAL
,TYREAL
,1,"r_cos", 5 },
{ TYDREAL
,TYDREAL
,1,"d_cos", 5 },
{ TYCOMPLEX
,TYCOMPLEX
,1,"c_cos" },
{ TYDCOMPLEX
,TYDCOMPLEX
,1,"z_cos" },
{ TYREAL
,TYREAL
,1,"r_tan", 6 },
{ TYDREAL
,TYDREAL
,1,"d_tan", 6 },
{ TYREAL
,TYREAL
,1,"r_asin", 7 },
{ TYDREAL
,TYDREAL
,1,"d_asin", 7 },
{ TYREAL
,TYREAL
,1,"r_acos", 8 },
{ TYDREAL
,TYDREAL
,1,"d_acos", 8 },
{ TYREAL
,TYREAL
,1,"r_atan", 9 },
{ TYDREAL
,TYDREAL
,1,"d_atan", 9 },
{ TYREAL
,TYREAL
,2,"r_atn2", 10 },
{ TYDREAL
,TYDREAL
,2,"d_atn2", 10 },
{ TYREAL
,TYREAL
,1,"r_sinh", 11 },
{ TYDREAL
,TYDREAL
,1,"d_sinh", 11 },
{ TYREAL
,TYREAL
,1,"r_cosh", 12 },
{ TYDREAL
,TYDREAL
,1,"d_cosh", 12 },
{ TYREAL
,TYREAL
,1,"r_tanh", 13 },
{ TYDREAL
,TYDREAL
,1,"d_tanh", 13 },
{ TYCHAR
,TYLOGICAL
,2,"hl_ge" },
{ TYCHAR
,TYLOGICAL
,2,"l_ge" },
{ TYCHAR
,TYLOGICAL
,2,"hl_gt" },
{ TYCHAR
,TYLOGICAL
,2,"l_gt" },
{ TYCHAR
,TYLOGICAL
,2,"hl_le" },
{ TYCHAR
,TYLOGICAL
,2,"l_le" },
{ 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" }
/* For each machine, two arrays must be initialized.
radix for single precision
radix for double precision
precision for single precision
precision for double precision
emin for single precision
emin for double precision
emax for single precision
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
char callbyvalue
[ ][XL
] =
expptr
intrcall(np
, argsp
, nargs
)
register struct Specblock
*sp
;
register struct Chain
*cp
;
expptr
inline(), mkcxcon(), mkrealcon();
register struct Incstblock
*cstp
;
int f1field
, f2field
, f3field
;
packed
.ijunk
= np
->vardesc
.varno
;
f1field
= packed
.bits
.f1
;
f2field
= packed
.bits
.f2
;
f3field
= packed
.bits
.f3
;
for(cp
= argsp
->listp
; cp
; cp
= cp
->nextp
)
/* TEMPORARY */ ep
= (expptr
) (cp
->datap
);
/* TEMPORARY */ if( ISCONST(ep
) && ep
->headblock
.vtype
==TYSHORT
)
/* TEMPORARY */ cp
->datap
= (tagptr
) mkconv(tyint
, ep
);
mtype
= maxtype(mtype
, ep
->headblock
.vtype
);
if( ! ONEOF(mtype
, MSKINT
|MSKLOGICAL
) )
q
= mkexpr(OPBITNOT
, argsp
->listp
->datap
, ENULL
);
q
= mkexpr(op
, argsp
->listp
->datap
,
argsp
->listp
->nextp
->datap
);
frchain( &(argsp
->listp
) );
if(argsp
->listp
->datap
->headblock
.vtype
== TYERROR
)
free( (charptr
) argsp
->listp
->datap
);
frchain( &(argsp
->listp
) );
if(argsp
->listp
->nextp
->datap
->headblock
.vtype
==
argsp
->listp
->datap
->headblock
.vtype
== TYERROR
)
free( (charptr
) argsp
->listp
->nextp
->datap
);
free( (charptr
) argsp
->listp
->datap
);
frchain( &(argsp
->listp
) );
if( ISCOMPLEX(rettype
) && nargs
==2)
qr
= (expptr
) (argsp
->listp
->datap
);
qi
= (expptr
) (argsp
->listp
->nextp
->datap
);
if(ISCONST(qr
) && ISCONST(qi
))
else q
= mkexpr(OPCONV
,mkconv(rettype
-2,qr
),
q
= mkconv(rettype
, argsp
->listp
->datap
);
q
->headblock
.vtype
= rettype
;
frchain(&(argsp
->listp
));
cstp
= consttab
+ f3field
;
for(i
=0 ; i
<f2field
; ++i
)
return(mkintcon(intcon
[cstp
->constno
]));
return(mkrealcon(cstp
->rtype
,
realcon
[cstp
->constno
]) );
fatal("impossible intrinsic constant");
else err66("generic function");
for(i
=0; i
<f2field
; ++i
)
if(tyint
==TYLONG
&& ONEOF(sp
->rtype
,M(TYSHORT
)|M(TYLOGICAL
))
&& (sp
+1)->atype
==sp
->atype
)
if(q
= inline(sp
-spectab
, mtype
, argsp
->listp
))
frchain( &(argsp
->listp
) );
varstr(XL
, callbyvalue
[sp
->othername
-1]) );
q
= fixexpr( mkexpr(OPCCALL
, ap
, argsp
) );
ap
= builtin(sp
->rtype
, varstr(XL
, sp
->spxname
) );
q
= fixexpr( mkexpr(OPCALL
, ap
, argsp
) );
if( ! ONEOF(mtype
, MSKINT
|MSKREAL
) )
q
= mkexpr( (f1field
==INTRMIN
? OPMIN
: OPMAX
), argsp
, ENULL
);
q
->headblock
.vtype
= mtype
;
else if(rettype
== TYUNKNOWN
)
return( mkconv(rettype
, q
) );
fatali("intrcall: bad intrgroup %d", f1field
);
errstr("bad number of arguments to intrinsic %s",
varstr(VL
,np
->varname
) );
errstr("bad argument type to intrinsic %s", varstr(VL
, np
->varname
) );
register struct Intrblock
*p
;
nm
[i
++] = (*s
==' ' ? '\0' : *s
);
for(p
= intrtab
; p
->intrval
.intrgroup
!=INTREND
; ++p
)
if( eqn(VL
, nm
, p
->intrfname
) )
packed
.bits
.f1
= p
->intrval
.intrgroup
;
packed
.bits
.f2
= p
->intrval
.intrstuff
;
packed
.bits
.f3
= p
->intrval
.intrno
;
register struct Specblock
*sp
;
if(np
->vclass
!=CLPROC
|| np
->vprocclass
!=PINTRINSIC
)
fatalstr("intraddr: %s is not intrinsic", varstr(VL
,np
->varname
));
packed
.ijunk
= np
->vardesc
.varno
;
f3field
= packed
.bits
.f3
;
/* imag, log, and log10 arent specific functions */
if(f3field
==31 || f3field
==43 || f3field
==47)
if(tyint
==TYLONG
&& sp
->rtype
==TYSHORT
)
q
= builtin(sp
->rtype
, varstr(XL
,sp
->spxname
) );
errstr("cannot pass %s as actual",
return( (Addrp
) errnode() );
fatali("intraddr: impossible f1=%d\n", (int) packed
.bits
.f1
);
expptr
inline(fno
, type
, args
)
register expptr q
, t
, t1
;
case 9: /* short int abs */
case 10: /* long int abs */
case 11: /* double precision abs */
if( addressable(q
= (expptr
) (args
->datap
)) )
t
= (expptr
) mktemp(type
,PNULL
);
mkexpr(OPLE
, mkconv(type
,ICON(0)), cpexpr(t
)),
mkexpr(OPCOLON
, cpexpr(t
),
mkexpr(OPNEG
, cpexpr(t
), ENULL
) ));
t1
= mkexpr(OPCOMMA
, mkexpr(OPASSIGN
, cpexpr(t
),q
), t1
);
q
= mkexpr(OPSTAR
, mkconv(TYDREAL
,args
->datap
), args
->nextp
->datap
);
case 27: /* len of character string */
q
= (expptr
) cpexpr(args
->datap
->headblock
.vleng
);
case 14: /* half-integer mod */
return( mkexpr(OPMOD
, (expptr
) (args
->datap
),
(expptr
) (args
->nextp
->datap
) ));