Mercurial > hg > jgplsrc
diff a.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 (2013-11-25) |
parents | |
children |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/a.c @@ -0,0 +1,163 @@ +/* Copyright 1990-2011, Jsoftware Inc. All rights reserved. */ +/* License in license.txt. */ +/* */ +/* Adverbs */ + +#include "j.h" + + +static DF1(swap1){DECLF; R jt->rank?irs2(w,w,fs,jt->rank[1],jt->rank[1],f2):CALL2(f2,w,w,fs);} +static DF2(swap2){DECLF; R jt->rank?irs2(w,a,fs,jt->rank[1],jt->rank[0],f2):CALL2(f2,w,a,fs);} + +F1(jtswap){A y;C*s;I n; + RZ(w); + if(VERB&AT(w))R ADERIV(CTILDE,swap1,swap2,RMAX,rr(w),lr(w)); + else{ + if(C2T&AT(w))RZ(w=cvt(LIT,w)) else ASSERT(LIT&AT(w),EVDOMAIN); + ASSERT(1>=AR(w),EVRANK); + n=AN(w); s=CAV(w); + ASSERT(vnm(n,s),EVILNAME); + RZ(y=nfs(AN(w),CAV(w))); + R nameref(y); +}} + + +static B booltab[64]={ + 0,0,0,0, 0,0,0,1, 0,0,1,0, 0,0,1,1, 0,1,0,0, 0,1,0,1, 0,1,1,0, 0,1,1,1, + 1,0,0,0, 1,0,0,1, 1,0,1,0, 1,0,1,1, 1,1,0,0, 1,1,0,1, 1,1,1,0, 1,1,1,1, +}; + +static DF2(jtbdot2){R from(plus(duble(cvt(B01,a)),cvt(B01,w)),VAV(self)->h);} + +static DF1(jtbdot1){R bdot2(zero,w,self);} + +static DF1(jtbasis1){DECLF;A z;D*x;I j;V*v; + PREF1(jtbasis1); + RZ(w=vi(w)); + switch(*AV(w)){ + case 0: + GA(z,FL,3,1,0); x=DAV(z); v=VAV(fs); + j=v->mr; x[0]=j<=-RMAX?-inf:j>=RMAX?inf:j; + j=v->lr; x[1]=j<=-RMAX?-inf:j>=RMAX?inf:j; + j=v->rr; x[2]=j<=-RMAX?-inf:j>=RMAX?inf:j; + R pcvt(INT,z); + case -1: R lrep(inv (fs)); + case 1: R lrep(iden(fs)); + default: ASSERT(0,EVDOMAIN); +}} + +F1(jtbdot){A b,h=0;I j,n,*v; + RZ(w); + if(VERB&AT(w))R ADERIV(CBDOT, jtbasis1,0L, 0,0,0); + RZ(w=vi(w)); + n=AN(w); v=AV(w); + if(1==n){j=*v; ASSERT(-16<=j&&j<=34,EVINDEX);} + else DO(n, j=*v++; ASSERT(-16<=j&&j<16,EVINDEX);); + if(1!=n||j<16){ + GA(b,B01,64,2,0); *AS(b)=16; *(1+AS(b))=4; MC(AV(b),booltab,64L); + RZ(h=cant2(IX(AR(w)),from(w,b))); + R fdef(CBDOT,VERB, jtbdot1,jtbdot2, w,0L,h, 0L, RMAX,0L,0L); + }else switch(j){ + default: ASSERT(0,EVNONCE); + case 16: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise0000, w,0L,0L, VIRS2, 0L,0L,0L); + case 17: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise0001, w,0L,0L, VIRS2, 0L,0L,0L); + case 18: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise0010, w,0L,0L, VIRS2, 0L,0L,0L); + case 19: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise0011, w,0L,0L, VIRS2, 0L,0L,0L); + case 20: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise0100, w,0L,0L, VIRS2, 0L,0L,0L); + case 21: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise0101, w,0L,0L, VIRS2, 0L,0L,0L); + case 22: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise0110, w,0L,0L, VIRS2, 0L,0L,0L); + case 23: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise0111, w,0L,0L, VIRS2, 0L,0L,0L); + case 24: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise1000, w,0L,0L, VIRS2, 0L,0L,0L); + case 25: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise1001, w,0L,0L, VIRS2, 0L,0L,0L); + case 26: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise1010, w,0L,0L, VIRS2, 0L,0L,0L); + case 27: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise1011, w,0L,0L, VIRS2, 0L,0L,0L); + case 28: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise1100, w,0L,0L, VIRS2, 0L,0L,0L); + case 29: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise1101, w,0L,0L, VIRS2, 0L,0L,0L); + case 30: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise1110, w,0L,0L, VIRS2, 0L,0L,0L); + case 31: R fdef(CBDOT,VERB, jtbitwise1,jtbitwise1111, w,0L,0L, VIRS2, 0L,0L,0L); + case 32: R ADERIV(CBDOT,jtbitwise1,jtbitwiserotate,0,0,0); + case 33: R ADERIV(CBDOT,jtbitwise1,jtbitwiseshift, 0,0,0); + case 34: R ADERIV(CBDOT,jtbitwise1,jtbitwiseshifta,0,0,0); +}} + + +/* The h parameter in self for u M. */ +/* 3 elememt boxed list */ +/* 0 - integer atom of # of entries in hash table */ +/* 1 - 2-column integer table of arguments */ +/* arguments are machine word integers */ +/* column 1 is right arg; column 1 is left arg */ +/* column 0 is IMIN for monad */ +/* 2 - box list of results corresp. to arguments */ +/* unused entries are set to 0 */ + +#if SY_64 +#define HIC(x,y) ((UI)x+10495464745870458733U*(UI)y) +#else +#define HIC(x,y) ((UI)x+2838338383U*(UI)y) +#endif + +static A jtmemoget(J jt,I x,I y,A self){A h,*hv,q;I*jv,k,m,*v; + h=VAV(self)->h; hv=AAV(h); + q=hv[1]; jv=AV(q); m=*AS(q); + k=HIC(x,y)%m; v=jv+2*k; while(IMIN!=*v&&!(y==*v&&x==v[1])){v+=2; if(v==jv+2*m)v=jv;} + R*(AAV(hv[2])+(v-jv)/2); +} + +static A jtmemoput(J jt,I x,I y,A self,A z){A*cv,h,*hv,q;I c,*jv,k,m,*mv,*v; + RZ(z); + c=AC(self); h=VAV(self)->h; hv=AAV(h); + q=hv[0]; mv= AV(q); + q=hv[1]; jv= AV(q); + q=hv[2]; cv=AAV(q); m=AN(q); + if(m<=2**mv){A cc,*cu=cv,jj;I i,*ju=jv,n=m,*u; + v=ptab; while(m>=*v)++v; m=*v; + RZ(jj=reshape(v2(m,2L),sc(IMIN))); jv= AV(jj); + GA(cc,BOX,m,1,0); cv=AAV(cc); + for(i=0,u=ju;i<n;++i,u+=2)if(IMIN!=*u){ + k=HIC(x,y)%m; v=jv+2*k; while(IMIN!=*v){v+=2; if(v==jv+2*m)v=jv;} + cv[(v-jv)/2]=cu[i]; cu[i]=0; v[0]=u[0]; v[1]=u[1]; + } + q=hv[1]; AC(q)=1; fa(q); AC(jj)+=c; hv[1]=jj; + q=hv[2]; AC(q)=1; fa(q); AC(cc)+=c; hv[2]=cc; + } + ++*mv; + k=HIC(x,y)%m; v=jv+2*k; while(IMIN!=*v){v+=2; if(v==jv+2*m)v=jv;} + cv[(v-jv)/2]=raa(c,z); v[0]=y; v[1]=x; + R z; +} + +static I jtint0(J jt,A w){A x; + if(AR(w))R IMIN; + if(NUMERIC&AT(w))switch(AT(w)){ + case B01: R (I)*BAV(w); + case INT: R *AV(w); + } + x=pcvt(INT,w); + R x&&INT&AT(x)?*AV(x):IMIN; +} + +DF1(jtmemo1){DECLF;A z;I x,y; + RZ(w); + x=IMIN; y=int0(w); + if(y==IMIN)R CALL1(f1,w,fs); + R (z=memoget(x,y,self))?z:memoput(x,y,self,CALL1(f1,w,fs)); +} + +DF2(jtmemo2){DECLF;A z;I x,y; + RZ(a&&w); + x=int0(a); y=int0(w); + if(x==IMIN||y==IMIN)R CALL2(f2,a,w,fs); + R (z=memoget(x,y,self))?z:memoput(x,y,self,CALL2(f2,a,w,fs)); +} + +F1(jtmemo){A h,*hv,q;I m;V*v; + RZ(w); + ASSERT(VERB&AT(w),EVDOMAIN); + v=VAV(w); m=ptab[1]; + GA(h,BOX,3,1,0); hv=AAV(h); + RZ(q=sc(0L)); hv[0]=q; + RZ(q=reshape(v2(m,2L),sc(IMIN))); hv[1]=q; + GA(q,BOX,m,1,0); hv[2]=q; + R fdef(CMCAP,VERB,jtmemo1,jtmemo2,w,0L,h,0L,v->mr,v->lr,v->rr); +}