vectorarray.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* EUSLISP vector and array functions
00003 /*
00004 /*      1987-Sep-24
00005 /*      1996-Jan  Bignum return
00006 /*      Copyright Toshihiro MATSUI,Electrotechinical Laboratory,1988.
00007 /****************************************************************/
00008 static char *rcsid="@(#)$Id$";
00009 
00010 #include "../c/eus.h"
00011 
00012 pointer MKVECTOR(ctx,n,argv)
00013 register context *ctx;
00014 register int n;
00015 register pointer argv[];
00016 { register pointer v;
00017   register int i;
00018   v=makevector(C_VECTOR,n);
00019   for (i=0; i<n; i++) v->c.vec.v[i]=argv[i];
00020 #ifdef SAFETY
00021   take_care(v);
00022 #endif
00023   return(v);}
00024 
00025 pointer MKINTVECTOR(ctx,n,argv)
00026 register context *ctx;
00027 register int n;
00028 register pointer argv[];
00029 { register pointer v;
00030   register int i;
00031   v=makevector(C_INTVECTOR,n);
00032   for (i=0; i<n; i++) v->c.ivec.iv[i]=bigintval(argv[i]);
00033 #ifdef SAFETY
00034   take_care(v);
00035 #endif
00036   return(v);}
00037 
00038 pointer vref(a,n)
00039         /*simple but not general vector (one dimensional) reference*/
00040 register pointer a;
00041 register int n;
00042 { register eusinteger_t x;
00043   numunion nu;
00044   if (n<0 || vecsize(a)<=n ) error(E_ARRAYINDEX);
00045   switch(elmtypeof(a)) {
00046     case ELM_FIXED: error(E_NOVECTOR);
00047     case ELM_CHAR:
00048     case ELM_BYTE:  return(makeint(a->c.str.chars[n]));
00049     case ELM_FLOAT: return(makeflt(a->c.fvec.fv[n]));
00050     case ELM_INT:  x=a->c.ivec.iv[n];  return(mkbigint(x));
00051 #if (WORD_SIZE == 64)
00052     /*
00053                         hanai: 32 was hard coded.
00054                         This size must be equal to that of eusinteger_t.
00055                         Constant 1 must be written as 1L.
00056                         Otherwise 1 << 32 becomes 1, meaning 0x00000001.
00057                         */
00058     case ELM_BIT:  x=1L<<(n % 64); 
00059                     if (a->c.ivec.iv[n/64] & x) return(makeint(1));
00060                     else return(makeint(0));
00061 #else
00062     case ELM_BIT:  x=1<<(n % 32); 
00063                     if (a->c.ivec.iv[n/32] & x) return(makeint(1));
00064                     else return(makeint(0));
00065 #endif
00066     case ELM_FOREIGN: return(makeint(((byte *)(a->c.ivec.iv[0]))[n]));
00067     case ELM_POINTER:
00068     default: return(a->c.vec.v[n]);}}
00069 
00070 pointer SVREF(ctx,n,argv)
00071 register context *ctx;
00072 int n;
00073 register pointer argv[];
00074 { register pointer a=argv[0];
00075   ckarg(2);
00076   n=ckintval(argv[1]);
00077   if (n<0) error(E_ARRAYINDEX);
00078   if (isvector(a)) {
00079     if (elmtypeof(a)==ELM_POINTER) {
00080       if (vecsize(a)<=n) error(E_ARRAYINDEX);
00081       return(a->c.vec.v[n]);}
00082     else error(E_NOVECTOR);}
00083   else if (isnum(a)) error(E_NOVECTOR);
00084   else if (objsize(a)<=n) error(E_ARRAYINDEX);
00085   a=a->c.obj.iv[n];
00086   if (a==UNBOUND) return(QUNBOUND);
00087   return(a);}
00088  
00089 pointer vset(a,n,newval)
00090 register pointer a;
00091 register int n;
00092 pointer newval;
00093 { register int x,y;
00094   numunion nu;
00095   extern eusinteger_t coerceintval(pointer);
00096 
00097   if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
00098   switch(elmtypeof(a)) {
00099 #if (WORD_SIZE == 64)
00100         case ELM_BIT:
00101                 x=1L<<(n % 64);
00102                 y=(ckintval(newval) & 1L)<<(n % 64);
00103                 a->c.ivec.iv[n/64]=(a->c.ivec.iv[n/64] & (~ x)) | y;
00104                 return(newval);
00105 #else
00106         case ELM_BIT:
00107                 x=1<<(n % 32);
00108                 y=(ckintval(newval) & 1)<<(n % 32);
00109                 a->c.ivec.iv[n/32]=a->c.ivec.iv[n/32] & (~ x) | y;
00110                 return(newval);
00111 #endif
00112         case ELM_BYTE: case ELM_CHAR:
00113                 a->c.str.chars[n]=ckintval(newval); return(newval);
00114         case ELM_INT:
00115                 a->c.ivec.iv[n]=coerceintval(newval);
00116                 return(newval);
00117         case ELM_FLOAT:
00118                 a->c.fvec.fv[n]=ckfltval(newval);  return(newval);
00119         case ELM_FOREIGN:
00120                 ((byte *)(a->c.ivec.iv[0]))[n]=ckintval(newval);
00121                 return(newval);
00122         case ELM_POINTER:
00123         pointer_update(a->c.vec.v[n],newval);
00124                 return(newval);} }
00125 
00126 pointer SVSET(ctx,n,argv)
00127 register context *ctx;
00128 register int n;
00129 register pointer argv[];
00130 { register pointer a=argv[0],newval=argv[2];
00131   ckarg(3);
00132   n=ckintval(argv[1]);
00133   if (n<0) error(E_ARRAYINDEX);
00134   if (isvector(a)) {
00135     if (elmtypeof(a)==ELM_POINTER) {
00136       if (vecsize(a)<=n) error(E_ARRAYINDEX);
00137       pointer_update(a->c.vec.v[n],newval);
00138       return(newval);}
00139     else error(E_NOVECTOR);}
00140   else if (isnum(a)) error(E_NOVECTOR);
00141   else if (objsize(a)<=n) error(E_ARRAYINDEX);
00142   pointer_update(a->c.obj.iv[n],newval);
00143   return(newval);}
00144 
00145 
00146 /****************************************************************/
00147 /* A R R A Y
00148 /****************************************************************/
00149 
00150 int arrayindex(a,n,indices)
00151 register pointer a;
00152 register int n;
00153 register pointer *indices;
00154 { register int index=0,i1,i2;
00155   register pointer *dim=a->c.ary.dim,p1,p2;
00156 
00157   if (n!=intval(a->c.ary.rank)) error(E_ARRAYDIMENSION);
00158   while (n-- >0) {
00159     p1= *indices++;
00160     p2= *dim++;
00161     i1= ckintval(p1);
00162     i2= intval(p2);
00163     if (i1>=i2) error(E_ARRAYINDEX);
00164     index=index*i2 + i1; }
00165   return(index+intval(a->c.ary.offset));}
00166     
00167 pointer AREF(ctx,n,argv)
00168 register context *ctx;
00169 register int n;
00170 register pointer argv[];
00171 { register pointer a=argv[0];
00172   register int i;
00173   if (n<2) error(E_MISMATCHARG);
00174   i=ckintval(argv[1]);
00175 #if 0
00176   printf("aref %d\n", i);
00177 #endif
00178   if (isvector(a)){ return(vref(a,i));}
00179 #if 0 
00180   printf("aref ok\n");
00181 #endif 
00182   if (!isarray(a)) error(E_NOARRAY);
00183   else return((pointer)vref(a->c.ary.entity,arrayindex(a,n-1,&argv[1])));}
00184 
00185 pointer ASET(ctx,n,argv)
00186 register context *ctx;
00187 register int n;
00188 register pointer argv[];
00189 { register pointer a=argv[0];
00190   register pointer val=argv[n-1];
00191 
00192   if (n<3) error(E_MISMATCHARG);
00193   if (isvector(a))  return(vset(a,ckintval(argv[1]),val));
00194   if (!isarray(a)) error(E_NOARRAY);
00195   return(vset(a->c.ary.entity,arrayindex(a,n-2,&argv[1]),val));}
00196 
00197 pointer ARRAYP(ctx,n,argv)
00198 register context *ctx;
00199 int n;
00200 register pointer argv[];
00201 { ckarg(1);
00202   if (isnum(argv[0])) return(NIL);
00203   else if (isarray(argv[0])) return(T);
00204   else if (isvector(argv[0])) return(T);
00205   else return(NIL);}
00206 
00207 pointer VECTORPOP(ctx,n,argv)
00208 register context *ctx;
00209 int n;
00210 pointer argv[];
00211 { register pointer a=argv[0],r;
00212   register int fp;
00213 
00214   ckarg(1);
00215   printf("vectorpop\n");
00216   if (!isarray(a)) error(E_NOARRAY);
00217   if (intval(a->c.ary.rank)!=1) error(E_ARRAYDIMENSION);
00218   fp=intval(a->c.ary.fillpointer);
00219   if (fp==0) error(E_ARRAYINDEX);
00220   fp--;
00221   r=(pointer)vref(a->c.ary.entity,fp+intval(a->c.ary.offset));
00222   a->c.ary.fillpointer=makeint(fp);
00223   return(r);}
00224 
00225 pointer VECTORPUSH(ctx,n,argv)
00226 register context *ctx;
00227 int n;
00228 pointer argv[];
00229 { register pointer a=argv[1];
00230   register int fp;
00231 
00232   ckarg(2);
00233   if (!isarray(a)) error(E_NOARRAY);
00234   if (intval(a->c.ary.rank)!=1) error(E_ARRAYDIMENSION);
00235   fp=ckintval(a->c.ary.fillpointer);
00236   vset(a->c.ary.entity,fp+intval(a->c.ary.offset),argv[0]);
00237   a->c.ary.fillpointer=makeint(fp+1);
00238   return(argv[0]);}
00239 
00240 pointer VECTOREXPUSH(ctx,n,argv)        /*vector-push-extend*/
00241 register context *ctx;
00242 int n;
00243 pointer argv[];
00244 { register pointer a=argv[1],entity,new;
00245   register int i,fp,vsize;
00246 
00247   ckarg(2);
00248   if (!isarray(a)) error(E_NOARRAY);
00249   if (intval(a->c.ary.rank)!=1) error(E_ARRAYDIMENSION);
00250   fp=ckintval(a->c.ary.fillpointer);
00251   entity=a->c.ary.entity;
00252   vsize=vecsize(entity);
00253   if (fp>=vsize) {      /*extend vector*/
00254     new=makevector(classof(entity),fp*2);
00255     switch(elmtypeof(entity)) {
00256       case ELM_BIT: n=(vsize+WORD_SIZE-1)/WORD_SIZE; break;
00257       case ELM_CHAR: case ELM_BYTE: n=(vsize+sizeof(eusinteger_t))/sizeof(eusinteger_t); break;
00258       default: n=vsize;}
00259     for (i=0; i<n; i++) pointer_update(new->c.vec.v[i],entity->c.vec.v[i]);
00260     entity=new;
00261     pointer_update(a->c.ary.entity,entity);
00262     a->c.ary.dim[0]=makeint(fp*2);}
00263   vset(entity,fp,argv[0]);
00264   a->c.ary.fillpointer=makeint(fp+1);
00265   return(argv[0]);}
00266 
00267 pointer VECTORP(ctx,n,argv)
00268 register context *ctx;
00269 int n;
00270 pointer argv[];
00271 { register pointer a=argv[0];
00272   ckarg(1);
00273   if (ispointer(a)) return(elmtypeof(a)?T:NIL);
00274   else return(NIL);}
00275 
00276 /****************************************************************/
00277 /* bit vector
00278 /****************************************************************/
00279 
00280 #define isbitvector(p) (isvector(p) && (elmtypeof(p)==ELM_BIT))
00281 
00282 pointer BIT(ctx,n,argv)
00283 register context *ctx;
00284 int n;
00285 pointer argv[];
00286 { pointer a=argv[0];
00287   eusinteger_t x;
00288   ckarg(2);
00289   n=ckintval(argv[1]);
00290 #if (WORD_SIZE == 64)
00291   if (isbitvector(a)) {
00292     if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
00293     x=(a->c.ivec.iv[n/64]) & (1L<<(n % 64));
00294     return(makeint(x?1L:0L));}
00295 #else
00296   if (isbitvector(a)) {
00297     if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
00298     x=(a->c.ivec.iv[n/32]) & (1<<(n % 32));
00299     return(makeint(x?1:0));}
00300 #endif
00301   else error(E_BITVECTOR);}
00302 
00303 pointer SETBIT(ctx,n,argv)
00304 register context *ctx;
00305 int n;
00306 pointer argv[];
00307 { pointer a=argv[0];
00308   int val;
00309   ckarg(3);
00310   n=ckintval(argv[1]);
00311   val=ckintval(argv[2]) & 1;
00312 #if (WORD_SIZE == 64)
00313   if (isbitvector(a)) {
00314     if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
00315     if (val) a->c.ivec.iv[n/64]|=  (1L<<(n%64));
00316     else     a->c.ivec.iv[n/64]&= ~(1L<<(n%64));
00317     return(makeint(val));}
00318 #else
00319   if (isbitvector(a)) {
00320     if (n<0 || vecsize(a)<=n) error(E_ARRAYINDEX);
00321     if (val) a->c.ivec.iv[n/32]|=  (1<<(n%32));
00322     else     a->c.ivec.iv[n/32]&= ~(1<<(n%32));
00323     return(makeint(val));}
00324 #endif
00325   else error(E_BITVECTOR);}
00326 
00327 pointer BITAND(ctx,n,argv)
00328 register context *ctx;
00329 register int n;
00330 register pointer argv[];
00331 { pointer result;
00332   register eusinteger_t *bv1, *bv2, *rbv, s; register long i=0;
00333   ckarg2(2,3);
00334   if (!isbitvector(argv[0]) || !isbitvector(argv[1])) error(E_BITVECTOR);
00335   s=vecsize(argv[0]);
00336   if (s!=vecsize(argv[1])) error(E_ARRAYINDEX);
00337   if (n==3) {
00338     result=argv[2];
00339     if (!isbitvector(result)) error(E_BITVECTOR);
00340     if (s!=vecsize(result)) error(E_ARRAYINDEX);}
00341   else result=makevector(C_BITVECTOR,s);
00342   bv1=argv[0]->c.ivec.iv; bv2=argv[1]->c.ivec.iv; rbv=result->c.ivec.iv;
00343   while (i<(s+WORD_SIZE-1)/WORD_SIZE) {  rbv[i]=bv1[i] & bv2[i]; i++;}
00344   return(result);}
00345 
00346 pointer BITIOR(ctx,n,argv)
00347 register context *ctx;
00348 register int n;
00349 register pointer argv[];
00350 { pointer result;
00351   register eusinteger_t *bv1, *bv2, *rbv, s; register long i=0;
00352   ckarg2(2,3);
00353   if (!isbitvector(argv[0]) || !isbitvector(argv[1])) error(E_BITVECTOR);
00354   s=vecsize(argv[0]);
00355   if (s!=vecsize(argv[1])) error(E_ARRAYINDEX);
00356   if (n==3) {
00357     result=argv[2];
00358     if (!isbitvector(result)) error(E_BITVECTOR);
00359     if (s!=vecsize(result)) error(E_ARRAYINDEX);}
00360   else result=makevector(C_BITVECTOR,s);
00361   bv1=argv[0]->c.ivec.iv; bv2=argv[1]->c.ivec.iv; rbv=result->c.ivec.iv;
00362   while (i<(s+WORD_SIZE-1)/WORD_SIZE) {  rbv[i]=bv1[i] | bv2[i]; i++;}
00363   return(result);}
00364 
00365 pointer BITXOR(ctx,n,argv)
00366 register context *ctx;
00367 register int n;
00368 register pointer argv[];
00369 { pointer result;
00370   register eusinteger_t *bv1, *bv2, *rbv, s; register long i=0;
00371   ckarg2(2,3);
00372   if (!isbitvector(argv[0]) || !isbitvector(argv[1])) error(E_BITVECTOR);
00373   s=vecsize(argv[0]);
00374   if (s!=vecsize(argv[1])) error(E_ARRAYINDEX);
00375   if (n==3) {
00376     result=argv[2];
00377     if (!isbitvector(result)) error(E_BITVECTOR);
00378     if (s!=vecsize(result)) error(E_ARRAYINDEX);}
00379   else result=makevector(C_BITVECTOR,s);
00380   bv1=argv[0]->c.ivec.iv; bv2=argv[1]->c.ivec.iv; rbv=result->c.ivec.iv;
00381   while (i<(s+WORD_SIZE-1)/WORD_SIZE) {  rbv[i]=bv1[i] ^ bv2[i]; i++;}
00382   return(result);}
00383 
00384 pointer BITEQV(ctx,n,argv)
00385 register context *ctx;
00386 register int n;
00387 register pointer argv[];
00388 { pointer result;
00389   register eusinteger_t *bv1, *bv2, *rbv, s; register long i=0;
00390   ckarg2(2,3);
00391   if (!isbitvector(argv[0]) || !isbitvector(argv[1])) error(E_BITVECTOR);
00392   s=vecsize(argv[0]);
00393   if (s!=vecsize(argv[1])) error(E_ARRAYINDEX);
00394   if (n==3) {
00395     result=argv[2];
00396     if (!isbitvector(result)) error(E_BITVECTOR);
00397     if (s!=vecsize(result)) error(E_ARRAYINDEX);}
00398   else result=makevector(C_BITVECTOR,s);
00399   bv1=argv[0]->c.ivec.iv; bv2=argv[1]->c.ivec.iv; rbv=result->c.ivec.iv;
00400   while (i<(s+WORD_SIZE-1)/WORD_SIZE) {  rbv[i]= ~(bv1[i] ^ bv2[i]); i++;}
00401   return(result);}
00402 
00403 pointer BITNAND(ctx,n,argv)
00404 register context *ctx;
00405 register int n;
00406 register pointer argv[];
00407 { pointer result;
00408   register eusinteger_t *bv1, *bv2, *rbv, s; register long i=0;
00409   ckarg2(2,3);
00410   if (!isbitvector(argv[0]) || !isbitvector(argv[1])) error(E_BITVECTOR);
00411   s=vecsize(argv[0]);
00412   if (s!=vecsize(argv[1])) error(E_ARRAYINDEX);
00413   if (n==3) {
00414     result=argv[2];
00415     if (!isbitvector(result)) error(E_BITVECTOR);
00416     if (s!=vecsize(result)) error(E_ARRAYINDEX);}
00417   else result=makevector(C_BITVECTOR,s);
00418   bv1=argv[0]->c.ivec.iv; bv2=argv[1]->c.ivec.iv; rbv=result->c.ivec.iv;
00419   while (i<(s+WORD_SIZE-1)/WORD_SIZE) {  rbv[i]= ~(bv1[i] & bv2[i]); i++;}
00420   return(result);}
00421 
00422 pointer BITNOR(ctx,n,argv)
00423 register context *ctx;
00424 register int n;
00425 register pointer argv[];
00426 { pointer result;
00427   register eusinteger_t *bv1, *bv2, *rbv, s; register long i=0;
00428   ckarg2(2,3);
00429   if (!isbitvector(argv[0]) || !isbitvector(argv[1])) error(E_BITVECTOR);
00430   s=vecsize(argv[0]);
00431   if (s!=vecsize(argv[1])) error(E_ARRAYINDEX);
00432   if (n==3) {
00433     result=argv[2];
00434     if (!isbitvector(result)) error(E_BITVECTOR);
00435     if (s!=vecsize(result)) error(E_ARRAYINDEX);}
00436   else result=makevector(C_BITVECTOR,s);
00437   bv1=argv[0]->c.ivec.iv; bv2=argv[1]->c.ivec.iv; rbv=result->c.ivec.iv;
00438   while (i<(s+WORD_SIZE-1)/WORD_SIZE) {  rbv[i]= ~(bv1[i] | bv2[i]); i++;}
00439   return(result);}
00440 
00441 pointer BITNOT(ctx,n,argv)
00442 register context *ctx;
00443 register int n;
00444 register pointer argv[];
00445 { pointer result;
00446   register eusinteger_t *bv1, *rbv, s; register long i=0;
00447   ckarg2(1,2);
00448   if (!isbitvector(argv[0])) error(E_BITVECTOR);
00449   s=vecsize(argv[0]);
00450   if (n==2) {
00451     result=argv[1];
00452     if (!isbitvector(result)) error(E_BITVECTOR);
00453     if (s!=vecsize(result)) error(E_ARRAYINDEX);}
00454   else result=makevector(C_BITVECTOR,s);
00455   bv1=argv[0]->c.ivec.iv; rbv=result->c.ivec.iv;
00456   while (i<(s+WORD_SIZE-1)/WORD_SIZE) { rbv[i]= ~bv1[i]; i++;}
00457   return(result);}
00458 
00459 void vectorarray(ctx,mod)
00460 register context *ctx;
00461 pointer mod;
00462 {
00463   defun(ctx,"AREF",mod,AREF,NULL);
00464   defun(ctx,"ASET",mod,ASET,NULL);
00465   defun(ctx,"VECTOR-POP",mod,VECTORPOP,NULL);
00466   defun(ctx,"VECTOR-PUSH",mod,VECTORPUSH,NULL);
00467   defun(ctx,"VECTOR-PUSH-EXTEND",mod,VECTOREXPUSH,NULL);
00468   defun(ctx,"ARRAYP",mod,ARRAYP,NULL);
00469   defun(ctx,"SVREF",mod,SVREF,NULL);
00470   defun(ctx,"SVSET",mod,SVSET,NULL);
00471   defun(ctx,"VECTOR",mod,MKVECTOR,NULL);
00472   defun(ctx,"VECTORP",mod,VECTORP,NULL);
00473   defun(ctx,"INTEGER-VECTOR",mod,MKINTVECTOR,NULL);
00474   defun(ctx,"BIT",mod,BIT,NULL);
00475   defun(ctx,"SBIT",mod,BIT,NULL);
00476   defun(ctx,"SETBIT",mod,SETBIT,NULL);
00477   defun(ctx,"BIT-AND",mod,BITAND,NULL);
00478   defun(ctx,"BIT-IOR",mod,BITIOR,NULL);
00479   defun(ctx,"BIT-XOR",mod,BITXOR,NULL);
00480   defun(ctx,"BIT-EQV",mod,BITEQV,NULL);
00481   defun(ctx,"BIT-NAND",mod,BITNAND,NULL);
00482   defun(ctx,"BIT-NOR",mod,BITNOR,NULL);
00483   defun(ctx,"BIT-NOT",mod,BITNOT,NULL);
00484   }


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 18:05:53