Clearing unfinished business

Author: HenryHRich

jsrc/ao.c

@@ -680,7 +680,7 @@ DF2(jtkeybox){F2PREFIP;PROLOG(0009);A ai,z=0;I nitems;
 }    // a <./ w
 
 
-static DF2(jtkeytally);
+F2(jtkeytally);
 
 static F1(jtkeytallysp){PROLOG(0015);A b,e,q,x,y,z;I c,d,j,k,*u,*v;P*p;
  ARGCHK1(w);
@@ -691,14 +691,15 @@ static F1(jtkeytallysp){PROLOG(0015);A b,e,q,x,y,z;I c,d,j,k,*u,*v;P*p;
  e=SPA(p,e); k=i0(e); // k is the sparse element in the rep of i.~ w
  j=0; DO(c, if(k<=u[i])break; if(u[i]==v[i])++j;);  // j = # unique values in w before the first fill element
  RZ(b=ne(e,x));  // b = mask of values in x that are different from the sparse element
- RZ(x=repeat(b,x)); RZ(x=keytally(x,x,mark)); u=AV(x); d=AN(x);  // u now -> #/.~ of the non-sparse items, d=count thereof
+// obsolete  RZ(x=repeat(b,x)); RZ(x=keytally(x,x,mark)); u=AV(x); d=AN(x);  // u now -> #/.~ of the non-sparse items, d=count thereof
+ RZ(x=repeat(b,x)); RZ(x=keytally(x,x)); u=AV(x); d=AN(x);  // u now -> #/.~ of the non-sparse items, d=count thereof
  I nfills=SETIC(w,k)-bsum(c,BAV(b));  // number of cells of fill
  GATV0(z,INT,d+(nfills!=0),1); v=AV(z);  // allocate result: one for each unique non-fill, plus one for the fills if any
  DQ(j, *v++=*u++;); if(nfills)*v++=nfills; DQ(d-j, *v++=*u++;);  // copy in the counts
  EPILOG(z);
 }    /* x #/.y , sparse x */
 
-static DF2(jtkeytally){F2PREFIP;PROLOG(0016);A z,q;I at,j,k,n,r,s,*qv,*u,*v;
+F2(jtkeytally){F2PREFIP;PROLOG(0016);A z,q;I at,j,k,n,r,s,*qv,*u,*v;
  ARGCHK2(a,w);  // we don't neep ip, but all jtkey dyads must support it
  SETIC(a,n); at=AT(a);
  ASSERT(n==SETIC(w,k),EVLENGTH);
@@ -816,7 +817,7 @@ DF2(jtkeyheadtally){F2PREFIP;PROLOG(0017);A f,q,x,y,z;I b;I at,*av,k,n,r,*qv,*u,
    }
   }
  }else{  // no special processing
-  RZ(q=indexof(a,a)); x=repeat(eq(q,IX(n)),w); y=keytally(q,q,0L); z=stitch(b?x:y,b?y:x);  // (((i.~a) = i. # a) # w) ,. (#/.~ i.~ a)   for ({. , #)
+  RZ(q=indexof(a,a)); x=repeat(eq(q,IX(n)),w); y=keytally(q,q); z=stitch(b?x:y,b?y:x);  // (((i.~a) = i. # a) # w) ,. (#/.~ i.~ a)   for ({. , #)
  }
  EPILOG(z);
 }    /* x ({.,#)/.y or x (#,{.)/. y */

jsrc/au.c

@@ -31,8 +31,8 @@ B jtprimitive(J jt,A w){A x=w;V*v;
  ARGCHK1(w);
  v=VAV(w);
  if(CTILDE==v->id&&NOUN&AT(v->fgh[0]))RZ(x=fix(w,zeroionei(0)));
- R!VAV(x)->fgh[0];
-}    /* 1 iff w is a primitive */
+ R((I)VAV(x)->fgh[0]==0&&v->id!=CFORK);   // fork has f=0 as a flag
+}    /* 1 iff w is a primitive, detected as having no f */
 
 // w is a conj, f C n
 // Return 1 if f is of the form <@:g  (or <@g when g has infinite rank)

jsrc/ca.c

@@ -5,23 +5,25 @@
 
 #include "j.h"
 
