Newsgroups: comp.lang.apl
Path: watmath!watserv2.uwaterloo.ca!torn!utnut!cs.utexas.edu!sdd.hp.com!decwrl!decwrl!csus.edu!sfsuvax1.sfsu.edu!vpcsc4
From: vpcsc4@sfsuvax1.sfsu.edu (Emmett McLean)
Subject: LinkJ translation of Mike Powell's keyed filed programs
Message-ID: <1993Jun2.043934.20801@csus.edu>
Sender: news@csus.edu
Organization: San Francisco State University
Date: Wed, 2 Jun 1993 04:39:34 GMT
Lines: 228


Here are Mike Powell's keyed file hacks translated into C.
This will be of interest to J hackers might wish to
implement keyed files as primitive operations.

I am counting on J functions to handle memory memory allocation. 
and don't know if this could cause some potential problems.  It would
be nice if Roger Hui could comment on memory allocation
in LinkJ. (For example, in a statement like a=(A)reshape(v2(4,4),sc(0)); 
should memory be allocated for a or does sc and reshape handle it ? And,
what about statements which use exec1 ? ) These programs have worked nicely
except for a few instances in which I 0!:2'd scripts which included 
intentional incorrect usages and the expected error messages did not show.  
I've had similar experiences with other LinkJ hacks.

'e-mail' me if you'd like a copy of Mike's original programs.

Anyway, here is main.c, some documentation, and a test script.
-Emmett
============main.c=================
/* Mike Powell's keyed file programs, in C */
#include <stdio.h>
#include <string.h>
#include "lj.h"
#include "jc.h"
#include <math.h>
#define IAV(x) (I)*AV(x)
#define LJF1RANK(m,f,self)    {RZ((A)   y); if(m<AR(y))            \
                                 R (A)rank1ex(  y,(A)self,(I)m,     f);}
#define LJF2RANK(l,r,f,self)  {RZ((A) x&&y); if(l<AR(x)||r<AR(y))   \
                                 R (A)rank2ex(x,y,(A)self,(I)l,(I)r,f);}
I kvs(y) A y;{A a,b;I t;
 a=(A)ope(y);
 if(!(BOX&AT(y)&&(AN(a)>=0)&&AT(a)&CHAR))R 0;
 b=(A)eq(scc(' '),a);
 R (I)i0(match(df1(b,bslash(slash(ds(COR)))),b));
}
static F1(kcrt){A a,b,c;
 LJF1RANK(0,kcrt,0); 
 ASSERT(kvs(y),EVDOMAIN);
 a=(A)lrep(iota(sc(0)));
 b=(A)lrep(reitem(v2(0,3),sc(0)));
 c=(A)over(sc(1024),over(sc(1536),over(shape(b),sc(1024))));
 c=(A)lrep(reitem(v2(2,3),over(sc(512),over(shape(a),c))));
 c=(A)over(take(sc(512),c),over(take(sc(1024),a),take(sc(1024),b)));
 jfwrite(c,y);
 R((A)shape(c));
}
static F2(kget){A a,b,c;
 LJF2RANK(127L,0,kget,0);
 ASSERT(kvs(y),EVDOMAIN);
 a=(A)exec1(jiread(over(y,box(v2(0,512)))));
 b=(A)exec1(jiread(over(y,box(from(v2(0,1),from(sc(0),a))))));
 c=(A)exec1(jiread(over(y,box(from(v2(0,1),from(sc(1),a))))));
 R (A)exec1(jiread(over(y,box(ravel(from(v2(0,1),from(indexof(b,box(x)),c)))))));
}
static F1(kmwrite){A a,b;
 a=(A)from(sc(0),y);
 y=(A)ope(from(sc(1),y));
 b=(A)over(jfsize(a),shape(y));
 y=(A)take(tymes(sc(512),ceil1(divide(shape(y),sc(400)))),y);
 a=(A)jfappend(y,a);
 R (A)over(b,shape(y));
}
static F2(knwrite){A a,b;
 a=(A)ge(from(sc(2),x),shape(ope(from(sc(1),y))));
 if(!IAV(a)) R kmwrite(y);
  else {
  a=(A)from(sc(0),y);
  y=(A)ope(from(sc(1),y));
  a=(A)jiwrite(y,over(a,box(over(from(sc(0),x),shape(y)))));
  R (A)over(from(sc(0),x),over(shape(y),from(sc(2),x)));
 }
}
static F2(kput){A a,b,c,d,e,f,t;
 ASSERT(kvs(y),EVDOMAIN); 
 a=(A)from(sc(0),x);
 x=(A)lrep(ope(from(sc(1),x)));
 b=(A)exec1(jiread(over(y,box(v2(0,512)))));
 c=(A)exec1(jiread(over(y,box(from(v2(0,1),from(sc(0),b))))));
 d=(A)exec1(jiread(over(y,box(from(v2(0,1),from(sc(1),b))))));
 e=(A)indexof(c,a);
 t=(A)ge(e,tally(c));
 if (IAV(t)){
  f=(A)kmwrite(over(y,box(x)));
  c=(A)over(c,a);
  a=(A)knwrite(ravel(from(sc(0),b)),over(y,box(lrep(c))));
  d=(A)over(d,f);
  b=(A)knwrite(ravel(from(sc(1),b)),over(y,box(lrep(d))));
  a=(A)reitem(v2(2,3),over(a,b));
  a=(A)take(sc(512),lrep(a));
  R (A)left1(f,jiwrite(a,over(y,box(v2(0,512)))));
 }else{
  f=(A)knwrite(ravel(from(e,d)),over(y,box(x)));
  a=(A)over(take(e,d),over(f,drop(increm(e),d)));
  a=(A)knwrite(ravel(from(sc(1),b)),over(y,box(lrep(a))));
  a=(A)reitem(v2(2,3),over(from(sc(0),b),a));
  R (A)left1(f,jiwrite(a,over(y,box(v2(0,512)))));
 }
} 
static F1(kdir){A z;
 LJF1RANK(0,kdir,0); 
 ASSERT(kvs(y),EVDOMAIN); 
 z=(A)exec1(jiread(over(y,box(v2(0,512)))));
 R (A)exec1(jiread(over(y,box(from(v2(0,1),from(sc(0),z))))));
}
static F2(kcopy){A a,b;I i,t;
 LJF2RANK(0,0,kcopy,0); 
 ASSERT(kvs(y),EVDOMAIN);
 ASSERT(kvs(x),EVDOMAIN);
 a=(A)kdir(x);
 b=(A)sc(0);
 t=i0((A)tally(a));
 for(i=0;i<t;i++)
  b=(A)left1(increm(b),kput(over(from(b,a),box(kget(ope(from(b,a)),x))),y));
 R (A)over(jfsize(x),jfsize(y));
}
static F2(kdel){A a,b,c,d;
 LJF2RANK(127L,0,kdel,0);
 ASSERT(kvs(y),EVDOMAIN); 
 a=(A)jma(CHAR,1,0);b=(A)jma(CHAR,1,0);c=(A)jma(CHAR,1,0);d=(A)jma(CHAR,1,0);
 a=(A)exec1(jiread(over(y,box(v2(0,512)))));
 b=(A)exec1(jiread(over(y,box(from(v2(0,1),from(sc(0),a))))));
 c=(A)exec1(jiread(over(y,box(from(v2(0,1),from(sc(1),a))))));
 d=(A)not(eps(b,box(x)));
 b=(A)repeat(d,b);
 b=(A)knwrite(ravel(from(sc(0),a)),over(y,box(lrep(b))));
 c=(A)repeat(d,c);
 c=(A)knwrite(ravel(from(sc(1),a)),over(y,box(lrep(c))));
 a=(A)reitem(v2(2,3),over(b,c));
 a=(A)take(sc(512),lrep(a));
 R (A)left1(eps(sc(0),d),jiwrite(a,over(y,box(v2(0,512)))));
}
static F1(kmer){ASSERT(0,EVDOMAIN);}
static F2(kder){ASSERT(0,EVDOMAIN);}
C jc(k,f1,f2)I k;AF*f1,*f2;
{ switch(k){
  case 0:
   *f1=kcrt;
   *f2=kder;
   R 1;
  case 1:
   *f1=kmer; 
   *f2=kget;
   R 1;
  case 2:
   *f1=kmer;
   *f2=kput;
   R 1;
  case 3:
   *f1=kdir;
   *f2=kder;
   R 1;
  case 4:
   *f1=kmer; 
   *f2=kcopy;
   R 1;
  case 5:
   *f1=kmer; 
   *f2=kdel;
   R 1;
  default:
   ASSERT(0,EVNONCE);       
  }
}

