00001
00002
00003
00004
00005
00006
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
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
00054
00055
00056
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
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)
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) {
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
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);
00464 defun(ctx,"ASET",mod,ASET);
00465 defun(ctx,"VECTOR-POP",mod,VECTORPOP);
00466 defun(ctx,"VECTOR-PUSH",mod,VECTORPUSH);
00467 defun(ctx,"VECTOR-PUSH-EXTEND",mod,VECTOREXPUSH);
00468 defun(ctx,"ARRAYP",mod,ARRAYP);
00469 defun(ctx,"SVREF",mod,SVREF);
00470 defun(ctx,"SVSET",mod,SVSET);
00471 defun(ctx,"VECTOR",mod,MKVECTOR);
00472 defun(ctx,"VECTORP",mod,VECTORP);
00473 defun(ctx,"INTEGER-VECTOR",mod,MKINTVECTOR);
00474 defun(ctx,"BIT",mod,BIT);
00475 defun(ctx,"SBIT",mod,BIT);
00476 defun(ctx,"SETBIT",mod,SETBIT);
00477 defun(ctx,"BIT-AND",mod,BITAND);
00478 defun(ctx,"BIT-IOR",mod,BITIOR);
00479 defun(ctx,"BIT-XOR",mod,BITXOR);
00480 defun(ctx,"BIT-EQV",mod,BITEQV);
00481 defun(ctx,"BIT-NAND",mod,BITNAND);
00482 defun(ctx,"BIT-NOR",mod,BITNOR);
00483 defun(ctx,"BIT-NOT",mod,BITNOT);
00484 }