-// <.@ >.@ and the like, monad 
+// [><].@[:]*  monad 
 static DF1(jtonf1){PROLOG(0021);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;  // scaf avoid repeated primitive calls inside rank
- if(RAT&AT(w))RZ(w=pcvt(XNUM,w));
- RZ(z=CALL1(f1,CALL1(g1,w,gs),fs));
- jt->xmode=m;
- EPILOG(z);
+ if(RAT&AT(w))RZSUFF(w=pcvt(XNUM,w), z=0; goto restore;);
+ z=CALL1(f1,CALL1(g1,w,gs),fs);  // no RZ...
+restore:;
+ jt->xmode=m;  // ...we must restore xmode...
+ EPILOG(z);  // ...and EPILOG will do nothing
 }
 
 // <.@ >.@ and the like, dyad 
 static DF2(jtuponf2){PROLOG(0022);DECLFG;A z;I flag=sv->flag,m=jt->xmode;
  ARGCHK2(a,w);
- if(primitive(gs))if(flag&VFLR)jt->xmode=XMFLR; else if(flag&VCEIL)jt->xmode=XMCEIL;  // scaf avoid repeated primitive calls inside rank
- if(RAT&AT(a))RZ(a=pcvt(XNUM,a));
- if(RAT&AT(w))RZ(w=pcvt(XNUM,w));
- RZ(z=INT&AT(a)&AT(w)&&FAV(gs)->id==CDIV?intdiv(a,w):CALL1(f1,CALL2(g2,a,w,gs),fs));
+ if(primitive(gs))if(flag&VFLR)jt->xmode=XMFLR; else if(flag&VCEIL)jt->xmode=XMCEIL;
+ if(RAT&AT(a))RZSUFF(a=pcvt(XNUM,a), z=0; goto restore;);
+ if(RAT&AT(w))RZSUFF(w=pcvt(XNUM,w), z=0; goto restore;);
+ z=INT&AT(a)&AT(w)&&FAV(gs)->id==CDIV?intdiv(a,w):CALL1(f1,CALL2(g2,a,w,gs),fs);  // no RZ, see above
+restore:;
  jt->xmode=m;
  EPILOG(z);
 }
@@ -92,8 +94,8 @@ static DF1(jtmodpow1){A g=FAV(self)->fgh[1]; R rank2ex0(FAV(g)->fgh[0],w,self,jt
 
 // #@> y
 static DF1(jttallyatopopen){F1PREFIP; A z; ARGCHK1(w); I an=AN(w); GATV(z,INT,an,AR(w),AS(w)) I *zv=IAV(z);
- if(likely(AT(w)&BOX)){A *wv=AAV(w); DO(an, A wc=C(wv[i]); I ic; SETIC(wc,ic); zv[i]=ic;)}
- else{mvc(an*SZI, zv, SZI, (iotavec-IOTAVECBEGIN+1));}
+ if(likely(AT(w)&BOX)){A *wv=AAV(w); DO(an, A wc=C(wv[i]); I ic; SETIC(wc,ic); zv[i]=ic;)}  // boxed w, copy item counts
+ else{mvc(an*SZI, zv, SZI, (iotavec-IOTAVECBEGIN+1));}  // all other like 1:"0
  RETF(z);
 }
 
@@ -149,7 +151,7 @@ DF2(atcomp){A z;AF f;
   z=f(jt,a,w,self);
   // postprocessing needed: 0x=none, 10=+./ (result is binary 0 if search completed), 11=*./ (result is binary 1 if search completed)
   if(likely(z!=0)){if(postflags&2){z=num((IAV(z)[0]!=AN(AR(a)>=AR(w)?a:w))^(postflags&1));}}
- }else z=(FAV(self)->fgh[2]?jtfolk2:jtupon2)(jt,a,w,self);   // revert if can't use special code
+ }else z=(FAV(self)->fgh[2]?jtfolk2:jtupon2)(jt,a,w,self);   // revert if can't use special code - not inplace
  POPCCT
  RETF(z);
 }
