Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 369 lines (317 sloc) 10.5 KB
#include "incs.h"
#include "scalar.h"
#include "k.h"
#include "km.h"
#include "0.h"
#include "v.h"
/* misc verbs */
Z I updateIndex(K *p,I x,K r);
Z K lookupEntryOrCreate(K *p,S k);
Z S notsp(S a);
Z I isDotDyadic(K x);
K itemAtIndex(K a, I i)// Return i-th item from any type as K - TODO: oom wherever this is used
{
I at=a->t;
if( 0< at)R ci(a);
if(-4==at)R Ks(kS(a)[i]); //could refactor all this
if(-3==at)R Kc(kC(a)[i]);
if(-2==at)R Kf(kF(a)[i]);
if(-1==at)R Ki(kI(a)[i]);
R ci(kK(a)[i]);
}
//Glue will be useful when it comes time to implement \d ?
S glueSS(S c, S d)
{
I x=strlen(c),y=strlen(d);
S m = malloc(x+y+2); //oom
sprintf(m,"%s.%s",c,d);
R m;
}
K glue(K a, K b) { R Ks(sp(glueSS(*kS(a),*kS(b)))); } //oom
//Dictionary and Dictionary Entry utility functions and accessors
// currently no guards for 0 inputs ... should this change?
K DI(K d, I i){R kK(d)[i];} //dictionary index, yields entry
S ES(K d){ R *kS(kK(d)[0]);} //dictionary entry's symbol
K DE(K d,S b){DO(d->n,K x=DI(d,i);if(b==ES(x))R x)R 0;} //dictionary entry lookup
Z K* EIA(K a,I i){R kK(a)+i;} //dictionary entry's address of i-th index
K* EVP(K e){R EIA(e,1);} //dictionary entry's value-pointer address (K*)
Z K* EAP(K e){R EIA(e,2);} //dictionary entry's attribute_dictionary-pointer address (K*)
K EV(K e){R *EVP(e);} //dictionary entry's stored value
//Potential K3/4 bug (won't spend time looking): names in functions (params,
//locals, global:: assigns, or global .k.a) are done at creation. if the named
//dict entries are deleted (what method) from K TREE what happens the next time
//you run the function? does function context affect this?
//Weird: Found some bug in K3.2 were running .` would add a copy of the entries in the root of the K tree every time. Not sure how to reproduce
//K* denameBig(K dir_sym,K name_sym){R denameS(*kS(dir_sym),*kS(name_sym));} //[unnecessary?] wrapper for K-object inputs
K* denameS(S dir_string, S t)
{
R denameD('.'==*t||!*t?&KTREE:denameD(&KTREE,dir_string),t);//duplicates '.' functionality in denameD to avoid dictionary initialization
}
Z K* denameRecurse(K*p,S t,I create);
K* denameD(K*d, S t)
{
if(!simpleString(t)) R 0; //some kind of error
R denameRecurse('.'==*t||!*t?&KTREE:d,t,1);
}
Z K* denameRecurse(K*p,S t,I create)
{
if(!*t)R p;
if('.'==*t)t++;
I c=0,a=(*p)->t;
while(t[c] && '.'!=t[c])c++;
S u=strdupn(t,c);//oom
S k=sp(u); //oom
free(u);
t+=c;
P('_'==*k,(K*)kerr("reserved"))// ... not positive this goes here. does it fit in LOC? or parser maybe?
//Probably the below error check (and any others in front of LOC) should be moved into LOC
//and LOC should have the potential to return 0 (indicating other errors as well, e.g. out of memory)
P(!(6==a || 5==a),(K*)TE)
K e=lookupEntryOrCreate(p,k); //To create a dename without path creation add a branch here that does lookup without create
P(!e,(K*)ME)
if('.'==*t && (!t[1] || '.'==t[1]))
{
t++;
p=EAP(e); //attribute dict
}
else p=EVP(e); //value
R denameRecurse(p,t,create);
}
Z K lookupEntryOrCreate(K *p, S k) //****only *dict or *_n are passed to here
{
K a=*p, x;
if(5==a->t) if(x=DE(a,k)) R x;
P(!strlen(k),TE) //TODO verify this noting `. is not `
P(strchr(k,'.'),DOE)
x=newEntry(k);
if(6==a->t){cd(*p); *p=newK(5,0);} //mm/o is this done right?
kap(p,x); //oom
cd(x);
R x;
}
K* lookupEVOrCreate(K *p, S k){K x=lookupEntryOrCreate(p,k); R x?EVP(x):0; } //mm/o
K lookup(K a, S b){K x=DE(a,b); R x?EV(x):_n();}
//TODO: oom at_verb everywhere
K at_verb(K a, K b)//[Internal Function] TODO: should handle a is dict/directory & b is executable string like "1+1+c"
{//"of" depends on this even though @[d;i] = .[d;,i] <--- that equality doesn't always hold
if(0==b->t && 0==b->n)R newK(0,0);//Overriding right-arg ()
I at=a->t, an=a->n, bt=b->t, bn=b->n;
K z;
if(at==6)//Left side nil (sort of like empty dict?)
{ //K3.2 - complicated functionality. Leads me to believe this part was implemented some other way
//2009.11.10 - probably it was. see how nil case was folded in in at_ref
if( 1==ABS(bt))R ci(b);//Overrides
if( 6==bt || (0>=bt && 0==bn)) R newK(0,0);//Careful: dicts can have 0==bn
if( 4==bt)R _n();
if(-4==bt){z=newK(0,bn); DO(bn,kK(z)[i]=_n()) R z;}//0#` handled above
R TE;
}
if(1==ABS(bt))//Note switch to "b->t" here
{
P(0<at,TE) //Type/Rank/Length Error. (Several cases are eliminated before here.)
I x; DO(bn, if((x=kI(b)[i]) >= an || x <0) R XE)
z=newK(at*-bt,bn);
if (-4==at) DO(bn,kS(z)[i]=kS(a)[kI(b)[i]]) //TODO: memcpy
else if(-3==at) DO(bn,kC(z)[i]=kC(a)[kI(b)[i]])
else if(-2==at) DO(bn,kF(z)[i]=kF(a)[kI(b)[i]])
else if(-1==at) DO(bn,kI(z)[i]=kI(a)[kI(b)[i]])
else if( 0==at){DO(bn,kK(z)[i]=ci(kK(a)[kI(b)[i]])) z=collapse(z);}
}
else if(4==ABS(bt))
{
P(5!=at,TE)
z=newK(0,bn);
DO(bn, kK(z)[i]=ci(lookup(a,kS(b)[i])))
z=collapse(z);
}
else if(6==bt)
{
if (0>=at)z=ci(a);
else if(5==at){z=newK(0,an); DO(an, kK(z)[i]=ci(EV(DI(a,i)))) z=collapse(z);} //TODO: untested
else R TE; // Type{3,4}/Rank{1,2} Error
}
else if(0==bt){z=newK(0,bn);U(z) DO(bn,M(z,kK(z)[i]=at_verb(a,kK(b)[i]))) }
else if(isDotDyadic(b) && at==5){z=newK(0,an); DO(an, kK(z)[i]=ci(*EAP(DI(a,i))))}
else R TE;
R z;
}
// "`k @ 0" ; "`k @ `a" ; "`k @ \"a\"" ; "`.k @ \"a\"" ; "`.k @ `a" ; "`.k @ `gdfgdfg" ; "`.k @ 1.0" ; "`.k @ 1 2 3" but "`asdas @ 0 1" ; "`sasd @ \"a\"" ; " `.asasas @ \"f\""
K at(K x, K y)
{
K a,z;
if(4==xt)R NYI; //TODO: Value/Execute when 4==xt ... weird cases: (first a:1)
if(7!=xt)R at_verb(x,y);
a=enlist(y);
M(a)
z=dot(x,a);
cd(a);
R z;
}
Z I updateIndex(K *p,I x, K r) //assert (*p)->t is <= 0 and valid x
{
I pt=(*p)->t, rt=r->t;
if(0==pt)
{
cd(kK(*p)[x]);
kK(*p)[x] = ci(r);
*p = demote(*p); //oom ?
}
else if(pt != -rt)
{
K t=promote(*p);
//U(t) //oom
cd(*p);
*p=t;
cd(kK(*p)[x]);
kK(*p)[x] = ci(r);
}
else
{
if(-4==pt) kS(*p)[x] = *kS(r);
if(-3==pt) kC(*p)[x] = *kC(r);
if(-2==pt) kF(*p)[x] = *kF(r);
if(-1==pt) kI(*p)[x] = *kI(r);
}
R 0;
}
Z I isVerbDyadic(K x,V v){R xt==7 && kW(x)[0]==v && !kW(x)[1];}
I isColonDyadic(K x){R isVerbDyadic(x,offsetColon);}
Z I isDotDyadic(K x) {R isVerbDyadic(x,offsetDot);}
K specialAmendDot(K c, K args) //If c is like colon_dyadic return args@1, else dot
{
if(isColonDyadic(c)) R 2==args->n?ci(kK(args)[1]):_n();
R vf_ex(&c,args);
}
//TODO: Is this a stable thing if my function mucks with the tree above me? No, but find 'reference error'
//TODO: Does this do the right thing for functions/nouns with valence > 2 ?
//TODO: k-tree elements with subelements whose refcount is >1 will bork????
//TODO: add ability to return error, catch errors in calling functions
K at_ref(K *p, K b, K c, K y) // @[`a;0 1;+;10 20]
{
I pt = (*p)->t, pn = (*p)->n;
P(pt > 0 && pt != 5 && pt != 6,RE)
I bt=b->t, bn=b->n;
if(0==bn && (-1==bt || 0==bt || 5==pt || 6==pt)) R 0;//Identity TODO ????
P(0==bn && bt <= 0,IE)
P(y && !atomI(b) && !atomI(y) && bn != yn, LE )
I n=(y && atomI(b))?yn:bn;
I argc = y?2:1;
if(1==ABS(bt))
{
P(5==pt || 6==pt,TE)
//Now pt <= 0
DO(bn, I x=kI(b)[i]; P(x<0 || x>=pn,XE))
DO(atomI(b)?1:n,
K args=newK(0,argc);U(args)//Cheating 0-type w/ NULLs
kK(args)[0]=itemAtIndex(*p,kI(b)[i%bn]);
if(argc > 1) kK(args)[1] = atomI(b)?ci(y):itemAtIndex(y,i%yn);
K r = specialAmendDot(c,args);
M(r,args)
updateIndex(p,kI(b)[i%bn],r);
cd(r);
cd(args);
)
}
else if(4==ABS(bt))
{
P(5!=pt && 6!=pt,TE)
DO(atomI(b)?1:n,
K args=newK(0,argc);U(args)//Cheating 0-type w/ NULLs
S u = kS(b)[i%bn];
kK(args)[0]= ci(*lookupEVOrCreate(p,u)); // ... mm/o? tricky
if(argc > 1) kK(args)[1] = atomI(b)?ci(y):itemAtIndex(y,i%yn);
K r = specialAmendDot(c,args);
M(r,args)
K *v = EVP(DE(*p,u));
cd(*v);
*v=r; //mm/o inc/dec r here ??
cd(args);
)
}
else if(6==bt)
{
P(y && !atomI(y) && yn != pn,LE)
if(6==pt) R 0;//Identity TODO ??
K k = 5==pt?Ks(0):Ki(0);
U(k)
if(y) M(k,y = promote(y))
if(5==pt) DO(pn, *kS(k)=ES(DI(*p,i)); at_ref(p,k,c,y?kK(y)[i%yn]:0) )
else DO(pn, *kI(k)=i; at_ref(p,k,c,y?kK(y)[i%yn]:0))
cd(k);cd(y);
}
else if(0==bt) DO(n, K e=0; if(y)U(e=itemAtIndex(y,i%yn)) at_ref(p,kK(b)[i%bn],c,e); cd(e) )
else R TE;
// @[.,(`a;10);1.0;:;9]
R 0;
}
//TODO: test here: the "enlist" shortcut had a bug in at(x,y)
K at_tetradic(K a, K b, K c, K y)
{
K d=enlist(b); U(d)
K e=dot_tetradic(a,d,c,y);
cd(d);
R e;
}
K colon_monadic(K a){R ci(a);}
K colon_dyadic(K a, K b){R ci(b);}
Z S notsp(S a)
{//In terms of interned S: Output `x. for input `x
I b=strlen(a);
S c=strcpy(malloc(b+2),a);
U(c)
c[b]='.'; c[b+1]='\0';
S d=sp(c);
free(c);
R d;
}
K not_attribute(K a)
{
I t=a->t, n=a->n;
K z;
if (4==ABS(t)){U(z=newK(t, n)) DO(n,if(!(kS(z)[i]=notsp(kS(a)[i]))){cd(z);R 0;}) }
else if(2==ABS(t)){U(z=newK(t/2,n)) DO(n,kI(z)[i]= (0==kF(a)[i])?1:0;)}//sic
else if(1==ABS(t)){U(z=newK(t, n)) DO(n,kI(z)[i]= (0==kI(a)[i])?1:0;)}
else if(0==ABS(t)){U(z=newK(t, n)) DO(n,if(!(kK(z)[i]=not_attribute(kK(a)[i]))){cd(z);R 0;})}//if 0, valid list contains >0 syms
else R TE;
R z;
}
Z K excl_mkdict(K a, K b) //make dict, dyadic `foo`bar`baz!(1 2 3;`a`b`c;"abc") version
{
I n=a->n;
K k, v, t, z;
U(z=newK(5,n)) // key, value, tuple, result
DO(n, M(z,k=Ks(kS(a)[i]),t=newK(0,3),v=ci(kK(b)[i])) kK(t)[0]=k; kK(t)[1]=v; kK(t)[2]=_n(); kK(z)[i]=t;);
R z;
}
K rotate_mod(K a, K b)
{
P(b->t > 2,TE)
P(4==ABS(a->t) && 0==b->t && a->n == b->n, excl_mkdict(a,b));
P(!(1==a->t || b->t > 0), IE)
R (b->t < 1)?rotate(a,b):mod(a,b);
}
I atomI(K a){R a->t>0?1:0;}//_n is atom
K atom(K a){R Ki(atomI(a));}//_n is atom
static K enumerate_charvec(C *pth)
{
K z;
I len=strlen(pth);
K p=newK(-3,len+3);
strncpy(kC(p),"ls ", 3);
strncpy(kC(p)+3,pth,len);
z = popen_charvec(kC(p));
cd(p);
R z;
}
K enumerate(K a)
{
I t=a->t;
K z;
if (6==t)z=newK(-4,0);
else if(5==t){I n=a->n; z=newK(-4,n);U(z) DO(n, kS(z)[i]=ES(DI(a,i)))}//TODO: test this accessor composition
else if(-3==t || 3==t){ return enumerate_charvec(kC(a)); }
else if(4==t)R NYI; //TODO: 4==t enumerate dictionary of sym on k-tree, other sym: nil =Kn()
else if(1==t || 2==t){I n= t==1?*kI(a):(I)*kF(a); P(n<0,DOE) z=newK(-1,n); U(z) DO(n,kI(z)[i]=i)}//could instead be (in)?tolerant ceil/floor
else R DOE;//Domain Error? Type Error on '!1 2 3'
R z;
}