use Structures: all; use SimplePrint: all; /* % Dyadic Scalar Function kernel macro definitions % Function names are defined as: % {valence, jsymbol, compute type, result type} % Having result type available will let us support things like % int*int where we know result will be integer, rather than being % required to support double_real result. 1996-05-05 */ /* x plus y */ #define dplusBBI(XV,YV) (toi(XV)+toi(YV)) #define dplusBII(XV,YV) (toi(XV)+YV) #define dplusIBI(XV,YV) (XV+toi(YV)) #define dplusIII(XV,YV) (XV+YV) #define dplusDDD(XV,YV) (XV+YV) #define dplusBDD(XV,YV) (tod(XV)+YV) #define dplusDBD(XV,YV) (XV+tod(YV)) #define dplusIDD(XY,YV) (tod(XV)+YV) #define dplusDID(XV,YV) (XV+tod(YV)) /* x minus y */ #define dbarBBI(XV,YV) (toi(XV)-toi(YV)) #define dbarIBI(XV,YV) (XV-toi(YV)) #define dbarBII(XV,YV) (XV-YV) #define dbarIII(XV,YV) (XV-YV) #define dbarIDD(XV,YV) (tod(XV)-YV) #define dbarDID(XV,YV) (XV-tod(YV)) #define dbarDDD(XV,YV) (XV-YV) #define dbarBDD(XV,YV) (tod(XV)-YV) #define dbarDBD(XV,YV) (XV-tod(YV)) /* x times y */ #define dmpyBBB(XV,YV) (XV&YV) #define dmpyIII(XV,YV) (XV*YV) #define dmpyDDD(XV,YV) (XV*YV) #define dmpyBII(XV,YV) (toi(XV)*YV) #define dmpyIBI(XV,YV) (XV*toi(YV)) #define dmpyBDD(XV,YV) (tod(XV)*YV) #define dmpyDBD(XV,YV) (XV*tod(YV)) #define dmpyDID(XV,YV) (XV*tod(YV)) #define dmpyIDD(XV,YV) (tod(XV)*YV) /* x divided by y */ inline double APEX_DIVIDEDD (double X, double Y) { if (X == Y) z = 1.0d; else z = X/Y; return(z); } #define ddivBDD(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivIDD(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivDDD(XV,YV) (APEX_DIVIDEDD(XV,YV)) /* x min y */ inline int APEX_MINII (int x, int y) { if (x <= y) z = x; else z = y; return (z); } inline char APEX_MINCC (char x, char y) { if (x <= y) z = x; else z = y; return (z); } inline double APEX_MINDD (double x, double y) { if (x <= y) z = x; else z = y; return (z); } #define dminBBB(XV,YV) (XV&YV) #define dminIII(XV,YV) (APEX_MINII(XV,YV)) #define dminDDD(XV,YV) (APEX_MINDD(XV,YV)) #define dminCCC(XV,YV) (APEX_MINCC(XV,YV)) #define dminBII(XV,YV) (APEX_MINII(toi(XV),YV)) #define dminIBI(XV,YV) (APEX_MINII(XV,toi(YV))) #define dminBDD(XV,YV) (APEX_MINDD(tod(XV),YV)) #define dminDBD(XV,YV) (APEX_MINDD(XV,tod(YV))) #define dminIDD(XV,YV) (APEX_MINDD(tod(XV),YV)) #define dminDID(XV,YV) (APEX_MINDD(XV,tod(YV))) /* NB. max and min extended to characters */ inline int APEX_MAXII (int x, int y) { if (x >= y) z = x; else z = y; return (z); } inline char APEX_MAXCC (char x, char y) { if (x >= y) z = x; else z = y; return (z); } inline double APEX_MAXDD (double x, double y) { if (x >= y) z = x; else z = y; return (z); } /* x max y */ #define dmaxBBB(XV,YV) (XV|YV) #define dmaxIII(XV,YV) (APEX_MAXII(XV,YV)) #define dmaxDDD(XV,YV) (APEX_MAXDD(XV,YV)) #define dmaxCCC(XV,YV) (APEX_MAXCC(XV,YV)) #define dmaxBII(XV,YV) (APEX_MAXII(toi(XV),YV)) #define dmaxIBI(XV,YV) (APEX_MAXII(XV,toi(YV))) #define dmaxBDD(XV,YV) (APEX_MAXDD(tod(XV),YV)) #define dmaxDBD(XV,YV) (APEX_MAXDD(XV,tod(YV))) #define dmaxIDD(XV,YV) (APEX_MAXDD(tod(XV),YV)) #define dmaxDID(XV,YV) (APEX_MAXDD(XV,tod(YV))) /* x mod y */ #define dmodBBB(XV,YV,QUADct) ((~XV)&YV) /* x star y */ #define dstarBBB(XV,YV) (XV|~YV) #define dstarIDD(XV,YV) (exp(XV,YV)) #define dstarDDD(XV,YV) (exp(XV,YV)) /* The dstari fragment will not work in integer type because EmitDyadicScalarFns % (and everyone else!) uses lhtype,rhtype to compute fragment % type. This fails for general star because we do not know that % the result type is going to be double_real, as we can not % ascertain that the right argument is positive. % Do it the slow way for now... 1995-11-18 % Actually, now that we have predicates, we can do better! 1996-04-30 */ #define dlogBDD(XV,YV) (log(YV)/log(XV)) #define dlogIDD(XV,YV) (log(YV)/log(XV)) #define dlogDDD(XV,YV) (log(YV)/log(XV)) /* NB. Extension of ISO APL to allow comparison of characters */ /* relationals */ #define dltBBB(XV,YV,QUADct) ((~XV)&YV) #define dltIBB(XV,YV,QUADct) (XVYV) #define dgtDDB(XV,YV,QUADct) (fixmeXV>YV) #define dgtCCB(XV,YV,QUADct) (XV>YV) #define dgeBBB(XV,YV,QUADct) (XV|~YV) #define dgeIIB(XV,YV,QUADct) (XV>=YV) #define dgeDDB(XV,YV,QUADct) (fixmeXV>=YV) #define dgeCCB(XV,YV,QUADct) (XV>=YV) /* As of 2004-09-16, we don't support lcm/gcd. Needs work in code generator and dfa to support side effects in scan, etc. rbe */ #define dandBBB(XV,YV) (XV&YV) /* Euclids algorithm for lcm */ #define dandII(XV,YV) (for initial ax := abs(XV); ay := abs(YV); \ u = min(ax,ay); v := max (ax,ay); \ while (v ~= 0) repeat \ v := mod(old u,old v); \ u := old v; \ returns value of (ax*ay)/u \ end for) /* Euclids algorithm for lcm */ #define dandDD(XV,YV) (for initial ax := abs(XV); ay := abs(YV); \ u = min(ax,ay); v := max (ax,ay); \ while (v ~= 0) repeat \ v := mod(old u,old v); \ u := old v; \ returns value of (ax*ay)/u \ end for) #define dorBBB(XV,YV) (XV||YV) /* Euclids algorithm for gcd */ #define dorII(XV,YV) (for initial \ ax := abs(XV); ay := abs(YV); \ u = min(ax,ay); v := max (ax,ay); \ while (v ~= 0) repeat \ v := mod(old u,old v); \ u := old v; \ returns value of u \ end for) /* Euclids algorithm for gcd */ #define dorDDD(XV,YV) (for initial \ ax := abs(XV); ay := abs(YV); \ u = min(ax,ay); v := max (ax,ay); \ while (v ~= 0) repeat \ v := mod(old u,old v); \ u := old v; \ returns value of u \ end for) #define dnandBBB(XV,YV) (~XV&YV) #define dnorBBB(XV,YV) (~XV|YV) #define dcircDDD(XV,YV) (if (XV = 1.0d) then sin(YV) \ elseif (XV = 2.0d) then cos(YV) \ elseif (XV = 3.0d) then tan(YV) \ elseif (XV = 4.0d) then exp((1.0d+YV*YV),0.5d) \ else error[double_real] end if) /* domain error check above */ /* 1 circle */ #define dcirc1DDD(XV,YV) (sin(YV)) /* 2 circle */ #define dcirc2DDD(XV,YV) (cos(YV)) /* 3 circle */ #define dcirc3DDD(XV,YV) (tan(YV)) /* 3 circle */ #define dcirc4DDD(XV,YV) (exp((1.0d+YV*YV),0.5d)) /* % Start of boilerplate % This is used to generate the APEX stdlib.sis include file. % Standard equates and constants for APL compiler % Also standard coercion functions % For SAC, we map names of system variables, system functions, % quad, and quote-quadfrom APL symbols to legal SAC names % by replacing the quad/quote-quad with QUAD or QUOTEQUAD. % This happens in the syntax analyzer, for lack of a better % place. We also map quad/quote-quad to function calls, % removing the assignment. R. Bernecky 2004-06-11 */ /* Handy constant functions */ /* Empty vectors */ #define EMPTYBOOL _drop_SxV_(1, [true]) #define EMPTYINT _drop_SxV_(1, [0]) #define EMPTYDOUBLE _drop_SxV_(1, [0d]) #define EMPTYCHAR _drop_SxV_(1, [' ']) /* end of empty array jokes */ void APEXERROR(char[.] msg) { /* Error function. This needs work, as it should kill * the running task, too. */ /*print(msg); */ return(); } /* Structural function utility functions */ inline int VectorRotateAmount(int x, int y) { /* Normalize x rotate for array of shape y on selected axis */ /* normalize rotation count */ if (x>0) z = _mod_(x,y); else z = y - _mod_(_abs_(x),y); return(z); } /* First-axis catenate, stolen from NTCtemplates_array.mac */ #define CAT( a) \ inline \ a[*] (++)( a[+] arr_a, a[+] arr_b) \ { \ new_shp = _modarray_( _shape_( arr_a), \ [0], \ _add_SxS_( _sel_([0], _shape_( arr_a)), \ _sel_([0], _shape_( arr_b)) ) ); \ res = with( . <= iv < _shape_( arr_a)) \ genarray( new_shp, _sel_( iv, arr_a)); \ offset = _modarray_( _mul_SxA_( 0, new_shp), \ [0], \ _sel_([0], _shape_( arr_a)) ); \ res = with( offset <= iv <= .) \ modarray( res, iv, _sel_( _sub_AxA_( iv, offset), arr_b)); \ return( res); \ } #define BUILT_IN( fun) \ fun( int) \ fun( bool) \ fun( char) \ fun( double) \ fun( float) /* scalar take matrix, adapted from NTCtemplates_array.mac */ #define APLTAKE(a) \ inline \ a[*] take( int v, a[*] array) \ { \ v2 = _shape_(array); \ v2 = modarray(v2,[0],v); \ return( take(v2,array)); \ } /* Fill elements for Boolean, integer, double, and character */ #define OTFILLB false #define OTFILLI 0 #define OTFILLD 0d #define OTFILLC ' ' #define OTFILLboolean false #define OTFILLinteger 0 #define OTFILLdouble 0d #define OTFILLcharacter ' ' #define APEXPI 3.1415926535897932d #define APEXE 2.718281828d /* APEXPINFINITYI largest integer */ #define APEXPINFINITYD 1.7976931348623156D308 /* APEXMINFINITYI smallest integer */ #define APEXMINFINITYD -1.7976931348623156D308 /* % Various identity functions */ #define BtoB(x) (x) #define ItoI(x) (x) #define DtoD(x) (x) #define CtoC(x) (x) #define toc(x) (x) #define BtoB0(x) (x) #define ItoI0(x) (x) #define DtoD0(x) (x) #define CtoC0(x) (x) #define BtoB1(x) (x) #define ItoI1(x) (x) #define DtoD1(x) (x) #define CtoC1(x) (x) #define BtoB2(x) (x) #define ItoI2(x) (x) #define DtoD2(x) (x) #define CtoC2(x) (x) #define BtoB3(x) (x) #define ItoI3(x) (x) #define DtoD3(x) (x) #define CtoC3(x) (x) /* Lev and Dex */ #define ltakx(y) (y) /* We do not need no steenking rtakx */ #define ltakb(x,y) (y) #define ltakb(x,y) (y) #define rtakb(x,y) (x) #define rtakb(x,y) (x) #define ltaki(x,y) (y) #define ltaki(x,y) (y) #define rtaki(x,y) (x) #define rtaki(x,y) (x) #define ltakd(x,y) (y) #define ltakd(x,y) (y) #define rtakd(x,y) (x) #define rtakd(x,y) (x) #define ltakc(x,y) (y) #define ltakc(x,y) (y) #define rtakc(x,y) (x) #define rtakc(x,y) (x) inline bool[+] tob (bool[+] x) { z = with (. <= iv <= .) genarray(_shape_(x),tob(_sel_(iv,x))); return(z); } inline bool[+] tob (int[+] x) { z = with (. <= iv <= .) genarray(_shape_(x),tob(_sel_(iv,x))); return(z); } inline bool[+] tob (double[+] x) { z = with (. <= iv <= .) genarray(_shape_(x),tob(_sel_(iv,x))); return(z); } inline bool tob(bool x) { return(x); } inline bool tob(int x) { if (1 == _toi_S_(x)) z = true; else z = false; return(z); } inline bool tob(double x) { if (1 == _toi_S_(x)) z = true; else z = false; return(z); } inline int BtoI(bool x) { if (x) z = 1; else z = 0; return(z); } inline double BtoD(bool x) { if (x) z = 1.0d; else z = 0d; return(z); } #define BtoC(x) error[character] inline bool ItoB0(int x) { if (1 == x) z = true; else if (0 == x) z = false; else { /* error("domain error on BtoC\n"); stupid string vs array*/ z = false; } return(z); } #define ItoD(x) double(x) #define ItoC(x) error[character] inline bool DtoB(double x) { z = true; if (0d == x) z = false; /* stupid string vs array else error("domain error in DtoB\n"); */ return(z); } /* this is BROKEN 2004-08-24 rbe inline int DtoI(double x) { stupid string vs array if (x != trunc(x)) error("domain error in DtoI\n"); return(x); } * BROKEN */ #define DtoC(x) error[character] #define CtoB(x) error[boolean] #define CtoI(x) error[integer] #define CtoD(x) error[double_real] /* end of scalar coercions */ /* % Floating-point utilities % This taken from page 93 of the 1993-01-06 version % of Committee Draft 1 of the Extended ISO APL Standard % NO {quad}ct support yet! */ #define Dsignum(p) (if p = 0.0d0 then 0 elseif p<0.0d0 then -1 else 1 end if) #define Isignum(p) (if p = 0 then 0 elseif p<0 then -1 else 1 end if) #define Dmod(p,q) fmod(tod(p),tod(q)) #define Imod(p,q) _mod_(p,q) #define QuadAV( ) (for i in 0,255 returns array of character(i) end for) /* % 1996-12-07 Pearl Harbor Day. Try to fix bug in DBank infdivm % benchmark. (4 5 rho 6) + rank 1 (4 1 rho 7) introduces singleton % vectors into scalar fn calls. % Hence, we need support for singletons within scalar fns. % There is an similar, but independent, bug in rank support for % the extension case. */ /* vector-scalar simple search loops * This is origin-0 x1 iota y0 * cfn is comparator function type suffix to use, e.g, b,i,d,c, */ /* Lehmer's random number generator */ #define lehmer(qrl) mod(qrl*16807,2147483647) /* Ravel utility */ #define APEXRAVEL(y) (_reshape_([prod(_shape_(y))],y)) /* Transposes */ #define APEXTRANSPOSE(TYPE) \ inline TYPE APEXTranspose(TYPE y) \ { \ return(y); \ } \ inline TYPE[.] APEXTranspose(TYPE[.] y) \ { \ return(y); \ } \ inline TYPE[.,.] APEXTranspose(TYPE[.,.] y) \ {/* Rank 2 transpose */ \ return({[i,j] -> y[[j,i]]}); \ } \ inline TYPE[.,.,.] APEXTranspose(TYPE[.,.,.] y) \ { /* Rank-3 transpose */ \ return({[i,j,k] -> y[[k,j,i]]}); \ } \ inline TYPE[.,.,.,.] APEXTranspose(TYPE[.,.,.,.] y) \ { /* Rank-4 transpose */ \ return({[i,j,k,l] -> y[[l,k,j,i]]}); \ } \ inline TYPE[.,.,.,.,.] APEXTranspose(TYPE[.,.,.,.,.] y) \ { /* Rank-5 transpose */ \ return({[i,j,k,l,m] -> y[[m,l,k,j,i]]}); \ } \ inline TYPE[.,.,.,.,.,.] APEXTranspose(TYPE[.,.,.,.,.,.] y) \ { /* Rank-6 transpose */ \ return({[i,j,k,l,m,n] -> y[[n,m,l,k,j,i]]}); \ } \ inline TYPE[.,.,.,.,.,.,.] APEXTranspose(TYPE[.,.,.,.,.,.,.] y) \ { /* Rank-7 transpose */ \ return({[i,j,k,l,m,n,o] -> y[[o,n,m,l,k,j,i]]}); \ } APEXTRANSPOSE(bool) APEXTRANSPOSE(int) APEXTRANSPOSE(double) APEXTRANSPOSE(char) /* End of transpose utilities */ /* modulus functions */ inline int Dmodulo(int x, int y, double QUADct) { if (0 == x) z = 0; else z = Imod(y,x); return(z); } /* End of boilerplate */ #define toB(x) tob((x)) #define toI(x) toi((x)) #define toD(x) tod((x)) #define toC(x) toc((x)) /* Compiled by APEX at 2004-10-22 16:48:15.000 */ inline double plusDIDsl(double x, int y ) { /* SxS dyadic scalar fn, shapes match */ z = dplusDID(toD(x),toD(y)); return(z); } /* Index generator */ inline int[.] iotaXII(int shp, int QUADio) { /* HELP! Needs domain check for negative shp */ res = with( . <= [i] <= .) genarray( [toi(shp)], i+QUADio); return( res); } inline int[.] iotaXIIsy(int y, int QUADio) { return(iotaXII(y, QUADio)); } /* Index generator when argument known to be legal */ inline int[.] iotaXIINonNegsy( int shp, int QUADio) { res = with( . <= [i] <= .) genarray( [toi(shp)], i+QUADio); return( res); } /* Index generator on 1-element vectors */ inline int[.] iotaXII(int[1] shp, int QUADio) { /* HELP! Needs length error check */ /* HELP! Needs domain check for negative shp */ res = with( . <= [i] <= .) genarray( [toi(shp[0])], i+QUADio); return( res); } double quadXDD(double y, int QUADpp, int QUADpw) { /* {quad}{<-} scalar */ return(y); } double quadXDDsy(double y, int QUADpp, int QUADpw) { /* {quad}{<-} scalar */ return(y); } double quadXDD(double[*] y, int QUADpp, int QUADpw) { /* {quad}{<-} non-scalar */ return(y); } double quadXDDsy(double[*] y, int QUADpp, int QUADpw) { /* {quad}{<-} non-scalar */ return(y); } /* Start of function loopfs */ double loopfs(int n,int QUADio) { r_0=( 0.0d ) ; TMP_29=iotaXII( n ,QUADio) ; CTR030_= 0; CTR030z_ = _sel_([0],_shape_(TMP_29 ))-1; r_2=tod(r_0); for(; CTR030_ <= CTR030z_; CTR030_++){ i_0 = TMP_29 [CTR030_]; r_2=plusDIDsl(r_2 ,i_0 ); } r=r_2; return(r_2); } /* End of function loopfs */ /* Start of function main */ int main() { QUADio_0=toi(( false ) ); QUADct_0=( 1.0e-13 ) ; QUADpp_0=( 10 ) ; QUADpw_0=( 80 ) ; QUADrl_0=( 16807 ) ; QUADio_1=toi(( false ) ); QUADpp_1=( 10 ) ; QUADpw_1=( 10 ) ; n_0=( 5000000 ) ; QUADrl_1=( 16807 ) ; r_0=loopfs( n_0 ,QUADio_1) ; #if 0 TMP_62=quadXDD( r_0 ,QUADpp_1,QUADpw_1) ; r=r_0; #endif return(toi(r_0)); } /* End of function main */