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