main()
{A t;C s[456];
 jinit();
 while(1)
 {
  printf("   ");
  if(NULL==gets(s)||'\004'==*(s+strlen(s)-1))exit(0);
  t=jx(s);
  if(jerr)printf("jerr: %d\n",jerr); else if(!asgn)jpr(t);
 }
}

============testfiles.js=================
    
    create =. 10!:0
    get    =. 10!:1
    put    =. 10!:2
    dir    =. 10!:3
    copy   =. 10!:4
    delete =. 10!:5
    
    create <'testfile'
    NB. demo
    (('abc');(i.10)) put <'testfile'
    (('def');(i.5 5)) put <'testfile'
    (('mno');(2*i.5 5)) put <'testfile'
    (('xyz');('junkstuff')) put <'testfile'
    dir <'testfile'
    ('abc') get <'testfile'
    ('xyz') get <'testfile'
    create <'newtestfile'
    (<'testfile') copy <'newtestfile'
    dir <'newtestfile'
    ('abc') delete <'newtestfile'
    dir <'newtestfile'
    ('def') delete <'newtestfile'
    ('mno') delete <'newtestfile'
    ('xyz') delete <'newtestfile'
    (('yyz');('junkstuff')) put <'testfile'
   
    a =. i. 0 0
    a =. a,'y. =. 4 >. y.'
    a =. a,'b=. ? (y. , 5 5) $ 1000'
    a =. a,'i=.0 '
    a =. a,'create <''testfile'' '
    a =. a,'loop0)'
    a =. a,'1!:2&2 i'
    a =. a,'d=. (i;(i{b))put <''testfile'' '
    a =. a,'$.=.>(y.=(i=.>:i)) { loop0 ; end0 '
    a =. a,'end0)'
    a =. a,'1!:2&2 dir <''testfile'' '
    a =. a,'1!:2&2 ,&'' '' ": (3{b)'
    a =. a,'1!:2&2 (3) get <''testfile'' '
    a =. a,'i=. 0'
    a =. a,'loop1)'
    a =. a,'d=.(i) delete <''testfile'' '
    a =. a,'$.=.>(y.=(i=.>:i)) { loop1 ; end1 '
    a =. a,'end1)'
    a =. a,'y. =. dir <''testfile'' '
    a =. a : '' 
   
    a 550  NB. torture test.
