diff rl.c @ 0:e0bbaa717f41 draft default tip

lol J
author Jordi GutiƩrrez Hermoso <jordigh@octave.org>
date Mon, 25 Nov 2013 11:56:30 -0500 (2013-11-25)
parents
children
line wrap: on
line diff
new file mode 100644
--- /dev/null
+++ b/rl.c
@@ -0,0 +1,320 @@
+/* Copyright 1990-2011, Jsoftware Inc.  All rights reserved. */
+/* License in license.txt.                                   */
+/*                                                                         */
+/* Representations: Linear and Paren                                       */
+
+#include "j.h"
+
+#if !SY_WINCE
+extern int isdigit(int);
+#endif
+
+static F1(jtlnoun);
+static F1(jtlnum);
+static F1(jtlrr);
+
+#define NUMV(c)  (c==C9||c==CD||c==CA||c==CS)
+
+
+static B jtlp(J jt,A w){B b=1,p=0;C c,d,q=CQUOTE,*v;I j=0,n;
+ RZ(w);
+ n=AN(w); v=CAV(w); c=*v; d=*(v+n-1);
+ if(1==n||(2==n||3>=n&&' '==c)&&(d==CESC1||d==CESC2)||vnm(n,v))R 0;
+ if(C9==ctype[c])DO(n-1, d=c; c=ctype[*++v]; if(b=!NUMV(c)||d==CS&&c!=C9)break;)
+ else if(c==q)   DO(n-1, c=*v++; if(c==q)p=!p; if(b=p?0:c!=q)break;)
+ else if(c=='(') DO(n-1, c=*v++; j+=c=='('?1:c==')'?-1:0; if(b=!j)break;)
+ R b;
+}    /* 1 iff put parens around w */
+
+static A jtlcpa(J jt,B b,A w){A z=w;C*zv;I n;
+ RZ(w);
+ if(b){n=AN(w); GA(z,LIT,2+n,1,0); zv=CAV(z); *zv='('; MC(1+zv,AV(w),n); zv[1+n]=')';}
+ R z;
+}    /* if b then (w) otherwise just w */
+
+static A jtlcpb(J jt,B b,A w){A z=w;B p;C c,*v,*wv,*zv;I n;
+ RZ(w);
+ n=AN(w); wv=CAV(w); 
+ if(!b){
+  c=ctype[*wv]; v=wv; p=0;
+  if     (c==CQ)DO(n-1, c=ctype[*++v]; if(c==CQ)p=!p; else if(p){b=1; break;})
+  else if(c==C9)DO(n-1, c=ctype[*++v]; if(!(c==C9   ||c==CS   )){b=1; break;})
+  else          DO(n-1, c=      *++v ; if(!(c==CESC1||c==CESC2)){b=1; break;});
+  if(b&&vnm(n,wv))b=0;
+ }
+ if(b){GA(z,LIT,2+n,1,0); zv=CAV(z); *zv='('; MC(1+zv,wv,n); zv[1+n]=')';}
+ R z;
+}
+
+static A jtlcpx(J jt,A w){RZ(w); R CALL2(jt->lcp,lp(w),w,0);}
+
+static F1(jtltiea){A t,*v,*wv,x,y;B b;C c;I n,wd;
+ RZ(w);
+ n=AN(w); wv=AAV(w); wd=(I)w*ARELATIVE(w); RZ(t=spellout(CGRAVE));
+ GA(y,BOX,n+n,1,0); v=AAV(y);
+ DO(n, *v++=i?t:mtv; x=WVR(i); c=ID(x); RZ(x=lrr(x)); 
+     b=c==CHOOK||c==CFORK||i&&lp(x); RZ(*v++=CALL2(jt->lcp,b,x,0)););
+ R raze(y);
+}
+
+static F1(jtltieb){A pt,t,*v,*wv,x,y;B b;C c,*s;I wd,n;
+ RZ(w);
+ n=AN(w); wv=AAV(w); wd=(I)w*ARELATIVE(w); RZ(t=spellout(CGRAVE)); RZ(pt=over(scc(')'),t));
+ GA(y,BOX,n+n,1,0); v=AAV(y);
+ if(1>=n)x=mtv; else{GA(x,LIT,n-2,1,0); s=CAV(x); DO(n-2, *s++='(';);}
+ DO(n, *v++=0==i?x:1==i?t:pt; x=WVR(i); c=ID(x); RZ(x=lrr(x)); 
+     b=c==CHOOK||c==CFORK||i&&lp(x); RZ(*v++=CALL2(jt->lcp,b,x,0)););
+ R raze(y);
+}
+
+static F1(jtlsh){R over(thorn1(shape(w)),spellout(CDOLLAR));}
+
+static F1(jtlshape){I r,*s;
+ RZ(w);
+ r=AR(w); s=AS(w);
+ R 2==r&&(1==s[0]||1==s[1]) ? spellout((C)(1==s[1]?CCOMDOT:CLAMIN)) : !r ? mtv :
+     1<r ? lsh(w) : 1<AN(w) ? mtv : spellout(CCOMMA);
+}
+
+static F1(jtlchar){A y;B b,p=1,r1;C c,d,*u,*v;I j,k,m,n;
+ RZ(w);
+ m=AN(alp); n=AN(w); j=n-m; r1=1==AR(w); u=v=CAV(w); d=*v;
+ if(0<=j&&r1&&!memcmp(v+j,AV(alp),m)){ 
+  if(!j)R cstr("a.");
+  RZ(y=lchar(1==j?scc(*v):str(j,v)));
+  R lp(y)?over(cstr("a.,~"),y):over(y,cstr(",a."));
+ }
+ if(r1&&m==n&&(y=icap(ne(w,alp)))&&m>AN(y)){
+  if(1==AN(y))RZ(y=head(y));
+  R over(over(cstr("a. "),lcpx(lnum(y))),over(cstr("}~"),lchar(from(y,w))));
+ }
+ j=2; b=7<n||1<n&&1<AR(w);
+ DO(n, c=*v++; if(c==CQUOTE)++j; b&=c==d; p&=31<c&&c<127;); 
+ if(b){n=1; j=MIN(3,j);}
+ if(!p){
+  k=(UC)d; RZ(y=indexof(alp,w));
+  if(r1&&n<m&&(!k||k==m-n)&&equ(y,apv(n,k,1L)))R over(thorn1(sc(d?-n:n)),cstr("{.a."));
+  RZ(y=lnum(y));
+  R lp(y)?over(cstr("a.{~"),y):over(y,cstr("{a.")); 
+ }
+ GA(y,LIT,n+j,1,0); v=CAV(y);
+ *v=*(v+n+j-1)=CQUOTE; ++v;
+ if(2==j)MC(v,u,n); else DO(n, *v++=c=*u++; if(c==CQUOTE)*v++=c;);
+ R over(b?lsh(w):lshape(w),y);
+}    /* non-empty character array */
+
+static F1(jtlbox){A p,*v,*vv,*wv,x,y;B b=0;I n,wd;
+ RZ(w);
+ if(equ(ace,w)&&B01==AT(AAV0(w)))R cstr("a:");
+ n=AN(w); wv=AAV(w); wd=(I)w*ARELATIVE(w);
+ DO(n, x=WVR(i); if(BOX&AT(x)){b=1; break;}); b=b||1==n;
+ GA(y,BOX,n+n-!b,1,0); v=vv=AAV(y);
+ if(b){
+  RZ(p=cstr("),(<"));
+  DO(n, x=WVR(i); *v++=p; RZ(*v++=lnoun(x)););
+  RZ(*vv=cstr(1==n?"<":"(<")); if(1<n)RZ(vv[n+n-2]=cstr("),<"));
+  R over(lshape(w),raze(y));
+ }
+ DO(n, x=WVR(i); if(b=1!=AR(x)||!(LIT&AT(x)))break;);
+ if(!b){C c[256],d,*t;UC*s;
+  DO(256,c[i]=1;); 
+  RZ(x=raze(w)); s=UAV(x);
+  DO(AN(x), c[*s++]=0;);
+  if(c[CQUOTE]&&equ(w,words(x)))R over(cstr(";:"),lchar(x));
+  if(c[d=' ']||c[d='|']||c[d='/']||c[d=',']||c[d=';']){
+   GA(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););
+   RZ(y=lchar(y));
+   R over(lshape(w),over(cstr(isdigit(*CAV(y))?"<;.(_1) ":"<;._1 "),y));
+ }}
+ RZ(p=cstr(";"));
+ DO(n-1, RZ(*v++=lcpx(lnoun(WVR(i)))); *v++=p;);
+ RZ(*v=lnoun(WVR(n-1)));
+ R over(lshape(w),raze(y));
+}    /* non-empty boxed array */
+
+static F1(jtlnum1){A z;I t;
+ RZ(w);
+ t=AT(w);
+ RZ(z=t&FL+CMPX?df1(w,fit(ds(CTHORN),sc((I)18))):thorn1(w));
+ R t&XNUM+RAT&&!memchr(CAV(z),t&XNUM?'x':'r',AN(z))?over(z,scc('x')):z;
+}    /* dense non-empty numeric vector */
+
+static F1(jtlnum){A b,d,t,*v,y;B p;I n;
+ RZ(t=ravel(w));
+ n=AN(w);
+ if(7<n||1<n&&1<AR(w)){
+  d=minus(from(one,t),b=from(zero,t)); if(jt->jerr)RESETERR;
+  p=equ(t,plus(b,tymes(d,IX(n)))); if(jt->jerr)RESETERR;
+  if(p){
+   if(equ(d,zero))R over(lsh(w),lnum1(b));
+   GA(y,BOX,6,1,0); v=AAV(y); v[0]=v[1]=v[2]=v[3]=mtv;
+   if(p=!(equ(b,sc(n-1))&&equ(d,num[-1]))){
+    if     (!equ(b,zero   )){v[0]=lnum1(b); v[1]=spellout(CPLUS);}
+    if     ( equ(d,num[-1])) v[1]=spellout(CMINUS);
+    else if(!equ(d,one    )){v[2]=lnum1(d); v[3]=spellout(CSTAR);}
+   }
+   v[4]=spellout(CIOTA); v[5]=thorn1(p?shape(w):negate(shape(w)));
+   RE(y); R raze(y);
+ }}
+ R over(lshape(w),lnum1(t));
+}    /* dense numeric non-empty array */
+
+static F1(jtlsparse){A a,e,q,t,x,y,z;B ba,be,bn;I j,r,*v;P*p;
+ RZ(w);
+ r=AR(w); p=PAV(w); a=SPA(p,a); e=SPA(p,e); y=SPA(p,i); x=SPA(p,x);
+ bn=0; v=AS(w); DO(r, if(!*v++){bn=1; break;});
+ ba=0; if(r==AR(a)){v=AV(a); DO(r, if(i!=*v++){ba=1; break;});}
+ be=!(AT(w)&SFL&&0==*DAV(e));
+ if(be)RZ(z=over(lnoun(e),cstr(SB01&AT(w)?"":SINT&AT(w)?"+-~2":SFL&AT(w)?"+-~2.1":"+-~2j1")));
+ if(be||ba){
+  RZ(z=be?over(lcpx(lnoun(a)),       over(scc(';'),z)):lnoun(a));
+  RZ(z=   over(lcpx(lnoun(shape(w))),over(scc(';'),z))         );
+ }else RZ(z=lnoun(shape(w))); 
+ RZ(z=over(cstr("1$."),z));
+ if(bn||!*AS(y))R z;
+ if(AN(a)){
+  RZ(x=lcpx(lnoun(x)));
+  RZ(y=1==r?lnoun(ravel(y)):over(cstr("(<\"1)"),lnoun(y)));
+  RZ(t=over(x,over(cstr(" ("),over(y,cstr(")}"))))); 
+ }else RZ(t=over(lcpx(lnoun(head(x))),cstr(" a:}"))); 
+ ba=0; v=AV(a); DO(AN(a), if(i!=*v++){ba=1; break;});
+ if(!ba)R over(t,z);
+ RZ(q=less(IX(r),a));
+ RZ(z=over(over(lcpx(lnoun(q)),cstr("|:")),z));
+ RZ(z=over(t,z));
+ RZ(q=grade1(over(less(IX(r),q),q)));
+ j=r; v=AV(q); DO(r, if(i!=*v++){j=i; break;});
+ R over(lcpx(lnoun(drop(sc(j),q))),over(cstr("|:"),z));
+}    /* sparse array */
+
+static F1(jtlnoun0){A s,x;B r1;
+ RZ(w);
+ r1=1==AR(w); RZ(s=thorn1(shape(w)));
+ switch(AT(w)){
+  default:   R over(cstr("i."),s);
+  case LIT:  x=cstr(   "''"); R r1?x:over(over(s,scc('$')),x);
+  case C2T:  x=cstr("u: ''"); R r1?x:over(over(s,scc('$')),x);
+  case BOX:  R over(s,cstr("$a:"    ));
+  case B01:  R over(s,cstr("$0"     ));
+  case FL:   R over(s,cstr("$0.5"   ));
+  case CMPX: R over(s,cstr("$0j5"   ));
+  case XNUM: R over(s,cstr("$0x"    ));
+  case RAT:  R over(s,cstr("$1r2"   ));
+  case SBT:  R over(s,cstr("$s: ' '"));
+}}   /* empty dense array */
+
+static F1(jtlnoun){I t;
+ RZ(w);
+ t=AT(w);
+ if(t&SPARSE)R lsparse(w);
+ if(!AN(w))R lnoun0(w);
+ switch(t){
+  case LIT: R lchar(w);
+  case C2T: R over(cstr("u: "),lnum(uco2(num[3],w)));
+  case BOX: R lbox(w);
+  case SBT: R over(cstr("s: "),lbox(sb2(num[5],w)));
+  default:  R lnum(w);
+}}
+
+static A jtlsymb(J jt,C c,A w){A t;C buf[20],d,*s;I*u;V*v=VAV(w);
+ if(VDDOP&v->flag){
+  u=AV(v->h); s=buf; 
+  *s++=' '; *s++='('; s+=sprintf(s,FMTI,*u); spellit(CIBEAM,s); s+=2; s+=sprintf(s,FMTI,u[1]); *s++=')';
+  RZ(t=str(s-buf,buf)); 
+ }else RZ(t=spella(w));
+ d=cf(t);
+ R d==CESC1||d==CESC2?over(chr[' '],t):t;
+}
+
+static B laa(A a,A w){C c,d;
+ RZ(a&&w);
+ c=ctype[cl(a)]; d=ctype[cf(w)];
+ R (c==C9||c==CA)&&(d==C9||d==CA);
+}
+
+static B lnn(A a,A w){C c; RZ(a&&w); c=cl(a); R ('x'==c||C9==ctype[c])&&C9==ctype[cf(w)];}
+
+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*v;
+ RZ(a&&w);
+ n=AN(a); av=AAV(a); ad=(I)w*ARELATIVE(a); 
+ vb=VERB==AT(w); v=VAV(w); id=v->id;
+ b=id==CCOLON&&VXOP&v->flag;
+ if(1<=n){f=AVR(0); t=v->f; c=ID(t); ft=c==CHOOK||c==CFORK||c==CADVF||id==CFORK&&NOUN&AT(t)&&lp(f);}
+ if(2<=n){g=AVR(1); t=v->g; c=ID(t); gt=vb    ?c==CHOOK||c==CFORK:lp(g);}
+ if(3<=n){h=AVR(2); t=v->h; c=ID(t); ht=vb&&!b?c==CHOOK          :lp(h);}
+ switch(!b?id:2==n?CHOOK:CFORK){
+  case CADVF:
+  case CHOOK:
+   GA(y,BOX,3,1,0); u=AAV(y);
+   u[0]=f=CALL2(jt->lcp,ft||lnn(f,g),f,0);
+   u[2]=g=CALL2(jt->lcp,gt||b,       g,0);
+   u[1]=str(' '==cf(g)||id==CADVF&&!laa(f,g)&&!(lp(f)&&lp(g))?0L:1L," ");
+   RE(0); R raze(y);
+  case CFORK:
+   GA(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," "));
+   RZ(u[4]=h=CALL2(jt->lcp,ht,             h,0)); RZ(u[3]=str(' '==cf(h)?0L:1L," "));
+   R raze(y);
+  default:
+   t0=CALL2(jt->lcp,ft||NOUN&AT(v->f)&&!(VGERL&v->flag)&&lp(f),f,0);
+   t1=lsymb(id,w);
+   y=over(t0,laa(t0,t1)?over(chr[' '],t1):t1);
+   if(1==n)R y;
+   t2=lcpx(g);
+   R over(y,laa(y,t2)?over(chr[' '],t2):t2);
+}}
+
+static F1(jtlcolon){A*v,x,y;C*s,*s0;I m,n;
+ RZ(y=unparsem(one,w));
+ n=AN(y); v=AAV(y); RZ(x=lrr(VAV(w)->f));
+ if(2>n||2==n&&1==AN(v[0])&&':'==*CAV(v[0])){
+  if(!n)R over(x,str(5L," : \'\'"));
+  y=lrr(v[2==n]);
+  if(2==n)y=over(str(5L,"\':\'; "),y);
+  R over(over(x,str(3L," : ")),lcpx(y));
+ }
+ m=0; DO(n, m+=AN(v[i]););
+ GA(y,LIT,2+n+m,1,0);
+ s=s0=CAV(y);
+ DO(n, *s++=CLF; y=v[i]; m=AN(y); MC(s,CAV(y),m); s+=m;);
+ *s++=CLF; *s++=')'; 
+ RZ(y=str(s-s0,s0));
+ jt->ltext=jt->ltext?over(jt->ltext,y):y;
+ R over(x,str(4L," : 0"));
+}
+
+static F1(jtlrr){A fs,gs,hs,t,*tv;C id;I fl,m;V*v;
+ RZ(w);
+ if(AT(w)&NOUN)R lnoun(w);
+ 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);
+ 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);
+ GA(t,BOX,m,1,0); tv=AAV(t);
+ if(2<m)RZ(tv[2]=lrr(hs));
+ if(1<m)RZ(tv[1]=fl&VGERR?CALL1(jt->ltie,fxeach(gs),0L):lrr(gs));
+ if(0<m)RZ(tv[0]=fl&VGERL?CALL1(jt->ltie,fxeach(fs),0L):lrr(fs));
+ R linsert(t,w);
+}
+
+F1(jtlrep){PROLOG;A z;
+ jt->ltext=0; jt->lcp=(AF)jtlcpa; jt->ltie=jtltiea;
+ RE(z=lrr(w));
+ if(jt->ltext)z=over(z,jt->ltext);
+ jt->ltext=0;
+ EPILOG(z);
+}
+
+F1(jtprep){PROLOG;A z;
+ jt->ltext=0; jt->lcp=(AF)jtlcpb; jt->ltie=jtltieb;
+ RE(z=lrr(w));
+ if(jt->ltext)z=over(z,jt->ltext);
+ jt->ltext=0;
+ EPILOG(z);
+}
+