Mercurial > hg > jgplsrc
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; +}