lists.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* LIST functions
3 /* 1988-July-7
4 /* Copyright(C) Toshihiro Matsui, Electrotechnical Laboratory
5 /* all rights reserved.
6 /****************************************************************/
7 static char *rcsid="@(#)$Id$";
8 
9 #include "eus.h"
10 
11 extern pointer equal();
12 extern pointer call1(context *, pointer, pointer);
13 extern pointer call2(context *, pointer, pointer, pointer);
14 
15 /* CAR/CDR combinations*/
16 
17 pointer CAR(ctx,n,argv)
18 register context *ctx;
19 register int n;
20 register pointer *argv;
21 { register pointer a=argv[0];
22  ckarg(1);
23  if (iscons(a)) return(ccar(a));
24  if (a==NIL) return(NIL);
25  error(E_NOLIST);}
26 
27 pointer CDR(ctx,n,argv)
28 register context *ctx;
29 register int n;
30 register pointer *argv;
31 { register pointer a=argv[0];
32  ckarg(1);
33  if (iscons(a)) return(ccdr(a));
34  if (a==NIL) return(NIL);
35  error(E_NOLIST);}
36 
37 pointer CADR(ctx,n,argv)
38 register context *ctx;
39 register int n;
40 register pointer argv[];
41 { register pointer p=argv[0];
42  ckarg(1);
43  if (iscons(p)) p=ccdr(p);
44  else if (p==NIL) return(NIL);
45  else error(E_NOLIST);
46  if (iscons(p)) return(ccar(p));
47  else if (p==NIL) return(NIL);
48  else error(E_NOLIST);}
49 
50 pointer CDDR(ctx,n,argv)
51 register context *ctx;
52 register int n;
53 register pointer argv[];
54 { register pointer p=argv[0];
55  ckarg(1);
56  if (iscons(p)) p=ccdr(p);
57  else if (p==NIL) return(NIL);
58  else error(E_NOLIST);
59  if (iscons(p)) return(ccdr(p));
60  else if (p==NIL) return(NIL);
61  else error(E_NOLIST);}
62 
63 pointer CDAR(ctx,n,argv)
64 register context *ctx;
65 register int n;
66 register pointer argv[];
67 { register pointer p=argv[0];
68  ckarg(1);
69  if (iscons(p)) p=ccar(p);
70  else if (p==NIL) return(NIL);
71  else error(E_NOLIST);
72  if (iscons(p)) return(ccdr(p));
73  else if (p==NIL) return(NIL);
74  else error(E_NOLIST);}
75 
76 pointer CAAR(ctx,n,argv)
77 register context *ctx;
78 register int n;
79 register pointer argv[];
80 { register pointer p=argv[0];
81  ckarg(1);
82  if (iscons(p)) p=ccar(p);
83  else if (p==NIL) return(NIL);
84  else error(E_NOLIST);
85  if (iscons(p)) return(ccar(p));
86  else if (p==NIL) return(NIL);
87  else error(E_NOLIST);}
88 
89 pointer CADDR(ctx,n,argv)
90 register context *ctx;
91 register int n;
92 register pointer argv[];
93 { register pointer p=argv[0];
94  ckarg(1);
95  if (iscons(p)) p=ccdr(p);
96  else if (p==NIL) return(NIL);
97  else error(E_NOLIST);
98  if (iscons(p)) p=ccdr(p);
99  else if (p==NIL) return(NIL);
100  else error(E_NOLIST);
101  if (iscons(p)) return(ccar(p));
102  else if (p==NIL) return(NIL);
103  else error(E_NOLIST);}
104 
105 pointer NTH(ctx,n,argv)
106 register context *ctx;
107 register int n;
108 register pointer *argv;
109 { register int i;
110  register pointer a=argv[1];
111  ckarg(2);
112  i=ckintval(argv[0]);
113  if (i<0) error(E_NOINT);
114  while (i-->0 && islist(a)) a=ccdr(a);
115  if (islist(a)) return(ccar(a));
116  else if (a==NIL) return(NIL);
117  else error(E_NOLIST);}
118 
119 pointer NTHCDR(ctx,n,argv)
120 register context *ctx;
121 register int n;
122 register pointer *argv;
123 { register int i;
124  register pointer a;
125  ckarg(2);
126  i=ckintval(argv[0]);
127  a=argv[1];
128  if (i<0) error(E_NOINT);
129  if (a==NIL) return(NIL);
130  else if (!islist(a)) error(E_NOLIST);
131  while (i-->0 && islist(a)) a=ccdr(a);
132  return(a);}
133 
134 pointer CONS(ctx,n,argv)
135 register context *ctx;
136 register int n;
137 register pointer *argv;
138 { ckarg(2);
139  return(cons(ctx,argv[0],argv[1]));}
140 
141 pointer RPLACA(ctx,n,argv)
142 register context *ctx;
143 register int n;
144 register pointer argv[];
145 { register pointer a=argv[0];
146  ckarg(2);
147  if (islist(a)) {pointer_update(ccar(a),argv[1]);}
148  else error(E_NOLIST);
149  return(a);}
150 
151 pointer RPLACA2(ctx,n,argv)
152 register context *ctx;
153 register int n;
154 register pointer argv[];
155 { register pointer a=argv[0];
156  ckarg(2);
157  if (islist(a)) {pointer_update(ccar(a),argv[1]);}
158  else error(E_NOLIST);
159  return(argv[1]);}
160 
161 pointer RPLACD(ctx,n,argv)
162 register context *ctx;
163 register int n;
164 register pointer argv[];
165 { register pointer a=argv[0];
166  ckarg(2);
167  if (islist(a)) {pointer_update(ccdr(a),argv[1]);}
168  else error(E_NOLIST);
169  return(a);}
170 
171 pointer RPLACD2(ctx,n,argv)
172 register context *ctx;
173 register int n;
174 register pointer argv[];
175 { register pointer a=argv[0];
176  ckarg(2);
177  if (islist(a)) {pointer_update(ccdr(a),argv[1]);}
178  else error(E_NOLIST);
179  return(argv[1]);}
180 
181 pointer LIST(ctx,n,argv)
182 register context *ctx;
183 register int n;
184 register pointer argv[];
185 { register pointer result=NIL;
186  while (n>0) result=cons(ctx,argv[--n],result);
187  return(result);}
188 
189 pointer LIST_STAR(ctx,n,argv)
190 register context *ctx;
191 register int n;
192 register pointer argv[];
193 { register pointer result=argv[--n];
194  while (n>0) result=cons(ctx,argv[--n],result);
195  return(result);}
196 
197 pointer APPEND(ctx,n,argv)
198 register context *ctx;
199 register int n;
200 register pointer argv[];
201 { register pointer a,r;
202  register int i;
203  if (n==0) return(NIL);
204  r=argv[--n];
205  while (n>0) {
206  a=argv[--n];
207  if (!islist(a) && a != NIL) error(E_NOLIST);
208  i=0;
209  while (islist(a)) { ckpush(ccar(a)); a=ccdr(a); i++;}
210  while (i-->0) r=cons(ctx,vpop(),r);}
211  return(r);}
212 
213 pointer NCONC(ctx,n,argv)
214 register context *ctx;
215 register int n;
216 register pointer argv[];
217 { register pointer a,c;
218  while (--n>=0) if (islist(argv[n])) goto nconc1;
219  return(NIL);
220 nconc1:
221  a=argv[n];
222  while (--n>=0) {
223  c=argv[n];
224  if (islist(c)) {
225  while (islist(ccdr(c))) { breakck; c=ccdr(c);}
226  pointer_update(ccdr(c),a);
227  a=argv[n];}
228  }
229  return(a);}
230 
231 pointer subst(ctx,x,y,z)
232 register context *ctx;
233 register pointer x,y,z;
234 { pointer temp;
235  if (equal(y,z)==T) return(x);
236  if (!islist(z)) return(z);
237  temp=subst(ctx,x,y,ccar(z));
238  vpush(temp);
239  temp = subst(ctx,x,y,ccdr(z));
240  return (cons(ctx,vpop(),temp));}
241 
242 /* (subst new old list) */
243 pointer SUBST(ctx,n,argv)
244 register context *ctx;
245 int n;
246 register pointer argv[];
247 {
248  ckarg(3);
249  return(subst(ctx,argv[0],argv[1],argv[2]));}
250 
251 pointer nsubst(x,y,z)
252 register pointer x,y, *z;
253 { register pointer zz= *z;
254  if (y==zz) pointer_update(*z,x);
255  if (iscons(zz)) {
256  nsubst(x,y,&(zz->c.cons.car));
257  nsubst(x,y,&(zz->c.cons.cdr));} }
258 
259 pointer NSUBST(ctx,n,argv)
260 register context *ctx;
261 int n;
262 register pointer argv[];
263 { ckarg(3);
264  nsubst(argv[0],argv[1],&argv[2]);
265  return(argv[2]);}
266 
267 pointer memq(item,list)
268 register pointer item,list;
269 { while (iscons(list))
270  if (ccar(list)==item) return(list);
271  else list=ccdr(list);
272  return(NIL);}
273 
274 pointer MEMQ(ctx,n,argv)
275 register context *ctx;
276 int n;
277 register pointer argv[];
278 { ckarg(2);
279  return(memq(argv[0],argv[1]));}
280 
281 pointer MEMBER(ctx,n,argv)
282 register context *ctx;
283 int n;
284 register pointer argv[];
285 { pointer item=argv[0],list=argv[1],result;
286  ckarg(2);
287  while (islist(list)) {
288  result=equal(ccar(list),item);
289  if (result==T) return(list);
290  else if (result==UNBOUND) error(E_CIRCULAR);
291  else list=ccdr(list);}
292  return(NIL);}
293 
294 pointer SUPERMEMBER(ctx,n,argv)
295 register context *ctx;
296 int n;
297 register pointer argv[];
298 { register pointer item=argv[0],list=argv[1];
299  pointer key=argv[2],test=argv[3],testnot=argv[4];
300  register pointer target;
301  eusinteger_t result;
302  ckarg(5);
303  while (islist(list)) {
304  target=ccar(list);
305  if (key!=NIL) target=call1(ctx,key,target);
306  if (testnot!=NIL) result=(call2(ctx,testnot,item,target)==NIL);
307  else if (test==QEQUAL) {
308  target=equal(item,target);
309  if (target==UNBOUND) error(E_CIRCULAR);
310  else result=(target!=NIL);}
311  else if (test!=NIL) result=(call2(ctx,test,item,target)!=NIL);
312  else result=(item==target);
313  if (result) return(list);
314  else list=ccdr(list);}
315  return(NIL);}
316 
317 pointer assq(item,alist)
318 register pointer item,alist;
319 { register pointer temp;
320  while (iscons(alist)) {
321  temp=ccar(alist);
322  if (iscons(temp)) {
323  if (ccar(temp)==item) return(temp);
324  else alist=ccdr(alist);}
325  else error(E_ALIST);}
326  return(NIL);}
327 
328 pointer ASSQ(ctx,n,argv)
329 register context *ctx;
330 int n;
331 register pointer argv[];
332 { ckarg(2);
333  return(assq(argv[0],argv[1])); }
334 
335 pointer ASSOC(ctx,n,argv)
336 register context *ctx;
337 int n;
338 register pointer argv[];
339 { register pointer item=argv[0],alist=argv[1],temp,compare;
340  ckarg(2);
341  while (islist(alist)) {
342  temp=ccar(alist);
343  if (islist(temp)) {
344  compare=equal(item,ccar(temp));
345  if (compare==T) return(temp);
346  else if (compare==UNBOUND) error(E_CIRCULAR);
347  else alist=ccdr(alist);}
348  else error(E_ALIST);}
349  return(NIL);}
350 
351 pointer SUPERASSOC(ctx,n,argv)
352 register context *ctx;
353 int n;
354 register pointer argv[];
355 { register pointer item=argv[0],alist=argv[1];
356  pointer key=argv[2],test=argv[3],testnot=argv[4];
357  register pointer temp,target;
358  register eusinteger_t compare;
359  ckarg(5);
360  while (islist(alist)) {
361  target=ccar(alist);
362  if (islist(target)) { /*ignore non-pair elements*/
363  if (key==NIL) temp=ccar(target);
364  else temp=call1(ctx,key,target);
365  if (testnot!=NIL) compare=(call2(ctx,testnot,item,temp)==NIL);
366  else if (test==NIL || test==QEQ) compare=(item==temp);
367  else if (test==QEQUAL) compare=(equal(item,temp)==T);
368  else compare=(call2(ctx,test,item,temp)!=NIL);
369  if (compare) return(target);}
370  alist=ccdr(alist);}
371  return(NIL);}
372 
373 pointer BUTLAST(ctx,n,argv)
374 register context *ctx;
375 register int n;
376 pointer argv[];
377 { register pointer a=argv[0];
378  register int count=0;
379  if (n==2) n=ckintval(argv[1]);
380  else n=1;
381  if (!iscons(a)) {
382  if (a==NIL) return(NIL);
383  else error(E_NOLIST); }
384  if (n<0) error(E_USER,(pointer)"The second argument must be non-negative number");
385  while (iscons(a)) { ckpush(ccar(a)); a=ccdr(a); count++;}
386  n=min(count,n);
387  ctx->vsp -= n;
388  return((pointer)stacknlist(ctx,count-n));}
389 
390 pointer NBUTLAST(ctx,n,argv)
391 register context *ctx;
392 register int n;
393 pointer argv[];
394 { register pointer a=argv[0], b;
395  register int count=0;
396  register pointer *vspsave=ctx->vsp;
397  if (n==2) n=ckintval(argv[1]);
398  else n=1;
399  if (!iscons(a)) {
400  if (a==NIL) return(NIL);
401  else error(E_NOLIST); }
402  if (n<0) error(E_USER,(pointer)"The second argument must be non-negative number");
403  while (iscons(a)) { ckpush(a); a=ccdr(a); count++;}
404  n=min(count,n);
405  b= *(ctx->vsp - n - 1);
406  pointer_update(ccdr(b),NIL);
407  return(argv[0]);}
408 
409 
410 
411 void lists(ctx,mod)
412 register context *ctx;
413 register pointer mod;
414 { defun(ctx,"CAR",mod,CAR,NULL);
415  defun(ctx,"CDR",mod,CDR,NULL);
416  defun(ctx,"REST",mod,CDR,NULL);
417  defun(ctx,"CADR",mod,CADR,NULL);
418  defun(ctx,"CDDR",mod,CDDR,NULL);
419  defun(ctx,"CDAR",mod,CDAR,NULL);
420  defun(ctx,"CAAR",mod,CAAR,NULL);
421  defun(ctx,"CADDR",mod,CADDR,NULL);
422  defun(ctx,"NTH",mod,NTH,NULL);
423  defun(ctx,"NTHCDR",mod,NTHCDR,NULL);
424  defun(ctx,"CONS",mod,CONS,NULL);
425  defun(ctx,"RPLACA",mod,RPLACA,NULL);
426  defun(ctx,"RPLACA2",mod,RPLACA2,NULL);
427  defun(ctx,"RPLACD",mod,RPLACD,NULL);
428  defun(ctx,"RPLACD2",mod,RPLACD2,NULL);
429  defun(ctx,"APPEND",mod,APPEND,NULL);
430  defun(ctx,"NCONC",mod,NCONC,NULL);
431  defun(ctx,"SUBST",mod,SUBST,NULL);
432  defun(ctx,"NSUBST",mod,NSUBST,NULL);
433 
434  defun(ctx,"BUTLAST",mod,BUTLAST,NULL);
435  defun(ctx,"NBUTLAST",mod,NBUTLAST,NULL);
436  defun(ctx,"LIST",mod,LIST,NULL);
437  defun(ctx,"LIST*",mod,LIST_STAR,NULL);
438  defun(ctx,"MEMQ",mod,MEMQ,NULL);
439  defun(ctx,"MEMBER",mod,MEMBER,NULL);
440  defun(ctx,"SUPERMEMBER",mod,SUPERMEMBER,NULL);
441  defun(ctx,"ASSQ",mod,ASSQ,NULL);
442  defun(ctx,"ASSOC",mod,ASSOC,NULL);
443  defun(ctx,"SUPERASSOC",mod,SUPERASSOC,NULL);
444  }
445 
RPLACD
pointer RPLACD(context *ctx, int n, argv)
Definition: lists.c:161
NIL
pointer NIL
Definition: eus.c:110
CADDR
pointer CADDR(context *ctx, int n, argv)
Definition: lists.c:89
defun
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
E_CIRCULAR
@ E_CIRCULAR
Definition: eus.h:969
context
Definition: eus.h:524
nsubst
pointer nsubst(pointer x, pointer y, pointer *z)
Definition: lists.c:251
NTHCDR
pointer NTHCDR(context *ctx, int n, pointer *argv)
Definition: lists.c:119
memq
pointer memq(pointer item, pointer list)
Definition: lists.c:267
BUTLAST
pointer BUTLAST(context *ctx, int n, argv)
Definition: lists.c:373
call2
pointer call2(context *, pointer, pointer, pointer)
Definition: sequence.c:45
CDAR
pointer CDAR(context *ctx, int n, argv)
Definition: lists.c:63
QEQUAL
pointer QEQUAL
Definition: eus.c:127
min
#define min(x, y)
Definition: rmflags.c:17
T
pointer T
Definition: eus.c:110
CDR
pointer CDR(context *ctx, int n, pointer *argv)
Definition: lists.c:27
key
static void key(unsigned char c, int x, int y)
Definition: dinoshade.c:753
eus.h
RPLACD2
pointer RPLACD2(context *ctx, int n, argv)
Definition: lists.c:171
RPLACA
pointer RPLACA(context *ctx, int n, argv)
Definition: lists.c:141
SUPERASSOC
pointer SUPERASSOC(context *ctx, int n, argv)
Definition: lists.c:351
call1
pointer call1(context *, pointer, pointer)
Definition: sequence.c:37
RPLACA2
pointer RPLACA2(context *ctx, int n, argv)
Definition: lists.c:151
cell::c
union cell::cellunion c
MEMBER
pointer MEMBER(context *ctx, int n, argv)
Definition: lists.c:281
LIST
pointer LIST(context *ctx, int n, argv)
Definition: lists.c:181
cons::cdr
pointer cdr
Definition: eus.h:197
SUBST
pointer SUBST(context *ctx, int n, argv)
Definition: lists.c:243
NULL
#define NULL
Definition: transargv.c:8
CONS
pointer CONS(context *ctx, int n, pointer *argv)
Definition: lists.c:134
NTH
pointer NTH(context *ctx, int n, pointer *argv)
Definition: lists.c:105
rcsid
static char * rcsid
Definition: lists.c:7
cell::cellunion::cons
struct cons cons
Definition: eus.h:400
SUPERMEMBER
pointer SUPERMEMBER(context *ctx, int n, argv)
Definition: lists.c:294
equal
pointer equal()
ASSQ
pointer ASSQ(context *ctx, int n, argv)
Definition: lists.c:328
cons
pointer cons(context *, pointer, pointer)
Definition: makes.c:97
E_ALIST
@ E_ALIST
Definition: eus.h:971
E_NOLIST
@ E_NOLIST
Definition: eus.h:949
E_NOINT
@ E_NOINT
Definition: eus.h:956
NCONC
pointer NCONC(context *ctx, int n, argv)
Definition: lists.c:213
assq
pointer assq(pointer item, pointer alist)
Definition: lists.c:317
error
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
count
int count
Definition: thrtest.c:11
APPEND
pointer APPEND(context *ctx, int n, argv)
Definition: lists.c:197
CAAR
pointer CAAR(context *ctx, int n, argv)
Definition: lists.c:76
cell
Definition: eus.h:381
eusinteger_t
long eusinteger_t
Definition: eus.h:19
CADR
pointer CADR(context *ctx, int n, argv)
Definition: lists.c:37
LIST_STAR
pointer LIST_STAR(context *ctx, int n, argv)
Definition: lists.c:189
NSUBST
pointer NSUBST(context *ctx, int n, argv)
Definition: lists.c:259
CAR
pointer CAR(context *ctx, int n, pointer *argv)
Definition: lists.c:17
stacknlist
pointer stacknlist(context *, int)
Definition: makes.c:129
CDDR
pointer CDDR(context *ctx, int n, argv)
Definition: lists.c:50
cons::car
pointer car
Definition: eus.h:196
NBUTLAST
pointer NBUTLAST(context *ctx, int n, argv)
Definition: lists.c:390
lists
void lists(context *ctx, pointer mod)
Definition: lists.c:411
MEMQ
pointer MEMQ(context *ctx, int n, argv)
Definition: lists.c:274
QEQ
pointer QEQ
Definition: eus.c:127
E_USER
@ E_USER
Definition: eus.h:1006
a
char a[26]
Definition: freq.c:4
ASSOC
pointer ASSOC(context *ctx, int n, argv)
Definition: lists.c:335
n
GLfloat n[6][3]
Definition: cube.c:15
subst
pointer subst(context *ctx, pointer x, pointer y, pointer z)
Definition: lists.c:231
ckarg
ckarg(2)

euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 15 2023 02:06:43