sequence.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* sequence.c
3 /*
4 /* Copyright Toshihiro MATSUI, ETL, Umezono, Sakura-mura
5 /* 1986-Aug
6 /* 1987-Apr
7 /* 1987-July RPLACA and RPLACD are added
8 /* 1988-July REPLACE,REMOVE,POSITION,FIND,DELETE
9 /* are made compatible with CommonLisp
10 /****************************************************************/
11 static char *rcsid="@(#)$Id$";
12 
13 #include "eus.h"
14 #include <math.h> /* for round in coerceintval */
15 
16 #if (WORD_SIZE == 64)
17 #define bitref(vec,index) (((vec)->c.ivec.iv[(index)/64] >> ((index)%64)) & 1L)
18 #define bitset(vec,index,val) \
19  (val?((vec)->c.ivec.iv[(index)/64] |= (1L<<((index)%64))): \
20  ((vec)->c.ivec.iv[(index)/64] &= ~(1L<<((index)%64))))
21 #define MAX_SEQUENCE_COUNT 100000000
22 #else
23 #define bitref(vec,index) (((vec)->c.ivec.iv[(index)/32] >> ((index)%32)) & 1)
24 #define bitset(vec,index,val) \
25  (val?((vec)->c.ivec.iv[(index)/32] |= (1<<((index)%32))): \
26  ((vec)->c.ivec.iv[(index)/32] &= ~(1<<((index)%32))))
27 #define MAX_SEQUENCE_COUNT 1000000
28 #endif
29 
30 extern pointer QEQ;
31 pointer QIDENTITY;
32 static pointer pushrest;
33 
34 extern int pushsequence(context *,pointer,int,int);
35 extern pointer makesequence(context *, int,pointer);
36 
37 pointer call1(ctx,func,arg)
38 register context *ctx;
39 pointer func,arg;
40 { vpush(arg);
41  arg=ufuncall(ctx,func,func,(pointer)(ctx->vsp-1),NULL,1);
42  ctx->vsp-=1;
43  return(arg);}
44 
45 pointer call2(ctx,func,arg1,arg2)
46 register context *ctx;
47 pointer func,arg1,arg2;
48 { vpush(arg1); vpush(arg2);
49  arg1=ufuncall(ctx,func,func,(pointer)(ctx->vsp-2),NULL,2);
50  ctx->vsp-=2;
51  return(arg1);}
52 
53 /* type-independent vector access primitives */
54 
55 eusinteger_t coerceintval(x)
56 register pointer x;
57 { numunion nu;
58  int y;
59  if (isflt(x)) return((eusinteger_t)round(fltval(x)));
60  else return((eusinteger_t)bigintval(x));
61  }
62 
63 pointer fastvref(vec,index)
64 register pointer vec;
65 register int index;
66 { register byte *p=vec->c.str.chars;
67  eusinteger_t *pl=vec->c.ivec.iv;
68  long ival;
69  numunion nu;
70 
71  switch(elmtypeof(vec)) {
72  case ELM_FOREIGN: p=vec->c.foreign.chars;
73  case ELM_CHAR: case ELM_BYTE: return(makeint(p[index]));
74  case ELM_INT: ival=vec->c.ivec.iv[index];
75  return(mkbigint(ival));
76  case ELM_FLOAT: return(makeflt(vec->c.fvec.fv[index]));
77 #if (WORD_SIZE == 64)
78  case ELM_BIT: return(makeint((pl[index/64] & (1L<<((eusinteger_t)index%64)))?1L:0L));
79 #else
80  case ELM_BIT: return(makeint((pl[index/32] & (1<<((eusinteger_t)index%32)))?1:0));
81 #endif
82  case ELM_POINTER: return(vec->c.vec.v[index]);} }
83 
84 void fastvset(vec,index,val)
85 register pointer vec,val;
86 register int index;
87 { register byte *p;
88  numunion nu;
89  switch(elmtypeof(vec)) {
90  case ELM_INT: vec->c.ivec.iv[index]=coerceintval(val); return;
91  case ELM_FLOAT: vec->c.fvec.fv[index]=ckfltval(val); return;
92  case ELM_POINTER: pointer_update(vec->c.vec.v[index],val); return;
93  case ELM_CHAR: case ELM_BYTE:
94  vec->c.str.chars[index]=coerceintval(val); return;
95 #if (WORD_SIZE == 64)
96  case ELM_BIT: if (coerceintval(val) & 1L)
97  vec->c.ivec.iv[index/64] |= 1L << (index%64);
98  else vec->c.ivec.iv[index/64] &= ~(1L<<index%64);
99 #else
100  case ELM_BIT: if (coerceintval(val) & 1)
101  vec->c.ivec.iv[index/32] |= 1 << (index%32);
102  else vec->c.ivec.iv[index/32] &= ~(1<<index%32);
103 #endif
104  return;
105  case ELM_FOREIGN: p=vec->c.foreign.chars;
106  p[index]=coerceintval(val); return;} }
107 
108 /*************************************************/
109 
110 pointer IDENTITY(ctx,n,argv)
111 register context *ctx;
112 int n;
113 register pointer argv[];
114 { ckarg(1);
115  return(argv[0]);}
116 
117 pointer SUBSEQ(ctx,n,argv)
118 register context *ctx;
119 int n;
120 pointer argv[];
121 { register pointer a=argv[0],r;
122  register eusinteger_t s,e,i=0,count;
123  pointer fastvref();
124  void fastvset();
125  ckarg2(2,3);
126  s=ckintval(argv[1]);
127  if (n==3) {
128  e=ckintval(argv[2]);
129  if (e<s) error(E_STARTEND);}
130  if (a==NIL)return(NIL);
131  else if (islist(a)) {
132  while (islist(a) && i++<s) a=ccdr(a);
133  if (!islist(a)) error(E_STARTEND);
134  i=0;
135  if (n==3) {
136  while (s<e) {
137  if (!islist(a)) break;
138  ckpush(ccar(a)); a=ccdr(a); i++; s++;}}
139  else while (islist(a)) { ckpush(ccar(a)); a=ccdr(a); i++;}
140  return((pointer)stacknlist(ctx,i));}
141  else if (isarray(a)) {
142  s+=intval(a->c.ary.offset);
143  e+=intval(a->c.ary.offset);
144  a=a->c.ary.entity;}
145  if (isvector(a)) {
146  count=vecsize(a);
147  if (n==3) e=min(e,count);
148  else e=count;
149  count=e-s;
150  switch(elmtypeof(a)) {
151  case ELM_BIT:
152  r=makevector(classof(a), count);
153  while (count-->0) fastvset(r,i++,fastvref(a,s++));
154  return(r);
155  case ELM_BYTE: case ELM_CHAR:
156  r=makevector(classof(a), count);
157  memcpy(&r->c.str.chars[i], &a->c.str.chars[s], count);
158  return(r);
159  case ELM_FOREIGN:
160  { byte *p;
161  r=makevector(C_STRING, count);
162  p=a->c.foreign.chars;
163  memcpy(&r->c.str.chars[i], &p[s], count);
164  return(r);}
165  default:
166  r=makevector(classof(a), count);
167  memcpy(&r->c.vec.v[i], &a->c.vec.v[s], count*sizeof(pointer));
168  return(r);
169  }
170  }
171  else error(E_NOSEQ);}
172 
173 pointer COPYSEQ(ctx,n,argv)
174 register context *ctx;
175 int n;
176 pointer *argv;
177 { register pointer a,r;
178  register int i=0,s,k;
179  register byte *p;
180  ckarg(1);
181  a=argv[0];
182  if (a==NIL) return(NIL);
183  else if (islist(a)) {
184  while (islist(a)) { ckpush(ccar(a)); a=ccdr(a); i++;}
185  r=NIL;
186  while (i-->0) r=cons(ctx,vpop(),r);
187  return(r);}
188  else if (isarray(a)) {
189  if (a->c.ary.rank>makeint(1)) error(E_NOSEQ);
190  k=intval(a->c.ary.dim[0]);
191  s=intval(a->c.ary.offset);
192  a=a->c.ary.entity;}
193  if (isvector(a)) { k=vecsize(a); s=0;}
194  else error(E_NOSEQ);
195  p=a->c.str.chars;
196  switch(elmtypeof(a)) {
197  case ELM_BIT:
198  r=makevector(classof(a), k);
199  for (i=0; i<k; s++, i++) bitset(r,i,bitref(a,s));
200  break;
201  case ELM_FOREIGN:
202  r=makevector(C_STRING, k);
203  p=a->c.foreign.chars;
204  memcpy(r->c.str.chars, &p[s] ,k);
205  break;
206  case ELM_BYTE: case ELM_CHAR:
207  r=makevector(classof(a), k);
208  memcpy(r->c.str.chars, &p[s], k);
209  break;
210  default:
211  r=makevector(classof(a), k);
212  memcpy(r->c.vec.v, &a->c.vec.v[s], k*sizeof(pointer));
213  break;
214  }
215  return(r);}
216 
217 pointer REVERSE(ctx,n,argv)
218 register context *ctx;
219 int n;
220 pointer argv[];
221 { register pointer a=argv[0],r=NIL;
222  register byte *p;
223  register eusinteger_t i,k,s,e;
224  ckarg(1);
225  if (a==NIL) return(NIL);
226  else if (islist(a)) {
227  while (islist(a)) { r=cons(ctx,ccar(a),r); a=ccdr(a);}
228  return(r);}
229  else if (isarray(a)) {
230  if (a->c.ary.rank>makeint(1)) error(E_NOSEQ);
231  s=intval(a->c.ary.offset);
232  k=intval(a->c.ary.dim[0]);
233  a=a->c.ary.entity;}
234  else if (isvector(a)) { k=vecsize(a); s=0;}
235  else error(E_NOSEQ);
236  r=makevector(classof(a),k);
237  p=a->c.str.chars;
238  switch(elmtypeof(a)) {
239  case ELM_BIT: for (i=0; i<k; s++,i++) bitset(r,k-i-1,bitref(a,s));
240  break;
241  case ELM_FOREIGN: r=makevector(C_STRING, k); p=a->c.foreign.chars;
242  case ELM_CHAR: case ELM_BYTE:
243  for (i=0; i<k; s++,i++) r->c.str.chars[k-i-1]=p[s];
244  break;
245  default: for (i=0; i<k; s++,i++) pointer_update(r->c.vec.v[k-i-1],a->c.vec.v[s]);
246  break;}
247  return(r);}
248 
249 pointer NREVERSE(ctx,n,argv)
250 register context *ctx;
251 int n;
252 pointer argv[];
253 { register pointer a=argv[0],r=NIL, *vp;
254  register eusinteger_t i,k,s,kk,x,y;
255  register byte *cp;
256  ckarg(1);
257  if (a==NIL) return(NIL);
258  else if (islist(a)) {
259  i=0; r=a;
260  while (islist(r)) { ckpush(ccar(r)); r=ccdr(r); i++;}
261  r=a;
262  while (i>0) { pointer_update(ccar(r),vpop()); r=ccdr(r); i--;}
263  return(a);}
264  else if (isarray(a)) {
265  if (a->c.ary.rank>makeint(1)) error(E_NOSEQ);
266  s=intval(a->c.ary.offset);
267  k=intval(a->c.ary.dim[0]);
268  a=a->c.ary.entity;}
269  else if (isvector(a)) { k=vecsize(a); s=0;}
270  else error(E_NOSEQ);
271  kk=k/2; vp=a->c.vec.v;
272  cp=a->c.str.chars;
273  switch(elmtypeof(a)) {
274  case ELM_BIT:
275  for(i=0; i<kk; i++, s++) {
276  x=bitref(a,s);
277  y=bitref(a,k-i-1);
278 #if (WORD_SIZE == 64)
279  if (y) a->c.ivec.iv[s/64] |= (1L<<(s%64));
280  else a->c.ivec.iv[s/64] &= ~(1L<<(s%64));
281  if (x) a->c.ivec.iv[(k-i-1)/64] |= (1L<<((k-i-1)%64));
282  else a->c.ivec.iv[(k-i-1)/64] &= ~(1L<<((k-i-1)%64));
283 #else
284  if (y) a->c.ivec.iv[s/32] |= (1<<(s%32));
285  else a->c.ivec.iv[s/32] &= ~(1<<(s%32));
286  if (x) a->c.ivec.iv[(k-i-1)/32] |= (1<<((k-i-1)%32));
287  else a->c.ivec.iv[(k-i-1)/32] &= ~(1<<((k-i-1)%32));
288 #endif
289  }
290  break;
291  case ELM_FOREIGN: cp=a->c.foreign.chars;
292  case ELM_CHAR: case ELM_BYTE:
293  for(i=0; i<kk; i++, s++) {
294  x=cp[s]; cp[s]=cp[k-i-1]; cp[k-i-1]=x;}
295  break;
296  default:
297  vp=a->c.vec.v;
298  for(i=0; i<kk; i++, s++) {
299  r=vp[s]; pointer_update(vp[s],vp[k-i-1]); vp[k-i-1]=r;}
300  break; }
301  return(a);}
302 
303 int pushsequence(ctx,a,offset,count)
304 register context *ctx;
305 register pointer a;
306 register int offset,count;
307 { long i,len=0, x;
308  byte *p;
309  numunion nu;
310 
311  if (a==NIL) return(0);
312  else if (iscons(a)) {
313  while (offset-->0) { a=cdrof(a,E_SEQINDEX);}
314  while (count-->0 && iscons(a)) { ckpush(ccar(a)); a=ccdr(a); len++;}
315  pushrest=a;
316  return(len);}
317  else {
318  if (isarray(a)) {
319  if (a->c.ary.rank!=makeint(1)) error(E_NOSEQ);
320  offset+=intval(a->c.ary.offset); a=a->c.ary.entity;}
321  if (!isvector(a)) error(E_NOSEQ);
322  i=0; len=vecsize(a)-offset; len=min(len,count);
323  p=a->c.str.chars;
324  switch(elmtypeof(a)) {
325  case ELM_FOREIGN: p=a->c.foreign.chars; /* no break*/
326  case ELM_CHAR: case ELM_BYTE: while (i<len) ckpush(makeint(p[offset+i++]));
327  return(len);
328  case ELM_INT: while (i<len) {
329  x=a->c.ivec.iv[offset+i++];
330  ckpush(makeint(x)); }
331  return(len);
332  case ELM_FLOAT: while (i<len) ckpush(makeflt(a->c.fvec.fv[offset+i++]));
333  return(len);
334  case ELM_BIT: { eusinteger_t m, b;
335  while (i<len) {
336 #if (WORD_SIZE == 64)
337  m= 1L<<((offset+i)%64);
338  b=a->c.ivec.iv[(offset+i)/64] & m;
339 #else
340  m= 1<<((offset+i)%32);
341  b=a->c.ivec.iv[(offset+i)/32] & m;
342 #endif
343  ckpush(makeint(b?1:0));
344  i++;}
345  return(len);}
346  case ELM_POINTER: while (i<len) ckpush(a->c.vec.v[offset+i++]);
347  return(len);} }}
348 
349 pointer makesequence(ctx,n,resulttype)
350 register context *ctx;
351 register int n;
352 pointer resulttype;
353 { register pointer x,r;
354  register int cid=intval(resulttype->c.cls.cix);
355  numunion nu;
356  if (cid==conscp.cix) return((pointer)stacknlist(ctx,n));
357  else if (cid<=conscp.sub) {
358  r=NIL;
359  while (n-- > 0) {
360  vpush(r);
361  x=(pointer)makeobject(resulttype);
362  r=vpop();
363  pointer_update(x->c.cons.car,vpop());
364  pointer_update(x->c.cons.cdr,r);
365  r=x;}
366  return(r);}
367  else {
368  r=makevector(resulttype,n);
369  switch(elmtypeof(r)) {
370  case ELM_INT: while (--n>=0) r->c.ivec.iv[n]=coerceintval(vpop());
371  return(r);
372  case ELM_FLOAT: while (--n>=0) {
373  x=vpop();
374  r->c.fvec.fv[n]=ckfltval(x);}
375  return(r);
376  case ELM_POINTER: while (--n>=0) pointer_update(r->c.vec.v[n],vpop());
377  return(r);
378  case ELM_CHAR: case ELM_BYTE:
379  while (--n>=0) r->c.str.chars[n]=coerceintval(vpop());
380  return(r);
381  case ELM_BIT: while (--n>=0)
382 #if (WORD_SIZE == 64)
383  r->c.ivec.iv[n/64]|=(coerceintval(vpop()) & 1L)<<(n%64);
384 #else
385  r->c.ivec.iv[n/32]|=(coerceintval(vpop()) & 1)<<(n%32);
386 #endif
387  return(r);
388  case ELM_FOREIGN: error(E_USER,(pointer)"cannot coerce to foreign string"); } } }
389 
390 pointer CONCATENATE(ctx,n,argv)
391 register context *ctx;
392 int n;
393 register pointer argv[];
394 { register int i,argc=1,resultlen=0;
395  if (n<=1) return(NIL);
396  if (!isclass(argv[0])) error(E_NOCLASS,argv[0]);
397  while (argc<n) resultlen+=pushsequence(ctx,argv[argc++],0,MAX_SEQUENCE_COUNT);
398  return(makesequence(ctx,resultlen,argv[0]));}
399 
400 pointer COERCE(ctx,n,argv)
401 register context *ctx;
402 register int n;
403 register pointer argv[];
404 { register eusinteger_t offset,count,len,i;
405  register pointer a=argv[0];
406  ckarg(2);
407  if (!isclass(argv[1])) error(E_NOCLASS,argv[1]);
408  if (isarray(a)) {
409  if (a->c.ary.rank!=makeint(1)) error(E_NOSEQ,a);
410  offset=intval(a->c.ary.offset);
411  count=intval(a->c.ary.dim[0]);
412  a=a->c.ary.entity;}
413  else { offset=0; count=MAX_SEQUENCE_COUNT;}
414  len=pushsequence(ctx,a,offset,count);
415  return(makesequence(ctx,len,argv[1])); }
416 
417 pointer FILL(ctx,n,argv)
418 register context *ctx;
419 register int n;
420 pointer argv[];
421 { /* (Fill seq item :start :end) */
422  register pointer seq=argv[0], item=argv[1];
423  register eusinteger_t i=0,start,end, val, count;
424  eusfloat_t fval;
425  byte *bp;
426  numunion nu;
427 
428  ckarg(4);
429  start=ckintval(argv[2]); end=ckintval(argv[3]);
430  if (islist(seq)) {
431  while (i++<start && islist(seq)) seq=ccdr(seq);
432  while (start<end) {
433  if (!iscons(seq)) break;
434  pointer_update(ccar(seq),item); seq=ccdr(seq);
435  start++;}
436  return(argv[0]); }
437  else if (isvector(seq)) end=min(end,vecsize(seq));
438  else if (isarray(seq)) {
439  if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
440  end=min(end,intval(seq->c.ary.dim[0]))+intval(seq->c.ary.offset);
441  start+=intval(seq->c.ary.offset);
442  seq=seq->c.ary.entity;}
443  else error(E_NOSEQ);
444  switch (elmtypeof(seq)) {
445  case ELM_INT: val=coerceintval(item);
446  while (start<end) seq->c.ivec.iv[start++]=val;
447  break;
448  case ELM_FLOAT: fval=ckfltval(item);
449  while (start<end) seq->c.fvec.fv[start++]=fval;
450  break;
451  case ELM_POINTER: while (start<end) seq->c.vec.v[start++]=item; break;
452  case ELM_CHAR: case ELM_BYTE:
453  val = coerceintval(item);
454  bp=seq->c.str.chars;
455  while (start<end) bp[start++]=val;
456  break;
457  case ELM_BIT:
458 #if (WORD_SIZE == 64)
459  while (((start % 64) != 0) && (start<end))
460  fastvset(seq,start++,item);
461  count = (end-start)/64;
462  val= (coerceintval(item)==0L)?0L:~0L;
463  for (i=0; i<count; i++)
464  seq->c.ivec.iv[start/64+i]=val; /*all zero or all one*/
465  start = start + count*64;
466 #else
467  while (((start % 32) != 0) && (start<end))
468  fastvset(seq,start++,item);
469  count = (end-start)/32;
470  val= (coerceintval(item)==0)?0:~0;
471  for (i=0; i<count; i++)
472  seq->c.ivec.iv[start/32+i]=val; /*all zero or all one*/
473  start = start + count*32;
474 #endif
475  while (start<end) fastvset(seq, start++, item);
476  break;
477  case ELM_FOREIGN:
478  bp=seq->c.foreign.chars;
479  val=coerceintval(item);
480  while (start<end) bp[start++]=val;
481  break;
482  }
483  return(argv[0]);}
484 
485 pointer MAP(ctx,n,argv)
486 register context *ctx;
487 register int n;
488 pointer argv[];
489 { /* (MAP result-type function &rest seq) */
490  register pointer func=argv[1], argseq,r;
491  register eusinteger_t argc,rcount=0,offset;
492 
493  if (n<3) error(E_MISMATCHARG);
494  while (1) {
495  argc=0;
496  /*collect args*/
497  while (argc+2<n) {
498  argseq=argv[argc+2];
499  if (iscons(argseq)) {
500  ckpush(ccar(argseq));
501  argv[argc+2]=ccdr(argseq);}
502  else {
503  if (isarray(argseq)) {
504  if (argseq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
505  offset=intval(argseq->c.ary.offset);
506  argseq=argseq->c.ary.entity;}
507  else offset=0;
508  if (isvector(argseq) && vecsize(argseq)>rcount+offset)
509  ckpush(fastvref(argseq,rcount+offset));
510  else { ctx->vsp-=argc; goto makeresult;} }
511  argc++;}
512  r=ufuncall(ctx,ctx->callfp->form,func,(pointer)(ctx->vsp-argc),NULL,argc);
513  ctx->vsp-=argc;
514  vpush(r);
515  rcount++;}
516 makeresult:
517  if (isclass(argv[0])) return(makesequence(ctx,rcount,argv[0]));
518  else { ctx->vsp-=rcount; return(NIL);}}
519 
520 pointer POSITION(ctx,n,argv)
521 register context *ctx;
522 int n;
523 register pointer *argv;
524 { register pointer item=argv[0],seq=argv[1],element;
525  pointer test=argv[2],testnot=argv[3],key=argv[4];
526  pointer iftest=argv[5],ifnottest=argv[6];
527  register eusinteger_t start,end,count,i=0;
528 
529  ckarg(10);
530  start=ckintval(argv[7]); end=ckintval(argv[8]); count=ckintval(argv[9]);
531 
532  if (seq==NIL) return(NIL);
533  else if (islist(seq)) {
534  while (i++<start && islist(seq)) seq=ccdr(seq);
535  if (!islist(seq)) return(NIL);}
536  else if (isvector(seq)) end=min(end,vecsize(seq));
537  else if (isarray(seq)) {
538  if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
539  seq=seq->c.ary.entity; end=min(end,vecsize(seq));}
540  else error(E_NOSEQ);
541  while (start<end) {
542  /* elt */
543  if (seq==NIL) return(NIL);
544  else if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
545  else element=fastvref(seq,start);
546  if (key!=QIDENTITY) element=call1(ctx,key,element);
547  if (ifnottest!=NIL) {
548  if (call1(ctx,ifnottest,element)==NIL&&--count<=0) return(makeint(start));}
549  else if (iftest!=NIL) {
550  if (call1(ctx,iftest,element)!=NIL&&--count<=0) return(makeint(start));}
551  else if (testnot!=NIL) {
552  if (call2(ctx,testnot,item,element)==NIL&&--count<=0) return(makeint(start));}
553  else if (test!=QEQ) {
554  if (call2(ctx,test,item,element)!=NIL&&--count<=0) return(makeint(start));}
555  else if (item==element&&--count<=0) return(makeint(start));
556  start++;}
557  return(NIL);}
558 
559 pointer FIND(ctx,n,argv)
560 register context *ctx;
561 int n;
562 register pointer *argv;
563 { register pointer item=argv[0],seq=argv[1],element,testelement;
564  pointer test=argv[2],testnot=argv[3],key=argv[4];
565  pointer iftest=argv[5],ifnottest=argv[6];
566  register eusinteger_t start,end,i=0;
567 
568  ckarg(9);
569  start=ckintval(argv[7]); end=ckintval(argv[8]);
570 
571  if (seq==NIL) return(NIL);
572  else if (islist(seq)) {
573  while (i++<start && islist(seq)) seq=ccdr(seq);
574  if (!islist(seq)) return(NIL);}
575  else {
576  if (isarray(seq)) {
577  if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
578  seq=seq->c.ary.entity;}
579  if (isvector(seq)) end=min(end,vecsize(seq));
580  else error(E_NOSEQ);}
581  while (start<end) {
582  /* elt */
583  if (seq==NIL) return(NIL);
584  else if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
585  else element=fastvref(seq,start);
586  if (key!=QIDENTITY) testelement=call1(ctx,key,element);
587  else testelement=element;
588  if (ifnottest!=NIL) {
589  if (call1(ctx,ifnottest,testelement)==NIL) return(element);}
590  else if (iftest!=NIL) {
591  if (call1(ctx,iftest,testelement)!=NIL) return(element);}
592  else if (testnot!=NIL) {
593  if (call2(ctx,testnot,item,testelement)==NIL) return(element);}
594  else if (test!=QEQ) {
595  if (call2(ctx,test,item,testelement)!=NIL) return(element);}
596  else if (item==testelement) return(element);
597  start++;}
598  return(NIL);}
599 
600 pointer COUNT(ctx,n,argv)
601 register context *ctx;
602 int n;
603 register pointer *argv;
604 { register pointer item=argv[0],seq=argv[1],element,testelement;
605  pointer test=argv[2],testnot=argv[3],key=argv[4];
606  pointer iftest=argv[5],ifnottest=argv[6];
607  register eusinteger_t start,end,i=0;
608 
609  ckarg(9);
610  start=ckintval(argv[7]); end=ckintval(argv[8]);
611 
612  if (seq==NIL) return(makeint(0));
613  else if (islist(seq)) {
614  while (i++<start && islist(seq)) seq=ccdr(seq);
615  if (!islist(seq)) return(NIL);}
616  else {
617  if (isarray(seq)) {
618  if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
619  seq=seq->c.ary.entity;}
620  if (isvector(seq)) end=min(end,vecsize(seq));
621  else error(E_NOSEQ);}
622  i=0;
623  while (start<end) {
624  /* elt */
625  if (seq==NIL) return(makeint(i));
626  else if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
627  else element=fastvref(seq,start);
628  if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
629  if (ifnottest!=NIL) {
630  if (call1(ctx,ifnottest,testelement)==NIL) i++;}
631  else if (iftest!=NIL) {
632  if (call1(ctx,iftest,testelement)!=NIL) i++;}
633  else if (testnot!=NIL) {
634  if (call2(ctx,testnot,item,testelement)==NIL) i++;}
635  else if (test!=QEQ) {
636  if (call2(ctx,test,item,testelement)!=NIL) i++;}
637  else if (item==testelement) i++;
638  start++;}
639  return(makeint(i));}
640 
641 pointer UNIREMOVE(ctx,n,argv)
642 register context *ctx;
643 int n;
644 register pointer argv[];
645 { pointer item=argv[0],seq=argv[1],test=argv[2],testnot=argv[3],key=argv[4];
646  pointer iftest=argv[5],ifnottest=argv[6];
647  register pointer element,testelement;
648  eusinteger_t start,end,count,i,testresult,pushcount;
649 
650  ckarg(10);
651  start=ckintval(argv[7]); end=ckintval(argv[8]); count=ckintval(argv[9]);
652  if (seq==NIL) return(NIL);
653  else {
654  if (isarray(seq)) {
655  if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
656  seq=seq->c.ary.entity;}
657  if (isvector(seq)) end=min(end,vecsize(seq));
658  else if (!iscons(seq)) error(E_NOSEQ);}
659  pushcount=pushsequence(ctx,seq,0,start);
660  if (iscons(seq)) seq=pushrest;
661  while (start<end && count>0) {
662  if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
663  else if (isvector(seq)) element=fastvref(seq,start);
664  else error(E_SEQINDEX); /*list exhausted*/
665  start++;
666  if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
667  if (ifnottest!=NIL) testresult=(call1(ctx,ifnottest,testelement)==NIL);
668  else if (iftest!=NIL) testresult=(call1(ctx,iftest,testelement)!=NIL);
669  else if (testnot!=NIL) testresult=(call2(ctx,testnot,item,testelement)==NIL);
670  else if (test!=QEQ) testresult=(call2(ctx,test,item,testelement)!=NIL);
671  else testresult=(item==testelement);
672  if (testresult) { count--;}
673  else { ckpush(element); pushcount++;}}
674  if (iscons(argv[1])) {
675  while (pushcount-->0) seq=cons(ctx,vpop(),seq);
676  return(seq);}
677  else {
678  pushcount+=pushsequence(ctx,seq,end,MAX_SEQUENCE_COUNT);
679  return(makesequence(ctx,pushcount,classof(seq)));}}
680 
681 pointer REMOVE_DUPLICATES(ctx,n,argv)
682 register context *ctx;
683 int n;
684 pointer argv[];
685 { pointer seq=argv[0],test=argv[1],testnot=argv[2],key=argv[3];
686  register pointer element,testelement,seq2,element2;
687  register eusinteger_t i,start,end,testresult,pushcount;
688 
689  ckarg(6);
690  start=ckintval(argv[4]); end=ckintval(argv[5]);
691  if (seq==NIL) return(NIL);
692  if (isvector(seq)) end=min(end,vecsize(seq));
693  else if (!iscons(seq)) error(E_NOSEQ);
694  pushcount=pushsequence(ctx,seq,0,start);
695  if (iscons(seq)) seq=pushrest;
696  while (start<end) {
697  if (seq==NIL) break;
698  if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
699  else if (isvector(seq)) element=fastvref(seq,start);
700  else error(E_SEQINDEX); /*list exhausted*/
701  start++;
702  if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
703  i=start; seq2=seq; testresult=0;
704  while (i<end) {
705  if (seq2==NIL) break;
706  else if (iscons(seq2)) { element2=ccar(seq2); seq2=ccdr(seq2); }
707  else if (isvector(seq2)) element2=fastvref(seq2,i);
708  else error(E_SEQINDEX); /*list exhausted*/
709  i++;
710  if (key!=QIDENTITY) element2=call1(ctx,key,element2);
711  if (testnot!=NIL) testresult=(call2(ctx,testnot,testelement,element2)==NIL);
712  else if (test!=QEQ) testresult=(call2(ctx,test,testelement,element2)!=NIL);
713  else testresult=(testelement==element2);
714  if (testresult) /*duplicated!*/ break;}
715  if (!testresult) {ckpush(element); pushcount++;} }
716  if (iscons(argv[0])) {
717  while (pushcount-->0) seq=cons(ctx,vpop(),seq);
718  return(seq);}
719  else {
720  pushcount+=pushsequence(ctx,seq,end,MAX_SEQUENCE_COUNT);
721  return(makesequence(ctx,pushcount,classof(seq)));}}
722 
723 pointer DELETE(ctx,n,argv)
724 register context *ctx;
725 int n;
726 pointer argv[];
727 { pointer item=argv[0],seq=argv[1],test=argv[2],testnot=argv[3],key=argv[4];
728  pointer iftest=argv[5],ifnottest=argv[6];
729  register pointer element,testelement,result=seq,lastseq;
730  eusinteger_t start,end,count,i,testresult,first,lastindex;
731 
732  ckarg(10);
733  start=ckintval(argv[7]); end=ckintval(argv[8]); count=ckintval(argv[9]);
734  lastindex=start;
735  if (seq==NIL) return(NIL);
736  if (isarray(seq)) {
737  if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
738  seq=seq->c.ary.entity;}
739  if (isvector(seq)) end=min(end,vecsize(seq));
740  else if (!iscons(seq)) error(E_NOSEQ);
741 
742  if (iscons(seq)) {
743  first=(start==0);
744  for (i=0; i<start; i++) if (iscons(seq)) seq=ccdr(seq); else error(E_SEQINDEX);
745  lastseq=seq;}
746  while (start<end && count>0) {
747  if (iscons(seq)) element=ccar(seq);
748  else if (isvector(seq)) element=fastvref(seq,start);
749  else error(E_SEQINDEX); /*list exhausted*/
750  if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
751  if (ifnottest!=NIL) testresult=(call1(ctx,ifnottest,testelement)==NIL);
752  else if (iftest!=NIL) testresult=(call1(ctx,iftest,testelement)!=NIL);
753  else if (testnot!=NIL) testresult=(call2(ctx,testnot,item,testelement)==NIL);
754  else if (test!=QEQ) testresult=(call2(ctx,test,item,testelement)!=NIL);
755  else testresult=(item==testelement);
756  if (iscons(result)) {
757  if (testresult) {
758  count--;
759  if (first) { result=ccdr(seq);}
760  else { ccdr(lastseq)=ccdr(seq); first=0;}}
761  else { lastseq = seq; first=0;}
762  seq = ccdr(seq);}
763  else if (isvector(seq)) {
764  if (testresult) { count--;}
765  else {
766  if (start!=lastindex) fastvset(seq,lastindex,element);
767  lastindex++;} }
768  else error(E_SEQINDEX);
769  start++; }
770  if (isvector(result)) result->c.vec.size=makeint(lastindex);
771  return(result);}
772 
773 pointer SUBSTITUTE(ctx,n,argv)
774 register context *ctx;
775 int n;
776 register pointer argv[];
777 { pointer newitem=argv[0], olditem=argv[1], seq=argv[2];
778  pointer test=argv[3],testnot=argv[4],key=argv[5];
779  pointer iftest=argv[6],ifnottest=argv[7];
780  register pointer element,testelement;
781  register eusinteger_t i,start,end,count,testresult,pushcount;
782 
783  ckarg(11);
784  start=ckintval(argv[8]); end=ckintval(argv[9]); count=ckintval(argv[10]);
785  if (seq==NIL) return(NIL);
786  if (isarray(seq)) {
787  if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
788  seq=seq->c.ary.entity;}
789  if (isvector(seq)) end=min(end,vecsize(seq));
790  else if (!iscons(seq)) error(E_NOSEQ);
791  pushcount=pushsequence(ctx,seq,0,start);
792  if (iscons(seq)) seq=pushrest;
793  while (start<end && count>0) {
794  if (iscons(seq)) { element=ccar(seq); seq=ccdr(seq);}
795  else if (isvector(seq)) element=fastvref(seq,start);
796  else error(E_SEQINDEX); /*list exhausted*/
797  start++;
798  if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
799  if (ifnottest!=NIL) testresult=(call1(ctx,ifnottest,testelement)==NIL);
800  else if (iftest!=NIL) testresult=(call1(ctx,iftest,testelement)!=NIL);
801  else if (testnot!=NIL) testresult=(call2(ctx,testnot,olditem,testelement)==NIL);
802  else if (test!=QEQ) testresult=(call2(ctx,test,olditem,testelement)!=NIL);
803  else testresult=(olditem==testelement);
804 
805  if (testresult) { count--; ckpush(newitem);}
806  else { ckpush(element);}
807  pushcount++;}
808  if (iscons(argv[2])) {
809  while (pushcount-->0) seq=cons(ctx,vpop(),seq);
810  return(seq);}
811  else {
812  pushcount+=pushsequence(ctx,seq,end,MAX_SEQUENCE_COUNT);
813  return(makesequence(ctx,pushcount,classof(seq)));}}
814 
815 pointer NSUBSTITUTE(ctx,n,argv)
816 register context *ctx;
817 int n;
818 pointer argv[];
819 { pointer newitem=argv[0], olditem=argv[1], seq=argv[2];
820  pointer test=argv[3],testnot=argv[4],key=argv[5];
821  pointer iftest=argv[6],ifnottest=argv[7];
822  register pointer element,testelement;
823  register eusinteger_t i,start,end,count,testresult;
824 
825  ckarg(11);
826  start=ckintval(argv[8]); end=ckintval(argv[9]); count=ckintval(argv[10]);
827  if (seq==NIL) return(NIL);
828  if (isarray(seq)) {
829  if (seq->c.ary.rank!=makeint(1)) error(E_NOSEQ);
830  seq=seq->c.ary.entity;}
831  if (isvector(seq)) end=min(end,vecsize(seq));
832  else if (!iscons(seq)) error(E_NOSEQ);
833 
834  if (iscons(seq))
835  for (i=0; i<start; i++) if (iscons(seq)) seq=ccdr(seq); else error(E_SEQINDEX);
836  while (start<end && count>0) {
837  if (iscons(seq)) element=ccar(seq);
838  else if (isvector(seq)) element=fastvref(seq,start);
839  else error(E_SEQINDEX); /*list exhausted*/
840  if (key!=QIDENTITY) testelement=call1(ctx,key,element); else testelement=element;
841  if (ifnottest!=NIL) testresult=(call1(ctx,ifnottest,testelement)==NIL);
842  else if (iftest!=NIL) testresult=(call1(ctx,iftest,testelement)!=NIL);
843  else if (testnot!=NIL) testresult=(call2(ctx,testnot,olditem,testelement)==NIL);
844  else if (test!=QEQ) testresult=(call2(ctx,test,olditem,testelement)!=NIL);
845  else testresult=(olditem==testelement);
846  if (testresult) {
847  count--;
848  if (iscons(seq)) {pointer_update(ccar(seq),newitem);}
849  else if (isvector(seq)) fastvset(seq,start,newitem);
850  else error(E_SEQINDEX); }
851  if (iscons(seq)) seq=ccdr(seq);
852  start++;}
853  return(argv[2]);}
854 
855 /*replace vector elements in the first argument with the second argument*/
856 /* Bug: offset is ignored if vector is displaced to another array */
857 
858 pointer VECREPLACE(ctx,n,argv)
859 register context *ctx;
860 int n;
861 pointer argv[];
862 { register int i,count;
863  register pointer src,dest;
864  register byte *p, *p2;
865  int srcelmt,destelmt;
866  eusinteger_t ss,ds,se,de;
867  numunion nu;
868 
869  ckarg2(2,6);
870  dest=argv[0]; if (isarray(dest)) dest=dest->c.ary.entity;
871  src=argv[1]; if (isarray(src)) src=src->c.ary.entity;
872  if (!isvector(src) || !isvector(dest)) error(E_NOVECTOR);
873  ds=(n==2)?0:ckintval(argv[2]);
874  de=(n<=3)?vecsize(dest):ckintval(argv[3]);
875  ss=(n<=4)?0:ckintval(argv[4]);
876  se=(n<=5)?vecsize(src):ckintval(argv[5]);
877 
878  count=min(de-ds,se-ss);
879  de=ds+count;
880  srcelmt=elmtypeof(src);
881  destelmt=elmtypeof(dest);
882  if (srcelmt==ELM_BIT) {
883 #if (WORD_SIZE == 64)
884  if (destelmt==ELM_BIT && ss==0 && ds==0 && ((count%64) == 0)) {
885  /*copy word by word*/
886  for (i=0; i<count/64; i++) dest->c.ivec.iv[i] = src->c.ivec.iv[i];
887  return(argv[0]);}
888 #else
889  if (destelmt==ELM_BIT && ss==0 && ds==0 && ((count%32) == 0)) {
890  /*copy word by word*/
891  for (i=0; i<count/32; i++) dest->c.ivec.iv[i] = src->c.ivec.iv[i];
892  return(argv[0]);}
893 #endif
894  else goto general_replace;}
895  if (srcelmt==destelmt ||
896  (srcelmt==ELM_BYTE || srcelmt==ELM_CHAR || srcelmt==ELM_FOREIGN) &&
897  (destelmt==ELM_BYTE || destelmt==ELM_CHAR || destelmt==ELM_FOREIGN)) {
898  /*speed up for simple cases: calculate byte count*/
899  if (srcelmt!=ELM_BYTE && srcelmt!=ELM_CHAR && srcelmt!=ELM_FOREIGN)
900  { count*=sizeof(eusinteger_t); ss*=sizeof(eusinteger_t); ds*=sizeof(eusinteger_t);}
901  if (srcelmt==ELM_FOREIGN) p=src->c.foreign.chars + ss;
902  else p= &(src->c.str.chars[ss]);
903  if (destelmt==ELM_FOREIGN) p2=dest->c.foreign.chars + ds;
904  else p2= &(dest->c.str.chars[ds]);
905  if (srcelmt==ELM_FOREIGN || destelmt==ELM_FOREIGN) /*copy byte by byte*/
906  for (i=0; i<count; i++) *p2++ = *p++;
907  else memcpy((void *)p2, (void *)p, (size_t)count);
908  return(argv[0]);}
909 
910 general_replace:
911  /*coercion is required*/
912  /* extract src elements and place them on stack*/
913  pushsequence(ctx,src,ss,count);
914  if (destelmt==ELM_FOREIGN) p=dest->c.foreign.chars;
915  else p=dest->c.str.chars;
916  switch(destelmt) {
917  case ELM_INT: while (count-->0)
918  dest->c.ivec.iv[--de]=coerceintval(vpop());
919  break;
920  case ELM_FLOAT: while (count-->0) {
921  src=vpop();
922  dest->c.fvec.fv[--de]=ckfltval(src);}
923  break;
924  case ELM_POINTER: while (count-->0) {--de;pointer_update(dest->c.vec.v[de],vpop());}
925  break;
926  case ELM_CHAR: case ELM_BYTE: case ELM_FOREIGN:
927  while (count-->0) p[--de]=coerceintval(vpop());
928  break;
929  case ELM_BIT: while (count-->0) {
930  de--;
931 #if (WORD_SIZE == 64)
932  if (coerceintval(vpop()) & 1L)
933  dest->c.ivec.iv[de/64] |= 1L << (de%64);
934  else dest->c.ivec.iv[de/64] &= ~(1L << (de%64));
935 #else
936  if (coerceintval(vpop()) & 1)
937  dest->c.ivec.iv[de/32] |= 1 << (de%32);
938  else dest->c.ivec.iv[de/32] &= ~(1 << (de%32));
939 #endif
940  }
941  break; }
942  return(argv[0]);}
943 
944 
945 /****************************************************************/
946 /* SORT --- quicker sort
947 /****************************************************************/
948 
949 static pointer COMPAR,COMPKEY;
950 static int COMPTYPE;
951 context *qsortctx;
952 
953 int compar(x,y)
954 pointer *x, *y;
955 { pointer xx,yy,result;
956  eusfloat_t *fx,*fy;
957  numunion nu;
958 
959  switch (COMPTYPE) {
960  case ELM_CHAR: case ELM_BYTE:
961  xx= makeint(*(char *)x); yy= makeint(*(char *)y); break;
962  case ELM_INT: xx=makeint((eusinteger_t)(*x)); yy=makeint((eusinteger_t)(*y)); break;
963  case ELM_FLOAT:
964  fx=(eusfloat_t *)x; fy=(eusfloat_t *)y;
965  xx=makeflt(*fx); yy=makeflt(*fy); break;
966  default: xx= *x; yy= *y;}
967  if (COMPKEY) {
968  xx=call1(qsortctx,COMPKEY,xx);
969  (*qsortctx->vsp++=((pointer)xx)); // vpush
970  yy=call1(qsortctx,COMPKEY,yy);
971  (*qsortctx->vsp++=((pointer)yy)); // vpush
972  }
973  result=call2(qsortctx,COMPAR,xx,yy);
974  if (COMPKEY) {
975  (*(--(qsortctx->vsp))); // vpop
976  (*(--(qsortctx->vsp))); // vpop
977  }
978  if (result==NIL) return(1); else return(-1);}
979 
980 pointer SORT(ctx,n,argv)
981 register context *ctx;
982 register int n;
983 pointer argv[];
984 { register pointer seq,work;
985  pointer *xsp;
986  register int i,width;
987  ckarg2(2,3);
988  seq=argv[0];
989  if (seq==NIL) return(NIL);
990 
991 #if THREADED
992  mutex_lock(&qsort_lock);
993 #endif
994  qsortctx=ctx;
995  COMPAR=argv[1];
996  if (n==3) COMPKEY=argv[2]; else COMPKEY=0;
997  if (islist(seq)) { /*sort list destructively*/
998  n=0;
999  work=seq;
1000  xsp=ctx->vsp;
1001  while (islist(work)) { ckpush(ccar(work)); work=ccdr(work); n++;}
1002  COMPTYPE=ELM_FIXED;
1003  qsort(xsp,n,sizeof(pointer),(int (*)())compar);
1004  work=seq;
1005  for (i=0; i<n; i++) { pointer_update(ccar(work),*xsp++); work=ccdr(work);}
1006  ctx->vsp-=n;}
1007  else if (isvector(seq)) {
1008  COMPTYPE=elmtypeof(seq);
1009  if (COMPTYPE==ELM_CHAR || COMPTYPE==ELM_BYTE) width=1;
1010  else if (COMPTYPE==ELM_BIT || COMPTYPE==ELM_FOREIGN) error(E_NOVECTOR);
1011  else width=sizeof(eusinteger_t);
1012  qsort(seq->c.vec.v,vecsize(seq),width,(int (*)())compar);}
1013 #if THREADED
1014  mutex_unlock(&qsort_lock);
1015 #endif
1016  return(seq);}
1017 
1018 pointer LENGTH(ctx,n,argv)
1019 register context *ctx;
1020 int n;
1021 pointer argv[];
1022 { register pointer a=argv[0];
1023  register int l;
1024  ckarg(1);
1025  if (isnum(a)) error(E_NOSEQ);
1026  if (a==NIL) return(makeint(0));
1027  else if (piscons(a)) {
1028  l=0;
1029  while (islist(a)) { l++; a=ccdr(a);}
1030  return(makeint(l));}
1031  else if (pisarray(a)) {
1032  if (a->c.ary.rank!=makeint(1)) error(E_NOSEQ);
1033  if (a->c.ary.fillpointer==NIL) return(a->c.ary.dim[0]);
1034  else return(a->c.ary.fillpointer);}
1035  else if (elmtypeof(a)) return(a->c.vec.size);
1036  else error(E_NOSEQ);}
1037 
1038 pointer ELT(ctx,n,argv)
1039 register context *ctx;
1040 int n;
1041 pointer argv[];
1042 { register pointer a=argv[0];
1043  register eusinteger_t i=ckintval(argv[1]);
1044  ckarg(2);
1045  if (islist(a)) {
1046  if (i<0) error(E_SEQINDEX);
1047  while (i-->0 && islist(a)) a=ccdr(a);
1048  if (islist(a)) return(ccar(a));
1049  else error(E_SEQINDEX);}
1050  else if (isvector(a)) return((pointer)vref(a,i));
1051  else if (isarray(a) && a->c.ary.rank==makeint(1))
1052  return((pointer)vref(a->c.ary.entity, i));
1053  else error(E_USER,(pointer)"no sequence");}
1054 
1055 pointer SETELT(ctx,n,argv)
1056 register context *ctx;
1057 int n;
1058 register pointer argv[];
1059 { register pointer a=argv[0]; /* (setelt seq index val) */
1060  register eusinteger_t i=ckintval(argv[1]);
1061  ckarg(3);
1062  if (islist(a)) {
1063  if (i<0) error(E_SEQINDEX);
1064  while (i-->0 && islist(a)) a=ccdr(a);
1065  if (islist(a)) {pointer_update(ccar(a),argv[2]);return(argv[2]);}
1066  else error(E_SEQINDEX);}
1067  else { vset(a,i,argv[2]); return(argv[2]);}}
1068 
1069 
1070 void sequence(ctx,mod)
1071 register context *ctx;
1072 pointer mod;
1073 {
1074  QIDENTITY=defun(ctx,"IDENTITY",mod,IDENTITY,NULL);
1075  QIDENTITY=QIDENTITY->c.sym.spefunc;
1076  defun(ctx,"SUBSEQ",mod,SUBSEQ,NULL);
1077  defun(ctx,"COPY-SEQ",mod,COPYSEQ,NULL);
1078  defun(ctx,"REVERSE",mod,REVERSE,NULL);
1079  defun(ctx,"NREVERSE",mod,NREVERSE,NULL);
1080  defun(ctx,"CONCATENATE",mod,CONCATENATE,NULL);
1081  defun(ctx,"COERCE",mod,COERCE,NULL);
1082  defun(ctx,"MAP",mod,MAP,NULL);
1083  defunpkg(ctx,"RAW-FILL",mod,FILL,syspkg);
1084  defunpkg(ctx,"RAW-POSITION",mod,POSITION,syspkg);
1085  defunpkg(ctx,"RAW-FIND",mod,FIND,syspkg);
1086  defunpkg(ctx,"RAW-COUNT",mod,COUNT,syspkg);
1087  defunpkg(ctx,"UNIVERSAL-REMOVE",mod,UNIREMOVE,syspkg);
1088  defunpkg(ctx,"RAW-REMOVE-DUPLICATES",mod,REMOVE_DUPLICATES,syspkg);
1089  defunpkg(ctx,"RAW-DELETE",mod,DELETE,syspkg);
1090  defunpkg(ctx,"RAW-SUBSTITUTE",mod,SUBSTITUTE,syspkg);
1091  defunpkg(ctx,"RAW-NSUBSTITUTE",mod,NSUBSTITUTE,syspkg);
1092  defunpkg(ctx,"VECTOR-REPLACE",mod,VECREPLACE,syspkg);
1093  defun(ctx,"SORT",mod,SORT,NULL);
1094  defun(ctx,"LENGTH",mod,LENGTH,NULL);
1095  defun(ctx,"ELT",mod,ELT,NULL);
1096  defun(ctx,"SETELT",mod,SETELT,NULL);
1097  }
intvector::iv
eusinteger_t iv[1]
Definition: eus.h:305
compar
int compar(pointer *x, pointer *y)
Definition: sequence.c:953
se
static char se[3]
Definition: helpsub.c:27
_class::cix
pointer cix
Definition: eus.h:327
cell::cellunion::vec
struct vector vec
Definition: eus.h:414
fastvset
void fastvset(pointer vec, int index, pointer val)
Definition: sequence.c:84
cell::cellunion::cls
struct _class cls
Definition: eus.h:418
NSUBSTITUTE
pointer NSUBSTITUTE(context *ctx, int n, argv)
Definition: sequence.c:815
makeint
#define makeint(v)
Definition: sfttest.c:2
pointer
struct cell * pointer
Definition: eus.h:165
context
Definition: eus.h:524
cons
pointer cons(context *, pointer, pointer)
Definition: makes.c:97
QIDENTITY
pointer QIDENTITY
Definition: sequence.c:31
cell::cellunion::str
struct string str
Definition: eus.h:402
end
Definition: eustags.c:162
COMPTYPE
static int COMPTYPE
Definition: sequence.c:950
string::chars
byte chars[1]
Definition: eus.h:212
context::vsp
pointer * vsp
Definition: eus.h:525
arrayheader::fillpointer
pointer fillpointer
Definition: eus.h:313
n
GLfloat n[6][3]
Definition: cube.c:15
cell::cellunion::ary
struct arrayheader ary
Definition: eus.h:413
DELETE
pointer DELETE(context *ctx, int n, argv)
Definition: sequence.c:723
call1
pointer call1(context *ctx, pointer func, pointer arg)
Definition: sequence.c:37
FILL
pointer FILL(context *ctx, int n, argv)
Definition: sequence.c:417
foreign::chars
byte * chars
Definition: eus.h:216
makesequence
pointer makesequence(context *, int, pointer)
Definition: sequence.c:349
argc
static int argc
Definition: transargv.c:56
defunpkg
pointer defunpkg(context *, char *, pointer, pointer(*)(), pointer)
Definition: makes.c:636
vset
pointer vset(pointer, int, pointer)
Definition: vectorarray.c:89
conscp
cixpair conscp
Definition: eus.c:70
cell::cellunion::foreign
struct foreign foreign
Definition: eus.h:403
qsortctx
context * qsortctx
Definition: sequence.c:951
intval
#define intval(p)
Definition: sfttest.c:1
defun
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
POSITION
pointer POSITION(context *ctx, int n, pointer *argv)
Definition: sequence.c:520
ufuncall
pointer ufuncall(context *, pointer, pointer, pointer, struct bindframe *, int)
Definition: eval.c:1469
COMPAR
static pointer COMPAR
Definition: sequence.c:949
E_USER
Definition: eus.h:1006
C_STRING
pointer C_STRING
Definition: eus.c:146
makevector
pointer makevector(pointer, int)
Definition: makes.c:417
cell::cellunion::sym
struct symbol sym
Definition: eus.h:401
ckarg
ckarg(2)
ckfltval
float ckfltval()
arrayheader::offset
pointer offset
Definition: eus.h:313
cons::cdr
pointer cdr
Definition: eus.h:196
min
#define min(x, y)
Definition: rmflags.c:17
FIND
pointer FIND(context *ctx, int n, pointer *argv)
Definition: sequence.c:559
cell::cellunion::cons
struct cons cons
Definition: eus.h:400
key
static void key(unsigned char c, int x, int y)
Definition: dinoshade.c:753
cell::cellunion::ivec
struct intvector ivec
Definition: eus.h:416
E_NOCLASS
Definition: eus.h:962
cell::c
union cell::cellunion c
sequence
void sequence(context *ctx, pointer mod)
Definition: sequence.c:1070
NREVERSE
pointer NREVERSE(context *ctx, int n, argv)
Definition: sequence.c:249
pushrest
static pointer pushrest
Definition: sequence.c:32
arrayheader::entity
pointer entity
Definition: eus.h:313
coerceintval
eusinteger_t coerceintval(pointer x)
Definition: sequence.c:55
SUBSTITUTE
pointer SUBSTITUTE(context *ctx, int n, argv)
Definition: sequence.c:773
numunion
Definition: eus.h:428
rcsid
static char * rcsid
Definition: sequence.c:11
l
long l
Definition: structsize.c:3
cell
Definition: eus.h:381
s
short s
Definition: structsize.c:2
pushsequence
int pushsequence(context *, pointer, int, int)
Definition: sequence.c:303
vector::size
pointer size
Definition: eus.h:300
SORT
pointer SORT(context *ctx, int n, argv)
Definition: sequence.c:980
start
static time_stamp_t start
Definition: rgc_utils.c:75
cixpair::sub
short sub
Definition: eus.h:454
arrayheader::rank
pointer rank
Definition: eus.h:313
error
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
eusinteger_t
long eusinteger_t
Definition: eus.h:19
arrayheader::dim
pointer dim[ARRAYRANKLIMIT]
Definition: eus.h:313
COPYSEQ
pointer COPYSEQ(context *ctx, int n, pointer *argv)
Definition: sequence.c:173
bp
static int bp
Definition: helpsub.c:22
UNIREMOVE
pointer UNIREMOVE(context *ctx, int n, argv)
Definition: sequence.c:641
stacknlist
pointer stacknlist(context *, int)
Definition: makes.c:129
E_NOSEQ
Definition: eus.h:977
fltval
float fltval()
qsort_lock
mutex_t qsort_lock
Definition: mthread.c:21
COUNT
pointer COUNT(context *ctx, int n, pointer *argv)
Definition: sequence.c:600
count
int count
Definition: thrtest.c:11
index
char * index(char *sp, char c)
Definition: eustags.c:1669
LENGTH
pointer LENGTH(context *ctx, int n, argv)
Definition: sequence.c:1018
call2
pointer call2(context *ctx, pointer func, pointer arg1, pointer arg2)
Definition: sequence.c:45
NULL
#define NULL
Definition: transargv.c:8
MAP
pointer MAP(context *ctx, int n, argv)
Definition: sequence.c:485
VECREPLACE
pointer VECREPLACE(context *ctx, int n, argv)
Definition: sequence.c:858
SETELT
pointer SETELT(context *ctx, int n, argv)
Definition: sequence.c:1055
CONCATENATE
pointer CONCATENATE(context *ctx, int n, argv)
Definition: sequence.c:390
IDENTITY
pointer IDENTITY(context *ctx, int n, argv)
Definition: sequence.c:110
makeobject
pointer makeobject(pointer)
Definition: makes.c:407
byte
unsigned char byte
Definition: eus.h:163
floatvector::fv
eusfloat_t fv[1]
Definition: eus.h:309
REVERSE
pointer REVERSE(context *ctx, int n, argv)
Definition: sequence.c:217
symbol::spefunc
pointer spefunc
Definition: eus.h:203
vref
pointer vref(pointer, int)
Definition: vectorarray.c:38
cixpair::cix
short cix
Definition: eus.h:453
eusfloat_t
double eusfloat_t
Definition: eus.h:21
QEQ
pointer QEQ
Definition: eus.c:127
NIL
pointer NIL
Definition: eus.c:110
syspkg
pointer syspkg
Definition: eus.c:109
SUBSEQ
pointer SUBSEQ(context *ctx, int n, argv)
Definition: sequence.c:117
COERCE
pointer COERCE(context *ctx, int n, argv)
Definition: sequence.c:400
vector::v
pointer v[1]
Definition: eus.h:301
fastvref
pointer fastvref(pointer vec, int index)
Definition: sequence.c:63
cons::car
pointer car
Definition: eus.h:196
REMOVE_DUPLICATES
pointer REMOVE_DUPLICATES(context *ctx, int n, argv)
Definition: sequence.c:681
ELT
pointer ELT(context *ctx, int n, argv)
Definition: sequence.c:1038
a
char a[26]
Definition: freq.c:4
COMPKEY
static pointer COMPKEY
Definition: sequence.c:949
cell::cellunion::fvec
struct floatvector fvec
Definition: eus.h:415
makeflt
pointer makeflt()

euslisp
Author(s): Toshihiro Matsui
autogenerated on Mon Feb 28 2022 22:18:28