Mercurial > hg > jgplsrc

comparison au.c @ 0:e0bbaa717f41 draft default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
lol J
author Jordi Gutiérrez Hermoso <jordigh@octave.org>
date Mon, 25 Nov 2013 11:56:30 -0500
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:e0bbaa717f41
1 /* Copyright 1990-2011, Jsoftware Inc. All rights reserved. */
2 /* License in license.txt. */
3 /* */
4 /* Adverbs: Utilities */
5
6 #include "j.h"
7
8
9 static I jtfdepger(J jt,A w){A*wv;I d=0,k,wd;
10 wv=AAV(w); wd=(I)w*ARELATIVE(w);
11 DO(AN(w), k=fdep(fx(WVR(i))); d=MAX(d,k););
12 R d;
13 }
14
15 I jtfdep(J jt,A w){A f,g;I d=0,k;V*v;
16 RZ(w);
17 v=VAV(w);
18 if(v->fdep)R v->fdep;
19 if(f=v->f) d=VERB&AT(f)?fdep(f):NOUN&AT(f)&&VGERL&v->flag?fdepger(f):0;
20 if(g=v->g){k=VERB&AT(g)?fdep(g):NOUN&AT(g)&&VGERR&v->flag?fdepger(g):0; d=MAX(d,k);}
21 if(CFORK==v->id){k=fdep(v->h); d=MAX(d,k);}
22 R v->fdep=1+d;
23 } /* function depth: 1 + max depth of components */
24
25 F1(jtfdepadv){RZ(w); ASSERT(VERB&AT(w),EVDOMAIN); R sc(fdep(w));}
26
27
28 DF1(jtdf1){RZ(self); R CALL1(VAV(self)->f1, w,self);}
29 DF2(jtdf2){RZ(self); R CALL2(VAV(self)->f2,a,w,self);}
30
31 DF1(jtdfs1){A s=jt->sf,z; RZ(self); z=CALL1(VAV(self)->f1, w,jt->sf=self); jt->sf=s; R z;}
32 DF2(jtdfs2){A s=jt->sf,z; RZ(self); z=CALL2(VAV(self)->f2,a,w,jt->sf=self); jt->sf=s; R z;}
33 /* for monads and dyads that can possibly involve $: */
34
35 F1(jtself1){A z;I d=fdep(jt->sf); FDEPINC(d); z=df1( w,jt->sf); FDEPDEC(d); R z;}
36 F2(jtself2){A z;I d=fdep(jt->sf); FDEPINC(d); z=df2(a,w,jt->sf); FDEPDEC(d); R z;}
37
38 A jtac1(J jt,AF f){R fdef(0,VERB, f,0L, 0L,0L,0L, 0L, RMAX,RMAX,RMAX);}
39 A jtac2(J jt,AF f){R fdef(0,VERB, 0L,f, 0L,0L,0L, 0L, RMAX,RMAX,RMAX);}
40
41 F1(jtdomainerr1){ASSERT(0,EVDOMAIN);}
42 F2(jtdomainerr2){ASSERT(0,EVDOMAIN);}
43
44 A jtfdef(J jt,C id,I t,AF f1,AF f2,A fs,A gs,A hs,I flag,I m,I l,I r){A z;V*v;
45 RE(0);
46 GA(z,t,1,0,0); v=VAV(z);
47 v->f1 =f1?f1:jtdomainerr1; /* monad C function */
48 v->f2 =f2?f2:jtdomainerr2; /* dyad C function */
49 v->f =fs; /* monad */
50 v->g =gs; /* dyad */
51 v->h =hs; /* fork right tine or other auxiliary stuff */
52 v->flag =flag;
53 v->mr =m; /* monadic rank */
54 v->lr =l; /* left rank */
55 v->rr =r; /* right rank */
56 v->fdep =0; /* function depth */
57 v->id =id; /* spelling */
58 R z;
59 }
60
61 B nameless(A w){A f,g,h;C id;V*v;
62 if(!w||NOUN&AT(w))R 1;
63 v=VAV(w);
64 id=v->id; f=v->f; g=v->g; h=v->h;
65 R !(id==CTILDE&&NAME&AT(f)) && nameless(f) && nameless(g) && (id==CFORK?nameless(h):1);
66 }
67
68 B jtprimitive(J jt,A w){A x=w;V*v;
69 RZ(w);
70 v=VAV(w);
71 if(CTILDE==v->id&&NOUN&AT(v->f))RZ(x=fix(w));
72 R!VAV(x)->f;
73 } /* 1 iff w is a primitive */
74
75 B jtboxatop(J jt,A w){A x;C c;V*v;
76 RZ(w);
77 x=VAV(w)->f; v=VAV(x); c=v->id;
78 R COMPOSE(c)&&CBOX==ID(v->f);
79 } /* 1 iff "last" function in w is <@f */