@@ -198,7 +200,7 @@ F2(jtatop){F2PREFIP;A f,g,h=0,x;AF f1=on1,f2=jtupon2;B b=0,j;C c,d,e;I flag, fla
   // We must copy forwarded flags from f to f@][.  These are WILLOPEN/USESITEMCOUNT.  WILLOPEN/USESITEMCOUNT are copied from the  // monad into the monad and (A if @[, W if @])
   // BOXATOP is set if a is <
   flag2|=(c==CBOX)*(VF2BOXATOP2+VF2BOXATOP1)+(av->flag2&VF2WILLOPEN1+VF2WILLOPEN1PROP+VF2USESITEMCOUNT1)*(1+(d&1)?VF2WILLOPEN2WX/VF2WILLOPEN1:VF2WILLOPEN2AX/VF2WILLOPEN1);
-  fdeffill(z,flag2,CAT,VERB, onright1,d&1?onright2:onleft2, a,w,0, (av->flag&VASGSAFE)+(av->flag&VJTFLGOK1)*((VJTFLGOK2+VJTFLGOK1)/VJTFLGOK1), RMAX,RMAX,RMAX); R z;  // scaf ra not needed on w
+  fdeffill(z,flag2,CAT,VERB, onright1,d&1?onright2:onleft2, a,0,0, (av->flag&VASGSAFE)+(av->flag&VJTFLGOK1)*((VJTFLGOK2+VJTFLGOK1)/VJTFLGOK1), RMAX,RMAX,RMAX); FAV(z)->fgh[1]=w; R z;  // ra not needed on w
  }
  // Set flag with ASGSAFE status from f/g; keep INPLACE? in sync with f1,f2.  But we can turn off inplacing that is not supported by v, which may
  // save a few tests during execution and is vital for handling <@v, where we may execute v directly without going through @ and therefore mustn't inplace
