sequence.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* sequence.c
00003 /*
00004 /*      Copyright Toshihiro MATSUI, ETL, Umezono, Sakura-mura
00005 /*      1986-Aug
00006 /*      1987-Apr
00007 /*      1987-July       RPLACA and RPLACD are added
00008 /*      1988-July       REPLACE,REMOVE,POSITION,FIND,DELETE
00009 /*                      are made compatible with CommonLisp
00010 /****************************************************************/
00011 static char *rcsid="@(#)$Id$";
00012 
00013 #include "eus.h"
00014 #include <math.h> /* for round in coerceintval */
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 /* type-independent vector access primitives */
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; /* no break*/
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 { /* (Fill seq item :start :end) */
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;       /*all zero or all one*/
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;       /*all zero or all one*/
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 { /* (MAP result-type function &rest seq) */
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     /*collect args*/
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     /* elt */
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     /* elt */
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     /* elt */
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);     /*list exhausted*/
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);     /*list exhausted*/
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);   /*list exhausted*/
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) /*duplicated!*/ 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);     /*list exhausted*/
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);     /*list exhausted*/
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);     /*list exhausted*/
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 /*replace vector elements in the first argument with the second argument*/
00854 /* Bug: offset is ignored if vector is displaced to another array */
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       /*copy word by word*/
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       /*copy word by word*/
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     /*speed up for  simple cases:  calculate byte count*/
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) /*copy byte by byte*/
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   /*coercion is required*/
00910   /* extract src elements and place them on stack*/
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 /* SORT --- quicker sort
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)); // vpush
00968     yy=call1(qsortctx,COMPKEY,yy);
00969     (*qsortctx->vsp++=((pointer)yy)); // vpush
00970   }
00971   result=call2(qsortctx,COMPAR,xx,yy);
00972   if (COMPKEY) {
00973     (*(--(qsortctx->vsp))); // vpop
00974     (*(--(qsortctx->vsp))); // vpop
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)) {    /*sort list destructively*/
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];           /* (setelt seq index val) */
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   }


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Sep 3 2015 10:36:20