vxwcom.c
Go to the documentation of this file.
00001 #include "eus.h"
00002 #include "vxw_proto.h"
00003 
00004 static void putlong(s,i)
00005 pointer s;
00006 long i;
00007 { register unsigned char *ip= (unsigned char *)&i;
00008   writech(s,*ip++); writech(s,*ip++); writech(s,*ip++); writech(s,*ip++);}
00009 
00010 static unsigned long getlong(con)
00011 pointer con;
00012 { register unsigned int ival=0;
00013   ival=readch(con);
00014   ival=(ival<<8)+readch(con);
00015   ival=(ival<<8)+readch(con);
00016   ival=(ival<<8)+readch(con);
00017 /*  printf("result=%d\n",ival); */
00018   return(ival);}
00019 
00020 
00021 static putlength(s,len)
00022 pointer s;
00023 unsigned int len;
00024 { if (len<128) writech(s,len);
00025   else if (len<16384) {
00026     writech(s, 0x80 | (len >> 8));
00027     writech(s, len & 0xff);} 
00028   else error("argument to large");}
00029 
00030 static int putarg(s,p)
00031 pointer s,p;
00032 { numunion nu;
00033   register int i,len, elmt;
00034   register unsigned char *bp;
00035 
00036   if (isint(p)) { 
00037     writech(s, A_LONG); putlong(s,intval(p));}
00038   else if (isflt(p)) {
00039     writech(s, A_FLOAT);   nu.fval=fltval(p);   putlong(s, nu.ival);}
00040   else {
00041     if (isarray(p)) p=p->c.ary.entity;
00042     if (isvector(p)) {
00043       len=vecsize(p); elmt=elmtypeof(p);
00044       writech(s, A_VECTOR);
00045       bp= p->c.str.chars;
00046       switch(elmt) {
00047         case ELM_BIT: len=(len+7)/8; break;
00048         case ELM_FOREIGN: bp=(unsigned char *)p->c.ivec.iv[0]; break;
00049         case ELM_CHAR: case ELM_BYTE: break;
00050         case ELM_POINTER: error("binary vector expected"); break;
00051         case ELM_FLOAT: case ELM_INT: len<<=2; break;}
00052       putlength(s,len);
00053       writestr(s,bp,len);   }
00054     else error("invalid argument for VXW"); } }
00055 
00056 pointer CALL_VXW(ctx,n,argv)
00057 context *ctx;
00058 int n;
00059 pointer argv[];
00060 { int i=0, j, argc=3, len, stat;
00061   pointer con=argv[0], entry=argv[1], result=argv[2];
00062   pointer in,out;
00063   pointer p,result_vec;
00064   numunion nu;
00065     
00066   if (!isiostream(con)) error(E_STREAM); 
00067   in=con->c.iostream.in; out=con->c.iostream.out;
00068 
00069   if (issymbol(entry)) entry=Getstring(entry);
00070   if (isstring(entry)) {
00071     writech(out, A_SYMBOL);
00072     writech(out, vecsize(entry));
00073     writestr(out, entry->c.str.chars, vecsize(entry));}
00074   else if (isint(entry)) {
00075     writech(out, A_LONG);
00076     putlong(out, intval(entry));}
00077 
00078   while (argc<n) {
00079     if (debug) { prinx(ctx,argv[argc],STDOUT); terpri(STDOUT);}
00080     putarg(out, argv[argc++]);}
00081 
00082   writech(out, A_END);
00083 
00084   if (result==K_INTEGER) writech(out, A_LONG);
00085   else if (result==K_FLOAT) writech(out, A_FLOAT);
00086   else {
00087     if (isarray(result))  result=result->c.ary.entity;
00088     if (isvector(result)) {
00089       writech(out, A_VECTOR);
00090       len=vecsize(result);
00091       if ((elmtypeof(result) == ELM_INT) || (elmtypeof(result) == ELM_FLOAT))
00092         len=len*sizeof(long);
00093       putlength(out,len);}
00094     else error(E_NOVECTOR);}
00095   flushstream(out);
00096 
00097   /*read protocol status*/
00098   stat=readch(in);
00099   if (stat!=NULL) return(cons(ctx,makeint(stat),NIL));
00100 
00101   /*read result*/
00102   if (result==K_INTEGER) 
00103     return(makeint(getlong(in)));
00104   else if (result==K_FLOAT) {
00105     nu.ival=getlong(in);
00106     return(makeflt(nu.fval));}
00107   else if (result==K_STRING) { }
00108   else { /*vector*/
00109     for (i=0; i<len; i++) result->c.str.chars[i]=readch(in);
00110     return(argv[2]);}
00111   }
00112 
00113 vxwcom(ctx,n,argv)
00114 context *ctx;
00115 int n;
00116 pointer argv[];
00117 { pointer mod=argv[0];
00118   defun(ctx,"VXW",mod,CALL_VXW);}
00119 


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Mar 9 2017 04:57:50