-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathva1.c
125 lines (107 loc) · 5.04 KB
/
va1.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
/* Copyright 1990-2011, Jsoftware Inc. All rights reserved. */
/* License in license.txt. */
/* */
/* Verbs: Monadic Atomic */
#include "j.h"
#include "ve.h"
static AMON(floorDI,I,D, {D d=tfloor(*x); *z=(I)d; ASSERTW(d==*z,EWOV);})
static AMON(floorD, D,D, *z=tfloor(*x);)
static AMON(floorZ, Z,Z, *z=zfloor(*x);)
static AMON(ceilDI, I,D, {D d=tceil(*x); *z=(I)d; ASSERTW(d==*z,EWOV);})
static AMON(ceilD, D,D, *z=tceil(*x);)
static AMON(ceilZ, Z,Z, *z=zceil(*x);)
static AMON(cjugZ, Z,Z, *z=zconjug(*x);)
static AMON(sgnI, I,I, *z=SGN(*x);)
static AMON(sgnD, I,D, *z=jt->ct>ABS(*x)?0:SGN(*x);)
static AMON(sgnZ, Z,Z, if(jt->ct>zmag(*x))*z=zeroZ; else *z=ztrend(*x);)
static AMON(sqrtI, D,I, ASSERTW(0<=*x,EWIMAG); *z=sqrt((D)*x);)
static AMON(sqrtD, D,D, ASSERTW(0<=*x,EWIMAG); *z=sqrt( *x);)
static AMON(sqrtZ, Z,Z, *z=zsqrt(*x);)
static AMON(expB, D,B, *z=*x?2.71828182845904523536:1;)
static AMON(expI, D,I, *z=*x<EMIN?0.0:EMAX<*x?inf:exp((D)*x);)
static AMON(expD, D,D, *z=*x<EMIN?0.0:EMAX<*x?inf:exp( *x);)
static AMON(expZ, Z,Z, *z=zexp(*x);)
static AMON(logB, D,B, *z=*x?0:infm;)
static AMON(logI, D,I, ASSERTW(0<=*x,EWIMAG); *z=log((D)*x);)
static AMON(logD, D,D, ASSERTW(0<=*x,EWIMAG); *z=log( *x);)
static AMON(logZ, Z,Z, *z=zlog(*x);)
static AMON(absI, I,I, if(0<=*x)*z=*x; else{ASSERTW(IMIN<*x,EWOV); *z=-*x;})
static AMON(absD, D,D, *z= ABS(*x);)
static AMON(absZ, D,Z, *z=zmag(*x);)
static AHDR1(oneB,C,C){memset(z,C1,n);}
static AHDR1(idf ,C,C){} /* dummy */
static UC va1fns[]={CFLOOR, CCEIL, CPLUS, CSTAR, CSQRT, CEXP, CLOG, CSTILE, CBANG, CCIRCLE, C0};
static UA va1tab[]={
/* <. */ {{{ idf,VB}, { idf,VI}, {floorDI,VI}, {floorZ,VZ}, { idf,VX}, {floorQ,VX}}},
/* >. */ {{{ idf,VB}, { idf,VI}, { ceilDI,VI}, { ceilZ,VZ}, { idf,VX}, { ceilQ,VX}}},
/* + */ {{{ idf,VB}, { idf,VI}, { idf,VD}, { cjugZ,VZ}, { idf,VX}, { idf,VQ}}},
/* * */ {{{ idf,VB}, { sgnI,VI}, { sgnD,VI}, { sgnZ,VZ}, { sgnX,VX}, { sgnQ,VX}}},
/* %: */ {{{ idf,VB}, {sqrtI,VD}, { sqrtD,VD}, { sqrtZ,VZ}, {sqrtX,VX}, { sqrtQ,VQ}}},
/* ^ */ {{{expB,VD}, { expI,VD}, { expD,VD}, { expZ,VZ}, { expX,VX}, { expD,VD+VDD}}},
/* ^. */ {{{logB,VD}, { logI,VD}, { logD,VD}, { logZ,VZ}, { logX,VX}, { logQD,VD}}},
/* | */ {{{ idf,VB}, { absI,VI}, { absD,VD}, { absZ,VD}, { absX,VX}, { absQ,VQ}}},
/* ! */ {{{oneB,VB}, {factI,VD}, { factD,VD}, { factZ,VZ}, {factX,VX}, { factQ,VX}}},
/* o. */ {{{ 0L,0L}, { 0L,0L}, { 0L,0L}, { 0L,0L}, { pixX,VX}, { 0L,0L}}}
};
static A jtva1(J,A,C);
static A jtva1s(J jt,A w,C id,I cv,VF ado){A e,x,z,ze,zx;B c;C ee;I n,t,zt;P*wp,*zp;
t=atype(cv); zt=rtype(cv);
wp=PAV(w); e=SPA(wp,e); x=SPA(wp,x); c=t&&t!=AT(e);
if(c)RZ(e=cvt(t,e)); GA(ze,zt,1,0, 0 ); ado(jt,1L,AV(ze),AV(e));
if(c)RZ(e=cvt(t,x)); n=AN(x); GA(zx,zt,n,AR(x),AS(x)); ado(jt,n, AV(zx),AV(x));
if(jt->jerr){
if(jt->jerr<=NEVM)R 0;
ee=jt->jerr; RZ(ze=va1(e,id));
jt->jerr=ee; RZ(zx=va1(x,id));
}else if(cv&VRI+VRD){RZ(ze=cvz(cv,ze)); RZ(zx=cvz(cv,zx));}
GA(z,STYPE(AT(ze)),1,AR(w),AS(w)); zp=PAV(z);
SPB(zp,a,ca(SPA(wp,a)));
SPB(zp,i,ca(SPA(wp,i)));
SPB(zp,e,ze);
SPB(zp,x,zx);
R z;
}
#define VA1CASE(e,f) (256*(e)+(f))
static A jtva1(J jt,A w,C id){A e,z;B b,m;I cv,n,t,wt,zt;P*wp;VA2 p;VF ado;
RZ(w);
n=AN(w); wt=n?AT(w):B01;
ASSERT(wt&NUMERIC,EVDOMAIN);
if(b=1&&wt&SPARSE){wp=PAV(w); e=SPA(wp,e); wt=AT(e);}
if(jt->jerr){
m=!(wt&XNUM+RAT);
switch(VA1CASE(jt->jerr,id)){
default: R 0;
case VA1CASE(EWOV, CFLOOR): cv=VD; ado=floorD; break;
case VA1CASE(EWOV, CCEIL ): cv=VD; ado=ceilD; break;
case VA1CASE(EWOV, CSTILE): cv=VD+VDD; ado=absD; break;
case VA1CASE(EWIRR, CSQRT ): cv=VD+VDD; ado=sqrtD; break;
case VA1CASE(EWIRR, CEXP ): cv=VD+VDD; ado=expD; break;
case VA1CASE(EWIRR, CBANG ): cv=VD+VDD; ado=factD; break;
case VA1CASE(EWIRR, CLOG ): cv=VD+VDD*m; ado=m?(VF)logD:(VF)logXD; break;
case VA1CASE(EWIMAG,CSQRT ): cv=VZ+VZZ; ado=sqrtZ; break;
case VA1CASE(EWIMAG,CLOG ): cv=VZ+VZZ*m; ado=m?(VF)logZ:wt&XNUM?(VF)logXZ:(VF)logQZ;
}
RESETERR;
}else{
p=((va1tab+(strchr(va1fns,id)-(C*)va1fns))->p1)[wt&B01?0:wt&INT?1:wt&FL?2:wt&CMPX?3:wt&XNUM?4:5];
ado=p.f; cv=p.cv;
}
if(ado==idf)R rat(w);
if(b)R va1s(w,id,cv,ado);
t=atype(cv); zt=rtype(cv);
if(t&&t!=wt)RZ(w=cvt(t,w));
GA(z,zt,n,AR(w),AS(w));
ado(jt,n,AV(z),AV(w));
if(jt->jerr)R NEVM<jt->jerr?va1(w,id):0;
else R cv&VRI+VRD?cvz(cv,z):z;
}
F1(jtfloor1){R va1(w,CFLOOR);}
F1(jtceil1 ){R va1(w,CCEIL );}
F1(jtconjug){R va1(w,CPLUS );}
F1(jtsignum){R va1(w,CSTAR );}
F1(jtsqroot){R va1(w,CSQRT );}
F1(jtexpn1 ){R va1(w,CEXP );}
F1(jtlogar1){R va1(w,CLOG );}
F1(jtmag ){R va1(w,CSTILE);}
F1(jtfact ){R va1(w,CBANG );}
F1(jtpix ){RZ(w); R XNUM&AT(w)&&(jt->xmode==XMFLR||jt->xmode==XMCEIL)?va1(w,CCIRCLE):tymes(pie,w);}