00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011 static char *rcsid="@(#)$Id$";
00012
00013 #include "eus.h"
00014 #include <math.h>
00015
00016 #if (WORD_SIZE == 64)
00017 #define bitref(vec,index) (((vec)->c.ivec.iv[(index)/64] >> ((index)%64)) & 1L)
00018 #define bitset(vec,index,val) \
00019 (val?((vec)->c.ivec.iv[(index)/64] |= (1L<<((index)%64))): \
00020 ((vec)->c.ivec.iv[(index)/64] &= ~(1L<<((index)%64))))
00021 #else
00022 #define bitref(vec,index) (((vec)->c.ivec.iv[(index)/32] >> ((index)%32)) & 1)
00023 #define bitset(vec,index,val) \
00024 (val?((vec)->c.ivec.iv[(index)/32] |= (1<<((index)%32))): \
00025 ((vec)->c.ivec.iv[(index)/32] &= ~(1<<((index)%32))))
00026 #endif
00027
00028 extern pointer QEQ;
00029 pointer QIDENTITY;
00030 static pointer pushrest;
00031
00032 extern int pushsequence(context *,pointer,int,int);
00033 extern pointer makesequence(context *, int,pointer);
00034
00035 pointer call1(ctx,func,arg)
00036 register context *ctx;
00037 pointer func,arg;
00038 { vpush(arg);
00039 arg=ufuncall(ctx,func,func,(pointer)(ctx->vsp-1),NULL,1);
00040 ctx->vsp-=1;
00041 return(arg);}
00042
00043 pointer call2(ctx,func,arg1,arg2)
00044 register context *ctx;
00045 pointer func,arg1,arg2;
00046 { vpush(arg1); vpush(arg2);
00047 arg1=ufuncall(ctx,func,func,(pointer)(ctx->vsp-2),NULL,2);
00048 ctx->vsp-=2;
00049 return(arg1);}
00050
00051
00052
00053 eusinteger_t coerceintval(x)
00054 register pointer x;
00055 { numunion nu;
00056 int y;
00057 if (isflt(x)) return((eusinteger_t)round(fltval(x)));
00058 else return((eusinteger_t)bigintval(x));
00059 }
00060
00061 pointer fastvref(vec,index)
00062 register pointer vec;
00063 register int index;
00064 { register byte *p=vec->c.str.chars;
00065 eusinteger_t *pl=vec->c.ivec.iv;
00066 long ival;
00067 numunion nu;
00068
00069 switch(elmtypeof(vec)) {
00070 case ELM_FOREIGN: p=vec->c.foreign.chars;
00071 case ELM_CHAR: case ELM_BYTE: return(makeint(p[index]));
00072 case ELM_INT: ival=vec->c.ivec.iv[index];
00073 return(mkbigint(ival));
00074 case ELM_FLOAT: return(makeflt(vec->c.fvec.fv[index]));
00075 #if (WORD_SIZE == 64)
00076 case ELM_BIT: return(makeint((pl[index/64] & (1L<<((eusinteger_t)index%64)))?1L:0L));
00077 #else
00078 case ELM_BIT: return(makeint((pl[index/32] & (1<<((eusinteger_t)index%32)))?1:0));
00079 #endif
00080 case ELM_POINTER: return(vec->c.vec.v[index]);} }
00081
00082 void fastvset(vec,index,val)
00083 register pointer vec,val;
00084 register int index;
00085 { register byte *p;
00086 numunion nu;
00087 switch(elmtypeof(vec)) {
00088 case ELM_INT: vec->c.ivec.iv[index]=coerceintval(val); return;
00089 case ELM_FLOAT: vec->c.fvec.fv[index]=ckfltval(val); return;
00090 case ELM_POINTER: pointer_update(vec->c.vec.v[index],val); return;
00091 case ELM_CHAR: case ELM_BYTE:
00092 vec->c.str.chars[index]=coerceintval(val); return;
00093 #if (WORD_SIZE == 64)
00094 case ELM_BIT: if (coerceintval(val) & 1L)
00095 vec->c.ivec.iv[index/64] |= 1L << (index%64);
00096 else vec->c.ivec.iv[index/64] &= ~(1L<<index%64);
00097 #else
00098 case ELM_BIT: if (coerceintval(val) & 1)
00099 vec->c.ivec.iv[index/32] |= 1 << (index%32);
00100 else vec->c.ivec.iv[index/32] &= ~(1<<index%32);
00101 #endif
00102 return;
00103 case ELM_FOREIGN: p=vec->c.foreign.chars;
00104 p[index]=coerceintval(val); return;} }
00105
00106
00107
00108 pointer IDENTITY(ctx,n,argv)
00109 register context *ctx;
00110 int n;
00111 register pointer argv[];
00112 { ckarg(1);
00113 return(argv[0]);}
00114
00115 pointer SUBSEQ(ctx,n,argv)
00116 register context *ctx;
00117 int n;
00118 pointer argv[];
00119 { register pointer a=argv[0],r;
00120 register eusinteger_t s,e,i=0,count;
00121 pointer fastvref();
00122 void fastvset();
00123 ckarg2(2,3);
00124 s=ckintval(argv[1]);
00125 if (n==3) {
00126 e=ckintval(argv[2]);
00127 if (e<s) error(E_STARTEND);}
00128 if (a==NIL)return(NIL);
00129 else if (islist(a)) {
00130 while (islist(a) && i++<s) a=ccdr(a);
00131 if (!islist(a)) error(E_STARTEND);
00132 i=0;
00133 if (n==3) {
00134 while (s<e) {
00135 if (!islist(a)) break;
00136 ckpush(ccar(a)); a=ccdr(a); i++; s++;}}
00137 else while (islist(a)) { ckpush(ccar(a)); a=ccdr(a); i++;}
00138 return((pointer)stacknlist(ctx,i));}
00139 else if (isarray(a)) {
00140 s+=intval(a->c.ary.offset);
00141 e+=intval(a->c.ary.offset);
00142 a=a->c.ary.entity;}
00143 if (isvector(a)) {
00144 count=vecsize(a);
00145 if (n==3) e=min(e,count);
00146 else e=count;
00147 count=e-s;
00148 switch(elmtypeof(a)) {
00149 case ELM_BIT:
00150 r=makevector(classof(a), count);
00151 while (count-->0) fastvset(r,i++,fastvref(a,s++));
00152 return(r);
00153 case ELM_BYTE: case ELM_CHAR:
00154 r=makevector(classof(a), count);
00155 memcpy(&r->c.str.chars[i], &a->c.str.chars[s], count);
00156 return(r);
00157 case ELM_FOREIGN:
00158 { byte *p;
00159 r=makevector(C_STRING, count);
00160 p=a->c.foreign.chars;
00161 memcpy(&r->c.str.chars[i], &p[s], count);
00162 return(r);}
00163 default:
00164 r=makevector(classof(a), count);
00165 memcpy(&r->c.vec.v[i], &a->c.vec.v[s], count*sizeof(pointer));
00166 return(r);
00167 }
00168 }
00169 else error(E_NOSEQ);}
00170
00171 pointer COPYSEQ(ctx,n,argv)
00172 register context *ctx;
00173 int n;
00174 pointer *argv;
00175 { register pointer a,r;
00176 register int i=0,s,k;
00177 register byte *p;
00178 ckarg(1);
00179 a=argv[0];
00180 if (a==NIL) return(NIL);
00181 else if (islist(a)) {
00182 while (islist(a)) { ckpush(ccar(a)); a=ccdr(a); i++;}
00183 r=NIL;
00184 while (i-->0) r=cons(ctx,vpop(),r);
00185 return(r);}
00186 else if (isarray(a)) {
00187 if (a->c.ary.rank>makeint(1)) error(E_NOSEQ);
00188 k=intval(a->c.ary.dim[0]);
00189 s=intval(a->c.ary.offset);
00190 a=a->c.ary.entity;}
00191 if (isvector(a)) { k=vecsize(a); s=0;}
00192 else error(E_NOSEQ);
00193 p=a->c.str.chars;
00194 switch(elmtypeof(a)) {
00195 case ELM_BIT:
00196 r=makevector(classof(a), k);
00197 for (i=0; i<k; s++, i++) bitset(r,i,bitref(a,s));
00198 break;
00199 case ELM_FOREIGN:
00200 r=makevector(C_STRING, k);
00201 p=a->c.foreign.chars;
00202 memcpy(r->c.str.chars, &p[s] ,k);
00203 break;
00204 case ELM_BYTE: case ELM_CHAR:
00205 r=makevector(classof(a), k);
00206 memcpy(r->c.str.chars, &p[s], k);
00207 break;
00208 default:
00209 r=makevector(classof(a), k);
00210 memcpy(r->c.vec.v, &a->c.vec.v[s], k*sizeof(pointer));
00211 break;
00212 }
00213 return(r);}
00214
00215 pointer REVERSE(ctx,n,argv)
00216 register context *ctx;
00217 int n;
00218 pointer argv[];
00219 { register pointer a=argv[0],r=NIL;
00220 register byte *p;
00221 register eusinteger_t i,k,s,e;
00222 ckarg(1);
00223 if (a==NIL) return(NIL);
00224 else if (islist(a)) {
00225 while (islist(a)) { r=cons(ctx,ccar(a),r); a=ccdr(a);}
00226 return(r);}
00227 else if (isarray(a)) {
00228 if (a->c.ary.rank>makeint(1)) error(E_NOSEQ);
00229 s=intval(a->c.ary.offset);
00230 k=intval(a->c.ary.dim[0]);
00231 a=a->c.ary.entity;}
00232 else if (isvector(a)) { k=vecsize(a); s=0;}
00233 else error(E_NOSEQ);
00234 r=makevector(classof(a),k);
00235 p=a->c.str.chars;
00236 switch(elmtypeof(a)) {
00237 case ELM_BIT: for (i=0; i<k; s++,i++) bitset(r,k-i-1,bitref(a,s));
00238 break;
00239 case ELM_FOREIGN: r=makevector(C_STRING, k); p=a->c.foreign.chars;
00240 case ELM_CHAR: case ELM_BYTE:
00241 for (i=0; i<k; s++,i++) r->c.str.chars[k-i-1]=p[s];
00242 break;
00243 default: for (i=0; i<k; s++,i++) pointer_update(r->c.vec.v[k-i-1],a->c.vec.v[s]);
00244 break;}
00245 return(r);}
00246
00247 pointer NREVERSE(ctx,n,argv)
00248 register context *ctx;
00249 int n;
00250 pointer argv[];
00251 { register pointer a=argv[0],r=NIL, *vp;
00252 register eusinteger_t i,k,s,kk,x,y;
00253 register byte *cp;
00254 ckarg(1);
00255 if (a==NIL) return(NIL);
00256 else if (islist(a)) {
00257 i=0; r=a;
00258 while (islist(r)) { ckpush(ccar(r)); r=ccdr(r); i++;}
00259 r=a;
00260 while (i>0) { pointer_update(ccar(r),vpop()); r=ccdr(r); i--;}
00261 return(a);}
00262 else if (isarray(a)) {
00263 if (a->c.ary.rank>makeint(1)) error(E_NOSEQ);
00264 s=intval(a->c.ary.offset);
00265 k=intval(a->c.ary.dim[0]);
00266 a=a->c.ary.entity;}
00267 else if (isvector(a)) { k=vecsize(a); s=0;}
00268 else error(E_NOSEQ);
00269 kk=k/2; vp=a->c.vec.v;
00270 cp=a->c.str.chars;
00271 switch(elmtypeof(a)) {
00272 case ELM_BIT:
00273 for(i=0; i<kk; i++, s++) {
00274 x=bitref(a,s);
00275 y=bitref(a,k-i-1);
00276 #if (WORD_SIZE == 64)
00277 if (y) a->c.ivec.iv[s/64] |= (1L<<(s%64));
00278 else a->c.ivec.iv[s/64] &= ~(1L<<(s%64));
00279 if (x) a->c.ivec.iv[(k-i-1)/64] |= (1L<<((k-i-1)%64));
00280 else a->c.ivec.iv[(k-i-1)/64] &= ~(1L<<((k-i-1)%64));
00281 #else
00282 if (y) a->c.ivec.iv[s/32] |= (1<<(s%32));
00283 else a->c.ivec.iv[s/32] &= ~(1<<(s%32));
00284 if (x) a->c.ivec.iv[(k-i-1)/32] |= (1<<((k-i-1)%32));
00285 else a->c.ivec.iv[(k-i-1)/32] &= ~(1<<((k-i-1)%32));
00286 #endif
00287 }
00288 break;
00289 case ELM_FOREIGN: cp=a->c.foreign.chars;
00290 case ELM_CHAR: case ELM_BYTE:
00291 for(i=0; i<kk; i++, s++) {
00292 x=cp[s]; cp[s]=cp[k-i-1]; cp[k-i-1]=x;}
00293 break;
00294 default:
00295 vp=a->c.vec.v;
00296 for(i=0; i<kk; i++, s++) {
00297 r=vp[s]; pointer_update(vp[s],vp[k-i-1]); vp[k-i-1]=r;}
00298 break; }
00299 return(a);}
00300
00301 int pushsequence(ctx,a,offset,count)
00302 register context *ctx;
00303 register pointer a;
00304 register int offset,count;
00305 { long i,len=0, x;
00306 byte *p;
00307 numunion nu;
00308
00309 if (a==NIL) return(0);
00310 else if (iscons(a)) {
00311 while (offset-->0) { a=cdrof(a,E_SEQINDEX);}
00312 while (count-->0 && iscons(a)) { ckpush(ccar(a)); a=ccdr(a); len++;}
00313 pushrest=a;
00314 return(len);}
00315 else {
00316 if (isarray(a)) {
00317 if (a->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00318 offset+=intval(a->c.ary.offset); a=a->c.ary.entity;}
00319 if (!isvector(a)) error(E_NOSEQ);
00320 i=0; len=vecsize(a)-offset; len=min(len,count);
00321 p=a->c.str.chars;
00322 switch(elmtypeof(a)) {
00323 case ELM_FOREIGN: p=a->c.foreign.chars;
00324 case ELM_CHAR: case ELM_BYTE: while (i<len) ckpush(makeint(p[offset+i++]));
00325 return(len);
00326 case ELM_INT: while (i<len) {
00327 x=a->c.ivec.iv[offset+i++];
00328 ckpush(makeint(x)); }
00329 return(len);
00330 case ELM_FLOAT: while (i<len) ckpush(makeflt(a->c.fvec.fv[offset+i++]));
00331 return(len);
00332 case ELM_BIT: { eusinteger_t m, b;
00333 while (i<len) {
00334 #if (WORD_SIZE == 64)
00335 m= 1L<<((offset+i)%64);
00336 b=a->c.ivec.iv[(offset+i)/64] & m;
00337 #else
00338 m= 1<<((offset+i)%32);
00339 b=a->c.ivec.iv[(offset+i)/32] & m;
00340 #endif
00341 ckpush(makeint(b?1:0));
00342 i++;}
00343 return(len);}
00344 case ELM_POINTER: while (i<len) ckpush(a->c.vec.v[offset+i++]);
00345 return(len);} }}
00346
00347 pointer makesequence(ctx,n,resulttype)
00348 register context *ctx;
00349 register int n;
00350 pointer resulttype;
00351 { register pointer x,r;
00352 register int cid=intval(resulttype->c.cls.cix);
00353 numunion nu;
00354 if (cid==conscp.cix) return((pointer)stacknlist(ctx,n));
00355 else if (cid<=conscp.sub) {
00356 r=NIL;
00357 while (n-- > 0) {
00358 vpush(r);
00359 x=(pointer)makeobject(resulttype);
00360 r=vpop();
00361 pointer_update(x->c.cons.car,vpop());
00362 pointer_update(x->c.cons.cdr,r);
00363 r=x;}
00364 return(r);}
00365 else {
00366 r=makevector(resulttype,n);
00367 switch(elmtypeof(r)) {
00368 case ELM_INT: while (--n>=0) r->c.ivec.iv[n]=coerceintval(vpop());
00369 return(r);
00370 case ELM_FLOAT: while (--n>=0) {
00371 x=vpop();
00372 r->c.fvec.fv[n]=ckfltval(x);}
00373 return(r);
00374 case ELM_POINTER: while (--n>=0) pointer_update(r->c.vec.v[n],vpop());
00375 return(r);
00376 case ELM_CHAR: case ELM_BYTE:
00377 while (--n>=0) r->c.str.chars[n]=coerceintval(vpop());
00378 return(r);
00379 case ELM_BIT: while (--n>=0)
00380 #if (WORD_SIZE == 64)
00381 r->c.ivec.iv[n/64]|=(coerceintval(vpop()) & 1L)<<(n%64);
00382 #else
00383 r->c.ivec.iv[n/32]|=(coerceintval(vpop()) & 1)<<(n%32);
00384 #endif
00385 return(r);
00386 case ELM_FOREIGN: error(E_USER,(pointer)"cannot coerce to foreign string"); } } }
00387
00388 pointer CONCATENATE(ctx,n,argv)
00389 register context *ctx;
00390 int n;
00391 register pointer argv[];
00392 { register int i,argc=1,resultlen=0;
00393 if (n<=1) return(NIL);
00394 if (!isclass(argv[0])) error(E_NOCLASS,argv[0]);
00395 while (argc<n) resultlen+=pushsequence(ctx,argv[argc++],0,1000000);
00396 return(makesequence(ctx,resultlen,argv[0]));}
00397
00398 pointer COERCE(ctx,n,argv)
00399 register context *ctx;
00400 register int n;
00401 register pointer argv[];
00402 { register eusinteger_t offset,count,len,i;
00403 register pointer a=argv[0];
00404 ckarg(2);
00405 if (!isclass(argv[1])) error(E_NOCLASS,argv[1]);
00406 if (isarray(a)) {
00407 if (a->c.ary.rank!=makeint(1)) error(E_NOSEQ,a);
00408 offset=intval(a->c.ary.offset);
00409 count=intval(a->c.ary.dim[0]);
00410 a=a->c.ary.entity;}
00411 else { offset=0; count=1000000;}
00412 len=pushsequence(ctx,a,offset,count);
00413 return(makesequence(ctx,len,argv[1])); }
00414
00415 pointer FILL(ctx,n,argv)
00416 register context *ctx;
00417 register int n;
00418 pointer argv[];
00419 {
00420 register pointer seq=argv[0], item=argv[1];
00421 register eusinteger_t i=0,start,end, val, count;
00422 eusfloat_t fval;
00423 byte *bp;
00424 numunion nu;
00425
00426 ckarg(4);
00427 start=ckintval(argv[2]); end=ckintval(argv[3]);
00428 if (islist(seq)) {
00429 while (i++<start && islist(seq)) seq=ccdr(seq);
00430 while (start<end) {
00431 if (!iscons(seq)) break;
00432 pointer_update(ccar(seq),item); seq=ccdr(seq);
00433 start++;}
00434 return(argv[0]); }
00435 else if (isvector(seq)) end=min(end,vecsize(seq));
00436 else if (isarray(seq)) {
00437 if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00438 end=min(end,intval(seq->c.ary.dim[0]))+intval(seq->c.ary.offset);
00439 start+=intval(seq->c.ary.offset);
00440 seq=seq->c.ary.entity;}
00441 else error(E_NOSEQ);
00442 switch (elmtypeof(seq)) {
00443 case ELM_INT: val=coerceintval(item);
00444 while (start<end) seq->c.ivec.iv[start++]=val;
00445 break;
00446 case ELM_FLOAT: fval=ckfltval(item);
00447 while (start<end) seq->c.fvec.fv[start++]=fval;
00448 break;
00449 case ELM_POINTER: while (start<end) seq->c.vec.v[start++]=item; break;
00450 case ELM_CHAR: case ELM_BYTE:
00451 val = coerceintval(item);
00452 bp=seq->c.str.chars;
00453 while (start<end) bp[start++]=val;
00454 break;
00455 case ELM_BIT:
00456 #if (WORD_SIZE == 64)
00457 while (((start % 64) != 0) && (start<end))
00458 fastvset(seq,start++,item);
00459 count = (end-start)/64;
00460 val= (coerceintval(item)==0L)?0L:~0L;
00461 for (i=0; i<count; i++)
00462 seq->c.ivec.iv[start/64+i]=val;
00463 start = start + count*64;
00464 #else
00465 while (((start % 32) != 0) && (start<end))
00466 fastvset(seq,start++,item);
00467 count = (end-start)/32;
00468 val= (coerceintval(item)==0)?0:~0;
00469 for (i=0; i<count; i++)
00470 seq->c.ivec.iv[start/32+i]=val;
00471 start = start + count*32;
00472 #endif
00473 while (start<end) fastvset(seq, start++, item);
00474 break;
00475 case ELM_FOREIGN:
00476 bp=seq->c.foreign.chars;
00477 val=coerceintval(item);
00478 while (start<end) bp[start++]=val;
00479 break;
00480 }
00481 return(argv[0]);}
00482
00483 pointer MAP(ctx,n,argv)
00484 register context *ctx;
00485 register int n;
00486 pointer argv[];
00487 {
00488 register pointer func=argv[1], argseq,r;
00489 register eusinteger_t argc,rcount=0,offset;
00490
00491 if (n<3) error(E_MISMATCHARG);
00492 while (1) {
00493 argc=0;
00494
00495 while (argc+2<n) {
00496 argseq=argv[argc+2];
00497 if (iscons(argseq)) {
00498 ckpush(ccar(argseq));
00499 argv[argc+2]=ccdr(argseq);}
00500 else {
00501 if (isarray(argseq)) {
00502 if (argseq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00503 offset=intval(argseq->c.ary.offset);
00504 argseq=argseq->c.ary.entity;}
00505 else offset=0;
00506 if (isvector(argseq) && vecsize(argseq)>rcount+offset)
00507 ckpush(fastvref(argseq,rcount+offset));
00508 else { ctx->vsp-=argc; goto makeresult;} }
00509 argc++;}
00510 r=ufuncall(ctx,ctx->callfp->form,func,(pointer)(ctx->vsp-argc),NULL,argc);
00511 ctx->vsp-=argc;
00512 vpush(r);
00513 rcount++;}
00514 makeresult:
00515 if (isclass(argv[0])) return(makesequence(ctx,rcount,argv[0]));
00516 else { ctx->vsp-=rcount; return(NIL);}}
00517
00518 pointer POSITION(ctx,n,argv)
00519 register context *ctx;
00520 int n;
00521 register pointer *argv;
00522 { register pointer item=argv[0],seq=argv[1],element;
00523 pointer test=argv[2],testnot=argv[3],key=argv[4];
00524 pointer iftest=argv[5],ifnottest=argv[6];
00525 register eusinteger_t start,end,count,i=0;
00526
00527 ckarg(10);
00528 start=ckintval(argv[7]); end=ckintval(argv[8]); count=ckintval(argv[9]);
00529
00530 if (seq==NIL) return(NIL);
00531 else if (islist(seq)) {
00532 while (i++<start && islist(seq)) seq=ccdr(seq);
00533 if (!islist(seq)) return(NIL);}
00534 else if (isvector(seq)) end=min(end,vecsize(seq));
00535 else if (isarray(seq)) {
00536 if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00537 seq=seq->c.ary.entity; end=min(end,vecsize(seq));}
00538 else error(E_NOSEQ);
00539 while (start<end) {
00540
00541 if (seq==NIL) return(NIL);
00542 else if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
00543 else element=fastvref(seq,start);
00544 if (key!=QIDENTITY) element=call1(ctx,key,element);
00545 if (ifnottest!=NIL) {
00546 if (call1(ctx,ifnottest,element)==NIL&&--count<=0) return(makeint(start));}
00547 else if (iftest!=NIL) {
00548 if (call1(ctx,iftest,element)!=NIL&&--count<=0) return(makeint(start));}
00549 else if (testnot!=NIL) {
00550 if (call2(ctx,testnot,item,element)==NIL&&--count<=0) return(makeint(start));}
00551 else if (test!=QEQ) {
00552 if (call2(ctx,test,item,element)!=NIL&&--count<=0) return(makeint(start));}
00553 else if (item==element&&--count<=0) return(makeint(start));
00554 start++;}
00555 return(NIL);}
00556
00557 pointer FIND(ctx,n,argv)
00558 register context *ctx;
00559 int n;
00560 register pointer *argv;
00561 { register pointer item=argv[0],seq=argv[1],element,testelement;
00562 pointer test=argv[2],testnot=argv[3],key=argv[4];
00563 pointer iftest=argv[5],ifnottest=argv[6];
00564 register eusinteger_t start,end,i=0;
00565
00566 ckarg(9);
00567 start=ckintval(argv[7]); end=ckintval(argv[8]);
00568
00569 if (seq==NIL) return(NIL);
00570 else if (islist(seq)) {
00571 while (i++<start && islist(seq)) seq=ccdr(seq);
00572 if (!islist(seq)) return(NIL);}
00573 else {
00574 if (isarray(seq)) {
00575 if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00576 seq=seq->c.ary.entity;}
00577 if (isvector(seq)) end=min(end,vecsize(seq));
00578 else error(E_NOSEQ);}
00579 while (start<end) {
00580
00581 if (seq==NIL) return(NIL);
00582 else if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
00583 else element=fastvref(seq,start);
00584 if (key!=QIDENTITY) testelement=call1(ctx,key,element);
00585 else testelement=element;
00586 if (ifnottest!=NIL) {
00587 if (call1(ctx,ifnottest,testelement)==NIL) return(element);}
00588 else if (iftest!=NIL) {
00589 if (call1(ctx,iftest,testelement)!=NIL) return(element);}
00590 else if (testnot!=NIL) {
00591 if (call2(ctx,testnot,item,testelement)==NIL) return(element);}
00592 else if (test!=QEQ) {
00593 if (call2(ctx,test,item,testelement)!=NIL) return(element);}
00594 else if (item==testelement) return(element);
00595 start++;}
00596 return(NIL);}
00597
00598 pointer COUNT(ctx,n,argv)
00599 register context *ctx;
00600 int n;
00601 register pointer *argv;
00602 { register pointer item=argv[0],seq=argv[1],element,testelement;
00603 pointer test=argv[2],testnot=argv[3],key=argv[4];
00604 pointer iftest=argv[5],ifnottest=argv[6];
00605 register eusinteger_t start,end,i=0;
00606
00607 ckarg(9);
00608 start=ckintval(argv[7]); end=ckintval(argv[8]);
00609
00610 if (seq==NIL) return(makeint(0));
00611 else if (islist(seq)) {
00612 while (i++<start && islist(seq)) seq=ccdr(seq);
00613 if (!islist(seq)) return(NIL);}
00614 else {
00615 if (isarray(seq)) {
00616 if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00617 seq=seq->c.ary.entity;}
00618 if (isvector(seq)) end=min(end,vecsize(seq));
00619 else error(E_NOSEQ);}
00620 i=0;
00621 while (start<end) {
00622
00623 if (seq==NIL) return(makeint(i));
00624 else if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
00625 else element=fastvref(seq,start);
00626 if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
00627 if (ifnottest!=NIL) {
00628 if (call1(ctx,ifnottest,testelement)==NIL) i++;}
00629 else if (iftest!=NIL) {
00630 if (call1(ctx,iftest,testelement)!=NIL) i++;}
00631 else if (testnot!=NIL) {
00632 if (call2(ctx,testnot,item,testelement)==NIL) i++;}
00633 else if (test!=QEQ) {
00634 if (call2(ctx,test,item,testelement)!=NIL) i++;}
00635 else if (item==testelement) i++;
00636 start++;}
00637 return(makeint(i));}
00638
00639 pointer UNIREMOVE(ctx,n,argv)
00640 register context *ctx;
00641 int n;
00642 register pointer argv[];
00643 { pointer item=argv[0],seq=argv[1],test=argv[2],testnot=argv[3],key=argv[4];
00644 pointer iftest=argv[5],ifnottest=argv[6];
00645 register pointer element,testelement;
00646 eusinteger_t start,end,count,i,testresult,pushcount;
00647
00648 ckarg(10);
00649 start=ckintval(argv[7]); end=ckintval(argv[8]); count=ckintval(argv[9]);
00650 if (seq==NIL) return(NIL);
00651 else {
00652 if (isarray(seq)) {
00653 if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00654 seq=seq->c.ary.entity;}
00655 if (isvector(seq)) end=min(end,vecsize(seq));
00656 else if (!iscons(seq)) error(E_NOSEQ);}
00657 pushcount=pushsequence(ctx,seq,0,start);
00658 if (iscons(seq)) seq=pushrest;
00659 while (start<end && count>0) {
00660 if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
00661 else if (isvector(seq)) element=fastvref(seq,start);
00662 else error(E_SEQINDEX);
00663 start++;
00664 if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
00665 if (ifnottest!=NIL) testresult=(call1(ctx,ifnottest,testelement)==NIL);
00666 else if (iftest!=NIL) testresult=(call1(ctx,iftest,testelement)!=NIL);
00667 else if (testnot!=NIL) testresult=(call2(ctx,testnot,item,testelement)==NIL);
00668 else if (test!=QEQ) testresult=(call2(ctx,test,item,testelement)!=NIL);
00669 else testresult=(item==testelement);
00670 if (testresult) { count--;}
00671 else { ckpush(element); pushcount++;}}
00672 if (iscons(argv[1])) {
00673 while (pushcount-->0) seq=cons(ctx,vpop(),seq);
00674 return(seq);}
00675 else {
00676 pushcount+=pushsequence(ctx,seq,end,1000000);
00677 return(makesequence(ctx,pushcount,classof(seq)));}}
00678
00679 pointer REMOVE_DUPLICATES(ctx,n,argv)
00680 register context *ctx;
00681 int n;
00682 pointer argv[];
00683 { pointer seq=argv[0],test=argv[1],testnot=argv[2],key=argv[3];
00684 register pointer element,testelement,seq2,element2;
00685 register eusinteger_t i,start,end,testresult,pushcount;
00686
00687 ckarg(6);
00688 start=ckintval(argv[4]); end=ckintval(argv[5]);
00689 if (seq==NIL) return(NIL);
00690 if (isvector(seq)) end=min(end,vecsize(seq));
00691 else if (!iscons(seq)) error(E_NOSEQ);
00692 pushcount=pushsequence(ctx,seq,0,start);
00693 if (iscons(seq)) seq=pushrest;
00694 while (start<end) {
00695 if (seq==NIL) break;
00696 if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
00697 else if (isvector(seq)) element=fastvref(seq,start);
00698 else error(E_SEQINDEX);
00699 start++;
00700 if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
00701 i=start; seq2=seq; testresult=0;
00702 while (i<end) {
00703 if (seq2==NIL) break;
00704 else if (iscons(seq2)) { element2=ccar(seq2); seq2=ccdr(seq2); }
00705 else if (isvector(seq2)) element2=fastvref(seq2,i);
00706 else error(E_SEQINDEX);
00707 i++;
00708 if (key!=QIDENTITY) element2=call1(ctx,key,element2);
00709 if (testnot!=NIL) testresult=(call2(ctx,testnot,testelement,element2)==NIL);
00710 else if (test!=QEQ) testresult=(call2(ctx,test,testelement,element2)!=NIL);
00711 else testresult=(testelement==element2);
00712 if (testresult) break;}
00713 if (!testresult) {ckpush(element); pushcount++;} }
00714 if (iscons(argv[0])) {
00715 while (pushcount-->0) seq=cons(ctx,vpop(),seq);
00716 return(seq);}
00717 else {
00718 pushcount+=pushsequence(ctx,seq,end,1000000);
00719 return(makesequence(ctx,pushcount,classof(seq)));}}
00720
00721 pointer DELETE(ctx,n,argv)
00722 register context *ctx;
00723 int n;
00724 pointer argv[];
00725 { pointer item=argv[0],seq=argv[1],test=argv[2],testnot=argv[3],key=argv[4];
00726 pointer iftest=argv[5],ifnottest=argv[6];
00727 register pointer element,testelement,result=seq,lastseq;
00728 eusinteger_t start,end,count,i,testresult,first,lastindex;
00729
00730 ckarg(10);
00731 start=ckintval(argv[7]); end=ckintval(argv[8]); count=ckintval(argv[9]);
00732 lastindex=start;
00733 if (seq==NIL) return(NIL);
00734 if (isarray(seq)) {
00735 if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00736 seq=seq->c.ary.entity;}
00737 if (isvector(seq)) end=min(end,vecsize(seq));
00738 else if (!iscons(seq)) error(E_NOSEQ);
00739
00740 if (iscons(seq)) {
00741 first=(start==0);
00742 for (i=0; i<start; i++) if (iscons(seq)) seq=ccdr(seq); else error(E_SEQINDEX);
00743 lastseq=seq;}
00744 while (start<end && count>0) {
00745 if (iscons(seq)) element=ccar(seq);
00746 else if (isvector(seq)) element=fastvref(seq,start);
00747 else error(E_SEQINDEX);
00748 if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
00749 if (ifnottest!=NIL) testresult=(call1(ctx,ifnottest,testelement)==NIL);
00750 else if (iftest!=NIL) testresult=(call1(ctx,iftest,testelement)!=NIL);
00751 else if (testnot!=NIL) testresult=(call2(ctx,testnot,item,testelement)==NIL);
00752 else if (test!=QEQ) testresult=(call2(ctx,test,item,testelement)!=NIL);
00753 else testresult=(item==testelement);
00754 if (iscons(result)) {
00755 if (testresult) {
00756 count--;
00757 if (first) { result=ccdr(seq);}
00758 else { ccdr(lastseq)=ccdr(seq); first=0;}}
00759 else { lastseq = seq; first=0;}
00760 seq = ccdr(seq);}
00761 else if (isvector(seq)) {
00762 if (testresult) { count--;}
00763 else {
00764 if (start!=lastindex) fastvset(seq,lastindex,element);
00765 lastindex++;} }
00766 else error(E_SEQINDEX);
00767 start++; }
00768 if (isvector(result)) result->c.vec.size=makeint(lastindex);
00769 return(result);}
00770
00771 pointer SUBSTITUTE(ctx,n,argv)
00772 register context *ctx;
00773 int n;
00774 register pointer argv[];
00775 { pointer newitem=argv[0], olditem=argv[1], seq=argv[2];
00776 pointer test=argv[3],testnot=argv[4],key=argv[5];
00777 pointer iftest=argv[6],ifnottest=argv[7];
00778 register pointer element,testelement;
00779 register eusinteger_t i,start,end,count,testresult,pushcount;
00780
00781 ckarg(11);
00782 start=ckintval(argv[8]); end=ckintval(argv[9]); count=ckintval(argv[10]);
00783 if (seq==NIL) return(NIL);
00784 if (isarray(seq)) {
00785 if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00786 seq=seq->c.ary.entity;}
00787 if (isvector(seq)) end=min(end,vecsize(seq));
00788 else if (!iscons(seq)) error(E_NOSEQ);
00789 pushcount=pushsequence(ctx,seq,0,start);
00790 if (iscons(seq)) seq=pushrest;
00791 while (start<end && count>0) {
00792 if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
00793 else if (isvector(seq)) element=fastvref(seq,start);
00794 else error(E_SEQINDEX);
00795 start++;
00796 if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
00797 if (ifnottest!=NIL) testresult=(call1(ctx,ifnottest,testelement)==NIL);
00798 else if (iftest!=NIL) testresult=(call1(ctx,iftest,testelement)!=NIL);
00799 else if (testnot!=NIL) testresult=(call2(ctx,testnot,olditem,testelement)==NIL);
00800 else if (test!=QEQ) testresult=(call2(ctx,test,olditem,testelement)!=NIL);
00801 else testresult=(olditem==testelement);
00802
00803 if (testresult) { count--; ckpush(newitem);}
00804 else { ckpush(element);}
00805 pushcount++;}
00806 if (iscons(argv[2])) {
00807 while (pushcount-->0) seq=cons(ctx,vpop(),seq);
00808 return(seq);}
00809 else {
00810 pushcount+=pushsequence(ctx,seq,end,1000000);
00811 return(makesequence(ctx,pushcount,classof(seq)));}}
00812
00813 pointer NSUBSTITUTE(ctx,n,argv)
00814 register context *ctx;
00815 int n;
00816 pointer argv[];
00817 { pointer newitem=argv[0], olditem=argv[1], seq=argv[2];
00818 pointer test=argv[3],testnot=argv[4],key=argv[5];
00819 pointer iftest=argv[6],ifnottest=argv[7];
00820 register pointer element,testelement;
00821 register eusinteger_t i,start,end,count,testresult;
00822
00823 ckarg(11);
00824 start=ckintval(argv[8]); end=ckintval(argv[9]); count=ckintval(argv[10]);
00825 if (seq==NIL) return(NIL);
00826 if (isarray(seq)) {
00827 if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
00828 seq=seq->c.ary.entity;}
00829 if (isvector(seq)) end=min(end,vecsize(seq));
00830 else if (!iscons(seq)) error(E_NOSEQ);
00831
00832 if (iscons(seq))
00833 for (i=0; i<start; i++) if (iscons(seq)) seq=ccdr(seq); else error(E_SEQINDEX);
00834 while (start<end && count>0) {
00835 if (iscons(seq)) element=ccar(seq);
00836 else if (isvector(seq)) element=fastvref(seq,start);
00837 else error(E_SEQINDEX);
00838 if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
00839 if (ifnottest!=NIL) testresult=(call1(ctx,ifnottest,testelement)==NIL);
00840 else if (iftest!=NIL) testresult=(call1(ctx,iftest,testelement)!=NIL);
00841 else if (testnot!=NIL) testresult=(call2(ctx,testnot,olditem,testelement)==NIL);
00842 else if (test!=QEQ) testresult=(call2(ctx,test,olditem,testelement)!=NIL);
00843 else testresult=(olditem==testelement);
00844 if (testresult) {
00845 count--;
00846 if (iscons(seq)) {pointer_update(ccar(seq),newitem);}
00847 else if (isvector(seq)) fastvset(seq,start,newitem);
00848 else error(E_SEQINDEX); }
00849 if (iscons(seq)) seq=ccdr(seq);
00850 start++;}
00851 return(argv[2]);}
00852
00853
00854
00855
00856 pointer VECREPLACE(ctx,n,argv)
00857 register context *ctx;
00858 int n;
00859 pointer argv[];
00860 { register int i,count;
00861 register pointer src,dest;
00862 register byte *p, *p2;
00863 int srcelmt,destelmt;
00864 eusinteger_t ss,ds,se,de;
00865 numunion nu;
00866
00867 ckarg2(2,6);
00868 dest=argv[0]; if (isarray(dest)) dest=dest->c.ary.entity;
00869 src=argv[1]; if (isarray(src)) src=src->c.ary.entity;
00870 if (!isvector(src) || !isvector(dest)) error(E_NOVECTOR);
00871 ds=(n==2)?0:ckintval(argv[2]);
00872 de=(n<=3)?vecsize(dest):ckintval(argv[3]);
00873 ss=(n<=4)?0:ckintval(argv[4]);
00874 se=(n<=5)?vecsize(src):ckintval(argv[5]);
00875
00876 count=min(de-ds,se-ss);
00877 de=ds+count;
00878 srcelmt=elmtypeof(src);
00879 destelmt=elmtypeof(dest);
00880 if (srcelmt==ELM_BIT) {
00881 #if (WORD_SIZE == 64)
00882 if (destelmt==ELM_BIT && ss==0 && ds==0 && ((count%64) == 0)) {
00883
00884 for (i=0; i<count/64; i++) dest->c.ivec.iv[i] = src->c.ivec.iv[i];
00885 return(argv[0]);}
00886 #else
00887 if (destelmt==ELM_BIT && ss==0 && ds==0 && ((count%32) == 0)) {
00888
00889 for (i=0; i<count/32; i++) dest->c.ivec.iv[i] = src->c.ivec.iv[i];
00890 return(argv[0]);}
00891 #endif
00892 else goto general_replace;}
00893 if (srcelmt==destelmt ||
00894 (srcelmt==ELM_BYTE || srcelmt==ELM_CHAR || srcelmt==ELM_FOREIGN) &&
00895 (destelmt==ELM_BYTE || destelmt==ELM_CHAR || destelmt==ELM_FOREIGN)) {
00896
00897 if (srcelmt!=ELM_BYTE && srcelmt!=ELM_CHAR && srcelmt!=ELM_FOREIGN)
00898 { count*=sizeof(eusinteger_t); ss*=sizeof(eusinteger_t); ds*=sizeof(eusinteger_t);}
00899 if (srcelmt==ELM_FOREIGN) p=src->c.foreign.chars + ss;
00900 else p= &(src->c.str.chars[ss]);
00901 if (destelmt==ELM_FOREIGN) p2=dest->c.foreign.chars + ds;
00902 else p2= &(dest->c.str.chars[ds]);
00903 if (srcelmt==ELM_FOREIGN || destelmt==ELM_FOREIGN)
00904 for (i=0; i<count; i++) *p2++ = *p++;
00905 else memcpy((void *)p2, (void *)p, (size_t)count);
00906 return(argv[0]);}
00907
00908 general_replace:
00909
00910
00911 pushsequence(ctx,src,ss,count);
00912 if (destelmt==ELM_FOREIGN) p=dest->c.foreign.chars;
00913 else p=dest->c.str.chars;
00914 switch(destelmt) {
00915 case ELM_INT: while (count-->0)
00916 dest->c.ivec.iv[--de]=coerceintval(vpop());
00917 break;
00918 case ELM_FLOAT: while (count-->0) {
00919 src=vpop();
00920 dest->c.fvec.fv[--de]=ckfltval(src);}
00921 break;
00922 case ELM_POINTER: while (count-->0) {--de;pointer_update(dest->c.vec.v[de],vpop());}
00923 break;
00924 case ELM_CHAR: case ELM_BYTE: case ELM_FOREIGN:
00925 while (count-->0) p[--de]=coerceintval(vpop());
00926 break;
00927 case ELM_BIT: while (count-->0) {
00928 de--;
00929 #if (WORD_SIZE == 64)
00930 if (coerceintval(vpop()) & 1L)
00931 dest->c.ivec.iv[de/64] |= 1L << (de%64);
00932 else dest->c.ivec.iv[de/64] &= ~(1L << (de%64));
00933 #else
00934 if (coerceintval(vpop()) & 1)
00935 dest->c.ivec.iv[de/32] |= 1 << (de%32);
00936 else dest->c.ivec.iv[de/32] &= ~(1 << (de%32));
00937 #endif
00938 }
00939 break; }
00940 return(argv[0]);}
00941
00942
00943
00944
00945
00946
00947 static pointer COMPAR,COMPKEY;
00948 static int COMPTYPE;
00949 context *qsortctx;
00950
00951 int compar(x,y)
00952 pointer *x, *y;
00953 { pointer xx,yy,result;
00954 eusfloat_t *fx,*fy;
00955 numunion nu;
00956
00957 switch (COMPTYPE) {
00958 case ELM_CHAR: case ELM_BYTE:
00959 xx= makeint(*(char *)x); yy= makeint(*(char *)y); break;
00960 case ELM_INT: xx=makeint((eusinteger_t)(*x)); yy=makeint((eusinteger_t)(*y)); break;
00961 case ELM_FLOAT:
00962 fx=(eusfloat_t *)x; fy=(eusfloat_t *)y;
00963 xx=makeflt(*fx); yy=makeflt(*fy); break;
00964 default: xx= *x; yy= *y;}
00965 if (COMPKEY) {
00966 xx=call1(qsortctx,COMPKEY,xx);
00967 (*qsortctx->vsp++=((pointer)xx));
00968 yy=call1(qsortctx,COMPKEY,yy);
00969 (*qsortctx->vsp++=((pointer)yy));
00970 }
00971 result=call2(qsortctx,COMPAR,xx,yy);
00972 if (COMPKEY) {
00973 (*(--(qsortctx->vsp)));
00974 (*(--(qsortctx->vsp)));
00975 }
00976 if (result==NIL) return(1); else return(-1);}
00977
00978 pointer SORT(ctx,n,argv)
00979 register context *ctx;
00980 register int n;
00981 pointer argv[];
00982 { register pointer seq,work;
00983 pointer *xsp;
00984 register int i,width;
00985 ckarg2(2,3);
00986 seq=argv[0];
00987 if (seq==NIL) return(NIL);
00988
00989 #if THREADED
00990 mutex_lock(&qsort_lock);
00991 #endif
00992 qsortctx=ctx;
00993 COMPAR=argv[1];
00994 if (n==3) COMPKEY=argv[2]; else COMPKEY=0;
00995 if (islist(seq)) {
00996 n=0;
00997 work=seq;
00998 xsp=ctx->vsp;
00999 while (islist(work)) { ckpush(ccar(work)); work=ccdr(work); n++;}
01000 COMPTYPE=ELM_FIXED;
01001 qsort(xsp,n,sizeof(pointer),(int (*)())compar);
01002 work=seq;
01003 for (i=0; i<n; i++) { pointer_update(ccar(work),*xsp++); work=ccdr(work);}
01004 ctx->vsp-=n;}
01005 else if (isvector(seq)) {
01006 COMPTYPE=elmtypeof(seq);
01007 if (COMPTYPE==ELM_CHAR || COMPTYPE==ELM_BYTE) width=1;
01008 else if (COMPTYPE==ELM_BIT || COMPTYPE==ELM_FOREIGN) error(E_NOVECTOR);
01009 else width=sizeof(eusinteger_t);
01010 qsort(seq->c.vec.v,vecsize(seq),width,(int (*)())compar);}
01011 #if THREADED
01012 mutex_unlock(&qsort_lock);
01013 #endif
01014 return(seq);}
01015
01016 pointer LENGTH(ctx,n,argv)
01017 register context *ctx;
01018 int n;
01019 pointer argv[];
01020 { register pointer a=argv[0];
01021 register int l;
01022 ckarg(1);
01023 if (isnum(a)) error(E_NOSEQ);
01024 if (a==NIL) return(makeint(0));
01025 else if (piscons(a)) {
01026 l=0;
01027 while (islist(a)) { l++; a=ccdr(a);}
01028 return(makeint(l));}
01029 else if (pisarray(a)) {
01030 if (a->c.ary.rank!=makeint(1)) error(E_NOSEQ);
01031 if (a->c.ary.fillpointer==NIL) return(a->c.ary.dim[0]);
01032 else return(a->c.ary.fillpointer);}
01033 else if (elmtypeof(a)) return(a->c.vec.size);
01034 else error(E_NOSEQ);}
01035
01036 pointer ELT(ctx,n,argv)
01037 register context *ctx;
01038 int n;
01039 pointer argv[];
01040 { register pointer a=argv[0];
01041 register eusinteger_t i=ckintval(argv[1]);
01042 ckarg(2);
01043 if (islist(a)) {
01044 if (i<0) error(E_SEQINDEX);
01045 while (i-->0 && islist(a)) a=ccdr(a);
01046 if (islist(a)) return(ccar(a));
01047 else error(E_SEQINDEX);}
01048 else if (isvector(a)) return((pointer)vref(a,i));
01049 else if (isarray(a) && a->c.ary.rank==makeint(1))
01050 return((pointer)vref(a->c.ary.entity, i));
01051 else error(E_USER,(pointer)"no sequence");}
01052
01053 pointer SETELT(ctx,n,argv)
01054 register context *ctx;
01055 int n;
01056 register pointer argv[];
01057 { register pointer a=argv[0];
01058 register eusinteger_t i=ckintval(argv[1]);
01059 ckarg(3);
01060 if (islist(a)) {
01061 if (i<0) error(E_SEQINDEX);
01062 while (i-->0 && islist(a)) a=ccdr(a);
01063 if (islist(a)) {pointer_update(ccar(a),argv[2]);return(argv[2]);}
01064 else error(E_SEQINDEX);}
01065 else { vset(a,i,argv[2]); return(argv[2]);}}
01066
01067
01068 void sequence(ctx,mod)
01069 register context *ctx;
01070 pointer mod;
01071 {
01072 QIDENTITY=defun(ctx,"IDENTITY",mod,IDENTITY);
01073 QIDENTITY=QIDENTITY->c.sym.spefunc;
01074 defun(ctx,"SUBSEQ",mod,SUBSEQ);
01075 defun(ctx,"COPY-SEQ",mod,COPYSEQ);
01076 defun(ctx,"REVERSE",mod,REVERSE);
01077 defun(ctx,"NREVERSE",mod,NREVERSE);
01078 defun(ctx,"CONCATENATE",mod,CONCATENATE);
01079 defun(ctx,"COERCE",mod,COERCE);
01080 defun(ctx,"MAP",mod,MAP);
01081 defunpkg(ctx,"RAW-FILL",mod,FILL,syspkg);
01082 defunpkg(ctx,"RAW-POSITION",mod,POSITION,syspkg);
01083 defunpkg(ctx,"RAW-FIND",mod,FIND,syspkg);
01084 defunpkg(ctx,"RAW-COUNT",mod,COUNT,syspkg);
01085 defunpkg(ctx,"UNIVERSAL-REMOVE",mod,UNIREMOVE,syspkg);
01086 defunpkg(ctx,"RAW-REMOVE-DUPLICATES",mod,REMOVE_DUPLICATES,syspkg);
01087 defunpkg(ctx,"RAW-DELETE",mod,DELETE,syspkg);
01088 defunpkg(ctx,"RAW-SUBSTITUTE",mod,SUBSTITUTE,syspkg);
01089 defunpkg(ctx,"RAW-NSUBSTITUTE",mod,NSUBSTITUTE,syspkg);
01090 defunpkg(ctx,"VECTOR-REPLACE",mod,VECREPLACE,syspkg);
01091 defun(ctx,"SORT",mod,SORT);
01092 defun(ctx,"LENGTH",mod,LENGTH);
01093 defun(ctx,"ELT",mod,ELT);
01094 defun(ctx,"SETELT",mod,SETELT);
01095 }