diff io.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/io.c
@@ -0,0 +1,409 @@
+/* Copyright 1990-2011, Jsoftware Inc.  All rights reserved. */
+/* License in license.txt.                                   */
+/*                                                                         */
+/* Input/Output                                                            */
+
+#ifdef _WIN32
+#include <windows.h>
+#include <winbase.h>
+#else
+#include <stdlib.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <sys/mman.h>
+#define _stdcall
+#endif
+
+#include "j.h"
+#include "d.h"
+
+void jtwri(J jt,I type,C*p,I m,C*s){C buf[1024],*t=jt->outseq,*v=buf;I c,d,e,n;
+ if(jt->tostdout){
+  c=strlen(p);            /* prompt      */
+  e=strlen(t);            /* end-of-line */
+  n=sizeof(buf)-(c+e+1);  /* main text   */
+  d=m>n?n-3:m;
+  memcpy(v,p,c); v+=c;
+  memcpy(v,s,d); v+=d; if(m>n){memcpy(v,"...",3L); v+=3;}
+  memcpy(v,t,e); v+=e; 
+  *v=0;
+  jsto(jt,type,buf);
+}}
+
+static void jtwrf(J jt,I n,C*v,F f){C*u,*x;I j=0,m;
+ while(n>j){
+  u=j+v; 
+  m=(x=memchr(u,CLF,n-j))?1+x-u:n-j; 
+  fwrite(u,sizeof(C),m,f);
+  j+=m;
+}}
+
+A jtinpl(J jt,B b,I n,C*s){C c;I k=0;
+ if(n&&(c=*(s+n-1),CLF==c||CCR==c))--n;
+ ASSERT(!*jt->adbreak,EVINPRUPT);
+ if(!b){ /* 1==b means literal input */
+  if(n&&COFF==*(s+n-1))joff(zero);
+  c=jt->bx[9]; if(c<0)DO(n, if(' '!=s[i]&&c!=s[i]){k=i; break;});
+ }
+ R str(n-k,s+k);
+}
+
+static I advl(I j,I n,C*s){B b;C c,*v;
+ v=j+s; 
+ DO(n-j, c=*v++; b=c==CCR; if(b||c==CLF)R j+1+i+(b&&CLF==*v););
+ R n;
+}    /* advance one line on CR, CRLF, or LF */
+
+void breakclose(J jt);
+
+static C* nfeinput(J jt,C* s){A y;
+ jt->breakignore=1;
+ y=exec1(cstr(s));
+ jt->breakignore=0;
+ if(!y){breakclose(jt);exit(2);} /* J input verb failed */
+ jtwri(jt,MTYOLOG,"",strlen(CAV(y)),CAV(y));
+ return CAV(y); /* don't combine with previous line! CAV runs (x) 2 times! */
+}
+
+A jtjgets(J jt,C*p){A y;B b;C*v;I j,k,m,n;UC*s;
+ *jt->adbreak=0;
+ if(b=1==*p)p=""; /* 1 means literal input */
+ if(jt->dcs){
+  ++jt->dcs->dcn; j=jt->dcs->dci; 
+  y=jt->dcs->dcy; n=AN(y); s=UAV(y);
+  RZ(j<n);
+  jt->dcs->dcj=k=j;
+  jt->dcs->dci=j=advl(j,n,s);
+  m=j-k; if(m&&32>s[k+m-1])--m; if(m&&32>s[k+m-1])--m;
+  jtwri(jt,MTYOLOG,p,m,k+s);
+  R inpl(b,m,k+s);
+ }
+ /* J calls for input in 3 cases:
+    debug suspension for normal input
+    n : 0 input lines up to terminating )
+    1!:1[1 read from keyboard */
+ showerr();
+ if(jt->nfe)
+  v=nfeinput(jt,*p?"input_jfe_'      '":"input_jfe_''");
+ else{
+  ASSERT(jt->sminput,EVBREAK); 
+  v=((inputtype)(jt->sminput))(jt,p);
+ }
+ R inpl(b,(I)strlen(v),v);
+}
+
+extern C breakdata;
+
+#if SYS&SYS_UNIX
+void breakclose(J jt)
+{
+ if(jt->adbreak==&breakdata) return;
+ munmap(jt->adbreak,1);
+ jt->adbreak=&breakdata;
+ close(jt->breakfh);
+ jt->breakfh=0;
+ unlink(jt->breakfn);
+ *jt->breakfn=0;
+}
+#else
+void breakclose(J jt)
+{
+ if(jt->adbreak==&breakdata) return;
+ UnmapViewOfFile(jt->adbreak);
+ jt->adbreak=&breakdata;
+ CloseHandle(jt->breakmh);
+ jt->breakmh=0;
+ CloseHandle(jt->breakfh);
+ jt->breakfh=0;
+#if SY_WINCE
+ DeleteFile(tounibuf(jt->breakfn));
+#else
+ DeleteFile(jt->breakfn);
+#endif
+ *jt->breakfn=0;
+}
+#endif
+
+F1(jtjoff){I x;
+ RZ(w);
+ x=i0(w);
+ breakclose(jt);
+ if(jt->sesm)jsto(jt, MTYOEXIT,(C*)x);
+ exit((int)x);
+ R 0;
+}
+
+#if (SYS & SYS_SESM)
+
+I jdo(J jt, C* lp){I e,old;A x;
+ jt->jerr=0; jt->etxn=0; /* clear old errors */
+ old=jt->tbase+jt->ttop;
+ *jt->adbreak=0;
+ x=inpl(0,(I)strlen(lp),lp);
+ while(jt->iepdo&&jt->iep){jt->iepdo=0; immex(jt->iep); jt->jerr=0; tpop(old);}
+ if(!jt->jerr)immex(x);
+ e=jt->jerr;
+ jt->jerr=0;
+ if(e&&DBERRCAP==jt->db&&jt->dbtrap){
+  jt->db=0;
+  immex(jt->dbtrap);
+  jt->jerr=0;
+ }
+ while(jt->iepdo&&jt->iep){jt->iepdo=0; immex(jt->iep); jt->jerr=0; tpop(old);}
+ showerr();
+ spfree();
+ tpop(old);
+ R e;
+}
+
+#define SZINT             ((I)sizeof(int))
+
+DF1(jtwd){A z=0;C*p=0;D*pd;I e,*pi,t;V*sv;
+ F1RANK(1,jtwd,self);
+ RZ(w);
+ ASSERT(2>AR(w),EVRANK);
+ sv=VAV(self);
+ t=i0(sv->g);
+ if(t>=2000 && t<3000 && AN(w) && LIT!=AT(w) && C2T!=AT(w) && INT!=AT(w))
+ {
+	 switch(AT(w))
+	 {
+	 case B01:
+		RZ(w=vi(w));break;
+	 case FL:
+		pd=DAV(w);
+		GA(w,INT,AN(w),AR(w),0);
+		pi=AV(w);
+		DO(AN(w),*pi++=(I)(jfloor(0.5+*pd++));); 
+		break;
+	 default:
+		 ASSERT(0,EVDOMAIN);
+	 }
+ }
+ // t is 11!:t and w is wd argument
+ e=jt->smdowd ? ((dowdtype)(jt->smdowd))(jt, (int)t, w, &z) : EVDOMAIN;
+ if(!e) R mtm;   // e==0 is MTM
+ if(e==-1) R z;  // e---1 is zp
+ ASSERT(e<=0,e); // e>=0 is EVDOMAIN etc
+ RZ(z=df1(z,cut(ds(CBOX),num[-2]))); // e==-2 is lit pairs
+ R reshape(v2(AN(z)/2,2L),z);
+}
+
+C* getlocale(J jt){A y=locname(mtv); y=*AAV(y); R CAV(y);}
+
+static char breaknone=0;
+
+B jtsesminit(J jt){jt->adbreak=&breakdata; R 1;}
+#endif
+
+int _stdcall JDo(J jt, char* lp){int r;
+ r=(int)jdo(jt,lp);
+ while(jt->nfe)
+  r=(int)jdo(jt,nfeinput(jt,"input_jfe_'   '"));
+ R r;
+} 
+
+/* socket protocol CMDGET name */
+A _stdcall JGetA(J jt, I n, C* name){A x;
+ jt->jerr=0;
+ RZ(x=symbrdlock(nfs(n,name)));
+ ASSERT(!(FUNC&AT(x)),EVDOMAIN);
+ R binrep1(x);
+}
+
+/* socket protocol CMDSET */
+I _stdcall JSetA(J jt,I n,C* name,I dlen,C* d){I old;
+ jt->jerr=0;
+ if(!vnm(n,name)) R EVILNAME;
+ old=jt->tbase+jt->ttop;
+ symbis(nfs(n,name),jtunbin(jt,str(dlen,d)),jt->global);
+ tpop(old);
+ R jt->jerr;
+}
+
+/* set jclient callbacks */
+void _stdcall JSM(J jt, void* callbacks[])
+{
+	jt->smoutput = (outputtype)callbacks[0];
+	jt->smdowd = (dowdtype)callbacks[1];
+	jt->sminput = (inputtype)callbacks[2];
+	jt->sm = (I)callbacks[4];
+}
+
+C* _stdcall JGetLocale(J jt){return getlocale(jt);}
+
+A _stdcall Jga(J jt, I t, I n, I r, I*s){
+ return ga(t, n, r, s);
+}
+
+void oleoutput(J jt, I n, char* s);	/* SY_WIN32 only */
+
+/* jsto - display output in output window */
+void jsto(J jt,I type,C*s){C e;I ex;
+ if(jt->nfe)
+ {
+  C q[]="0 output_jfe_ (15!:18)0";
+  q[0]+=(C)type;
+  jt->mtyostr=s;
+  e=jt->jerr; ex=jt->etxn;
+  jt->jerr=0; jt->etxn=0;
+  jt->breakignore=1;exec1(cstr(q));jt->breakignore=0;
+  jt->jerr=e; jt->etxn=ex; 
+ }else{
+  if(jt->smoutput) ((outputtype)(jt->smoutput))(jt,(int)type,s);
+#if SY_WIN32 && !SY_WINCE
+  if(type & MTYOFM) oleoutput(jt,strlen(s),s);	/* save output for ole */
+#endif
+}}
+
+#if SYS&SYS_UNIX
+
+J JInit(void){
+  J jt;
+  /* jtglobinit must be done once when dll is first loaded
+     Windows does it in dll load routine  - thread safe
+     Unix does it here once, but this is not thread safe */
+  
+  static J g_jt=0;
+  if(!g_jt)
+  {
+    g_jt=malloc(sizeof(JST));
+    if(!g_jt) R 0;
+    memset(g_jt,0,sizeof(JST));
+    if(!jtglobinit(g_jt)){free(g_jt);g_jt=0; R 0;}
+  }
+  RZ(jt=malloc(sizeof(JST)));
+  memset(jt,0,sizeof(JST));
+  if(!jtjinit2(jt,0,0)){free(jt); R 0;};
+  R jt;
+}
+
+int JFree(J jt){return 0;}
+#endif
+
+F1(jtbreakfnq){
+ ASSERTMTV(w);
+ R cstr(jt->breakfn);
+}
+
+F1(jtbreakfns){A z;I *fh,*mh; void* ad;
+ ASSERT(1>=AR(w),EVRANK);
+ ASSERT(!AN(w)||AT(w)&LIT,EVDOMAIN);
+ ASSERT(AN(w)<NPATH,EVDOMAIN);
+ if(!strcmp(jt->breakfn,CAV(w))) R mtm;
+ breakclose(jt);
+#if SYS&SYS_UNIX
+ fh=(I*)(I)open(CAV(w),O_RDWR);
+ ASSERT(-1!=(I)fh,EVDOMAIN);
+ ad=mmap(0,1,PROT_READ|PROT_WRITE,MAP_SHARED,(I)fh,0);
+ if(0==ad){close(fh); ASSERT(0,EVDOMAIN);}
+#else
+ RZ(z=toutf16x(w));
+ fh=CreateFileW(USAV(z),GENERIC_READ|GENERIC_WRITE,FILE_SHARE_READ|FILE_SHARE_WRITE,0,OPEN_EXISTING,0,0);
+ ASSERT(INVALID_HANDLE_VALUE!=fh,EVDOMAIN);
+ mh=CreateFileMapping(fh,0,PAGE_READWRITE,0,1,0);
+ if(0==mh){CloseHandle(fh); ASSERT(0,EVDOMAIN);}
+ ad=MapViewOfFile(mh,FILE_MAP_WRITE,0,0,0);
+ if(0==ad){CloseHandle(mh); CloseHandle(fh); ASSERT(0,EVDOMAIN);}
+#endif
+ strcpy(jt->breakfn,CAV(w));
+ jt->breakfh=fh;
+ jt->breakmh=mh;
+ jt->adbreak=ad;
+ R mtm;
+}
+
+int valid(C* psrc, C* psnk)
+{
+	while(*psrc == ' ') ++psrc;
+	if(!isalpha(*psrc)) return EVILNAME;
+	while(isalnum(*psrc) || *psrc=='_') *psnk++ = *psrc++;
+	while(*psrc == ' ') ++psrc;
+	if(*psrc) return EVILNAME;
+	*psnk = 0;
+	return 0;		
+}
+
+int _stdcall JGetM(J jt, C* name, I* jtype, I* jrank, I* jshape, I* jdata)
+{
+	A a; char gn[256];
+	if(strlen(name) >= sizeof(gn)) return EVILNAME;
+	if(valid(name, gn)) return EVILNAME;
+	RZ(a=symbrdlock(nfs(strlen(gn),gn)));
+    if(FUNC&AT(a))R EVDOMAIN;
+	*jtype = AT(a);
+	*jrank = AR(a);
+	*jshape = (I)AS(a);
+	*jdata = (I)AV(a);
+	return 0;
+}
+
+static int setterm(J jt, C* name, I* jtype, I* jrank, I* jshape, I* jdata)
+{
+	A a;
+	I k=1,i,n;
+	char gn[256];
+
+	switch(*jtype)
+	{
+	case LIT:
+	case B01:
+		n = sizeof(char);
+		break;
+
+	case INT:
+		n = sizeof(I);
+		break;
+		
+	case FL:
+		n = sizeof(double);
+		break;
+		
+	case CMPX:
+		n = 2 * sizeof(double);
+		break;
+		
+	default:
+		return EVDOMAIN;	
+	}
+
+	// validate name
+	if(strlen(name) >= sizeof(gn)) return EVILNAME;
+	if(valid(name, gn)) return EVILNAME; 
+	for(i=0; i<*jrank; ++i)	k *= ((I*)(*jshape))[i];
+	a = ga(*jtype, k, *jrank, (I*)*jshape);
+	if(!a) return EVWSFULL;
+	memcpy(AV(a), (void*)*jdata, n*k);
+	jset(gn, a);
+	return jt->jerr;
+}
+
+int _stdcall JSetM(J jt, C* name, I* jtype, I* jrank, I* jshape, I* jdata)
+{
+	int er;
+
+	PROLOG;
+	er = setterm(jt, name, jtype, jrank, jshape, jdata);
+	tpop(_ttop);
+	return er;
+}
+
+#define EDCBUSY	-1
+#define EDCEXE	-2
+
+C* esub(J jt, I ec)
+{
+	if(!ec) return "";
+	if(ec == EDCBUSY) return "busy with previous input";
+	if(ec == EDCEXE) return "not supported in EXE server";
+	if(ec > NEVM || ec < 0) return "unknown error";
+	return (C*)AV(*(ec+AAV(jt->evm)));
+}
+
+int _stdcall JErrorTextM(J jt, I ec, I* p)
+{
+	*p = (I)esub(jt, ec);
+	return 0;
+}