add #g read macro for reading binary encoding float/integer array

Author: YoheiKakiuchi

lisp/c/eus_proto.h

@@ -334,6 +334,7 @@ extern pointer makeclass(context */*ctx*/, pointer /*name*/, pointer /*superobj*
 extern pointer makeobject(pointer /*class*/);
 extern pointer makevector(pointer /*vclass*/, int /*size*/);
 extern pointer makefvector(int /*s*/);
+extern pointer makeivector(int /*s*/);
 extern pointer defvector(context */*ctx*/, char */*name*/, pointer /*super*/, int /*elm*/, int /*size*/);
 extern pointer makematrix(context */*ctx*/, int /*row*/, int /*column*/);
 extern pointer makemodule(context */*ctx*/, int /*size*/);

lisp/c/makes.c

@@ -443,6 +443,14 @@ register int s;
   v->c.vec.size=makeint(s);
   return(v);}
 
+pointer makeivector(s)
+register int s;
+{ register pointer v;
+  register bpointer b;
+  v=alloc(s+1,ELM_INT, intvectorcp.cix,s+1);
+  v->c.vec.size=makeint(s);
+  return(v);}
+
 pointer defvector(ctx,name,super,elm,size)	/*define vector class*/
 register context *ctx;
 char *name;

lisp/c/reader.c

@@ -450,6 +450,173 @@ register pointer s;	/*input stream*/
     }
   vpop();
   return(result); }
