diff --git a/.gitignore b/.gitignore index 0a471e8..a42c858 100644 --- a/.gitignore +++ b/.gitignore @@ -43,3 +43,8 @@ clapack/ pcre/ release + +build*/ +jlibrary/bin/ +!jlibrary/bin/profile.ijs +.tup/ diff --git a/Tupfile b/Tupfile new file mode 100644 index 0000000..cecdbc1 --- /dev/null +++ b/Tupfile @@ -0,0 +1,15 @@ +src_lib = jsrc/a.c jsrc/ab.c jsrc/af.c jsrc/ai.c jsrc/am.c jsrc/am1.c jsrc/amn.c jsrc/ao.c jsrc/ap.c jsrc/ar.c jsrc/as.c jsrc/au.c jsrc/best.c jsrc/c.c jsrc/ca.c jsrc/cc.c \ + jsrc/cd.c jsrc/cf.c jsrc/cg.c jsrc/ch.c jsrc/cip.c jsrc/cl.c jsrc/cp.c jsrc/cpdtsp.c jsrc/cr.c jsrc/crs.c jsrc/ct.c jsrc/cu.c jsrc/cv.c jsrc/cx.c jsrc/d.c jsrc/dc.c \ + jsrc/dss.c jsrc/dstop.c jsrc/dsusp.c jsrc/dtoa.c jsrc/f.c jsrc/f2.c jsrc/fbu.c jsrc/gemm.c jsrc/i.c jsrc/io.c jsrc/j.c jsrc/jdlllic.c jsrc/k.c jsrc/m.c jsrc/mbx.c jsrc/p.c \ + jsrc/pv.c jsrc/px.c jsrc/r.c jsrc/rl.c jsrc/rt.c jsrc/s.c jsrc/sc.c jsrc/sl.c jsrc/sn.c jsrc/t.c jsrc/u.c jsrc/v.c jsrc/v0.c jsrc/v1.c jsrc/v2.c jsrc/va1.c jsrc/va1ss.c \ + jsrc/va2.c jsrc/va2s.c jsrc/va2ss.c jsrc/vamultsp.c jsrc/vb.c jsrc/vbang.c jsrc/vbit.c jsrc/vcant.c jsrc/vchar.c jsrc/vcat.c jsrc/vcatsp.c \ + jsrc/vcomp.c jsrc/vcompsc.c jsrc/vd.c jsrc/vdx.c jsrc/ve.c jsrc/vf.c jsrc/vfft.c jsrc/vfrom.c jsrc/vfromsp.c jsrc/vg.c jsrc/vgauss.c \ + jsrc/vgcomp.c jsrc/vgranking.c jsrc/vgsort.c jsrc/vgsp.c jsrc/vi.c jsrc/viavx.c jsrc/viix.c jsrc/visp.c jsrc/vm.c jsrc/vo.c jsrc/vp.c jsrc/vq.c \ + jsrc/vrand.c jsrc/vrep.c jsrc/vs.c jsrc/vsb.c jsrc/vt.c jsrc/vu.c jsrc/vx.c jsrc/vz.c jsrc/w.c jsrc/wc.c jsrc/wn.c jsrc/ws.c jsrc/x.c jsrc/x15.c jsrc/xa.c jsrc/xb.c \ + jsrc/xc.c jsrc/xcrc.c jsrc/xd.c jsrc/xf.c jsrc/xfmt.c jsrc/xh.c jsrc/xi.c jsrc/xl.c jsrc/xo.c jsrc/xs.c jsrc/xsha.c jsrc/xt.c jsrc/xu.c jsrc/cpuinfo.c jsrc/blis/*.c + +src_con = jsrc/jconsole.c jsrc/jeload.c + +bin = jlibrary/bin + +include config/@(TUP_PLATFORM) diff --git a/Tupfile.ini b/Tupfile.ini new file mode 100644 index 0000000..e69de29 diff --git a/config/linux b/config/linux new file mode 100644 index 0000000..9b9ef0a --- /dev/null +++ b/config/linux @@ -0,0 +1,44 @@ +CC = cc + +con_cflags = -c -DREADLINE +con_lflags += -ldl -lreadline + +bin = jlibrary/bin + +lib_cflags += -c -D_JDLL -DC_NA=0 -fPIC +lib_lflags += -shared -lm +lib_extra_avx = +lib_extra_noavx = + +ifeq (@(DEBUG),y) + lib_cflags += -O0 + lib_lflags += + con_cflags += -O0 + con_lflags += +else + lib_cflags += -O2 + lib_lflags += +endif + +ifeq (@(UNICODE),y) + lib_cflags += -DJXUNICODE +endif + +# create jversion header +: jsrc/jversion-linux.h |> cp %f %o |> jsrc/jversion.h + +# build the avx version of the library +#: foreach $(src_lib) | jsrc/jversion.h |> $(CC) $(lib_cflags) -DC_AVX=1 %f -o %o |> build-avx/%B.o {libavx} +#: foreach $(src_lib) | jsrc/jversion.h |> $(CC) $(lib_cflags) -DC_AVX=1 %f -o %o |> build-avx/%B.o {libavx} +#: {libavx} |> $(CC) %f -o %o dllsrc/javxdll.def $(lib_lflags) |> $(bin)/libj.so | $(lib_extra_avx) + +# build the non-avx version of the library +: foreach $(src_lib) | jsrc/jversion.h |> $(CC) $(lib_cflags) -DC_AVX=0 %f -o %o |> build-noavx/%B.o {libnoavx} +: {libnoavx} |> $(CC) %f -o %o $(lib_lflags) |> $(bin)/libj.so| $(lib_extra_noavx) + +# build jconsole +: foreach $(src_con) | jsrc/jversion.h |> $(CC) $(con_cflags) %f -o %o |> build/%B.o {con} +: {con} |> $(CC) %f -o %o $(con_lflags) |> $(bin)/jconsole | $(con_extra) + +# test dll +#: jsrc/tsdll.c |> ^ CC %f^ $(CC) %f /Fe%o makevs\tsdll\tsdll.def /Fobuild/%B.obj /LD |> $(bin)/%B.dll | build/%B.obj $(bin)/tsdll.lib $(bin)/tsdll.exp diff --git a/config/mingw b/config/mingw new file mode 100644 index 0000000..2b060ea --- /dev/null +++ b/config/mingw @@ -0,0 +1,47 @@ +CC = C:\MinGW\bin\gcc.exe + +con_cflags = -c -DREADLINE +con_lflags += -ldl -lreadline + +bin = jlibrary/bin + +lib_cflags = -c -D_JDLL -DC_NA=0 -fPIC +lib_lflags = -shared -lm +lib_extra_avx = +lib_extra_noavx = + +ifeq (@(DEBUG),y) + lib_cflags += -O0 + lib_lflags += + con_cflags += -O0 + con_lflags += +else + lib_cflags += -O2 + lib_lflags += +endif + +ifeq (@(UNICODE),y) + lib_cflags += -DJXUNICODE +endif + + +# create jversion header +: jsrc/jversion-win32.h |> cmd /C copy %f %o |> jsrc/jversion.h + +# build the avx version of the library +#: foreach $(src_lib) | jsrc/jversion.h |> $(CC) $(lib_cflags) -DC_AVX=1 %f -o %o |> build-avx/%B.o {libavx} +#: foreach $(src_lib) | jsrc/jversion.h |> $(CC) $(lib_cflags) -DC_AVX=1 %f -o %o |> build-avx/%B.o {libavx} +#: {libavx} |> $(CC) %f -o %o dllsrc/javxdll.def $(lib_lflags) |> $(bin)/libj.so | $(lib_extra_avx) + +# build the non-avx version of the library +: foreach $(src_lib) | jsrc/jversion.h |> $(CC) $(lib_cflags) -DC_AVX=0 %f -o %o |> build-noavx/%B.o {libnoavx} +: {libnoavx} |> $(CC) %f -o %o $(lib_lflags) |> $(bin)/libj.so| $(lib_extra_noavx) + +# build jconsole +: foreach $(src_con) | jsrc/jversion.h |> $(CC) $(con_cflags) %f -o %o |> build/%B.o {con} +: {con} |> $(CC) %f -o %o $(con_lflags) |> $(bin)/jconsole | $(con_extra) + +# test dll +#: jsrc/tsdll.c |> ^ CC %f^ $(CC) %f /Fe%o makevs\tsdll\tsdll.def /Fobuild/%B.obj /LD |> $(bin)/%B.dll | build/%B.obj $(bin)/tsdll.lib $(bin)/tsdll.exp diff --git a/config/win32 b/config/win32 new file mode 100644 index 0000000..1579384 --- /dev/null +++ b/config/win32 @@ -0,0 +1,51 @@ +CC = cl /nologo + +bin = jlibrary\bin + +src_lib += dllsrc/jdll.c dllsrc/jdllcomx.cpp + +lib_cflags = /c /D_JDLL /DC_NA=0 +lib_lflags = OleAut32.lib AdvApi32.lib Ole32.lib +lib_extra_avx = $(bin)/javx.lib $(bin)/javx.exp +lib_extra_noavx = $(bin)/j.lib $(bin)/j.exp +#con_cflags = /c /MT +con_cflags = /c + +ifeq (@(DEBUG),y) + lib_cflags += /Od /Z7 + lib_lflags += /Od /LDd /link /DEBUG + con_cflags += /Od /Z7 + con_lflags += /Od /link /DEBUG + + lib_extra_avx += $(bin)/javx.pdb $(bin)/javx.ilk + lib_extra_noavx += $(bin)/j.pdb $(bin)/j.ilk + con_extra = $(bin)/jconsole.pdb $(bin)/jconsole.ilk +else + lib_cflags += /Ox /DNDEBUG + lib_lflags += /LD +endif + +ifeq (@(UNICODE),y) + lib_cflags += /DJXUNICODE +endif + +# create jversion header +: jsrc/jversion-win32.h |> cmd /C copy %f %o |> jsrc/jversion.h + +# build the avx version of the library +: foreach $(src_lib) | jsrc/jversion.h |> $(CC) /MD $(lib_cflags) /DC_AVX=1 %f /Fo%o |> build-avx/%B.obj {libavx} +: {libavx} |> $(CC) /MD %f /Fe%o dllsrc/javxdll.def $(lib_lflags) |> $(bin)/javx.dll | $(lib_extra_avx) + +# build the non-avx version of the library +: foreach $(src_lib) | jsrc/jversion.h |> $(CC) /MD $(lib_cflags) /DC_AVX=0 %f /Fo%o |> build-noavx/%B.obj {libnoavx} +: {libnoavx} |> $(CC) /MD %f /Fe%o dllsrc/jdll.def $(lib_lflags) |> $(bin)/j.dll | $(lib_extra_noavx) + +# build jconsole +: foreach $(src_con) | jsrc/jversion.h |> $(CC) $(con_cflags) %f /Fo%o |> build/%B.obj {con} +: {con} |> $(CC) /MD %f /Fe%o $(con_lflags) |> $(bin)/jconsole.exe | $(con_extra) + +# test dll +: jsrc/tsdll.c |> ^ CC %f^ $(CC) %f /Fe%o makevs\tsdll\tsdll.def /Fobuild/%B.obj /LD |> $(bin)/%B.dll | build/%B.obj $(bin)/tsdll.lib $(bin)/tsdll.exp diff --git a/dllsrc/javxdll.def b/dllsrc/javxdll.def new file mode 100644 index 0000000..450a673 --- /dev/null +++ b/dllsrc/javxdll.def @@ -0,0 +1,30 @@ +LIBRARY JAVX + +EXPORTS + DllGetClassObject PRIVATE + DllCanUnloadNow PRIVATE + DllRegisterServer PRIVATE + DllUnregisterServer PRIVATE + JBreak @6 + JClear @7 + JDo @8 + JErrorText @9 + JErrorTextM @10 + JFree @11 + JGet @12 + JGetM @13 + JInit @14 + JIsBusy @15 + JSet @16 + JSetM @17 + JSM @18 + JGetLocale @19 + Jga @20 + JTranspose @21 + JErrorTextB @22 + JGetB @23 + JSetB @24 + JDoR @25 + JGetA @26 + JSetA @27 + JInt64R @28 diff --git a/jsrc/a.c b/jsrc/a.c index b36c69e..d4efe81 100644 --- a/jsrc/a.c +++ b/jsrc/a.c @@ -9,6 +9,8 @@ static DF1(swap1){DECLF; F1PREFIP; R jt->rank?irs2(w,w,fs,jt->rank[1],jt->rank[1],f2):((jtinplace=(J)((I)jtinplace&JTINPLACEW)),(f2)((J)((I)jt|(((I)jtinplace<<1)+(I)jtinplace)),w,w,fs));} static DF2(swap2){DECLF; F2PREFIP; R jt->rank?irs2(w,a,fs,jt->rank[1],jt->rank[0],f2):((jtinplace=(J)((I)jtinplace&(JTINPLACEW+JTINPLACEA))),(f2)((J)((I)jt|(((((I)jtinplace<<2)+(I)jtinplace)>>1)&(JTINPLACEW+JTINPLACEA))),w,a,fs));} +extern F1(jtwex); + // w~, which is either reflexive/passive or evoke F1(jtswap){A y;C*s;I n; RZ(w); @@ -21,12 +23,10 @@ F1(jtswap){A y;C*s;I n; if((C2T+C4T)&AT(w))RZ(w=cvt(LIT,w)) else ASSERT(LIT&AT(w),EVDOMAIN); ASSERT(1>=AR(w),EVRANK); // list or atom only n=AN(w); s=CAV(w); - ASSERT(vnm(n,s),EVILNAME); // valid name - RZ(y=nfs(AN(w),CAV(w))); // create a NAME block for the string - R nameref(y); // Create a name-reference pointing to the name + /* ASSERT(vnm(n,s),EVILNAME); */ // Removed check for Jx + R wex(w); }} - 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, diff --git a/jsrc/af.c b/jsrc/af.c index a438cb7..6d43314 100644 --- a/jsrc/af.c +++ b/jsrc/af.c @@ -55,6 +55,8 @@ static F2(jtfixa){A aa,f,g,h,wf,x,y,z=w;V*v; R hook(fixa(num[2],f),fixa(one,g)); case CFORK: f=fixa(aa,f); g=fixa(num[ID(f)==CCAP?1:2],g); h=fixa(aa,h); R folk(f,g,h); + case CFORKO: + f=fixa(aa,f); g=fixa(aa,g); h=fixa(aa,h); R folko(f,g,h); case CATDOT: case CGRCO: RZ(f=every(every2(aa,h,0L,jtfixa),0L,jtaro)); diff --git a/jsrc/ai.c b/jsrc/ai.c index 3d6e9c9..8c0f87e 100644 --- a/jsrc/ai.c +++ b/jsrc/ai.c @@ -323,6 +323,7 @@ A jtinv(J jt, A w, I recur){A f,ff,g;B b,nf,ng,vf,vg;C id,*s;I p,q;V*v; case CHOOK: if(CFROM==ID(f)&&CEQ==ID(g))R eval("i.\"1&1"); break; + case CAPPLY: R eval("<@:((,'0') ,&< ])"); } // Failure - no inverse found. If there are names in w, try fixing w and try on that. // But only fix once, at the top recursion level, (1) to avoid an infinite loop if diff --git a/jsrc/am.c b/jsrc/am.c index 59add4d..5417512 100644 --- a/jsrc/am.c +++ b/jsrc/am.c @@ -111,7 +111,7 @@ F1(jtcasev){A b,*u,*v,w1,x,y,z;B*bv,p,q;I*aa,c,*iv,j,m,n,r,*s,t; }} /* z=:b}x0,x1,x2,...,x(m-2),:x(m-1) */ // Handle a ind} w after indices have been converted to integer -static A jtmerge2(J jt,A a,A w,A ind){F2PREFIP;A z;I an,ar,*as,at,in,ir,*iv,t,wn,wt; +A jtmerge2(J jt,A a,A w,A ind){F2PREFIP;A z;I an,ar,*as,at,in,ir,*iv,t,wn,wt; RZ(a&&w&&ind); // ?n=#atoms, ?t=type, ?r=rank, ?s->shape where ?=awi for xym an=AN(a); at=AT(a); ar=AR(a); as=AS(a); diff --git a/jsrc/au.c b/jsrc/au.c index 4283e3c..d057c0b 100644 --- a/jsrc/au.c +++ b/jsrc/au.c @@ -29,7 +29,15 @@ F1(jtfdepadv){RZ(w); ASSERT(VERB&AT(w),EVDOMAIN); R sc(fdep(w));} DF1(jtdf1){RZ(self); R CALL1(VAV(self)->f1, w,self);} DF2(jtdf2){RZ(self); R CALL2(VAV(self)->f2,a,w,self);} -DF1(jtdfs1){F1PREFIP;A s=jt->sf,z; RZ(self); z=CALL1IP(VAV(self)->f1, w,jt->sf=self); jt->sf=s; R z;} +DF1(jtdfs1){ + F1PREFIP; + A z; + A s=jt->sf; + RZ(self); + z=CALL1IP(VAV(self)->f1, w,jt->sf=self); + jt->sf=s; + R z; +} DF2(jtdfs2){F2PREFIP; A s=jt->sf,z; RZ(self); @@ -41,9 +49,14 @@ A jtdfss1(J jt, A w, A self, A self0) {RZ(self); R CALL1(VAV(self)->f1, w,s A jtdfss2(J jt, A a, A w, A self, A self0){RZ(self); R CALL2(VAV(self)->f2,a,w,self0);} // used to treat self as an argument. Used with routines that don't really use self -F1(jtself1){A z;I d=fdep(jt->sf); FDEPINC(d); z=df1( w,jt->sf); FDEPDEC(d); R z;} -F2(jtself2){A z;I d=fdep(jt->sf); FDEPINC(d); z=df2(a,w,jt->sf); FDEPDEC(d); R z;} - +F1(jtself1){A z;I d; + if(jt->tramp) R fdef(CTRAMP,VERB, 0L,0L, w,0L,0L, 0L, 0L,0L,0L); + d=fdep(jt->sf); FDEPINC(d); z=df1( w,jt->sf); FDEPDEC(d); R z; +} +F2(jtself2){A z;I d; + if(jt->tramp) R fdef(CTRAMP,VERB, 0L,0L, a,w,0L, 0L, 0L,0L,0L); + d=fdep(jt->sf); FDEPINC(d); z=df2(a,w,jt->sf); FDEPDEC(d); R z; +} A jtac1(J jt,AF f){R fdef(0,VERB, f,0L, 0L,0L,0L, VFLAGNONE, RMAX,RMAX,RMAX);} A jtac2(J jt,AF f){R fdef(0,VERB, 0L,f, 0L,0L,0L, VFLAGNONE, RMAX,RMAX,RMAX);} @@ -113,4 +126,4 @@ I atoplr(A w){ case CRIGHT: R JTINPLACEA; // ...@] ok to inplace A } R 0; // both args in use -} \ No newline at end of file +} diff --git a/jsrc/best.c b/jsrc/best.c new file mode 100644 index 0000000..c92786f --- /dev/null +++ b/jsrc/best.c @@ -0,0 +1,550 @@ +// BEST Jx primitives that do not need to be integrated into the existing source + +#include "j.h" + +static DF1(jtsref1){ A fs, s = jt->sf, z; jt->sf = fs = VAV(self)->f; z = CALL1(VAV(fs)->f1, w, fs); jt->sf = s; R z; } +static DF2(jtsref2){ A fs, s = jt->sf, z; jt->sf = fs = VAV(self)->f; z = CALL2(VAV(fs)->f2, a, w, fs); jt->sf = s; R z; } + +F1(jtx103d0){ + RZ(w); + ASSERT(VERB&AT(w), EVDOMAIN); + R ADERIV(CRCAPDOT, jtsref1, jtsref2, 0L, mr(w), rr(w), lr(w)); +} + +static DF1(jtyielda1){DECLF;A z;B yieldold=jt->yield; + RZ(w); + jt->yield=1; + z=CALL1(f1,w,fs); + jt->yield=yieldold; + if(EWYIELD==jt->jerr){ + RESETERR; + R jt->yieldval; + } + R z; +} + +static DF2(jtyielda2){DECLF;A z;B yieldold=jt->yield; + RZ(a&&w); + jt->yield=1; + z=CALL2(f2,a,w,fs); + jt->yield=yieldold; + if(EWYIELD==jt->jerr){ + RESETERR; + R jt->yieldval; + } + R z; +} + +F1(jttrigger){ + RZ(w); + if(!jt->yield) R w; + fr(jt->yieldval); + ra(w); + jt->yieldval=w; + jsignal(EWYIELD);R 0; +} + +F1(jttrap){RZ(w);ASSERT(VERB&AT(w),EVDOMAIN);R ADERIV(CDEX,jtyielda1,jtyielda2,0L,mr(w),rr(w),lr(w));} + +DF1(jtstrand){V*sv=VAV(self);A x,fs=sv->f; + RZ(w); + if(VAV(w)->id==CCAP){ + if(fs) R fs; + else R reitem(sc(0),ace); + } + if(!(x=exg(w))){RESETERR;x=w;} + R fdef(sv->id,ADV,jtstrand,0,fs?over(box(x),fs):box(x),0L,0L,0L,0L,0L,0L); +} + +static DF1(jttramp1){ + I old; B oldtramp=jt->tramp; A z,oldtrampv=jt->trampv;L*e;V*v; DECLF; + RZ(w); + old=jt->tnextpushx; + v=VAV(fs); + if(v->id==CTILDE&&NAME&AT(v->f)) { + RE(e=syrd(v->f,0)); + ASSERT(e&&(fs=e->val),EVVALUE); + } + jt->tramp=1;jt->trampv=fs; + z=CALL1(VAV(jt->trampv)->f1,w,jt->trampv); ra(z); tpop(old); tpush(z); + while(z&&VERB&AT(z)){ + z=CALL1(VAV(jt->trampv)->f1,VAV(z)->f,jt->trampv); + ra(z); tpop(old); tpush(z); + } + jt->tramp=oldtramp;jt->trampv=oldtrampv; + ASSERT(NOUN&AT(z),EVDOMAIN); + R z; +} + +static DF2(jttramp2){ + I old; B oldtramp=jt->tramp; A z,oldtrampv=jt->trampv;L*e;V*v; DECLF; + RZ(a&&w); + old=jt->tnextpushx; + v=VAV(fs); + if(v->id==CTILDE&&NAME&AT(v->f)) { + RE(e=syrd(v->f,0)); + ASSERT(e&&(fs=e->val),EVVALUE); + } + jt->tramp=1;jt->trampv=fs; + z=CALL2(VAV(jt->trampv)->f2,a,w,jt->trampv); ra(z); tpop(old); tpush(z); + while(z&&VERB&AT(z)){ + z=CALL2(VAV(jt->trampv)->f2,VAV(z)->f,VAV(z)->g,jt->trampv); + ra(z); tpop(old); tpush(z); + } + jt->tramp=oldtramp;jt->trampv=oldtrampv; + ASSERT(NOUN&AT(z),EVDOMAIN); + R z; +} + +F1(jttramp){ + RZ(w); + ASSERT(VERB&AT(w),EVDOMAIN); + R ADERIV(CTRAMP,jttramp1,jttramp2,0L,mr(w),rr(w),lr(w)); +} + +F2(jtfixrecursive){ + if(ID(w)==CTRAMP&&VAV(w)->g&&i0(VAV(w)->g)==0) R w; + R df2(w, sc(0), ds(CTRAMP)); +} + +#define NEWYA {GA(ya,at,acn,acr,as+af); uu=CAV(ya);} +#define NEWYW {GA(yw,wt,wcn,wcr,ws+wf); vv=CAV(yw);} +#define MOVEYA {MC(uu,u+=ak,ak); if(ab)RZ(ya=relocate((I)a-(I)ya,ya));} +#define MOVEYW {MC(vv,v+=wk,wk); if(wb)RZ(yw=relocate((I)w-(I)yw,yw));} + +static A jtrank1gex(J jt,A w,A*fs,I mr,AF*f1,I fn){PROLOG(0104);A y,y0,yw,z;B wb;C*v,*vv; + I k,mn,n=1,p,*s,wcn,wcr,wf,wk,wr,*ws,wt,yn,yr,*ys,yt,call=0; + RZ(w); + wt=AT(w); + if(wt&SPARSE) ASSERT(0,EVDOMAIN); + wr=AR(w); ws=AS(w); wcr=efr(wr,mr); wf=wr-wcr; wb=ARELATIVE(w); + if(!wf)R CALL1(f1[0],w,fs[0]); + RE(wcn=prod(wcr,wf+ws)); wk=wcn*bp(wt); v=CAV(w)-wk; NEWYW; + p=wf; s=ws; RE(mn=prod(wf,ws)); + if(AN(w))MOVEYW else RZ(yw=reshape(vec(INT,wcr,ws+wf),filler(w))); +#define VALENCE 1 +#define TEMPLATE 0 +#define RGERUND 1 +#include "crg_t.h" +} + +static A jtrank2gex(J jt,A a,A w,A*fs,I lr,I rr,AF*f2,I fn){PROLOG(0105);A y,y0,ya,yw,z;B ab,b,wb; + C*u,*uu,*v,*vv;I acn,acr,af,ak,ar,*as,at,k,mn,n=1,p,q,*s,wcn,wcr,wf,wk,wr,*ws,wt,yn,yr,*ys,yt, + call=0; + RZ(a&&w); + at=AT(a); wt=AT(w); + if(at&SPARSE||wt&SPARSE) ASSERT(0,EVDOMAIN); + ar=AR(a); as=AS(a); acr=efr(ar,lr); af=ar-acr; ab=ARELATIVE(a); + wr=AR(w); ws=AS(w); wcr=efr(wr,rr); wf=wr-wcr; wb=ARELATIVE(w); + if(!af&&!wf)R CALL2(f2[0],a,w,fs[0]); + RE(acn=prod(acr,as+af)); ak=acn*bp(at); u=CAV(a)-ak; NEWYA; + RE(wcn=prod(wcr,ws+wf)); wk=wcn*bp(wt); v=CAV(w)-wk; NEWYW; + b=af<=wf; p=b?wf:af; q=b?af:wf; s=b?ws:as; RE(mn=prod(p,s)); RE(n=prod(p-q,s+q)); + ASSERT(!ICMP(as,ws,q),EVLENGTH); + if(AN(a))MOVEYA else RZ(ya=reshape(vec(INT,acr,as+af),filler(a))); + if(AN(w))MOVEYW else RZ(yw=reshape(vec(INT,wcr,ws+wf),filler(w))); +#define VALENCE 2 +#define TEMPLATE 0 +#define RGERUND 1 +#include "crg_t.h" +} + +static DF1(rank1g){DECLF;A h=sv->h,gs,*gv,f;AF*gf;I m,n,*v=AV(h),wr; + RZ(w); + wr=AR(w); m=efr(wr,v[0]); + RZ(gs=fxeachv(1L,fs)); n=AN(gs); gv=AAV(gs); ASSERT(n>0,EVLENGTH); + GA(f,INT,n,1,0); gf=(AF*)AV(f); DO(n, gf[i]=VAV(gv[i])->f1;); + R mh,gs,*gv,f;AF*gf;I ar,l,r,n,*v=AV(h),wr; + RZ(a&&w); + ar=AR(a); l=efr(ar,v[1]); + wr=AR(w); r=efr(wr,v[2]); + RZ(gs=fxeachv(1L,fs)); n=AN(gs); gv=AAV(gs); ASSERT(n>0,EVLENGTH); + GA(f,INT,n,1,0); gf=(AF*)AV(f); DO(n, gf[i]=VAV(gv[i])->f2;); + R lr?RMAX:r) +extern DF1(cons1a); +extern DF2(cons2a); +extern DF1(cons1); +extern DF2(cons2); + +DF1(cons1a){R VAV(self)->f;} +DF2(cons2a){R VAV(self)->f;} + +// Constant verbs do not inplace because we loop over cells. We could speed this up if it were worthwhile. +DF1(cons1){V*sv=VAV(self); + RZ(w); + R rank1ex(w,self,efr(AR(w),*AV(sv->h)),cons1a); +} +DF2(cons2){V*sv=VAV(self);I*v=AV(sv->h); + RZ(a&&w); + R rank2ex(a,w,self,efr(AR(a),v[1]),efr(AR(w),v[2]),efr(AR(a),v[1]),efr(AR(w),v[2]),cons2a); +} + +// Handle u"n y where u supports irs. Since the verb may support inplacing even with rank (,"n for example), pass that through. +// If inplacing is allowed here, pass that on to irs. It will see whether the action verb can support inplacing. +// NOTHING HERE MAY DEREFERENCE jt!! +static DF1(rank1i){DECLF;A h=sv->h;I*v=AV(h); R irs1(w,fs,*v,f1);} +static DF2(rank2i){DECLF;A h=sv->h;I*v=AV(h); R irs2(a,w,fs,v[1],v[2],f2);} + +// u"n y when u does not support irs. We loop over cells, and as we do there is no reason to enable inplacing +static DF1(rank1){DECLF;A h=sv->h;I m,*v=AV(h),wr; + RZ(w); + wr=AR(w); m=efr(wr,v[0]); + R mh;I ar,l,r,*v=AV(h),wr; + RZ(a&&w); + ar=AR(a); l=efr(ar,v[1]); + wr=AR(w); r=efr(wr,v[2]); + R l f"r monad + static C ir1[]={CCOMMA,CLAMIN,CLEFT,CRIGHT,CCANT,CROT,CTAKE,CDROP,CGRADE,CDGRADE, + CBOX,CNE,CTAIL,CCTAIL,CSLASH,CBSLASH,CBSDOT,CCOMDOT,CPCO,CATDOT,0}; + static C ir2[]={CCOMMA,CLAMIN,CLEFT,CRIGHT,CCANT,CROT,CTAKE,CDROP,CGRADE,CDGRADE, + CDOLLAR,CPOUND,CIOTA,CICO,CEPS,CLBRACE,CMATCH, + CEQ,CLT,CMIN,CLE,CGT,CMAX,CGE,CPLUS,CPLUSDOT,CPLUSCO,CSTAR,CSTARDOT,CSTARCO, + CMINUS,CDIV,CEXP,CNE,CSTILE,CBANG,CCIRCLE,0}; + // For noun u, set flags to empty and use the constant routines + if(NOUN&AT(a)){*f1=cons1; *f2=cons2; *flag=0; R;} + // Verb u. Calculate m, the flags to use for u. We set VIRSx if the verb is a primitive with known + // IRS, or if u has a IRS flags set (except when that flag came from execution of ") + v=VAV(a); c=v->id; + if(NOUN&AT(a)){*f1=cons1; *f2=cons2; *flag=0; R;} + if(strchr(ir1,c))m+=VIRS1; + if(strchr(ir2,c))m+=VIRS2; + if(!(m&VIRS1)&&v->flag&VIRS1&&c!=CQQ)m+=VIRS1; + if(!(m&VIRS2)&&v->flag&VIRS2&&c!=CQQ)m+=VIRS2; + // If u does not have intrinsic IRS, see if it is a combination that has IRS + if(!m){ + p=0; if(f=v->f){d=ID(f);p=VERB&AT(f)&&strchr(ir2,d);}; // p=1 if f has IRS2 + q=0; if(g=v->g){e=ID(g);q=VERB&AT(g)&&strchr(ir2,e);}; // q=1 if g has IRS2 + switch(c){ + case CFIT: if(p&&d!=CEXP)m+=VIRS2; if(d==CNE)m+=VIRS1; break; // u!.n, preserve IRS2 except for ^!.n; preserve IRS1 for ~:!.n (nub sieve) + case CTILDE: if(p)m+=VIRS1+VIRS2; break; // u~, set IRS if dyad u has IRS2 + case CAMP: if(p&&NOUN&AT(g)||q&&NOUN&AT(f))m+=VIRS1; break; // u&n or m&v, preserve IRS2 of the verb + case CFORK: if(v->f1==(AF)jtmean)m+=VIRS1; // mean is also supported by IRS1 (kludge - should set flag when mean detected) + }} + + // Set m to the verb flags, which we will use to select the action routine, based on whether u supports IRS. + // VISATOMIC1 overrides IRS1. + I nm = v->flag&(VIRS1|VIRS2|VISATOMIC1); + if(nm&VISATOMIC1)nm|=VIRS1; // scaf + if((~nm)&(m&(VIRS1|VIRS2))) + *((I*)0)=0; // scaf + + // We have m. Now decide the return routines. If the rank is nugatory, skip it & preserve the original routine pointer. + // Otherwise, use the driver routine that executes irs? or rank?ex for the verb + // I think this can be improved, by detecting the nugatory case by looking at the verb ranks. This code may go back to + // the time when arithmetic verbs had infinite rank. + // Preserve the INPLACE flags from u - but only when irs etc can handle them! + // not yet m |= v->flag&(VINPLACEOK1|VINPLACEOK2); +// obsolete *f1=strchr(at1,c) ? v->f1 : m&VIRS1 ? rank1i : rank1; + *f1=nm&VISATOMIC1 ? v->f1 : nm&VIRS1 ? rank1i : rank1; + *f2= nm&VIRS2 ? rank2i : rank2; + *flag=0; // u"n itself does not support IRS - it IS IRS, and requires explicit rank is rank is applied to it +} + +static A jtcex(J jt,A w,AF f){A z; RE(w); z=f(jt,w); RESETERR; R z;} + /* conditional execute */ +F2(jtqqco){A h,t;AF f1,f2;D*d;I flag,*hv,n,r[3],*v; + RZ(a&&w); + GA(h,INT,3,1,0); hv=AV(h); + if(VERB&AT(w)){ + GA(t,FL,3,1,0); d=DAV(t); + n=r[0]=hv[0]=mr(w); d[0]=n<=-RMAX?-inf:RMAX<=n?inf:n; + n=r[1]=hv[1]=lr(w); d[1]=n<=-RMAX?-inf:RMAX<=n?inf:n; + n=r[2]=hv[2]=rr(w); d[2]=n<=-RMAX?-inf:RMAX<=n?inf:n; + w=t; + }else{ + n=AN(w); + ASSERT(1>=AR(w),EVRANK); + ASSERT(0g); + ASSERT(o<2,EVDOMAIN); + RZ(x=optimizers[o](jt,fs)); + R df1(w,x); +} + +static DF2(jtopt2){DECLF;I o;A x; + RZ(a&&w); + o=i0(sv->g); + ASSERT(o<2,EVDOMAIN); + RZ(x=optimizers[o](jt,fs)); + R df2(a,w,x); +} + +F2(jtoptimize){I o; + ASSERTVN(a,w); + o=i0(w); + switch(o){ + case 0: R CDERIV(CTRAMP, jtsref1, jtsref2, 0L, mr(a), rr(a), lr(a)); break; + } + R fdef(CTRAMP,VERB,jtopt1,jtopt2,a,w,0,0,RMAX,RMAX,RMAX); +} + +static F2(jtisf){R symbis(onm(a),CALL1(jt->pre,w,0L),jt->symb);} + +F2(jtassign) {A f,n,v;B ger=0;C c,*s; + n=a; v=w; + jt->asgn = 0; // if the word number of the lhs is 1, it's either (noun)=: or name=: or 'value'=: at the beginning of the line; so indicate + if(LIT&AT(n)&&1>=AR(n)){ + // lhs is ASCII characters, atom or list. Convert it to words + //ASSERT(1>=AR(n),EVRANK); must be true + s=CAV(n); ger=CGRAVE==*s; // s->1st character; remember if it is ` + RZ(n=words(ger?str(AN(n)-1,1+s):n)); // convert to words (discarding leading ` if present) + if(1==AN(n)){ + // Only one name in the list. If one-name AR assignment, leave as a list so we go through the AR-assignment path below + if(!ger){RZ(n=head(n));} // One-name normal assignment: make it a scalar, so we go through the name-assignment path & avoid unboxing + } + } + ASSERT(AN(n)||!IC(v),EVILNAME); // error if name empty + // Point to the block for the assignment; fetch the assignment pseudochar (=. or =:); choose the starting symbol table + // depending on which type of assignment (but if there is no local symbol table, always use the global) + jt->symb=jt->global; + // if simple assignment to a name (normal case), do it + if(NAME&AT(n)) symbis(n,v,jt->symb); + // otherwise, if it's an assignment to an atomic computed name, convert the string to a name and do the single assignment + else if(!AR(n))symbis(onm(n),v,jt->symb); + // otherwise it's multiple assignment (could have just 1 name to assign, if it is AR assignment). + // Verify rank 1. For each lhs-rhs pair, do the assignment (in jtisf). + // if it is AR assignment, apply jtfxx to each assignand, to convert AR to internal form + // if not AR assignment, just open each box of rhs and assign + else {ASSERT(1==AR(n),EVRANK); jt->pre=ger?jtfxx:jtope; rank2ex(n,v,0L,-1L,-1L,-1L,-1L,jtisf);} + RNE(w); +} + +F2(jtassignl) {A f,n,v;B ger=0;C c,*s; + n=a; v=w; + jt->asgn = 0; // if the word number of the lhs is 1, it's either (noun)=: or name=: or 'value'=: at the beginning of the line; so indicate + if(LIT&AT(n)&&1>=AR(n)){ + // lhs is ASCII characters, atom or list. Convert it to words + //ASSERT(1>=AR(n),EVRANK); must be true + s=CAV(n); ger=CGRAVE==*s; // s->1st character; remember if it is ` + RZ(n=words(ger?str(AN(n)-1,1+s):n)); // convert to words (discarding leading ` if present) + if(1==AN(n)){ + // Only one name in the list. If one-name AR assignment, leave as a list so we go through the AR-assignment path below + if(!ger){RZ(n=head(n));} // One-name normal assignment: make it a scalar, so we go through the name-assignment path & avoid unboxing + } + } + ASSERT(AN(n)||!IC(v),EVILNAME); // error if name empty + // Point to the block for the assignment; fetch the assignment pseudochar (=. or =:); choose the starting symbol table + // depending on which type of assignment (but if there is no local symbol table, always use the global) + jt->symb=jt->local?jt->local:jt->global; + // if simple assignment to a name (normal case), do it + if(NAME&AT(n)) symbis(n,v,jt->symb); + // otherwise, if it's an assignment to an atomic computed name, convert the string to a name and do the single assignment + else if(!AR(n))symbis(onm(n),v,jt->symb); + // otherwise it's multiple assignment (could have just 1 name to assign, if it is AR assignment). + // Verify rank 1. For each lhs-rhs pair, do the assignment (in jtisf). + // if it is AR assignment, apply jtfxx to each assignand, to convert AR to internal form + // if not AR assignment, just open each box of rhs and assign + else {ASSERT(1==AR(n),EVRANK); jt->pre=ger?jtfxx:jtope; rank2ex(n,v,0L,-1L,-1L,-1L,-1L,jtisf);} + RNE(w); +} + + +F2(jttiebox){A a1=a,w1=w; + RZ(a&&w); + if(VERB&AT(a)||!exg(head(a))){RESETERR;a1=arep(a);} + if(VERB&AT(w)||!exg(head(w))){RESETERR;w1=arep(w);} + R over(a1,w1); +} + +F1(jtwex){ /* F1: argument is type A; result is type A */ + PROLOG(0106); /* checkpoint for freeing temporary space */ + A z; /* eventual result is type A */ + RZ(w); /* exit immediately if argument is 0 */ + ASSERT(NOUN&AT(w),EVDOMAIN); /* check that argument is a noun */ + ASSERT(!AN(w)||LIT&AT(w),EVDOMAIN); /* check type (empty of any type is accepted) */ + ASSERT(1>=AR(w),EVRANK); /* check rank */ + FDEPINC(1); /* increment function call depth by 1 */ + z=parse(tokens(w,0)); /* execute the string */ + FDEPDEC(1); /* decrement function call depth by 1 */ + RZ(z); /* check for 0 return from parse */ + if(AT(z)&MARK)z=mtv; /* "empty" execution result gets an mtv */ + EPILOG(z); /* free temporary space since last checkpoint */ +} + +F1(jtiotadd){ + /* + RZ(w); + R applystr(cstr("|.@:|:@:(j./&:i./)@+."), w); */ + + + A v, z; + RZ(w); + v=eval("|.@:|:@:(j./&:i./)@+."); + ASSERT(VERB&AT(v), EVDOMAIN); + z=df1(w,v); + R z; + + /* + A z, x, y; Z v; + RZ(w); + F1RANK(0,jtiotadd,0); + RZ(w = cvt(CMPX, w)); v = ZAV(w)[0]; + x=iota(scf(v.im)); + y=iota(scf(v.re)); + z=rank2ex(x,y,0,0,1,jtjdot2); + R reverse(cant1(z));*/ +} + +#define seqdo(x0,x1,x2,x3,x4) jtseqdo(jt,(x0),(x1),(x2),(x3),(x4)) +#define consfn(x) jtconsfn(jt,(x)) + +A jtseqdo(J jt,A a,A w,A fs,A gs,I n){PROLOG(0110);A aa,s=w,*u,x,y,*yu=0,z;B b;C*av,*aav,*yv; + I ak,*e,i=0,k,m,old,xn,*xs,xt,xr; + RZ(x=df1(s,gs)); xt=AT(x); xn=AN(x); xr=AR(x); xs=AS(x); k=xn*bp(xt); + if(a){m=aii(a); ak=m*bp(AT(a)); GA(aa,AT(a),m,MAX(0,AR(a)-1),1+AS(a)); av=CAV(a); aav=CAV(aa);} + GA(y,xt,xn*(1+n),1+xr,0); e=AS(y); *e++=1+n; ICPY(e,xs,xr); + yv=CAV(y); + if(xt&DIRECT){MC(yv,AV(x),k); yv+=k;}else{yu=(A*)yv; u=AAV(x); DO(k/SZI, ra(*u); *yu++=*u++;);} + old=jt->tnextpushx; + for(i=0;i1){GA(aa,AT(a),m,AR(aa),AS(aa)); aav=CAV(aa); old=jt->tnextpushx;} + MC(aav,av+i*ak,ak); RZ(s=df2(aa,s,fs)); + }else RZ(s=df1(s,fs)); + RZ(x=df1(s,gs)); + if(!(xt==AT(x)&&xn==AN(x)&&xr==AR(x)))break; + if(1tnextpushx; + for(++i;i1){GA(aa,AT(a),m,AR(aa),AS(aa)); aav=CAV(aa); old=jt->tnextpushx;} + MC(aav,av+i*ak,ak); RZ(s=df2(aa,s,fs)); + }else RZ(s=df1(s,fs)); + RZ(*yu++=x=df1(s,gs)); + ra(x); gc(s,old); + } + RZ(y=ope(y)); + } + GA(z,BOX,2,1,0); u=AAV(z); u[0]=s; u[1]=y; EPILOG(z); +} /* a f 256!:0 g w and n f 256!:1 g w */ + +DF2(jtseqstate){A aa,s=w,*u,z;C*av,*aav;I ak,m,n,old;V*v; + RZ(a&&w&&self); + n=IC(a); m=aii(a); ak=m*bp(AT(a)); v=VAV(self); + GA(aa,AT(a),m,MAX(0,AR(a)-1),1+AS(a)); av=CAV(a); aav=CAV(aa); + old=jt->tnextpushx; + DO(n, MC(aav,av+i*ak,ak); RZ(s=df2(aa,s,v->f)); ra(s); tpop(old); tpush(s);); + GA(z,BOX,2,1,0); u=AAV(z); + u[0]=s; RZ(u[1]=repeat(sc(1+n),lamin1(df1(s,v->g)))); + R z; +} /* a f 256!:0 g w where g is a constant function */ + +DF2(jtseqex2){A fs;B b;C c;V*v; + RZ(a&&w&&self); + v=VAV(self); fs=v->f; + c=ID(fs); b=(c==CAT||c==CATCO)&&CRIGHT==ID(VAV(fs)->g); + R seqdo(b?0:a,w,fs,v->g,IC(a)); +} /* a f 256!:0 g w */ + +B jtconsfn(J jt,A w){C c;V*v; + RZ(w); + v=VAV(w); c=v->id; + R c==CFCONS||c==CQQ&&NOUN&AT(v->f)||c==CUNDER&&ds(COPE)==v->g&&consfn(v->f); +} /* 1 iff w is a constant function */ + +DF2(jtseqex){AF f2;//V*sv=VAV(self); + ASSERTVV(a,w); + f2=consfn(w)?jtseqstate:jtseqex2; +// R fdef(CIBEAM, VERB, 0L,f2, a,w,over(sv->f,sv->g), 0, 0L,RMAX,RMAX); + R fdef(CSEQRED, VERB, 0L,f2, a,w,0, 0, 0L,RMAX,RMAX); +} /* 256!:0 */ diff --git a/jsrc/best.h b/jsrc/best.h new file mode 100644 index 0000000..6eddc0e --- /dev/null +++ b/jsrc/best.h @@ -0,0 +1,44 @@ +// Prototypes +static DF1(jtyielda1); +static DF2(jtyielda2); +F1(jttrigger); +F1(jttrap); +DF1(jtstrand); +static DF1(jttramp1); +static DF2(jttramp2); +F1(jttramp); +F2(jtfixrecursive); +F2(jtassign); +F2(jtassignl); +F2(jtqqco); +DF1(jtatomapply1); +DF2(jtatomapply2); +F1(jtatomdf1); +F2(jtatomdf2); +F2(jtoptimize); +F1(jtx103d0); +F2(jttiebox); +F1(jtiotadd); +F1(jtwex); + +#define wex(x) jtwex(jt,(x)) + +#define VDVERB (I)134217728LL /* derived from a verb */ + +#define EWYIELD 56 /* [. executed in ]. */ + +// jc.h character definitions +#define CCONC (C)'\344' /* 228 344 e4 &:: */ +#define CCONV (C)'\345' /* 231 347 e7 &.. */ +#define CPARL (C)'\346' /* 229 345 e5 |:: */ +#define CRCAPDOT (C)'\361' /* 241 361 f1 R. */ +#define CKEEPL (C)'\362' /* 242 362 f2 =.. */ +#define CTRAMP (C)'\363' /* 243 363 f3 O. trampoline */ +#define CSELFX (C)'\364' /* 244 364 f4 $:: */ +#define CAPPLY (C)'\365' /* 244 365 f5 ".. */ +#define CKEEP (C)'\366' /* 245 366 f6 =:: */ +#define CFCO (C)'\367' /* 246 367 f7 f: */ +#define CQQCO (C)'\370' /* 247 370 f8 ":: */ +#define CIDD (C)'\371' /* 248 371 f9 i.. */ +#define CSEQRED (C)'\372' /* 249 372 fa &:. */ +#define CFORKO (C)'5' /* 53 065 35 */ \ No newline at end of file diff --git a/jsrc/blis.h b/jsrc/blis.h index de110f6..815fa13 100644 --- a/jsrc/blis.h +++ b/jsrc/blis.h @@ -1,6 +1,10 @@ #ifndef _BLIS_HEADER #define _BLIS_HEADER +#ifdef JXKINDLE +#undef __GNUC__ +#endif + /* simplified blis header */ #define BLIS_DRIVER_GENERIC 0 diff --git a/jsrc/ca.c b/jsrc/ca.c index d7ee55c..835500d 100644 --- a/jsrc/ca.c +++ b/jsrc/ca.c @@ -179,6 +179,9 @@ F2(jtatco){A f,g;AF f1=on1,f2=jtupon2;B b=0;C c,d,e;I flag,j,m=-1;V*av,*wv; j=i0(wv->g); if(CBOX==ID(wv->f)&&!j){f2=jtrazecut0; flag&=~VINPLACEOK2;} else if(boxatop(w)&&j&&-2<=j&&j<=2){f1=jtrazecut1; f2=jtrazecut2; flag&=~(VINPLACEOK1|VINPLACEOK2);} + break; + case CHOOK: + if(e==CLEFT&&ID(g)==CLEFT) R w; }} if(0<=m){ b=d==CFIT&&equ(zero,wv->g); diff --git a/jsrc/cf.c b/jsrc/cf.c index 25f9565..5ce433f 100644 --- a/jsrc/cf.c +++ b/jsrc/cf.c @@ -106,6 +106,8 @@ A jtfolk(J jt,A f,A g,A h){A p,q,x,y;AF f1=jtfolk1,f2=jtfolk2;B b;C c,fi,gi,hi;I if(gi==CLBRACE&&hi==CRIGHT){ p=fv->f; q=fv->g; if(CLEFT==ID(q)&&CQQ==ID(p)&&(v=VAV(p),x=v->f,CLT==ID(x)&&equ(one,v->g))){f2=jtsfrom; flag &=~(VINPLACEOK2);} + break; + case CLEFT: if((gi==CAT||gi==CATCO)&&ID(gv->g)==CRIGHT) R atco(hook(ds(CLEFT), f), atco(gv->f, h)); }} switch(fi==CCAP?gi:hi){ case CQUERY: if(hi==CDOLLAR||hi==CPOUND){f2=jtrollk; flag &=~(VINPLACEOK2);} break; @@ -139,8 +141,56 @@ A jtfolk(J jt,A f,A g,A h){A p,q,x,y;AF f1=jtfolk1,f2=jtfolk2;B b;C c,fi,gi,hi;I R fdef(CFORK,VERB, f1,f2, f,g,h, flag, RMAX,RMAX,RMAX); } +#define TDECL V*sv=VAV(self);A fs=sv->f,gs=sv->g,hs=sv->h + +static DF2(taca){ + TDECL; + A x = df1(a,fs); + RZ(x); + A y = df1(w,hs); + RZ(y); + if(ADV&AT(x)&&ADV&AT(y)){ + R folko(x, gs, y); + } else if(ADV&AT(x)&&VERB&AT(y)){ + R hook(hook(x, gs), y); + } else if(VERB&AT(x)&&ADV&AT(y)){ + R hook(hook(x, gs), y); + } else if(ADV&AT(x)&&CONJ&AT(y)){ + R hook(hook(x, gs), y); + } + R df2(x, y, gs); +} + +A jtfolko(J jt,A f,A g,A h){ + RZ(f&&g&&h); + R fdef(CFORKO,CONJ, 0,taca, f,g,h, 0L, 0L,0L,0L); +} -static DF1(taa){TDECL;A t=df1(w,fs); ASSERT(!t||AT(t)&NOUN+VERB,EVSYNTAX); R df1(t,gs);} +static DF1(taa); + +static DF2(tca){ + TDECL; + A t=df2(a,w,fs); + ASSERT(t&&AT(t)&NOUN+VERB+ADV+CONJ,EVSYNTAX); + if(AT(t)&ADV){ + R fdef(CADVF, ADV, taa,0L, t,gs,0L, 0, 0L,0L,0L); + } else if(AT(t)&CONJ) { + R fdef(CHOOK, CONJ, 0L,tca, t,gs,0L, 0, 0L,0L,0L); + } + R df1(t,gs); +} + +static DF1(taa){TDECL; + A t=df1(w,fs); + ASSERT(t&&AT(t)&NOUN+VERB+ADV+CONJ,EVSYNTAX); + if(AT(t)&ADV){ + R fdef(CADVF, ADV, taa,0L, t,gs,0L, 0, 0L,0L,0L); + } else if(AT(t)&CONJ) { + R fdef(CHOOK, CONJ, 0L,tca, t,gs,0L, 0, 0L,0L,0L); + } + R df1(t,gs); +} +//static DF1(taa){TDECL;A t=df1(w,fs); ASSERT(!t||AT(t)&NOUN+VERB,EVSYNTAX); R df1(t,gs);} static DF1(tvc){TDECL; R df2(fs,w,gs);} /* also nc */ static DF1(tcv){TDECL; R df2(w,gs,fs);} /* also cn */ @@ -232,6 +282,9 @@ F2(jthook){AF f1=0,f2=0;C c,d,e,id;I flag=VFLAGNONE;V*u,*v; } // Return the derived verb R fdef(CHOOK, VERB, f1,f2, a,w,0L, flag, RMAX,RMAX,RMAX); + case BD(ADV, VERB): R CALL1(VAV(w)->f1,a,w); // R fdef(CHOOK, VERB, jtadvverb1,jtadvverb2, a,w,0L, flag, RMAX,RMAX,RMAX); + case BD(ADV, CONJ): R CALL1(VAV(a)->f1,w,a); + case BD(CONJ,ADV ): f2=tca; R fdef(CHOOK, CONJ, 0L,f2, a,w,0L, flag, 0L,0L,0L); // All other cases produce an adverb case BD(ADV, ADV ): f1=taa; break; case BD(NOUN,CONJ): diff --git a/jsrc/cp.c b/jsrc/cp.c index 12d4e37..839b882 100644 --- a/jsrc/cp.c +++ b/jsrc/cp.c @@ -94,7 +94,7 @@ static DF1(jtply1){PROLOG(0040);DECLFG;A b,hs,j,*xv,y,z;B*bv,q;I i,k,m,n,*nv,old RZ(z=CALL1(f1,y=z,fs)); if(q&&equ(y,z)){DO(m-k, INSTALLBOX(x,xv,k,z); ++k;); break;} while(kpgcp))gc3(x,z,0L,old); }} if(0f1; @@ -106,7 +106,7 @@ static DF1(jtply1){PROLOG(0040);DECLFG;A b,hs,j,*xv,y,z;B*bv,q;I i,k,m,n,*nv,old RZ(z=CALL1(f1,y=z,fs)); if(q&&equ(y,z)){DO(1+k, INSTALLBOX(x,xv,k,z); --k;); break;} while(0<=k&&i==nv[k]){INSTALLBOX(x,xv,k,z); --k; q=0<=k?bv[k]:0;} - if(!(i%10))gc3(x,z,0L,old); + if(!(i%jt->pgcp))gc3(x,z,0L,old); }} z=ope(reshape(shape(hs),from(grade1(j),x))); EPILOG(z); } diff --git a/jsrc/cr.c b/jsrc/cr.c index c40e9ba..4c6fda2 100644 --- a/jsrc/cr.c +++ b/jsrc/cr.c @@ -555,7 +555,6 @@ static DF2(rank2){DECLF;A h=sv->h;I ar,l=AV(h)[1],r=AV(h)[2],wr; }else R CALL2(f2,a,w,fs); // pass in verb ranks to save a level of rank processing if not infinite } - // a"w; result is a verb F2(jtqq){A h,t;AF f1,f2;D*d;I *hv,n,r[3],vf,*v; RZ(a&&w); diff --git a/jsrc/crg_t.h b/jsrc/crg_t.h new file mode 100644 index 0000000..e7b9ece --- /dev/null +++ b/jsrc/crg_t.h @@ -0,0 +1,122 @@ +/* Copyright 1990-2009, Jsoftware Inc. All rights reserved. */ +/* Licensed use only. Any other use is in violation of copyright. */ +/* */ +/* cr.c templates */ + +/* template 0 used by the rank operator general cases (monad and dyad) */ +/* requires: */ +/* VALENCE 1 or 2 */ + +#if TEMPLATE==0 +#if VALENCE==1 +#define RDECLS A prevyw +#if RGERUND==1 +#define RCALL CALL1(f1[call%fn],yw,fs[call%fn]) +#else +#define RCALL CALL1(f1,prevyw=yw,fs) +#endif +#define RDIRECT (wt&DIRECT) +#define RFLAG (!(AFLAG(w)&AFNJA+AFSMM+AFREL)) +#define RARG {if(yw==prevyw||ACUC1shape, ?cr=effective rank, ?f=#frame, ?b=relative flag, for each argument +// ?cn=number of atoms in a cell, ?k=#bytes in a cell, uv point to one cell before aw data +// Allocate y? to hold one cell of ?, with uu,vv pointing to the data of y? +// b means 'w frame is larger'; p=#larger frame; q=#shorter frame; s->larger frame +// mn=#cells in larger frame (& therefore #cells in result); n=# times to repeat each cell +// from shorter-frame argument + +{B cc=1;C*zv;I j=0,jj=0,old;RDECLS; + if(mn){y0=y=RCALL; call++; RZ(y);} // if there are cells, execute on the first one + else{I d; + // if there are no cells, execute on a cell of fills. Do this quietly, because + // if there is an error, we just want to use a value of 0 for the result; thus debug + // mode off and RESETERR on failure. + // However, if the error is a non-computational error, like out of memory, it + // would be wrong to ignore it, because the verb might execute erroneously with no + // indication that anything unusual happened. So fail then + d=jt->db; jt->db=0; y=RCALL; call++; jt->db=d; + if(jt->jerr){if(EMSK(jt->jerr)&EXIGENTERROR)RZ(y); y=zero; RESETERR;} + } + + // yt=type, yr=rank, ys->shape, yn=#atoms k=#bytes of first-cell result + yt=AT(y); yr=AR(y); ys=AS(y); yn=AN(y); k=yn*bp(yt); + // First shot: zip through the cells, laying the results into the output area + // one by one. We can do this if the results are direct (i. e. not pointers), + // or if there are no results at all; and we can continue until we hit an incompatible result-type. + // With luck this will process the entire input. + if(!mn||yt&DIRECT&&RFLAG){I zn; + RARG1; RE(zn=mult(mn,yn)); // Reallocate y? if needed; zn=number of atoms in all result cells (if they stay homogeneous) + GA(z,yt,zn,p+yr,0L); ICPY(AS(z),s,p); ICPY(p+AS(z),ys,yr); // allocate output area, move in long frame followed by result-shape + if(mn){zv=CAV(z); MC(zv,AV(y),k);} // If there was a first cell, copy it in + // Establish the point we will free to after each call. This must be after the allocated result area, and + // after the starting result cell. After we call the verb we will free up what it allocated, until we have to + // reallocate the result cell; then we would be wiping out a cell that we ourselves allocated, so we stop + // freeing then + old=jt->tnextpushx; + for(j=1;j x <@f y which is the final result + } + EPILOG(z); // If the result is boxed, we know we had no wastage at this level except for yz, which is small compared to z +} +#undef VALENCE +#undef RARG +#undef RARG1 +#undef RCALL +#undef RDIRECT +#undef RFLAG +#undef RDECLS +#undef RGERUND +#undef RCALL +#endif /* TEMPLATE 0 */ + + +#undef TEMPLATE +#undef EXIGENTERROR +#undef EMSK diff --git a/jsrc/cu.c b/jsrc/cu.c index 209dde9..1b32ed3 100644 --- a/jsrc/cu.c +++ b/jsrc/cu.c @@ -9,7 +9,7 @@ static A jteverysp(J jt,A w,A fs,AF f1){A*wv,x,z,*zv;P*wp,*zp; RZ(w); - ASSERT(SBOX&AT(w),EVNONCE); + //ASSERT(SBOX&AT(w),EVNONCE); RZ(z=ca(w)); wp=PAV(w); x=SPA(wp,x); wv=AAV(x); zp=PAV(z); x=SPA(zp,x); zv=AAV(x); diff --git a/jsrc/i.c b/jsrc/i.c index d7785d5..800e52f 100644 --- a/jsrc/i.c +++ b/jsrc/i.c @@ -193,6 +193,8 @@ jt->assert = 1; jt->transposeflag=1; // jt->int64rflag=0; jt->xmode=XMEXACT; + jt->pgcp=10000; + R 1; } @@ -235,34 +237,3 @@ static C jtjinit3(J jt){S t; } C jtjinit2(J jt,int dummy0,C**dummy1){jt->sesm=1; R jinit3();} - -/* unused cpuInfo - -#if 0 // Now we detect architecture at installation time, using C_AVX - // See if processor supports AVX instructions - // Tip o' hat to InsufficientlyComplicated and the commenter - // Checking for AVX requires 3 things: - // 1) CPUID indicates that the OS uses XSAVE and XRSTORE - // instructions (allowing saving YMM registers on context - // switch) - // 2) CPUID indicates support for AVX - // 3) XGETBV indicates the AVX registers will be saved and - // restored on context switch - // - // Note that XGETBV is only available on 686 or later CPUs, so - // the instruction needs to be conditionally run. - int cpuInfo[4]; - __cpuid(cpuInfo, 1); - - I osUsesXSAVE_XRSTORE = cpuInfo[2] & (1L << 27); - I cpuAVXSuport = cpuInfo[2] & (1L << 28); - - if (osUsesXSAVE_XRSTORE && cpuAVXSuport) - { - // Check if the OS will save the YMM registers - unsigned long long xcrFeatureMask = _xgetbv(_XCR_XFEATURE_ENABLED_MASK); - jt->cpuarchavx = (xcrFeatureMask & 0x6) == 0x6; - } -#endif -*/ - diff --git a/jsrc/j.h b/jsrc/j.h index efa157d..69b2285 100644 --- a/jsrc/j.h +++ b/jsrc/j.h @@ -595,6 +595,7 @@ extern unsigned int __cdecl _clearfp (void); #include "vdx.h" #include "a.h" #include "s.h" +#include "best.h" // CTTZ(w) counts trailing zeros in low 32 bits of w. Result is undefined if w is 0. // CTTZZ(w) does the same, but returns 32 if w is 0 @@ -862,3 +863,9 @@ static __forceinline void aligned_free(void *ptr) { #endif #define CRC32LL CRC32L // takes UIL (8 bytes), return UI #endif + +#ifdef JXUNICODE +#define IFUNIC(expr) expr +#else +#define IFUNIC(expr) +#endif diff --git a/jsrc/ja.h b/jsrc/ja.h index 2b5b3e9..18dfd57 100644 --- a/jsrc/ja.h +++ b/jsrc/ja.h @@ -372,6 +372,7 @@ #define fnegate(x) jtfnegate(jt,(x)) #define fnum(x) jtfnum(jt,(x)) #define folk(x,y,z) jtfolk(jt,(x),(y),(z)) +#define folko(x,y,z) jtfolko(jt,(x),(y),(z)) #define fong(x,y) jtfong(jt,(x),(y)) #define foreign(x,y) jtforeign(jt,(x),(y)) #define foreignextra(x,y) jtforeignextra(jt,(x),(y)) @@ -398,6 +399,7 @@ #define ftymes(x,y) jtftymes(jt,(x),(y)) #define fullname(x) jtfullname(jt,(x)) #define fx(x) jtfx(jt,(x),0L) +#define fxx(x) jtfxx(jt,(x)) #define fxchar(x) jtfxchar(jt,(x)) #define fxeach(x) jtfxeach(jt,(x)) #define fxeachacv(x) jtfxeachacv(jt,(x)) @@ -623,7 +625,7 @@ #define memoget(x,y,z) jtmemoget(jt,(x),(y),(z)) #define memoput(x0,x1,x2,x3) jtmemoput(jt,(x0),(x1),(x2),(x3)) #define merge1(x,y) jtmerge1(jt,(x),(y)) -#define merge2(x0,x1,x2,x3) jtmerge2(jt,(x0),(x1),(x2),(x3)) +#define merge2(x0,x1,x2) jtmerge2(jt,(x0),(x1),(x2)) #define mf(x) jtmf(jt,(x)) #define minimum(x,y) jtminimum(jt,(x),(y)) #define minors(x) jtminors(jt,(x)) @@ -1189,6 +1191,9 @@ #define vs(x) jtvs(jt,(x)) #define vtokens(x) jtvtokens(jt,(x)) #define vtrans(x) jtvtrans(jt,(x)) +#ifdef JXUNICODE +#define vutf8(x) jtvutf8(jt,(x)) +#endif #define wa(x,y,z) jtwa(jt,(x),(y),(z)) #define weight(x,y) jtweight(jt,(x),(y)) #define widthdp(x,y,z) jtwidthdp(jt,(x),(y),(z)) diff --git a/jsrc/je.h b/jsrc/je.h index fb25608..34978d3 100644 --- a/jsrc/je.h +++ b/jsrc/je.h @@ -96,6 +96,7 @@ extern F1(jtevms); extern F1(jtex); extern F1(jtexec1); extern F1(jtexg); +extern F1(jtexgdo); extern F1(jtexpn1); extern F1(jtfact); extern F1(jtfactor); @@ -687,6 +688,7 @@ extern I jtfdep(J,A); extern void jtfh(J,A); extern I jtfnum(J,A); extern A jtfolk(J,A,A,A); /* "fork" name conflict under UNIX */ +extern A jtfolko(J,A,A,A); extern A jtfrombsn(J,A,A,I); extern A jtfrombu(J,A,A,I); extern A jtfxeachv(J,I,A); @@ -827,6 +829,9 @@ extern A jtvec(J,I,I,void*); extern F jtvfn(J,F); extern A jtvger2(J,C,A,A); extern B jtvnm(J,I,C*); +#ifdef JXUNICODE +extern I jtvutf8(J,C*); +#endif extern void jtwri(J,I,C*,I,C*); extern A jtxcvt(J,I,A); extern B jtxlinit(J); diff --git a/jsrc/jerr.h b/jsrc/jerr.h index 8b56735..f62ed7b 100644 --- a/jsrc/jerr.h +++ b/jsrc/jerr.h @@ -46,6 +46,7 @@ #define EWIRR 46 /* irrational result */ #define EWRAT 47 /* rational result */ #define EWDIV0 48 /* division by zero */ +#define EWTHROW 49 /* throw. executed */ #define EWOV 50 // integer overflow from the old routines that do not support recovery. Anything >= EWOV is an overflow. Leave at 50 until asm routines are retired #define EWOV1 51 // integer overflow that can be recovered because the float version has already been saved #define EWOVIP 52 // overflow, but recoverable even though executed in place. It starts here, but identifies the routine it came from: diff --git a/jsrc/jt.h b/jsrc/jt.h index 7876902..3ef2aa1 100644 --- a/jsrc/jt.h +++ b/jsrc/jt.h @@ -272,6 +272,13 @@ typedef struct { #if MEMAUDIT & 2 I audittstackdisabled; // set to 1 to disable auditing #endif +/* BEST Jx fields */ + I pgcp; /* ^: garbage collection period */ + B tramp; /* 1 if in O. */ + A trampv; /* verb for O. */ + A yieldval; /* return value from ]: passed to ]. */ + B yield; /* 1 if in a trap block */ + B worker; /* 1 if this jt belongs to a worker thread */ } JST; typedef JST* J; diff --git a/jsrc/jtype.h b/jsrc/jtype.h index 77a6255..c2b7a5e 100644 --- a/jsrc/jtype.h +++ b/jsrc/jtype.h @@ -533,7 +533,6 @@ typedef struct {AF f1,f2;A f,g,h;I flag,mr,lr,rr,fdep; C id;} V; #define VASGSAFE ((I)1L<<27) // does not alter locale/path #define VISATOMIC1 ((I)1L<<28) // processes each atom individually (should have had rank 0, but didn't) - typedef struct {DX re;DX im;} ZX; /* extended complex */ diff --git a/jsrc/jversion-linux.h b/jsrc/jversion-linux.h new file mode 100644 index 0000000..130dfdb --- /dev/null +++ b/jsrc/jversion-linux.h @@ -0,0 +1,5 @@ +#define jversion "806" +#define jplatform "linux" // windows/linux/darwin/raspberry/android/... +#define jtype "beta" // release,beta,... may include bug level such as beta-3 +#define jlicense "BEST" +#define jbuilder "Jx-patches" \ No newline at end of file diff --git a/jsrc/jversion-win32.h b/jsrc/jversion-win32.h new file mode 100644 index 0000000..7dbc5fe --- /dev/null +++ b/jsrc/jversion-win32.h @@ -0,0 +1,5 @@ +#define jversion "806" +#define jplatform "windows" // windows/linux/darwin/raspberry/android/... +#define jtype "beta" // release,beta,... may include bug level such as beta-3 +#define jlicense "BEST" +#define jbuilder "Jx-patches" diff --git a/jsrc/p.c b/jsrc/p.c index dbca46a..375e7ee 100644 --- a/jsrc/p.c +++ b/jsrc/p.c @@ -7,7 +7,6 @@ #include "p.h" #include - #define PARSERSTKALLO (490*sizeof(PSTK)) // number of stack entries to allocate, when we allocate, in bytes /* NVR - named value reference */ @@ -101,6 +100,7 @@ static PSTK* jtis(J jt){A f,n,v;B ger=0;C c,*s;PSTK* stack=jt->parserstkend1; #define PADV 2+8 #define PCONJ 2+12 #define PTRIDENT 1+4 +#define PSAI 1+16 #define PBIDENT 1+8 #define PASGN 1+12 #define PPAREN 3+0 // error offset immaterial, since never fails @@ -113,6 +113,7 @@ PT cases[] = { EDGE+AVN, VERB+NOUN, ADV, ANY, 0, jtvadv, 1,2,1, EDGE+AVN, VERB+NOUN, CONJ, VERB+NOUN, 0, jtvconj, 1,3,1, EDGE+AVN, VERB+NOUN, VERB, VERB, 0, jtvfolk, 1,3,1, + EDGE, ADV, CONJ, ADV, 0, jtvsai, 1,3,1, EDGE, CAVN, CAVN, ANY, 0, jtvhook, 1,2,1, NAME+NOUN, ASGN, CAVN, ANY, 0, jtvis, 0,2,1, LPAR, CAVN, RPAR, ANY, 0, jtvpunc, 0,2,0, @@ -329,7 +330,8 @@ F1(jtparsea){PSTK *stack;A z,*v;I es,i,m,maxnvrlen; L* s; // symbol-table entry // have been shifted out of the first position #define ST(i) AT(stack[i].a) if(ST(2) & CAVN) { // cases 0-7 - if(ST(0)&NAME)i = PASGN; // NAME is set only if followed by ASGN + if((ST(1) & ST(3) & ADV) && (ST(2) & CONJ)){i = PSAI;} + else if(ST(0)&NAME)i = PASGN; // NAME is set only if followed by ASGN else { // cases 0-6 if (!(ST(0)&(EDGE + AVN)))i = PNOMATCH; else if ((ST(1) | ST(2))&(ADV + CONJ)){ // cases 3, 4, 6, and 7 when NOUN=:AC @@ -386,6 +388,8 @@ F1(jtparsea){PSTK *stack;A z,*v;I es,i,m,maxnvrlen; L* s; // symbol-table entry EPZ(stack[3].a = dfs2(stack[1].a, stack[3].a, stack[2].a)); stack[3].t = stack[1].t; SM(2,0); stack += 2; break; case PTRIDENT: EPZ(stack[3].a = folk(stack[1].a, stack[2].a, stack[3].a)); stack[3].t = stack[1].t; SM(2,0); stack += 2; break; + case PSAI: + EPZ(stack[3].a = folko(stack[1].a, stack[2].a, stack[3].a)); stack[3].t = stack[1].t; SM(2,0); stack += 2; break; case PBIDENT: EPZ(stack[2].a = hook(stack[1].a, stack[2].a)); stack[2].t = stack[1].t; SM(1,0); stack += 1; break; case PPAREN: diff --git a/jsrc/p.h b/jsrc/p.h index b49b7e0..ddf7b94 100644 --- a/jsrc/p.h +++ b/jsrc/p.h @@ -4,7 +4,7 @@ /* Parsing: Macros and Defined Constants */ -#define NCASES 9L /* # of rows in cases parses table */ +#define NCASES 10L /* # of rows in cases parses table */ #define ACTION(f) A* f(J jt) #define TACT(f) TA f(J jt,I b,I e,TA*stack) #define IS(name,val) symbis(name,val,jt->local) @@ -27,6 +27,7 @@ extern TACT(jtvadv); extern TACT(jtvconj); extern TACT(jtvdyad); extern TACT(jtvfolk); +extern TACT(jtvsai); extern TACT(jtvhook); extern TACT(jtvis); extern TACT(jtvmonad); diff --git a/jsrc/pv.c b/jsrc/pv.c index 33d025f..dd52212 100644 --- a/jsrc/pv.c +++ b/jsrc/pv.c @@ -148,6 +148,8 @@ TACT(jtvconj){TA z={0,0}; if(CHK2)z.a=df2(stack[b].a,stack[e].a,stack[e-1].a); R TACT(jtvfolk){TA z={0,0}; if(CHK3)z.a=folk(stack[b].a,stack[1+b].a,stack[e].a); R z;} +TACT(jtvsai){TA z={0}; if(CHK3)z.a=folk(stack[b].a,stack[1+b].a,stack[e].a); R z;} + TACT(jtvhook){TA z={0,0}; if(CHK2)z.a=hook(stack[b].a,stack[e].a); R z;} TACT(jtvpunc){R stack[e-1];} diff --git a/jsrc/px.c b/jsrc/px.c index 9bbb652..9838695 100644 --- a/jsrc/px.c +++ b/jsrc/px.c @@ -50,6 +50,12 @@ F1(jtimmea){A t,z; static A jtcex(J jt,A w,AF f,A self){A z; RE(w); z=f(jt,w,self); RESETERR; R z;} /* conditional execute */ +F1(jtexgdo){ + RZ(w); + if(LIT&AT(w))R wex(w); + R exg(w); +} + F1(jtexg){A*v,*wv,x,y,z;I n,wd; RZ(w); n=AN(w); wv=AAV(w); wd=(I)w*ARELATIVE(w); diff --git a/jsrc/r.c b/jsrc/r.c index 1501322..8aeab1a 100644 --- a/jsrc/r.c +++ b/jsrc/r.c @@ -15,7 +15,7 @@ static F1(jtdrr){PROLOG(0055);A df,dg,fs,gs,hs,*x,z;B b,ex,xop;C c,id;I fl,*hv,m fs=v->f; gs=v->g; hs=v->h; if(fl&VXOPCALL)R drr(hs); xop=1&&VXOP&fl; ex=id==CCOLON&&hs&&!xop; - b=id==CHOOK||id==CADVF; c=id==CFORK; + b=id==CHOOK||id==CADVF; c=id==CFORK||id==CFORKO; m=!!fs+(gs||ex); if(!m)R spella(w); if(evoke(w))R sfn(0,fs); @@ -24,9 +24,17 @@ static F1(jtdrr){PROLOG(0055);A df,dg,fs,gs,hs,*x,z;B b,ex,xop;C c,id;I fl,*hv,m if(ex)RZ(dg=unparsem(zero,w)); m+=!b&&!xop||hs&&xop; GATV(z,BOX,m,1,0); x=AAV(z); - RZ(x[0]=df); - RZ(x[1]=b||c||xop?dg:fl&VDDOP?(hv=AV(hs),link(sc(hv[0]),link(spellout(id),sc(hv[1])))):spellout(id)); - if(2flag)R aro(hs); xop=1&&VXOP&v->flag; ex=hs&&id==CCOLON&&!xop; - m=id==CFORK?3:!!fs+(ex||xop&&hs||!xop&&gs); + m=id==CFORK||id==CFORKO?3:!!fs+(ex||xop&&hs||!xop&&gs); if(!m)R spella(w); if(evoke(w))R sfn(0,fs); } @@ -63,8 +71,12 @@ static F1(jtfxchar){A y;C c,d,id,*s;I m,n; ASSERT(1>=AR(w),EVRANK); // string must be an atom or list ASSERT(n,EVLENGTH); s=CAV(w); c=*(s+n-1); +#ifdef JXUNICODE + DO(n, d=s[i]; ASSERT(32<=d&&(m=vutf8(s+i)),EVSPELL); i+=m-1;); +#else DO(n, d=s[i]; ASSERT(32<=d&&d<127,EVSPELL);); // must be all ASCII - if(CA==ctype[(UC)*s]&&c!=CESC1&&c!=CESC2)R swap(w); // If name and not control word, treat as name~, create nameref +#endif +if((CA==ctype[(UC)*s]IFUNIC(||128&*s))&&c!=CESC1&&c!=CESC2)R swap(w); ASSERT(id=spellin(n,s),EVSPELL); // not name, must be control word or primitive. Also classify string if(id!=CFCONS)y=ds(id); else{m=s[n-2]-'0'; y=FCONS(CSIGN!=*s?sc(m):2==n?ainf:sc(-m));} // define 0:, if it's that ASSERT(y&&RHS&AT(y),EVDOMAIN); // make sure it's a noun/verb @@ -75,6 +87,8 @@ static F1(jtfxchar){A y;C c,d,id,*s;I m,n; // self is normally 0; if nonzero, we return a noun type ('0';jerr==EVSPELL)RESETERR; +#endif if(c[d=' ']||c[d='|']||c[d='/']||c[d=',']||c[d=';']){ GATV(y,LIT,n+AN(x),1,0); t=CAV(y); DO(n, x=WVR(i); *t++=d; MC(t,AV(x),AN(x)); t+=AN(x);); @@ -259,6 +262,7 @@ static F2(jtlinsert){A*av,f,g,h,t,t0,t1,t2,*u,y;B b,ft,gt,ht,vb;C c,id;I ad,n;V* u[1]=str(' '==cf(g)||id==CADVF&&!laa(f,g)&&!(lp(f)&&lp(g))?0L:1L," "); RE(0); R raze(y); case CFORK: + case CFORKO: GAT(y,BOX,5,1,0); u=AAV(y); RZ(u[0]=f=CALL2(jt->lcp,ft||lnn(f,g), f,0)); RZ(u[2]=g=CALL2(jt->lcp,gt||lnn(g,h)||b,g,0)); RZ(u[1]=str(' '==cf(g)?0L:1L," ")); @@ -267,10 +271,11 @@ static F2(jtlinsert){A*av,f,g,h,t,t0,t1,t2,*u,y;B b,ft,gt,ht,vb;C c,id;I ad,n;V* default: t0=CALL2(jt->lcp,ft||NOUN&AT(v->f)&&!(VGERL&v->flag)&&lp(f),f,0); t1=lsymb(id,w); + if(id==CQRYCO&&1==n){t2=t1;t1=t0;t0=t2;} y=over(t0,laa(t0,t1)?over(chr[' '],t1):t1); - if(1==n)R y; + if(1==n)R id==CQRYCO?jtlcpa(jt,1,y):y; t2=lcpx(g); - R over(y,laa(y,t2)?over(chr[' '],t2):t2); + R id==CQRYCO?jtlcpa(jt,1,over(y,laa(y,t2)?over(chr[' '],t2):t2)):over(y,laa(y,t2)?over(chr[' '],t2):t2); }} static F1(jtlcolon){A*v,x,y;C*s,*s0;I m,n; @@ -300,7 +305,7 @@ static DF1(jtlrr){A fs,gs,hs,t,*tv;C id;I fl,m;V*v; if(AT(w)&NAME)R sfn(0,w); v=VAV(w); id=v->id; fs=v->f; gs=v->g; hs=v->h; fl=v->flag; if(fl&VXOPCALL)R lrr(hs); - m=!!fs+!!gs+(id==CFORK)+(hs&&id==CCOLON&&VXOP&fl); + m=!!fs+!!gs+(id==CFORK||id==CFORKO)+(hs&&id==CCOLON&&VXOP&fl); if(!m)R lsymb(id,w); if(evoke(w))R sfn(0,fs); if(!(VXOP&fl)&&hs&&BOX&AT(hs)&&id==CCOLON)R lcolon(w); diff --git a/jsrc/rt.c b/jsrc/rt.c index 66385de..20bbd7d 100644 --- a/jsrc/rt.c +++ b/jsrc/rt.c @@ -126,7 +126,7 @@ static F1(jttrr){PROLOG(0058);A fs,gs,hs,s,t,*x,z;B ex,xop;C id;I fl,*hv,m;V*v; v=VAV(w); id=v->id; fl=v->flag; fs=v->f; gs=v->g; hs=v->h; if(fl&VXOPCALL)R trr(hs); xop=1&&VXOP&fl; ex=id==CCOLON&&hs&&!xop; - m=!!fs+(gs||ex)+(id==CFORK||xop&&hs); + m=!!fs+(gs||ex)+(id==CFORK||id==CFORKO||xop&&hs); if(!m)R tleaf(spella(w)); if(evoke(w))R tleaf(sfn(0,fs)); GATV(t,BOX,m,1,0); x=AAV(t); diff --git a/jsrc/sc.c b/jsrc/sc.c index a935d55..150b47b 100644 --- a/jsrc/sc.c +++ b/jsrc/sc.c @@ -11,7 +11,10 @@ static DF2(jtunquote){A aa,fs,g,ll,oldn,oln,z;B lk;I d,i;L*e;V*v; RE(0); JATTN; v=VAV(self); - aa=v->f; RE(e=syrd(aa,&g)); + aa=v->f; RE(e=syrd(aa,&g)); + if(e&&(fs=e->val)) { + if(jt->tramp&&fs==jt->trampv) R fdef(CTRAMP, VERB, 0L, (AF)a, w, 0L, 0L, 0L, 0L, 0L, 0L); + } fs=v->h?v->h:e?e->val:0; /* see namerefop() re v->h */ oldn=jt->curname; jt->curname=aa; oln =jt->curlocn; jt->curlocn=ll=g?LOCNAME(g):0; diff --git a/jsrc/sn.c b/jsrc/sn.c index cdc8ebd..a12d042 100644 --- a/jsrc/sn.c +++ b/jsrc/sn.c @@ -5,17 +5,27 @@ #include "j.h" +#ifdef JXUNICODE +I jtvutf8(J jt,C*s) {C c,u;UC m;I i; + i=0; c=s[i]; if(!(c&128)) R 1; + m=64; while(c&m){i++; RZ(s[i]|192==128); m>>=1;} R i+(i>0); +} /* return the length of the first UTF-8 char of s (0 for error). */ +#endif + // validate fullname (possibly locative). s->name, n=length. Returns 1 if name valid, 0 if not B jtvnm(J jt,I n,C*s){C c,d,t;I j,k; if(!(n))R 0; // error if empty string c=*s; d=*(s+n-1); // c = first char of name, d is the last if(jt->dotnames&&2==n&&'.'==d&&('m'==c||'n'==c||'u'==c||'v'==c||'x'==c||'y'==c))R 1; // if x. y. ..., that's OK - if(!(CA==ctype[(UC)c]))R 0; // first char must be alphabetic + RZ(CA==ctype[(UC)c]IFUNIC(||128&c)); // first char must be alphabetic // c='a'; // Now c='this character', d='previous character'; assign c to harmless value (not needed) j=0; // Init no indirect locative found // scan the string: verify all remaining characters alphameric (incl _); set j=index of first indirect locative (pointing to the __), or 0 if no ind loc // (the string can't start with _) - DO(n, d=c; c=s[i]; t=ctype[(UC)c]; if(!(t==CA||t==C9))R 0; if(c=='_'&&d=='_'&&!j&&i!=n-1){j=i-1;}); + DO(n, d=c; + IFUNIC( RZ((k=vutf8(s+i))!=0); i+=k-1; ) + c=s[i]; t=ctype[(UC)c]; RZ(t==CA||t==C9 IFUNIC(||k>1)); + if(c=='_'&&d=='_'&&!j&&i!=n-1){j=i-1;}); // If the last char is _, any ind loc is invalid; scan to find previous _ (call its index j, error if 0); audit locale name, or OK if empty (base locale) if(c=='_'){if(!(!j))R 0; DO(j=n-1, if('_'==s[--j])break;); if(!(j))R 0; k=n-j-2; R(!k||vlocnm(k,s+j+1));} // Here last char was not _, and j is still pointed after __ if any diff --git a/jsrc/t.c b/jsrc/t.c index 7c5aba7..1b0a4b7 100644 --- a/jsrc/t.c +++ b/jsrc/t.c @@ -5,6 +5,9 @@ #include "j.h" +extern F1(jtcceach); +extern F1(jtccevery); +extern F1(jtparl); C ctype[256]={ 0, 0, 0, 0, 0, 0, 0, 0, 0, CS, 0, 0, 0, 0, 0, 0, /* 0 */ @@ -109,7 +112,7 @@ B jtpinit(J jt){A t;C*s; /* }* */ pdef(CCASEV, VERB, jtcasev, 0L, RMAX,RMAX,RMAX,VFLAGNONE); // f2 gets filled in with pointer to a name when this is used /* }. */ pdef(CBEHEAD, VERB, jtbehead, jtdrop, RMAX,1, RMAX,VASGSAFE|VIRS1|VIRS2); // alias CDROP /* }: */ pdef(CCTAIL, VERB, jtcurtail, 0L, RMAX,0, 0 ,VASGSAFE|VIRS1); - /* " */ pdef(CQQ, CONJ, 0L, jtqq, 0, 0, 0 ,VFLAGNONE); + /* " */ pdef(CQQ, CONJ, 0L, jtqqco, 0, 0, 0 ,VFLAGNONE); /* ". */ pdef(CEXEC, VERB, jtexec1, jtexec2, 1, RMAX,RMAX,VFLAGNONE); /* ": */ pdef(CTHORN, VERB, jtthorn1, jtthorn2, RMAX,1, RMAX,VASGSAFE); /* ` */ pdef(CGRAVE, CONJ, 0L, jttie, 0, 0, 0 ,VFLAGNONE); @@ -166,5 +169,22 @@ B jtpinit(J jt){A t;C*s; /* x: */ pdef(CXCO, VERB, jtxco1, jtxco2, RMAX,RMAX,RMAX,VASGSAFE|VISATOMIC1); /* y. */ /* see above */ + extern DF2(jtseqex); + + // BEST Jx definitions + /* =..*/ pdef(CKEEPL, VERB, 0L, jtassignl,RMAX,RMAX,RMAX,0); + /* =::*/ pdef(CKEEP, VERB, 0L, jtassign, RMAX,RMAX,RMAX,0); + /* [. */ pdef(CLEV, VERB, jttrigger, 0L, RMAX,RMAX,RMAX,0); + /* ]. */ pdef(CDEX, ADV, jttrap, 0L, 0, 0, 0 ,0); + /* ]: */ pdef(CIDA, ADV, jtstrand, 0L, 0, 0, 0 ,0); + /* "..*/ pdef(CAPPLY, VERB, jtexgdo, jtapplystr,RMAX,1, RMAX,0); + /* "::*/ pdef(CQQCO, CONJ, 0L, jtqqco, 0, 0, 0 ,0); + /* ?: */ pdef(CQRYCO, VERB, jtatomdf1, jtatomdf2,0,0,0,0); + /* O. */ pdef(CTRAMP, CONJ, 0L, jtoptimize,0, 0, 0 ,0); + /* `. */ pdef(CGRDOT, CONJ, 0L, jttiebox, 0, 0, 0 ,0); + /* i..*/ pdef(CIDD, VERB, jtiotadd, 0L, 0, 0, 0, 0); + /* &:.*/ pdef(CSEQRED, CONJ, 0, jtseqex, 0, 0, 0 ,0); + /* $::*/ pdef(CSELFX, VERB, jtself1, jtself2, RMAX,RMAX,RMAX,0); + if(jt->jerr){printf("pinit failed; error %hhi\n", jt->jerr); R 0;} else R 1; } diff --git a/jsrc/v.c b/jsrc/v.c index d737434..ade609a 100644 --- a/jsrc/v.c +++ b/jsrc/v.c @@ -88,6 +88,7 @@ F2(jtright2){R lr2(0,a,w);} F1(jtright1){R w;} F1(jtiota){A z;I m,n,*v; + ASSERT(AT(w)&NOUN, EVDOMAIN); F1RANK(1,jtiota,0); if(AT(w)&XNUM+RAT)R cvt(XNUM,iota(vi(w))); RZ(w=vi(w)); n=AN(w); v=AV(w); diff --git a/jsrc/vo.c b/jsrc/vo.c index 4872003..e2c70be 100644 --- a/jsrc/vo.c +++ b/jsrc/vo.c @@ -26,9 +26,22 @@ F1(jtbox0){ R z; } +F1(jtboxsp){A z, *zv;I r, n; + if(jt->rank){ + r=jt->rank[1]; jt->rank=0; + z=denseit(w); + z=df1(z,qq(ds(CLT),sc(r))); + z=every(z,0,jtsparse1); + }else{ + GATV(z,BOX,1,0,0); zv=AAV(z); + rat1(w); *zv=w; + } + R z; +} + F1(jtbox){A y,z,*zv;C*wv;I f,k,m,n,r,wr,*ws; RZ(w); - ASSERT(!(SPARSE&AT(w)),EVNONCE); + if(SPARSE&AT(w)) R jtboxsp(jt,w); // Set NOSMREL if w is not boxed or it has NOSMREL set I newflags = (AFLAG(w) | ((~AT(w))>>(BOXX-AFNOSMRELX))) & AFNOSMREL; if(!jt->rank){ diff --git a/jsrc/w.c b/jsrc/w.c index cc4d5fa..bdf12f0 100644 --- a/jsrc/w.c +++ b/jsrc/w.c @@ -40,13 +40,20 @@ static ST state[10][9]={ // result is word index & length; z is (# words),(i0,l0),(i1,l1),... // (# words) is negated if the last word is NB. F1(jtwordil){A z;C e,nv,s,t=0;I b,i,m,n,*x,xb,xe;ST p;UC*v; +#ifdef JXUNICODE + C u; I k; +#endif RZ(w); // if no string, could be empty line from keyboard; return null A in that case nv=0; s=SS; // set not creating numeric constant; init state (after space) n=AN(w); v=UAV(w); GATV(z,INT,1+n+n,1,0); x=1+AV(z); // get count of characters n and address v; // allocate absolute worst-case output area (each char is 1 word, plus 1 for count); point x to output indexes for(i=0;i1?CA:)wtype[v[i]]]; e=p.effect; // go to next state + + if(e==EI){ // if 'emit'... t&=s==S9; // was previous state S9? (means we were building a number) if(t){if(!nv){nv=1; xb=b;} xe=i;} // if so, b must be set; if this is first number, remember starting index. In any case remember presumptive ending index else{if(nv){nv=0; *x++=xb; *x++=xe-xb;} *x++=b; *x++=i-b;} // Not S9. If a numeric constant was in progress, it ended on the word BEFORE @@ -54,6 +61,9 @@ F1(jtwordil){A z;C e,nv,s,t=0;I b,i,m,n,*x,xb,xe;ST p;UC*v; } s=p.new; // get next state if(e){b=i; t=s==S9;} // If we should move the chains, remember the new starting position, and whether we are processing a numeric +#ifdef JXUNICODE + i+=k-1; +#endif } if(s==SQ){jsignal3(EVOPENQ,w,b); R 0;} // error if open quote t&=s==S9; // finish outing the last word as above @@ -118,7 +128,7 @@ A jtenqueue(J jt,A a,A w,I env){A*v,*x,y,z;B b;C d,e,p,*s,*wi;I i,n,*u,wl;UC c; GATV(z,BOX,n,1,0); x=v=AAV(z); // allocate list of words; set running word pointer x, and static // beginning-of-list pointer v, to start of list of output pointers for(i=0;i1 character, starts with nonnumeric, and ends with inflection, convert to pseudocharacter if(128>c&&(y=ds(e))){ // If first char is ASCII, see if the form including inflections is a primitive; diff --git a/jsrc/ws.c b/jsrc/ws.c index 2e6f569..43d8e4d 100644 --- a/jsrc/ws.c +++ b/jsrc/ws.c @@ -7,14 +7,14 @@ #include "w.h" -static C spell[3][70]={ +static C spell[3][72]={ '=', '<', '>', '_', '+', '*', '-', '%', '^', '$', '~', '|', '.', ':', ',', ';', '#', '@', '/', CBSLASH, '[', ']', '{', '}', '`', CQQ, '&', '!', '?', 'a', 'A', 'b', 'c', 'C', 'd', 'D', 'e', 'E', 'f', 'H', - 'i', 'I', 'j', 'L', 'm', 'M', 'n', 'o', - 'p', 'q', 'r', 's', 'S', 't', 'T', 'u', + 'i', 'I', 'j', 'L', 'm', 'M', 'n', 'o', 'O', + 'p', 'q', 'r', 'R', 's', 'S', 't', 'T', 'u', 'v', 'x', 'y', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 0, @@ -23,8 +23,8 @@ static C spell[3][70]={ CBASE, CATDOT, CSLDOT, CBSDOT, CLEV, CDEX, CTAKE, CDROP, CGRDOT, CEXEC, CUNDER, CFIT, CQRYDOT, CALP, CATOMIC, CBDOT, CCDOT, CCYCLE, CDDOT, CDCAP, CEPS, CEBAR, CFIX, CHGEOM, - CIOTA, CICAP, CJDOT, CLDOT, CMDOT, CMCAP, CNDOT, CCIRCLE, - CPOLY, 1, CRDOT, 1, 1, CTDOT, CTCAP, CUDOT, + CIOTA, CICAP, CJDOT, CLDOT, CMDOT, CMCAP, CNDOT, CCIRCLE, CTRAMP, + CPOLY, 1, CRDOT, CRCAPDOT,1, 1, CTDOT, CTCAP, CUDOT, CVDOT, CXDOT, CYDOT, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, @@ -32,23 +32,23 @@ static C spell[3][70]={ CPOWOP, CSELF, CNE, CCANT, CODD, CADVERSE,CLAMIN, CWORDS, CABASE, CATCO, CGRADE, CDGRADE, CCAP, CIDA, CTAIL, CCTAIL, CGRCO, CTHORN, CAMPCO, CIBEAM, CQRYCO, CACE, 1, 1, - 1, 1, 1, CDCAPCO, 1, 1, 1, 1, - CICO, 1, 1, CLCAPCO, 1, 1, 1, 1, - CPCO, CQCO, 1, CSCO, CSCAPCO, CTCO, 1, CUCO, + 1, 1, 1, CDCAPCO, 1, 1, CFCO, 1, + CICO, 1, 1, CLCAPCO, 1, 1, 1, 1, 1, + CPCO, CQCO, 1, 1, CSCO, CSCAPCO, CTCO, 1, CUCO, 1, CXCO, 1, CFCONS, CFCONS, CFCONS, CFCONS, CFCONS, CFCONS, CFCONS, CFCONS, CFCONS, CFCONS, 0, }; -static C sp3[4][5]={ - CFETCH, CEMEND, CPDERIV, CUNDCO, 0, - '{', '}', 'p', '&', 0, - CESC2, CESC2, CESC1, CESC1, 0, - CESC2, CESC2, CESC1, CESC2, 0, +static C sp3[4][15]={ + CFETCH, CEMEND, CPDERIV, CUNDCO, CKEEPL, CKEEP, CSELFX, CAPPLY, CCONC, CCONV, CSEQRED, CPARL, CQQCO, CIDD, 0, + '{', '}', 'p', '&', '=', '=', '$', '"', '&', '&', '&', '|', '"', 'i', 0, + CESC2, CESC2, CESC1, CESC1, CESC1, CESC2, CESC2, CESC1, CESC2, CESC1, CESC2, CESC2, CESC2, CESC1,0, + CESC2, CESC2, CESC1, CESC2, CESC1, CESC2, CESC2, CESC1, CESC2, CESC1, CESC1, CESC2, CESC2, CESC1,0, }; /* trigraphs */ // *s is a string with length n representing a primitive. Convert the primitive to // a 1-byte pseudocharacter number. Return value of 0 means error -C spellin(I n,C*s){C c,d,p=*s,*t;I j; +C spellin(I n,C*s){C c,d,p=*s,*t=sp3[1];I j; // p is the first character, c the second, d the third switch(n){ case 1: @@ -57,13 +57,22 @@ C spellin(I n,C*s){C c,d,p=*s,*t;I j; case 2: // For 2-byte characters, look the character up in the table and choose the appropriate inflection c=s[1]; j=c==CESC1?1:c==CESC2?2:0; - R j&&(t=(C*)strchr(spell[0],p)) ? spell[j][t-spell[0]] : 0; // if inflection is not . or :, or character not found, return error + t=(C*)strchr(spell[0],p); + R j&&t ? spell[j][t-spell[0]] : 0; // if inflection is not . or :, or character not found, return error case 3: c=s[1]; d=s[2]; if(p==CSIGN&&d==CESC2&&'1'<=c&&c<='9')R CFCONS; // lump all _0-9: as CFCONS // sp3 desribes a character in a column. Row 1 is the uninflected character, rows 2-3 give a supported inflection. If those match, // the pseudocharacter in in row 0 - if(t=(C*)strchr(sp3[1],p)){j=t-sp3[1]; R c==sp3[2][j]&&d==sp3[3][j]?sp3[0][j]:0;} + while(t){ + if(t=(C*)strchr(t,p)){ + j=t-sp3[1]; + if(c==sp3[2][j]&&d==sp3[3][j]) { + R sp3[0][j]; + } + t++; + } + } default: /* note: fall through if character does not support 2 inflections */ // invalid inflection, return 0 R 0; diff --git a/jsrc/x.c b/jsrc/x.c index 40df018..a16b9a3 100644 --- a/jsrc/x.c +++ b/jsrc/x.c @@ -11,6 +11,9 @@ #include "j.h" #include "x.h" +F1(jtpgcpq); +F1(jtpgcps); + #define SDERIV(id,f1,f2,flag,m,l,r) \ fdef(id,VERB,secf1,secf2,a,w,v2((I)(f1?f1:jtdomainerr1),(I)(f2?f2:jtdomainerr2)),(flag),(I)m,(I)l,(I)r) @@ -185,6 +188,7 @@ F2(jtforeign){I p,q; case XC(9,47): R CDERIV(CIBEAM, jtbreakfns, 0, VASGSAFE,RMAX,0, 0 ); case XC(9,48): R CDERIV(CIBEAM, jtdotnamesq, 0, VASGSAFE,RMAX,0, 0 ); case XC(9,49): R CDERIV(CIBEAM, jtdotnamess, 0, VASGSAFE,RMAX,0, 0 ); + #if 0 case XC(9,50): R CDERIV(CIBEAM, jtxepq, 0, VASGSAFE,RMAX,0, 0 ); case XC(9,51): R CDERIV(CIBEAM, jtxeps, 0, VASGSAFE,RMAX,0, 0 ); @@ -199,6 +203,9 @@ F2(jtforeign){I p,q; + case XC(9,84): R CDERIV(CIBEAM, jtpgcpq, 0, VFLAGNONE,RMAX,0, 0 ); + case XC(9,85): R CDERIV(CIBEAM, jtpgcps, 0, VFLAGNONE,RMAX,0, 0 ); + /* case XC(11,*): handled at beginning */ /* case XC(12,*): reserved for D.H. Steinbrook tree stuff */ @@ -285,3 +292,15 @@ void double_trick(D a,D b,D c,D d,D e,D f,D g,D h){;} #ifdef C_CD_ARMHF void double_trick(float f0,float f1,float f2,float f3,float f4,float f5,float f6,float f7,float f8,float f9,float f10,float f11,float f12,float f13,float f14,float f15){;} #endif + +F1(jtpgcpq) { + ASSERTMTV(w); + R sc(jt->pgcp); +} + +F1(jtpgcps) {I p; + p=i0(w); + ASSERT(p>0, EVDOMAIN); + jt->pgcp=p; + R mtm; +} \ No newline at end of file diff --git a/jsrc/xa.c b/jsrc/xa.c index 5c85031..c165f5f 100644 --- a/jsrc/xa.c +++ b/jsrc/xa.c @@ -80,6 +80,7 @@ F1(jtevms){A t,*tv,*wv; F1(jtfxx){ RZ(w); + if(AT(w)&VERB+ADV+CONJ) R w; ASSERT(AT(w)&LIT+BOX,EVDOMAIN); ASSERT(1>=AR(w),EVRANK); R fx(ope(w)); diff --git a/jsrc/xc.c b/jsrc/xc.c index 34245ac..fa1696c 100644 --- a/jsrc/xc.c +++ b/jsrc/xc.c @@ -4,17 +4,119 @@ /* Xenos: Custom */ #include "j.h" +#include "p.h" +#include "x.h" +#include "xc.h" - -F2(jtforeignextra){ +F2(jtforeignextra){I p, q; RZ(a&&w); + p=i0(a); q=i0(w); RE(0); + switch(XC(p,q)){ + case XC(102,0): R CDERIV(CIBEAM, 0L, jtx102d0, VFLAGNONE,0L, RMAX,RMAX); + case XC(102,1): R CDERIV(CIBEAM, 0L, jtx102d1, VFLAGNONE,0L, RMAX,RMAX); + + case XC(104,2): R CDERIV(CIBEAM, jtbg, 0, VFLAGNONE,RMAX, 0, 0 ); + case XC(104,3): R CDERIV(CIBEAM, jtgb, 0, VFLAGNONE,RMAX, 0, 0 ); + case XC(104,5): R fdef(CIBEAM,CONJ, 0L,jtoa, a,w,0L, 0L, 0L, 0L, 0L ); + } R CDERIV(CIBEAM, 0,0, VFLAGNONE,RMAX,RMAX,RMAX); } -F2(jtfixrecursive){A f,g,y; +F2(jtapipx){A h;C*av,*wv;I ak,at,ar,*as,k,p,*u,*v,wk,wm,wn,wt,wr,*ws; + RZ(a&&w); + at=AT(a); ar=AR(a); as=AS(a); + wt=AT(w); wr=AR(w); ws=AS(w); p=-1; + if(AN(a)&&ar&&ar>=wr&&at>=wt&&5e8>AC(a)){ + p=0; u=as+ar-wr; v=ws; if(ar==wr){++u; ++v;} + DO(wr-(ar==wr), k=*u++-*v++; if(0k){p=-1; break;}); + k=bp(at); ak=k*AN(a); wm=ar==wr?*ws:1; wn=wm*aii(a); wk=k*wn; + } + if(0<=p&&AM(a)>=ak+wk+(1&&at&LAST0)){ + if(at>wt)RZ(w=cvt(at,w)); + if(p){RZ(h=vec(INT,wr,as+ar-wr)); if(ar==wr)*AV(h)=*ws; RZ(w=take(h,w));} + av=ak+CAV(a); wv=CAV(w); + if(wr&&ar>1+wr){RZ(setfv(a,w)); mvc(wk,av,k,jt->fillv);} + if(wr)MC(av,wv,k*AN(w)); else mvc(wk,av,k,wv); + *as+=wm; AN(a)+=wn; if(at&LAST0)*(av+wk)=0; + }else RZ(a=over(a,w)); + R a; +} /* append in place if possible */ + +/* naive in-place operations */ +/* AMIP=: 4 : '(< (i{::y) (j{y)} k{::y) k}y [ ''i j k''=. x' */ +/* APIP=: 4 : '(< (i{::y),j{::y ) i}y [ ''i j ''=. x' */ + +extern A jtmerge2(J jt,A a,A w,A ind); +static DF2(jtx102d0){A ind,*wv,x,y;I*av,i,n; + RZ(a&&w); + n=AN(w); wv=AAV(w); + ASSERT(!n||BOX&AT(w),EVDOMAIN); + ASSERT(1==AR(a)&&1==AR(w),EVRANK); + ASSERT(3==AN(a),EVLENGTH); + RZ(a=vi(a)); av=AV(a); + i=av[0]; if(0>i)i+=n; ASSERT(0<=i&&ii)i+=n; ASSERT(0<=i&&ii)i+=n; ASSERT(0<=i&&ii)i+=n; ASSERT(0<=i&&ij)j+=n; ASSERT(0<=j&&jjerr){RESETERR; RZ(s=lrep(WVR(i)));} + else {RZ(s=lrep(t));} + GA(p, LIT, AN(s)+2, AR(s), AS(s)); + pv=CAV(p); + pv[0]='('; pv[1+AN(s)]=')'; + memcpy((C*)pv+1, CAV(s), AN(s)); + rv[i]=p; + } + EPILOG(r); +} + +static F1(jtgb){I i, c, wd; A r, *rv,*wv; + PROLOG(0108); + RZ(w); + ASSERT(AT(w)&BOX||!AN(w), EVDOMAIN); + c=AN(w); wv=AAV(w); wd=(I)w*ARELATIVE(w); + GA(r, BOX, c, AR(w), AS(w)); rv=AAV(r); + for(i=0;ilocal; + PROLOG(0109); + RZ(w&&a); + ASSERT(VERB&AT(w), EVDOMAIN); + t=tmpname(jt,a); + n=nfs(AN(t),CAV(t)); + symbis(n,a,jt->global); + r=CALL1(VAV(w)->f1, t, w); + ex(box(t)); + EPILOG(r); + } diff --git a/jsrc/xc.h b/jsrc/xc.h index 977ecee..6a46298 100644 --- a/jsrc/xc.h +++ b/jsrc/xc.h @@ -3,31 +3,33 @@ /* */ /* Xenos: Custom */ +static F1(jtbg); +static F1(jtgb); +F1(jtwex); + +static F2(jtisf); +F2(jttiebox); -static DF2(jtcblas_dgemm); -static DF2(jtcblas_dscal); static DF1(jtdgeev); static DF1(jtdgeqrf); +static DF1(jttconj); +static DF1(jtvvadv); + +static DF2(jtcblas_dgemm); +static DF2(jtcblas_dscal); static DF2(jtdmultmatmat_32x32); static DF2(jtmatadd); -static DF2(jtseqex); -static DF2(jtseqpow); +DF2(jtoa); static DF2(jtx102d0); static DF2(jtx102d1); -static DF1(jtx103d0); -static F1(jtwex); -static F2(jttiebox); -static F1(jtbg); -static F1(jtgb); -static DF1(jttconj); -static DF2(jtoa); +#define assign(x,y) jtassign(jt,(x),(y)) #define bg(x) jtbg(jt, (x)) -#define consfn(x) jtconsfn(jt,(x)) #define gb(x) jtgb(jt, (x)) #define oa(x) jtoa(jt,(x)) -#define seqdo(x0,x1,x2,x3,x4) jtseqdo(jt,(x0),(x1),(x2),(x3),(x4)) #define seqlim(x,y,z) jtseqlim(jt,(x),(y),(z)) #define tconj(x) jttconj(jt, (x)) #define tiebox(x,y) jttiebox(jt,(x),(y)) -#define wex(x) jtwex(jt,(x)) +#define whilec(x,y,z) jtwhilec(jt,(x),(y),(z)) diff --git a/test/g220.ijs b/test/g220.ijs index 4daef1b..e6ea9a4 100644 --- a/test/g220.ijs +++ b/test/g220.ijs @@ -24,9 +24,9 @@ mean=: +/ % # 'domain error' -: ex '(<''mean'')~ x' 'ill-formed name' -: ex ' ''a___''~ 12' -'ill-formed name' -: ex ' ''a_gosh!_''~ 12' -'ill-formed name' -: ex '''a_gosh*@!_''~ 12' -'ill-formed name' -: ex ' ''do_gosh!_''~ 12' +'value error' -: ex ' ''a_gosh!_''~ 12' +'value error' -: ex '''a_gosh*@!_''~ 12' +'value error' -: ex ' ''do_gosh!_''~ 12' 4!:55 ;:'mean t x y' diff --git a/test/g5x4.ijs b/test/g5x4.ijs index c1a1efb..c1c2b1a 100644 --- a/test/g5x4.ijs +++ b/test/g5x4.ijs @@ -114,7 +114,7 @@ th =. 3 : ('f=.y fx'; '{.@(]`<@.(1&<@#)) jtr<''f''') g =.[`((e.&' ' # i.@#)@])`] f =. g} h =. g`:6} -(jtr<'f') -: jtr <'h' +NB. (jtr<'f') -: jtr <'h' NB. Doesn't match in Jx g =. */\.`(i.@#)`(+/~) f =. i.^:g diff --git a/test/gf.ijs b/test/gf.ijs index 61f42aa..a8f6ff9 100644 --- a/test/gf.ijs +++ b/test/gf.ijs @@ -48,8 +48,11 @@ fact1=: 1:`(* $:@dec)@.sgn '1:`(* $:@<:)@.*' -: fact f. lr '1:`(* $:@<:)@.*' -: fact1 f. lr +NB. Jx f. produces tacit verbs, invalidates all tests below +1[0 : 0 '>:@(3 : ''1:`(* $:@<:)@.* y'' :(4 : ''x 1:`(* $:@<:)@.* y''))' -: inc@fact f. lr '3 : ''1:`(* $:@<:)@.* y'' :(4 : ''x 1:`(* $:@<:)@.* y'')&.<:' -: fact&.dec f. lr +) s =: $: cap =: [: @@ -64,7 +67,7 @@ eq=: 2 : 0 assert. (5!:1 <'f') -: 5!:1 <'g' 1 ) - +1[0 : 0 >:@ s eq (>:@ ambi ) >:@:s eq (>:@:ambi ) >:@ s@ *: eq (>:@ monad@ *: ) @@ -115,6 +118,7 @@ s"2@*: eq (monad"2@*: ) s"2@*:@>: eq (monad"2@*:@>:) s"2~ eq (dyad"2~ ) (s"2 >: ) eq (dyad"2 >: ) +) C=: 0:`0:`1:`($:&<: + ($: <:)) @. ([: #. <:,0<[) f=: (C +:)"0 f. diff --git a/test/gtrain.ijs b/test/gtrain.ijs index f060965..4b56246 100644 --- a/test/gtrain.ijs +++ b/test/gtrain.ijs @@ -112,7 +112,7 @@ g=: 4 : 'x e. , y' NB. adverb adverb trains ------------------------------------------------ -'syntax error' -: ex ' + ((1 : ''/'') \)' +NB. 'syntax error' -: ex ' + ((1 : ''/'') \)' NB. Legal in Jx 4!:55 ;:'adot1 adot2 sdot0 b f g i x' diff --git a/tup.config b/tup.config new file mode 100644 index 0000000..538a5a1 --- /dev/null +++ b/tup.config @@ -0,0 +1,3 @@ +CONFIG_DEBUG=y +CONFIG_UNICODE=y +