diff dsusp.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/dsusp.c
@@ -0,0 +1,232 @@
+/* Copyright 1990-2011, Jsoftware Inc.  All rights reserved. */
+/* License in license.txt.                                   */
+/*                                                                         */
+/* Debug: Suspension                                                       */
+
+#include "j.h"
+#include "d.h"
+#include "w.h"
+
+
+/* deba() and debz() must be coded and executed in pairs */
+/* in particular, do NOT do error exits between them     */
+/* e.g. the following is a NO NO:                        */
+/*    d=deba(...);                                       */
+/*    ASSERT(blah,EVDOMAIN);                             */
+/*    debz()                                             */
+
+DC jtdeba(J jt,C t,A x,A y,A fs){A q;DC d;
+ GA(q,LIT,sizeof(DST),1,0); d=(DC)AV(q);
+ memset(d,C0,sizeof(DST));
+ d->dctype=t; d->dclnk=jt->sitop; jt->sitop=d;
+ switch(t){
+  case DCPARSE:  d->dcy=y; break;
+  case DCSCRIPT: d->dcy=y; d->dcm=(I)fs; break;
+  case DCCALL:   
+   d->dcx=x; d->dcy=y; d->dcf=fs; 
+   d->dca=jt->curname; d->dcm=NAV(jt->curname)->m;
+   d->dcn=(I)jt->cursymb;
+   d->dcstop=-2;
+   if(jt->dbss==SSSTEPINTO){d->dcss=SSSTEPINTO; jt->dbssd=d; jt->dbss=0;}
+ }
+ R d;
+}    /* create new top of si stack */
+
+void jtdebz(J jt){jt->sitop=jt->sitop->dclnk;}
+     /* remove     top of si stack */
+
+F1(jtsiinfo){A z,*zv;DC d;I c=5,n,*s;
+ ASSERTMTV(w);
+ n=0; d=jt->sitop; while(d){++n; d=d->dclnk;}
+ GA(z,BOX,c*n,2,0); s=AS(z); s[0]=n; s[1]=c; zv=AAV(z);
+ d=jt->sitop;
+ while(d){
+  RZ(zv[0]=sc(d->dctype));
+  RZ(zv[1]=d->dcsusp?scc('*'):scc(' '));
+  RZ(zv[2]=sc((I)d->dcss));
+  RZ(zv[3]=d->dctype==DCCALL?sc(lnumsi(d)):mtv);
+  switch(d->dctype){
+   case DCPARSE:  RZ(zv[4]=unparse(d->dcy)); break;
+   case DCCALL:   RZ(zv[4]=sfn(0,d->dca));   break;
+   case DCSCRIPT: zv[4]=d->dcy;              break;
+   case DCJUNK:   zv[4]=mtv;                 break; 
+  }
+  zv+=c; d=d->dclnk;
+ }
+ R z;
+}    /* 13!:32 si info */
+
+I lnumcw(I j,A w){CW*u;
+ if(0>j)R -2; 
+ else if(!w)R j; 
+ else{u=(CW*)AV(w); DO(AN(w), if(j<=u[i].source)R i;) R IMAX/2;}
+}    /* line number in CW corresp. to j */
+
+I lnumsi(DC d){A c;I i;
+ if(c=d->dcc){i=*(I*)d->dci; R(MIN(i,AN(c)-1)+(CW*)AV(c))->source;}else R 0;
+}    /* source line number from stack entry */
+
+
+
+static DC suspset(DC d){DC e;
+ while(d&&DCCALL!=d->dctype){e=d; d=d->dclnk;}  /* find topmost call                 */
+ if(!(d&&DCCALL==d->dctype))R 0;                /* don't suspend if no such call     */
+ if(d->dcc)e->dcsusp=1;                         /* if explicit, set susp on line     */
+ else      d->dcsusp=1;                         /* if not explicit, set susp on call */
+ R d;
+}    /* find topmost call and set suspension flag */
+
+static B jterrcap(J jt){A y,*yv;
+ jt->dbsusact=SUSCLEAR;
+ GA(y,BOX,4,1,0); yv=AAV(y);
+ RZ(yv[0]=sc(jt->jerr1));
+ RZ(yv[1]=str(jt->etxn1,jt->etx));
+ RZ(yv[2]=dbcall(mtv));
+ RZ(yv[3]=locname(mtv));
+ RZ(symbis(nfs(22L,"STACK_ERROR_INFO_base_"),y,mark));
+ R 1;
+}    /* error capture */
+
+static void jtsusp(J jt){B t;DC d;I old=jt->tbase+jt->ttop;
+ jt->dbsusact=SUSCONT;
+ d=jt->dcs; t=jt->tostdout;
+ jt->dcs=0; jt->tostdout=1;
+ jt->fdepn =MIN(NFDEP ,jt->fdepn +NFDEP /10);
+ jt->fcalln=MIN(NFCALL,jt->fcalln+NFCALL/10);
+ if     (jt->dbssexec){RESETERR; immex(jt->dbssexec); tpop(old);}
+ else if(jt->dbtrap  ){RESETERR; immex(jt->dbtrap  ); tpop(old);}
+ while(jt->dbsusact==SUSCONT){
+  jt->jerr=0;
+  if(jt->iepdo&&jt->iep){jt->iepdo=0; immex(jt->iep); tpop(old);}
+  immex(jgets("      ")); 
+  tpop(old);
+ }
+ if(jt->dbuser){jt->fdepn-=NFDEP/10; jt->fcalln-=NFCALL/10;}
+ else          {jt->fdepn =NFDEP;    jt->fcalln =NFCALL;   }
+ jt->dcs=d; jt->tostdout=t;
+}    /* user keyboard loop while suspended */
+
+static A jtdebug(J jt){A z=0;C e;DC c,d;I*v;
+ if(jt->dbssd){jt->dbssd->dcss=0; jt->dbssd=0;}
+ RZ(d=suspset(jt->sitop));
+ v=(I*)d->dci; 
+ if(0>*v)R 0;
+ e=jt->jerr; jt->jerr=0;
+ if(DBERRCAP==jt->db)errcap(); else susp();
+ switch(jt->dbsusact){
+  case SUSRUN:      
+   --*v; break;
+  case SUSRET:      
+   *v=-2; z=jt->dbresult; jt->dbresult=0; break;
+  case SUSJUMP: 
+   *v=lnumcw(jt->dbjump,d->dcc)-1; break;
+  case SUSCLEAR:
+   jt->jerr=e;    
+   c=jt->sitop; 
+   while(c){if(DCCALL==c->dctype)*(I*)(c->dci)=-2; c=c->dclnk;} 
+ }
+ if(jt->dbsusact!=SUSCLEAR)jt->dbsusact=SUSCONT;
+ d->dcsusp=0;
+ R z;
+}
+
+
+static A jtparseas(J jt,B as,A w){A*u,*v,y,z;I n;
+ n=AN(w); v=AAV(w);
+ GA(y,BOX,5+n,1,0); u=AAV(y);
+ *u++=mark; DO(n, *u++=*v++;); *u++=mark; *u++=mark; *u++=mark; *u++=mark;
+ z=parsea(y);  /* y is destroyed by parsea */
+ if(as&&z)ASSERT(NOUN&AT(z)&&all1(eq(one,z)),EVASSERT);
+ R z;
+}
+
+/* parsex: parse an explicit defn line              */
+/* w  - line to be parsed                           */
+/* lk - 1 iff locked function                       */
+/* ci - current row of control matrix               */
+/* c  - stack entry for dbunquote for this function */
+
+A jtparsex(J jt,A w,B lk,CW*ci,DC c){A z;B as,s;DC d,t=jt->sitop;
+ RZ(w);
+ JATTN;
+ as=ci->type==CASSERT;
+ if(lk)R parseas(as,w);
+ RZ(d=deba(DCPARSE,0L,w,0L));
+ if(0==c)z=parseas(as,w);   /* anonymous or not debug */
+ else{                      /* named and debug        */
+  if(s=dbstop(c,ci->source)){z=0; jsignal(EVSTOP);}
+  else                      {z=parseas(as,w);     }
+  if(!z&&(s||DBTRY!=jt->db)){t->dcj=d->dcj=jt->jerr; z=debug(); t->dcj=0;}
+ }
+ debz();
+ R z;
+}
+
+DF2(jtdbunquote){A t,z;B b=0,s;DC d;I i;V*sv;
+ sv=VAV(self); t=sv->f; 
+ RZ(d=deba(DCCALL,a,w,self));
+ if(CCOLON==sv->id&&t&&NOUN&AT(t)){  /* explicit */
+  ra(self); z=a?dfs2(a,w,self):dfs1(w,self); fa(self);
+ }else{                              /* tacit    */
+  i=0; d->dci=(I)&i;
+  while(0==i){
+   if(s=dbstop(d,0L)){z=0; jsignal(EVSTOP);}
+   else              {ra(self); z=a?dfs2(a,w,self):dfs1(w,self); fa(self);}
+   if(!z&&(s||DBTRY!=jt->db)){d->dcj=jt->jerr; z=debug(); if(self!=jt->sitop->dcf)self=jt->sitop->dcf;}
+   if(b){fa(a); fa(w);}
+   if(b=jt->dbalpha||jt->dbomega){a=jt->dbalpha; w=jt->dbomega; jt->dbalpha=jt->dbomega=0;}
+   ++i;
+  }
+ }
+ if(d->dcss)ssnext(d,d->dcss);
+ if(jt->dbss==SSSTEPINTOs)jt->dbss=0;
+ debz();
+ R z;
+}    /* function call, debug version */
+
+
+F1(jtdbc){I k;
+ RZ(w);
+ if(AN(w)){
+  RE(k=i0(w));
+  ASSERT(!k||k==DB1||k==DBERRCAP,EVDOMAIN);
+  ASSERT(!k||!jt->glock,EVDOMAIN);
+ }
+ jt->redefined=0;
+ if(AN(w)){jt->db=jt->dbuser=k; jt->fdepn=NFDEP/(k?2:1); jt->fcalln=NFCALL/(k?2:1);}
+ jt->dbsusact=SUSCLEAR; 
+ R mtm;
+}    /* 13!:0  clear stack; enable/disable suspension */
+
+F1(jtdbq){ASSERTMTV(w); R sc(jt->dbuser);}
+     /* 13!:17 debug flag */
+
+F1(jtdbrun ){ASSERTMTV(w); jt->dbsusact=SUSRUN;  R mtm;}
+     /* 13!:4  run again */
+
+F1(jtdbnext){ASSERTMTV(w); jt->dbsusact=SUSNEXT; R mtm;}
+     /* 13!:5  run next */
+
+F1(jtdbret ){RZ(w); jt->dbsusact=SUSRET; jt->dbresult=ra(w); R mtm;}
+     /* 13!:6  exit with result */
+
+F1(jtdbjump){RE(jt->dbjump=i0(w)); jt->dbsusact=SUSJUMP; R mtm;}
+     /* 13!:7  resume at line n (return result error if out of range) */
+
+static F2(jtdbrr){DC d;
+ RE(0);
+ d=jt->sitop; while(d&&DCCALL!=d->dctype)d=d->dclnk; 
+ ASSERT(d&&VERB&AT(d->dcf)&&!d->dcc,EVDOMAIN);  /* must be explicit verb */
+ jt->dbalpha=ra(a); jt->dbomega=ra(w); 
+ jt->dbsusact=SUSRUN;
+ R mtm;
+}
+
+F1(jtdbrr1 ){R dbrr(0L,w);}   /* 13!:9   re-run with arg(s) */
+F2(jtdbrr2 ){R dbrr(a, w);}
+
+F1(jtdbtrapq){ASSERTMTV(w); R jt->dbtrap?jt->dbtrap:mtv;}   
+     /* 13!:14 query trap */
+
+F1(jtdbtraps){RZ(w=vs(w)); fa(jt->dbtrap); jt->dbtrap=AN(w)?ra(w):0L; R mtm;}
+     /* 13!:15 set trap */