Mercurial > hg > jgplsrc
diff ca.c @ 0:e0bbaa717f41 draft default tip
lol J
author | Jordi Gutiérrez Hermoso <jordigh@octave.org> |
---|---|
date | Mon, 25 Nov 2013 11:56:30 -0500 |
parents | |
children |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/ca.c @@ -0,0 +1,247 @@ +/* Copyright 1990-2011, Jsoftware Inc. All rights reserved. */ +/* License in license.txt. */ +/* */ +/* Conjunctions: Atop and Ampersand */ + +#include "j.h" + + +static DF1(jtonf1){PROLOG;DECLFG;A z;I flag=sv->flag,m=jt->xmode; + PREF1(jtonf1); + if(primitive(gs))if(flag&VFLR)jt->xmode=XMFLR; else if(flag&VCEIL)jt->xmode=XMCEIL; + if(RAT&AT(w))RZ(w=pcvt(XNUM,w)); + z=CALL1(f1,CALL1(g1,w,gs),fs); + jt->xmode=m; + EPILOG(z); +} + +static DF2(jtuponf2){PROLOG;DECLFG;A z;I flag=sv->flag,m=jt->xmode; + RZ(a&&w); + if(primitive(gs))if(flag&VFLR)jt->xmode=XMFLR; else if(flag&VCEIL)jt->xmode=XMCEIL; + if(RAT&AT(a))RZ(a=pcvt(XNUM,a)); + if(RAT&AT(w))RZ(w=pcvt(XNUM,w)); + z=INT&AT(a)&&INT&AT(w)&&CDIV==ID(gs)?intdiv(a,w):CALL1(f1,CALL2(g2,a,w,gs),fs); + jt->xmode=m; + EPILOG(z); +} + +static X jtxmodpow(J jt,A a,A w,A h){A ox,z; + if(!(XNUM&AT(a)))RZ(a=cvt(XNUM,a)); + if(!(XNUM&AT(w)))RZ(w=cvt(XNUM,w)); + if(!(XNUM&AT(h)))RZ(h=cvt(XNUM,h)); + ox=jt->xmod; jt->xmod=h; + GA(z,XNUM,1,0,0); *XAV(z)=xpow(*XAV(a),*XAV(w)); + jt->xmod=ox; + RNE(z); +} + +#define DMOD 46340 /* <. %: _1+2^31 */ + +#if SY_64 +#define XMOD 3037000499 /* <. %: _1+2^63 */ +#else +#define XMOD 94906265 /* <. %: _1+2^53 */ +static I dmodpow(D x,I n,D m){D z=1; while(n){if(1&n)z=fmod(z*x,m); x=fmod(x*x,m); n>>=1;} R(I)z;} +#endif + +static I imodpow(I x,I n,I m){I z=1; while(n){if(1&n)z=(z*x)%m; x=(x*x)%m; n>>=1;} R z;} + +static DF2(jtmodpow2){A h;B b,c;I at,m,n,wt,x,z; + PREF2(jtmodpow2); + h=VAV(self)->h; + if(RAT&AT(a))RZ(a=pcvt(XNUM,a)) else if(!(AT(a)&INT+XNUM))RZ(a=pcvt(INT,a)); + if(RAT&AT(w))RZ(w=pcvt(XNUM,w)) else if(!(AT(w)&INT+XNUM))RZ(w=pcvt(INT,w)); + at=AT(a); wt=AT(w); + if((AT(h)&XNUM||at&XNUM||wt&XNUM)&&at&XNUM+INT&&wt&INT+XNUM){A z; + z=xmodpow(a,w,h); if(!jt->jerr)R z; RESETERR; R residue(h,expn2(a,w)); + } + n=*AV(w); + if(!(INT&at&&INT&wt&&0<=n))R residue(h,expn2(a,w)); + m=*AV(h); x=*AV(a); + if(!m)R expn2(a,w); + if(XMOD<m||XMOD<-m||m==IMIN||x==IMIN)R cvt(INT,xmodpow(a,w,h)); + if(b=0>m)m=-m; + if(c=0>x)x=-x; x=x%m; if(c)x=m-x; +#if SY_64 + z=imodpow(x,n,m); +#else + z=m>DMOD?dmodpow((D)x,n,(D)m):imodpow(x,n,m); +#endif + R sc(b?z-m:z); +} /* a m&|@^ w ; m guaranteed to be INT or XNUM */ + +static DF1(jtmodpow1){A g=VAV(self)->g; R rank2ex(VAV(g)->f,w,self,0L,0L,jtmodpow2);} + /* m&|@(n&^) w ; m guaranteed to be INT or XNUM */ + +static CS1(on1, CALL1(f1,CALL1(g1,w,gs),fs)) +static CS2(jtupon2,CALL1(f1,CALL2(g2,a,w,gs),fs)) + +static DF2(on2){PROLOG;DECLFG;A ga,gw,z; + PREF2(on2); + gw=CALL1(g1,w,gs); + ga=CALL1(g1,a,gs); + z=CALL2(f2,ga,gw,fs); + EPILOG(z); +} + +static DF2(atcomp){AF f; + RZ(a&&w); + f=atcompf(a,w,self); + R f?f(jt,a,w,self):upon2(a,w,self); +} + +static DF2(atcomp0){A z;AF f;D oldct=jt->ct; + RZ(a&&w); + f=atcompf(a,w,self); + jt->ct=0; z=f?f(jt,a,w,self):upon2(a,w,self); jt->ct=oldct; + R z; +} + +F2(jtatop){A f,g,h=0,x;AF f1=on1,f2=jtupon2;B b=0,j;C c,d,e;I flag=0,m=-1;V*av,*wv; + ASSERTVV(a,w); + av=VAV(a); c=av->id; + wv=VAV(w); d=wv->id; + switch(c){ + case CNOT: if(d==CMATCH){f2=jtnotmatch; flag+=VIRS2;} break; + case CGRADE: if(d==CGRADE){f1=jtranking; flag+=VIRS1;} break; + case CSLASH: if(d==CCOMMA)f1=jtredravel; break; + case CCEIL: f1=jtonf1; f2=jtuponf2; flag=VCEIL; break; + case CFLOOR: f1=jtonf1; f2=jtuponf2; flag=VFLR; break; + case CICAP: if(d==CNE)f1=jtnubind; else if(FIT0(CNE,wv))f1=jtnubind0; break; + case CQUERY: if(d==CDOLLAR||d==CPOUND)f2=jtrollk; break; + case CQRYDOT: if(d==CDOLLAR||d==CPOUND)f2=jtrollkx; break; + case CRAZE: if(d==CCUT&&boxatop(w)){f1=jtrazecut1; f2=jtrazecut2;} break; + case CSLDOT: if(d==CSLASH&&CSLASH==ID(av->f))f2=jtpolymult; break; + case CQQ: if(d==CTHORN&&CEXEC==ID(av->f)&&equ(zero,av->g))f1=jtdigits10; break; + case CEXP: if(d==CCIRCLE)f1=jtexppi; break; + case CAMP: + x=av->f; if(RAT&AT(x))RZ(x=pcvt(XNUM,x)); + if((d==CEXP||d==CAMP&&CEXP==ID(wv->g))&&AT(x)&INT+XNUM&&!AR(x)&&CSTILE==ID(av->g)){ + h=x; flag=VMOD; + if(d==CEXP)f2=jtmodpow2; else f1=jtmodpow1; + }} + if(d==CEBAR||d==CEPS||(b=FIT0(CEPS,wv))){ + f=av->f; g=av->g; e=ID(f); if(b)d=ID(wv->f); + if(c==CICAP)m=7; + else if(c==CSLASH)m=e==CPLUS?4:e==CPLUSDOT?5:e==CSTARDOT?6:-1; + else if(c==CAMP&&(g==zero||g==one)){j=*BAV(g); m=e==CIOTA?j:e==CICO?2+j:-1;} + switch(0<=m?d:-1){ + case CEBAR: f2=b?atcomp0:atcomp; flag=6+8*m; break; + case CEPS: f2=b?atcomp0:atcomp; flag=7+8*m; break; + }} + R fdef(CAT,VERB, f1,f2, a,w,h, flag, (I)wv->mr,(I)wv->lr,(I)wv->rr); +} + +F2(jtatco){A f,g;AF f1=on1,f2=jtupon2;B b=0;C c,d,e;I flag=0,j,m=-1;V*av,*wv; + ASSERTVV(a,w); + av=VAV(a); c=av->id; f=av->f; g=av->g; e=ID(f); + wv=VAV(w); d=wv->id; + switch(c){ + case CNOT: if(d==CMATCH){f2=jtnotmatch; flag+=VIRS2;} break; + case CGRADE: if(d==CGRADE){f1=jtranking; flag+=VIRS1;} break; + case CCEIL: f1=jtonf1; f2=jtuponf2; flag=VCEIL; break; + case CFLOOR: f1=jtonf1; f2=jtuponf2; flag=VFLR; break; + case CQUERY: if(d==CDOLLAR||d==CPOUND)f2=jtrollk; break; + case CQRYDOT: if(d==CDOLLAR||d==CPOUND)f2=jtrollkx; break; + case CICAP: m=7; if(d==CNE)f1=jtnubind; else if(FIT0(CNE,wv))f1=jtnubind0; break; + case CAMP: if(g==zero||g==one){j=*BAV(g); m=e==CIOTA?j:e==CICO?2+j:-1;} break; + case CSLASH: + if(vaid(f)&&vaid(w))f2=jtfslashatg; + if(d==CCOMMA)f1=jtredravel; else m=e==CPLUS?4:e==CPLUSDOT?5:e==CSTARDOT?6:-1; + break; + case CSEMICO: + if(d==CLBRACE)f2=jtrazefrom; + else if(d==CCUT){ + j=i0(wv->g); + if(CBOX==ID(wv->f)&&!j)f2=jtrazecut0; + else if(boxatop(w)&&j&&-2<=j&&j<=2){f1=jtrazecut1; f2=jtrazecut2;} + }} + if(0<=m){ + b=d==CFIT&&equ(zero,wv->g); + switch(b?ID(wv->f):d){ + case CEQ: f2=b?atcomp0:atcomp; flag=0+8*m; break; + case CNE: f2=b?atcomp0:atcomp; flag=1+8*m; break; + case CLT: f2=b?atcomp0:atcomp; flag=2+8*m; break; + case CLE: f2=b?atcomp0:atcomp; flag=3+8*m; break; + case CGE: f2=b?atcomp0:atcomp; flag=4+8*m; break; + case CGT: f2=b?atcomp0:atcomp; flag=5+8*m; break; + case CEBAR: f2=b?atcomp0:atcomp; flag=6+8*m; break; + case CEPS: f2=b?atcomp0:atcomp; flag=7+8*m; break; + }} + R fdef(CATCO,VERB, f1,f2, a,w,0L, flag, RMAX,RMAX,RMAX); +} + +F2(jtampco){AF f1=on1;C c,d;I flag=0;V*wv; + ASSERTVV(a,w); + c=ID(a); wv=VAV(w); d=wv->id; + if (c==CSLASH&&d==CCOMMA) f1=jtredravel; + else if(c==CRAZE&&d==CCUT&&boxatop(w))f1=jtrazecut1; + else if(c==CGRADE&&d==CGRADE) {f1=jtranking; flag+=VIRS1;} + R fdef(CAMPCO,VERB, f1,on2, a,w,0L, flag, RMAX,RMAX,RMAX); +} + +static DF1(withl){DECLFG; R jt->rank?irs2(fs,w,gs,AR(fs),jt->rank[1],g2):CALL2(g2,fs,w,gs);} +static DF1(withr){DECLFG; R jt->rank?irs2(w,gs,fs,jt->rank[1],AR(gs),f2):CALL2(f2,w,gs,fs);} + +static DF1(ixfixedleft ){V*v=VAV(self); R indexofprehashed(v->f,w,v->h);} +static DF1(ixfixedright ){V*v=VAV(self); R indexofprehashed(v->g,w,v->h);} + +static DF1(ixfixedleft0 ){A z;D old=jt->ct;V*v=VAV(self); + jt->ct=0.0; z=indexofprehashed(v->f,w,v->h); jt->ct=old; + R z; +} + +static DF1(ixfixedright0){A z;D old=jt->ct;V*v=VAV(self); + jt->ct=0.0; z=indexofprehashed(v->g,w,v->h); jt->ct=old; + R z; +} + +static DF2(with2){R df1(w,powop(self,a));} + +F2(jtamp){A h=0;AF f1=on1,f2=on2;B b;C c,d=0;D old=jt->ct;I flag=0,mode=-1,p,r;V*u,*v; + RZ(a&&w); + switch(CONJCASE(a,w)){ + default: ASSERTSYS(0,"amp"); + case NN: ASSERT(0,EVDOMAIN); + case NV: + f1=withl; v=VAV(w); c=v->id; + if(AN(a)&&AR(a)){ + if(b=c==CFIT&&equ(zero,v->g))c=ID(v->f); + mode=c==CIOTA?IIDOT:c==CICO?IICO:-1; + } + if(0<=mode){ + if(b){jt->ct=0.0; h=indexofsub(mode,a,mark); jt->ct=old; f1=ixfixedleft0;} + else { h=indexofsub(mode,a,mark); f1=ixfixedleft ;} + }else switch(c){ + case CWORDS: RZ(a=fsmvfya(a)); f1=jtfsmfx; break; + case CIBEAM: if(v->f&&v->g&&128==i0(v->f)&&3==i0(v->g)){RZ(h=crccompile(a)); f1=jtcrcfixedleft;} + } + R fdef(CAMP,VERB, f1,with2, a,w,h, flag, RMAX,RMAX,RMAX); + case VN: + f1=withr; + if(AN(w)&&AR(w)){ + v=VAV(a); c=v->id; p=v->flag%256; if(b=c==CFIT&&equ(zero,v->g))c=ID(v->f); + if(7==p%8)mode=II0EPS+p/8; /* (e.i.0:) etc. */ + else mode=c==CEPS?IEPS:c==CLESS?ILESS:-1; + } + if(0<=mode){ + if(b){jt->ct=0.0; h=indexofsub(mode,w,mark); jt->ct=old; f1=ixfixedright0;} + else { h=indexofsub(mode,w,mark); f1=ixfixedright ;} + } + R fdef(CAMP,VERB, f1,with2, a,w,h, flag, RMAX,RMAX,RMAX); + case VV: + v=VAV(w); c=v->id; r=v->mr; + if(c==CFORK||c==CAMP){ + if(c==CFORK)d=ID(v->h); + if(CIOTA==ID(v->g)&&(!d||d==CLEFT||d==CRIGHT)&&equ(alp,v->f)){ + u=VAV(a); d=u->id; + if(d==CLT||d==CLE||d==CEQ||d==CNE||d==CGE||d==CGT)f2=jtcharfn2; + }}else switch(ID(a)){ + case CGRADE: if(c==CGRADE){f1=jtranking; flag+=VIRS1;} break; + case CSLASH: if(c==CCOMMA)f1=jtredravel; break; + case CCEIL: f1=jtonf1; flag=VCEIL; break; + case CFLOOR: f1=jtonf1; flag=VFLR; break; + case CRAZE: if(c==CCUT&&boxatop(w))f1=jtrazecut1; + } + R fdef(CAMP,VERB, f1,f2, a,w,0L, flag, r,r,r); +}}