@@ -209,7 +211,7 @@ F2(jtatop){F2PREFIP;A f,g,h=0,x;AF f1=on1,f2=jtupon2;B b=0,j;C c,d,e;I flag, fla
 #define IDBIT(c) ((UI8)1<<((c)&0x3f))   // mask for c
 #define SPECAT (IDBIT(CBOX)|IDBIT(CNOT)|IDBIT(CGRADE)|IDBIT(CSLASH)|IDBIT(CPOUND)|IDBIT(CCEIL)|IDBIT(CFLOOR)|IDBIT(CRAZE)|IDBIT(CQUERY)|IDBIT(CQRYDOT)|IDBIT(CICAP)|IDBIT(CAMP)|IDBIT(CSTAR)|IDBIT(CSLDOT)|IDBIT(CQQ)|IDBIT(CEXP))  // mask for all special cases
  if((I)(SPECAT>>(c&0x3f))&BETWEENC(c,CNOT,CQQ)){
-  switch(c&0x3f){
+  switch(c&0x3f){   // **** DO NOT add cases without adding them to the SPECAT test above! ****
   case CBOX&0x3f:    flag2 |= (VF2BOXATOP1|VF2BOXATOP2); break;  // mark this as <@f 
   case CNOT&0x3f:    if(d==CMATCH){f2=jtnotmatch; flag+=VIRS2; flag&=~VJTFLGOK2;} break;
   case CGRADE&0x3f:  if(d==CGRADE){f1=jtranking; flag+=VIRS1; flag&=~VJTFLGOK1;} break;
@@ -307,7 +309,7 @@ F2(jtatco){F2PREFIP;A f,g;AF f1=on1cell,f2=jtupon2cell;C c,d,e;I flag, flag2=0,m
  flag = ((av->flag&wv->flag)&VASGSAFE)+(wv->flag&(VJTFLGOK1|VJTFLGOK2));
 #define SPECATCO (IDBIT(CEXP)|IDBIT(CBOX)|IDBIT(CGRADE)|IDBIT(CSLASH)|IDBIT(CPOUND)|IDBIT(CCEIL)|IDBIT(CFLOOR)|IDBIT(CSEMICO)|IDBIT(CNOT)|IDBIT(CQUERY)|IDBIT(CQRYDOT)|IDBIT(CICAP)|IDBIT(CAMP)|IDBIT(CSTAR))  // mask for all special cases
  if(unlikely((I)(SPECATCO>>(c&0x3f))&BETWEENC(c,CNOT,CPOUND))){
-  switch(c&0x3f){
+  switch(c&0x3f){   // **** DO NOT add cases without adding them to the SPECATCO test above! ****
   case CBOX&0x3f:    flag2 |= (VF2BOXATOP1|VF2BOXATOP2); break;  // mark this as <@f
 #if SLEEF && (C_AVX2 || EMU_AVX2)
   case CEXP&0x3f:    if(d==CPOLY){f2=jtpoly2; flag+=VIRS2+(VFATOPPOLYEXP<<VFATOPPOLYX);} break;   // ^@:p.

jsrc/ch.c

@@ -65,9 +65,11 @@ static DF2(jthgeom2){PROLOG(0036);A h,*hv,t,z;B b;I an,*av,j,n;V*sv=FAV(self);
 static DF1(jthgeom1){R hgeom2(sc(IMAX),w,self);}
 
 static F2(jtcancel){A c,d,f,x,y;
- f=eval("#/.~");   // scaf could call keytally
- a=ravel(a); x=nub(a); df1(c,a,f);
- w=ravel(w); y=nub(w); df1(d,w,f);
+// obsolete  f=eval("#/.~");   // scaf could call keytally
+// obsolete  a=ravel(a); x=nub(a); df1(c,a,f);
+// obsolete  w=ravel(w); y=nub(w); df1(d,w,f);
+ a=ravel(a); x=nub(a); c=keytally(a,a);  // nub of a, & # times values appear
+ w=ravel(w); y=nub(w); d=keytally(w,w);  // same for w
  a=repeat(maximum(num(0),minus(c,from(indexof(y,x),over(d,zeroionei(0))))),x);
  w=repeat(maximum(num(0),minus(d,from(indexof(x,y),over(c,zeroionei(0))))),y);
  R jlink(a,w);

jsrc/cip.c

@@ -1462,7 +1462,7 @@ finrle: ;
      if(_mm256_testz_pd(recipbad,sgnbit))break;  // testz is 1 if all comparisons false, i. e. all recips in range
        // we wait to test until we have all the reciprocals because we expect few permutations.  If there are 0 pivots they may generate NaNs in the L values, but not in recips
 
-     // falling through, we didn't get all the pivots: we must search for a permutation.  scaf The only one that matters takes the largest pivot for each column, in order
+     // falling through, we didn't get all the pivots: we must search for a permutation.
 
      // if the current permutation is a new best, remember it
      I ngood=CTTZI(_mm256_movemask_pd(recipbad));  // number of leading OK pivots

jsrc/cx.c

@@ -101,15 +101,17 @@ static B forinitnames(J jt,CDATA*cv,I cwtype,A line,I i, I go){  // i and go are
  cv->w=cwtype;  // remember type of control struct
  cv->i=i, cv->go=go;  // remember start/end line#s of control struct
  if(cwtype==CFOR){
-  // for for_xyz., get the symbol indexes for xyz & xyz_index   scaf are these preallocated, or should be?
+  // for for_xyz., get the symbol indexes for xyz & xyz_index.  We lookup, though we could put the symbol#s into the CW
   I k=AN(line)-5;  /* length of item name; -1 if omitted (for.; for_. not allowed) */
+  ASSERT(k<=255-6,EVILNAME);  // max name length is 255, and we must append _index
   if(k>0){A x;  // if it is a for_xyz.
-   // We need a string buffer for "xyz_index".  Use the stack if the name is short
-   C ss[20], *s; if(unlikely(k>(I)(sizeof(ss)-6))){GATV0(x,LIT,k+6,1); s=CAV1(x);}else s=ss;  // s point to buffer
+   C ss[255], *s=ss;  // We need a string buffer for "xyz_index"; s points to buffer
+// obsolete  if(unlikely(k>(I)(sizeof(ss)-6))){GATV0(x,LIT,k+6,1); s=CAV1(x);}else s=ss;
    MC(s,CAV(line)+4,k);  MC(s+k,"_index",6L);  // move "xyz_index" into *s
-   cv->itemsym=(probeislocal(nfs(k,s),jt->locsyms))-SYMORIGIN;  // get index of symbol in table, which must have been preallocated
-   cv->indexsym=(probeislocal(nfs(k+6,s),jt->locsyms))-SYMORIGIN;  // also symbol for xyz_index
-   if(unlikely(k>(I)(sizeof(ss)-6))){ACINITZAP(x); fr(x);}  // remove tpop and free, now that we're done.  We may be in a loop 
+   A indexnm; RZ(indexnm=nfs(k+6,s)) ASSERT(!(NAV(indexnm)->flag&NMLOC+NMILOC),EVILNAME) cv->indexsym=(probeislocal(indexnm,jt->locsyms))-SYMORIGIN;   // get name, verify not locative get (preallocated) index of symbol xyz_index in table
+   RZ(indexnm=nfs(k,s)) ASSERT(!(NAV(indexnm)->flag&NMLOC+NMILOC),EVILNAME) cv->itemsym=(probeislocal(indexnm,jt->locsyms))-SYMORIGIN;   // get name, verify not locative get (preallocated) index of symbol xyz in table
+// obsolete    NAV(indexnm)->m-=6; cv->itemsym=(probeislocal(nfs(k,s),jt->locsyms))-SYMORIGIN;  // also symbol for xyz
+// obsolete    if(unlikely(k>(I)(sizeof(ss)-6))){ACINITZAP(x); fr(x);}  // remove tpop and free, now that we're done.  We may be in a loop 
   }else{cv->itemsym=cv->indexsym=0;}  // if not for_xyz., indicate with 0 indexes
  }
  R 1;  // normal return

jsrc/io.c

@@ -608,7 +608,7 @@ B jtsesminit(JS jjt, I nthreads){R 1;}
 
 // Main entry point to run the sentence in *lp in the master thread, or in the thread given if jt is not a JS pointer
 // Run sentence; result is jt->jerr
-// If JE(jt,nfe), loop forever reading sentences scaf this is a kludge, should be a call parameter to engage loop (to allow recursive calls)
+// If JE(jt,nfe), loop forever reading sentences (but not if this is a recursive call)
 CDPROC int _stdcall JDo(JS jt, C* lp){int r;
  SETJTJM(jt,jm)
 

jsrc/ja.h

@@ -641,7 +641,7 @@ extern void jfree4gmp(void*,size_t);
 #define keyi(x,y,z)                 jtkeyi(jt,(x),(y),(z))
 #define keysp(x,y,z)                jtkeysp(jt,(x),(y),(z))
 #define keyrs(x,y)                  jtkeyrs(jt,(x),(y))
-#define keytally(x,y,z)             jtkeytally(jt,(x),(y),(z))
+#define keytally(x,y)             jtkeytally(jt,(x),(y))
 #define keytallysp(x)               jtkeytallysp(jt,(x))
 #define laguerre(x,y,z)             jtlaguerre(jt,(x),(y),(z))
 #define lamin1(x)                   jtlamin1(jt,(x))  

jsrc/je.h

@@ -146,6 +146,7 @@ extern F1(jtgsignal);
 extern A jtkeyct(J,A,A,A,D);
 extern DF2(jtkeybox);
 extern DF2(jtkeyheadtally);
+extern F2(jtkeytally);
 extern F1(jthalve);
 extern F1(jthash);
 extern F1(jthead);
@@ -652,6 +653,7 @@ extern DF2(jtpowop);
 extern DF2(jtrazecut0);
 extern DF2(jtrazecut2);
 extern DF2(jtrollk);
+extern F2(jtrollksub);
 extern DF2(jtrollkx);
 extern DF2(jtsumattymes1);
 extern DF2(jtxop2);

jsrc/jtype.h

@@ -1144,7 +1144,7 @@ typedef struct {
 // NOTE: comparison type e. is type 7.  If u&n sees bits 0-2=111 in u, it will generate a hashtable.  To prevent this from
 // happening incorrectly, leave bit 2=0.
 #define VFCOMPCOMP      0xff  // flag bits for comparison compounds, also used for other purposes
-// NOTE: comparison flags pun with VFATOP[RL] in (comp i[.:] [01]:) but that's OK because the constant verbs don't inplace thus they ignore the punned flags  scaf this is wrong
+// NOTE: comparison flags pun with VFATOP[RL] in (comp i[.:] [01]:) but that's OK because if the function reverts, it turns off inplacing
 // for other types, they are defined as follows:
 #define VFATOPL         JTINPLACEW     // (in execution of forks and v0`v1`v2) f/v0 is x@[, so OK to inplace w arg of h
 #define VFATOPR         JTINPLACEA     // (in execution of forks and v0`v1`v2) f/v0 is x@], so OK to inplace a arg of h