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 #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 /* type-independent vector access primitives */
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; /* no break*/
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 { /* (Fill seq item :start :end) */
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;       /*all zero or all one*/
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;       /*all zero or all one*/
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 { /* (MAP result-type function &rest seq) */
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     /*collect args*/
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     /* elt */
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     /* elt */
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     /* elt */
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);     /*list exhausted*/
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);     /*list exhausted*/
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);   /*list exhausted*/
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) /*duplicated!*/ 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);     /*list exhausted*/
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);     /*list exhausted*/
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);     /*list exhausted*/
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 /*replace vector elements in the first argument with the second argument*/
00856 /* Bug: offset is ignored if vector is displaced to another array */
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       /*copy word by word*/
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       /*copy word by word*/
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     /*speed up for  simple cases:  calculate byte count*/
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) /*copy byte by byte*/
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   /*coercion is required*/
00912   /* extract src elements and place them on stack*/
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 /* SORT --- quicker sort
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)); // vpush
00970     yy=call1(qsortctx,COMPKEY,yy);
00971     (*qsortctx->vsp++=((pointer)yy)); // vpush
00972   }
00973   result=call2(qsortctx,COMPAR,xx,yy);
00974   if (COMPKEY) {
00975     (*(--(qsortctx->vsp))); // vpop
00976     (*(--(qsortctx->vsp))); // vpop
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)) {    /*sort list destructively*/
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];           /* (setelt seq index val) */
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   }


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