+
+static pointer readbinaryarray(context *ctx, pointer s, pointer subchr, pointer val)
+{
+  register pointer elm;
+  numunion nu;
+  int i, ch;
+  unsigned long size;
+  int rank;
+  int dim[ARRAYRANKLIMIT];
+  unsigned char *buffer;
+  pointer entity;
+  pointer ret = NIL;
+
+  for (i = 0; i < ARRAYRANKLIMIT; i++) dim[i] = 0;
+  ch = nextch(ctx,s);
+  if (ch != '(') error(E_USER, (pointer)"invalid binary array form [(]");
+
+  rank = 0;
+  size = 1;
+  elm = read1(ctx,s); // read size list
+  while(elm != NIL) {
+    if( isint(elm->c.cons.car) ) {
+      dim[rank] = intval(elm->c.cons.car);
+      size *= dim[rank];
+      rank++;
+    }
+    elm = elm->c.cons.cdr;
+  }
+  elm = read1(ctx,s); // read elemtype
+
+  if (elm == K_FLOAT || elm == K_FLOAT32) {
+    entity = makefvector(size);
+#ifdef x86_64
+    buffer = malloc(sizeof(float) * size);
+#else
+    buffer = (unsigned char *) &(entity->c.fvec.fv[0]);
+#endif
+    size *= 4;
+  } else if (elm == K_DOUBLE) {
+    entity = makefvector(size);
+#ifdef x86_64
+    buffer = (unsigned char *) &(entity->c.fvec.fv[0]);
+#else
+    buffer = malloc(sizeof(double) * size);
+#endif
+    size *= 8;
+  } else if (elm == K_SHORT) {
+    entity = makeivector(size);
+    buffer = malloc(sizeof(short) * size);
+    size *= 2;
+  } else if (elm == K_INTEGER) {
+    entity = makeivector(size);
+#ifdef x86_64
+    buffer = malloc(sizeof(int) * size);
+#else
+    buffer = (unsigned char *) &(entity->c.ivec.iv[0]);
+#endif
+    size *= 4;
+  } else if (elm == K_LONG) {
+    entity = makeivector(size);
+#ifdef x86_64
+    buffer = (unsigned char *) &(entity->c.ivec.iv[0]);
+#else
+    buffer = malloc(sizeof(long long) * size);
+#endif
+    size *= 8;
+  } else {
+    error(E_USER, (pointer)"invalid binary element type");
+  }
+  vpush(entity);
+  if(rank == 1) {
+    // just return vector
+    ret = entity;
+    vpop();
+    vpush(ret);
+  } else {
+    // make array
+    ret = alloc(vecsize(speval(ARRAY)->c.cls.vars), ELM_FIXED,
+                intval(speval(ARRAY)->c.cls.cix),
+                vecsize(speval(ARRAY)->c.cls.vars));
+    ret->c.ary.entity = entity;
+    vpop();
+    vpush(ret);
+    ret->c.ary.fillpointer = NIL;
+    ret->c.ary.rank = makeint(rank);
+    ret->c.ary.offset = makeint(0);
+    for (i = 0; i < ARRAYRANKLIMIT; i++) ret->c.ary.dim[i] = makeint(dim[i]);
+    ret->c.ary.plist = NIL;
+  }
+
+  ch = nextch(ctx,s);
+  if (ch != '"') {
+    error(E_USER, (pointer)"invalid binary array form [\"]");
+  }
+  i = 0;
+  while((ch = readch(s)) != EOF) {
+    buffer[i++] = ch;
+    if(i >= size) break;
+  }
+  if(i != size) {
+    error(E_USER, (pointer)"invalid size of string");
+  }
+  if (elm == K_FLOAT || elm == K_FLOAT32) {
+#ifdef x86_64
+    float *src = (float *)buffer;
+    eusfloat_t *dst = (eusfloat_t *)&(entity->c.fvec.fv[0]);
+    for (i = 0; i < size/4; i++) {
+      *dst++ = *src++;
+    }
+    free(buffer);
+#else
+    // do nothing
+#endif
+  } else if (elm == K_DOUBLE) {
+#ifdef x86_64
+    // do nothing
+#else
+    double *src = (double *)buffer;
+    eusfloat_t *dst = (eusfloat_t *)&(entity->c.fvec.fv[0]);
+    for (i = 0; i < size/8; i++) {
+      *dst++ = *src++;
+    }
+    free(buffer);
+#endif
+  } else if (elm == K_SHORT) {
+    short *src = (short *)buffer;
+    eusinteger_t *dst = (eusinteger_t *)&(entity->c.ivec.iv[0]);
+    for (i = 0; i < size/2; i++) {
+      *dst++ = *src++;
+    }
+    free(buffer);
+  } else if (elm == K_INTEGER) {
+#ifdef x86_64
+    int *src = (int *)buffer;
+    eusinteger_t *dst = (eusinteger_t *)&(entity->c.ivec.iv[0]);
+    for (i = 0; i < size/4; i++) {
+      *dst++ = *src++;
+    }
+    free(buffer);
+#else
+    // do nothing
+#endif
+  } else if (elm == K_LONG) {
+#ifdef x86_64
+    // do nothing
+#else
+    long long *src = (long long *)buffer;
+    eusinteger_t *dst = (eusinteger_t *)&(entity->c.ivec.iv[0]);
+    for (i = 0; i < size/8; i++) {
+      *dst++ = *src++;
+    }
+    free(buffer);
+#endif
+  }
+
+  ch = readch(s);
+  if (ch != '"') {
+    error(E_USER, (pointer)"invalid binary array form / end of [\"]");
+  }
+  ch=nextch(ctx,s);
+  while (ch!=')' && ch!=EOF) {
+    ch=nextch(ctx,s);
+  }
+
+  return vpop();
+}
+
 
 /****************************************************************/
 /* read dispatch macro expression
@@ -1058,6 +1225,7 @@ register context *ctx;
   sharpmacro['I']=makeint((eusinteger_t)readivector);
   sharpmacro['J']=makeint((eusinteger_t)readobject);
   sharpmacro['V']=makeint((eusinteger_t)readobject);
+  sharpmacro['G']=makeint((eusinteger_t)readbinaryarray);
 
   /* make default readtable */
   rdtable=(pointer)makereadtable(ctx);