Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | /* Copyright (C) 1995,1996 Free Software Foundation, Inc. |
2 | * | |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
15 | * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
16 | * | |
17 | * As a special exception, the Free Software Foundation gives permission | |
18 | * for additional uses of the text contained in its release of GUILE. | |
19 | * | |
20 | * The exception is that, if you link the GUILE library with other files | |
21 | * to produce an executable, this does not by itself cause the | |
22 | * resulting executable to be covered by the GNU General Public License. | |
23 | * Your use of that executable is in no way restricted on account of | |
24 | * linking the GUILE library code into it. | |
25 | * | |
26 | * This exception does not however invalidate any other reasons why | |
27 | * the executable file might be covered by the GNU General Public License. | |
28 | * | |
29 | * This exception applies only to the code released by the | |
30 | * Free Software Foundation under the name GUILE. If you copy | |
31 | * code from other Free Software Foundation releases into a copy of | |
32 | * GUILE, as the General Public License permits, the exception does | |
33 | * not apply to the code that you add in this way. To avoid misleading | |
34 | * anyone as to the status of such modified files, you must delete | |
35 | * this exception notice from them. | |
36 | * | |
37 | * If you write modifications of your own for GUILE, it is your choice | |
38 | * whether to permit this exception to apply to your modifications. | |
39 | * If you do not wish that, delete this exception notice. | |
40 | */ | |
41 | \f | |
42 | #include <stdio.h> | |
43 | #include "_scm.h" | |
44 | ||
45 | #ifdef __STDC__ | |
46 | #include <stdarg.h> | |
47 | #define var_start(x, y) va_start(x, y) | |
48 | #else | |
49 | #include <varargs.h> | |
50 | #define var_start(x, y) va_start(x) | |
51 | #endif | |
52 | ||
53 | \f | |
54 | ||
55 | ||
56 | #ifdef __STDC__ | |
57 | SCM | |
58 | scm_listify (SCM elt, ...) | |
59 | #else | |
60 | SCM | |
61 | scm_listify (elt, va_alist) | |
62 | SCM elt; | |
63 | va_dcl | |
64 | ||
65 | #endif | |
66 | { | |
67 | va_list foo; | |
68 | SCM answer; | |
69 | SCM *pos; | |
70 | ||
71 | var_start (foo, elt); | |
72 | answer = SCM_EOL; | |
73 | pos = &answer; | |
74 | while (elt != SCM_UNDEFINED) | |
75 | { | |
76 | *pos = scm_cons (elt, SCM_EOL); | |
77 | pos = &SCM_CDR (*pos); | |
78 | elt = va_arg (foo, SCM); | |
79 | } | |
80 | return answer; | |
81 | } | |
82 | ||
83 | ||
84 | SCM_PROC(s_list, "list", 0, 0, 1, scm_list); | |
85 | #ifdef __STDC__ | |
86 | SCM | |
87 | scm_list(SCM objs) | |
88 | #else | |
89 | SCM | |
90 | scm_list(objs) | |
91 | SCM objs; | |
92 | #endif | |
93 | { | |
94 | return objs; | |
95 | } | |
96 | ||
97 | ||
98 | ||
99 | \f | |
100 | ||
101 | SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p); | |
102 | #ifdef __STDC__ | |
103 | SCM | |
104 | scm_null_p(SCM x) | |
105 | #else | |
106 | SCM | |
107 | scm_null_p(x) | |
108 | SCM x; | |
109 | #endif | |
110 | { | |
111 | return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F; | |
112 | } | |
113 | ||
114 | SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p); | |
115 | #ifdef __STDC__ | |
116 | SCM | |
117 | scm_list_p(SCM x) | |
118 | #else | |
119 | SCM | |
120 | scm_list_p(x) | |
121 | SCM x; | |
122 | #endif | |
123 | { | |
124 | if (scm_ilength(x)<0) | |
125 | return SCM_BOOL_F; | |
126 | else | |
127 | return SCM_BOOL_T; | |
128 | } | |
129 | ||
130 | ||
131 | #ifdef __STDC__ | |
132 | long | |
133 | scm_ilength(SCM sx) | |
134 | #else | |
135 | long | |
136 | scm_ilength(sx) | |
137 | SCM sx; | |
138 | #endif | |
139 | { | |
140 | register long i = 0; | |
141 | register SCM x = sx; | |
142 | do { | |
143 | if SCM_IMP(x) return SCM_NULLP(x) ? i : -1; | |
144 | if SCM_NCONSP(x) return -1; | |
145 | x = SCM_CDR(x); | |
146 | i++; | |
147 | if SCM_IMP(x) return SCM_NULLP(x) ? i : -1; | |
148 | if SCM_NCONSP(x) return -1; | |
149 | x = SCM_CDR(x); | |
150 | i++; | |
151 | sx = SCM_CDR(sx); | |
152 | } | |
153 | while (x != sx); | |
154 | return -1; | |
155 | } | |
156 | ||
157 | SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length); | |
158 | #ifdef __STDC__ | |
159 | SCM | |
160 | scm_list_length(SCM x) | |
161 | #else | |
162 | SCM | |
163 | scm_list_length(x) | |
164 | SCM x; | |
165 | #endif | |
166 | { | |
167 | int i; | |
168 | i = scm_ilength(x); | |
169 | SCM_ASSERT(i >= 0, x, SCM_ARG1, s_list_length); | |
170 | return SCM_MAKINUM (i); | |
171 | } | |
172 | ||
173 | ||
174 | \f | |
175 | ||
176 | SCM_PROC (s_list_append, "list-append", 0, 0, 1, scm_list_append); | |
177 | #ifdef __STDC__ | |
178 | SCM | |
179 | scm_list_append(SCM args) | |
180 | #else | |
181 | SCM | |
182 | scm_list_append(args) | |
183 | SCM args; | |
184 | #endif | |
185 | { | |
186 | SCM res = SCM_EOL; | |
187 | SCM *lloc = &res, arg; | |
188 | if SCM_IMP(args) { | |
189 | SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append); | |
190 | return res; | |
191 | } | |
192 | SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append); | |
193 | while (1) { | |
194 | arg = SCM_CAR(args); | |
195 | args = SCM_CDR(args); | |
196 | if SCM_IMP(args) { | |
197 | *lloc = arg; | |
198 | SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append); | |
199 | return res; | |
200 | } | |
201 | SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append); | |
202 | for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) { | |
203 | SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_list_append); | |
204 | *lloc = scm_cons(SCM_CAR(arg), SCM_EOL); | |
205 | lloc = &SCM_CDR(*lloc); | |
206 | } | |
207 | SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_list_append); | |
208 | } | |
209 | } | |
210 | ||
211 | ||
212 | SCM_PROC (s_list_append_x, "list-append!", 0, 0, 1, scm_list_append_x); | |
213 | #ifdef __STDC__ | |
214 | SCM | |
215 | scm_list_append_x(SCM args) | |
216 | #else | |
217 | SCM | |
218 | scm_list_append_x(args) | |
219 | SCM args; | |
220 | #endif | |
221 | { | |
222 | SCM arg; | |
223 | tail: | |
224 | if SCM_NULLP(args) return SCM_EOL; | |
225 | arg = SCM_CAR(args); | |
226 | SCM_ASSERT(SCM_NULLP(arg) || (SCM_NIMP(arg) && SCM_CONSP(arg)), arg, SCM_ARG1, s_list_append_x); | |
227 | args = SCM_CDR(args); | |
228 | if SCM_NULLP(args) return arg; | |
229 | if SCM_NULLP(arg) goto tail; | |
230 | SCM_CDR(scm_last_pair(arg)) = scm_list_append_x(args); | |
231 | return arg; | |
232 | } | |
233 | ||
234 | ||
235 | \f | |
236 | ||
237 | ||
238 | SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse); | |
239 | #ifdef __STDC__ | |
240 | SCM | |
241 | scm_list_reverse(SCM lst) | |
242 | #else | |
243 | SCM | |
244 | scm_list_reverse(lst) | |
245 | SCM lst; | |
246 | #endif | |
247 | { | |
248 | SCM res = SCM_EOL; | |
249 | SCM p = lst; | |
250 | for(;SCM_NIMP(p);p = SCM_CDR(p)) { | |
251 | SCM_ASSERT(SCM_CONSP(p), lst, SCM_ARG1, s_list_reverse); | |
252 | res = scm_cons(SCM_CAR(p), res); | |
253 | } | |
254 | SCM_ASSERT(SCM_NULLP(p), lst, SCM_ARG1, s_list_reverse); | |
255 | return res; | |
256 | } | |
257 | ||
258 | SCM_PROC (s_list_reverse_x, "list-reverse!", 1, 1, 0, scm_list_reverse_x); | |
259 | #ifdef __STDC__ | |
260 | SCM | |
261 | scm_list_reverse_x (SCM lst, SCM newtail) | |
262 | #else | |
263 | SCM | |
264 | scm_list_reverse_x (lst, newtail) | |
265 | SCM lst; | |
266 | SCM newtail; | |
267 | #endif | |
268 | { | |
269 | SCM old_tail; | |
270 | if (newtail == SCM_UNDEFINED) | |
271 | newtail = SCM_EOL; | |
272 | ||
273 | loop: | |
274 | if (!(SCM_NIMP (lst) && SCM_CONSP (lst))) | |
275 | return lst; | |
276 | ||
277 | old_tail = SCM_CDR (lst); | |
278 | SCM_SETCDR (lst, newtail); | |
279 | if (SCM_NULLP (old_tail)) | |
280 | return lst; | |
281 | ||
282 | newtail = lst; | |
283 | lst = old_tail; | |
284 | goto loop; | |
285 | } | |
286 | ||
287 | ||
288 | \f | |
289 | ||
290 | ||
291 | SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref); | |
292 | #ifdef __STDC__ | |
293 | SCM | |
294 | scm_list_ref(SCM lst, SCM k) | |
295 | #else | |
296 | SCM | |
297 | scm_list_ref(lst, k) | |
298 | SCM lst; | |
299 | SCM k; | |
300 | #endif | |
301 | { | |
302 | register long i; | |
303 | SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref); | |
304 | i = SCM_INUM(k); | |
305 | SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_ref); | |
306 | while (i-- > 0) { | |
307 | SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); | |
308 | lst = SCM_CDR(lst); | |
309 | } | |
310 | erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), | |
311 | SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_ref); | |
312 | return SCM_CAR(lst); | |
313 | } | |
314 | ||
315 | SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x); | |
316 | #ifdef __STDC__ | |
317 | SCM | |
318 | scm_list_set_x(SCM lst, SCM k, SCM val) | |
319 | #else | |
320 | SCM | |
321 | scm_list_set_x(lst, k, val) | |
322 | SCM lst; | |
323 | SCM k; | |
324 | SCM val; | |
325 | #endif | |
326 | { | |
327 | register long i; | |
328 | SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x); | |
329 | i = SCM_INUM(k); | |
330 | SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_set_x); | |
331 | while (i-- > 0) { | |
332 | SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); | |
333 | lst = SCM_CDR(lst); | |
334 | } | |
335 | erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), | |
336 | SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x); | |
337 | SCM_CAR (lst) = val; | |
338 | return val; | |
339 | } | |
340 | ||
341 | ||
342 | ||
343 | SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x); | |
344 | #ifdef __STDC__ | |
345 | SCM | |
346 | scm_list_cdr_set_x(SCM lst, SCM k, SCM val) | |
347 | #else | |
348 | SCM | |
349 | scm_list_cdr_set_x(lst, k, val) | |
350 | SCM lst; | |
351 | SCM k; | |
352 | SCM val; | |
353 | #endif | |
354 | { | |
355 | register long i; | |
356 | SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x); | |
357 | i = SCM_INUM(k); | |
358 | SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_cdr_set_x); | |
359 | while (i-- > 0) { | |
360 | SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); | |
361 | lst = SCM_CDR(lst); | |
362 | } | |
363 | erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), | |
364 | SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_cdr_set_x); | |
365 | SCM_SETCDR (lst, val); | |
366 | return val; | |
367 | } | |
368 | ||
369 | ||
370 | \f | |
371 | ||
372 | ||
373 | ||
374 | SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair); | |
375 | #ifdef __STDC__ | |
376 | SCM | |
377 | scm_last_pair(SCM sx) | |
378 | #else | |
379 | SCM | |
380 | scm_last_pair(sx) | |
381 | SCM sx; | |
382 | #endif | |
383 | { | |
384 | register SCM res = sx; | |
385 | register SCM x; | |
386 | ||
387 | if (SCM_NULLP (sx)) | |
388 | return SCM_EOL; | |
389 | ||
390 | SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair); | |
391 | while (!0) { | |
392 | x = SCM_CDR(res); | |
393 | if (SCM_IMP(x) || SCM_NCONSP(x)) return res; | |
394 | res = x; | |
395 | x = SCM_CDR(res); | |
396 | if (SCM_IMP(x) || SCM_NCONSP(x)) return res; | |
397 | res = x; | |
398 | sx = SCM_CDR(sx); | |
399 | SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair); | |
400 | } | |
401 | } | |
402 | ||
403 | SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail); | |
404 | SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail); | |
405 | #ifdef __STDC__ | |
406 | SCM | |
407 | scm_list_tail(SCM lst, SCM k) | |
408 | #else | |
409 | SCM | |
410 | scm_list_tail(lst, k) | |
411 | SCM lst; | |
412 | SCM k; | |
413 | #endif | |
414 | { | |
415 | register long i; | |
416 | SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail); | |
417 | i = SCM_INUM(k); | |
418 | while (i-- > 0) { | |
419 | SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail); | |
420 | lst = SCM_CDR(lst); | |
421 | } | |
422 | return lst; | |
423 | } | |
424 | ||
425 | ||
426 | SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head); | |
427 | #ifdef __STDC__ | |
428 | SCM | |
429 | scm_list_head(SCM lst, SCM k) | |
430 | #else | |
431 | SCM | |
432 | scm_list_head(lst, k) | |
433 | SCM lst; | |
434 | SCM k; | |
435 | #endif | |
436 | { | |
437 | SCM answer; | |
438 | SCM * pos; | |
439 | register long i; | |
440 | ||
441 | SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_head); | |
442 | answer = SCM_EOL; | |
443 | pos = &answer; | |
444 | i = SCM_INUM(k); | |
445 | while (i-- > 0) | |
446 | { | |
447 | SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head); | |
448 | *pos = scm_cons (SCM_CAR (lst), SCM_EOL); | |
449 | pos = &SCM_CDR (*pos); | |
450 | lst = SCM_CDR(lst); | |
451 | } | |
452 | return answer; | |
453 | } | |
454 | ||
455 | ||
456 | \f | |
457 | ||
458 | #ifdef __STDC__ | |
459 | static void | |
460 | sloppy_mem_check (SCM obj, char * where, char * why) | |
461 | #else | |
462 | static void | |
463 | sloppy_mem_check (obj, where, why) | |
464 | SCM obj; | |
465 | char * where; | |
466 | char * why; | |
467 | #endif | |
468 | { | |
469 | SCM_ASSERT ((scm_ilength (obj) >= 0), obj, where, why); | |
470 | } | |
471 | ||
472 | ||
473 | SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq); | |
474 | #ifdef __STDC__ | |
475 | SCM | |
476 | scm_sloppy_memq(SCM x, SCM lst) | |
477 | #else | |
478 | SCM | |
479 | scm_sloppy_memq(x, lst) | |
480 | SCM x; | |
481 | SCM lst; | |
482 | #endif | |
483 | { | |
484 | for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) | |
485 | { | |
486 | if (SCM_CAR(lst)==x) | |
487 | return lst; | |
488 | } | |
489 | return lst; | |
490 | } | |
491 | ||
492 | ||
493 | SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv); | |
494 | #ifdef __STDC__ | |
495 | SCM | |
496 | scm_sloppy_memv(SCM x, SCM lst) | |
497 | #else | |
498 | SCM | |
499 | scm_sloppy_memv(x, lst) | |
500 | SCM x; | |
501 | SCM lst; | |
502 | #endif | |
503 | { | |
504 | for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) | |
505 | { | |
506 | if (SCM_BOOL_F != scm_eqv_p (SCM_CAR(lst), x)) | |
507 | return lst; | |
508 | } | |
509 | return lst; | |
510 | } | |
511 | ||
512 | ||
513 | SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member); | |
514 | #ifdef __STDC__ | |
515 | SCM | |
516 | scm_sloppy_member (SCM x, SCM lst) | |
517 | #else | |
518 | SCM | |
519 | scm_sloppy_member (x, lst) | |
520 | SCM x; | |
521 | SCM lst; | |
522 | #endif | |
523 | { | |
524 | for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) | |
525 | { | |
526 | if (SCM_BOOL_F != scm_equal_p (SCM_CAR(lst), x)) | |
527 | return lst; | |
528 | } | |
529 | return lst; | |
530 | } | |
531 | ||
532 | ||
533 | ||
534 | SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq); | |
535 | #ifdef __STDC__ | |
536 | SCM | |
537 | scm_memq(SCM x, SCM lst) | |
538 | #else | |
539 | SCM | |
540 | scm_memq(x, lst) | |
541 | SCM x; | |
542 | SCM lst; | |
543 | #endif | |
544 | { | |
545 | SCM answer; | |
546 | answer = scm_sloppy_memq (x, lst); | |
547 | sloppy_mem_check (answer, (char *)SCM_ARG2, s_memq); | |
548 | return answer; | |
549 | } | |
550 | ||
551 | ||
552 | ||
553 | SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv); | |
554 | #ifdef __STDC__ | |
555 | SCM | |
556 | scm_memv(SCM x, SCM lst) | |
557 | #else | |
558 | SCM | |
559 | scm_memv(x, lst) | |
560 | SCM x; | |
561 | SCM lst; | |
562 | #endif | |
563 | { | |
564 | SCM answer; | |
565 | answer = scm_sloppy_memv (x, lst); | |
566 | sloppy_mem_check (answer, (char *)SCM_ARG2, s_memv); | |
567 | return answer; | |
568 | } | |
569 | ||
570 | ||
571 | SCM_PROC(s_member, "member", 2, 0, 0, scm_member); | |
572 | #ifdef __STDC__ | |
573 | SCM | |
574 | scm_member(SCM x, SCM lst) | |
575 | #else | |
576 | SCM | |
577 | scm_member(x, lst) | |
578 | SCM x; | |
579 | SCM lst; | |
580 | #endif | |
581 | { | |
582 | SCM answer; | |
583 | answer = scm_sloppy_member (x, lst); | |
584 | sloppy_mem_check (answer, (char *)SCM_ARG2, s_member); | |
585 | return answer; | |
586 | } | |
587 | ||
588 | ||
589 | \f | |
590 | ||
591 | SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x); | |
592 | #ifdef __STDC__ | |
593 | SCM | |
594 | scm_delq_x (SCM item, SCM lst) | |
595 | #else | |
596 | SCM | |
597 | scm_delq_x (item, lst) | |
598 | SCM item; | |
599 | SCM lst; | |
600 | #endif | |
601 | { | |
602 | SCM start; | |
603 | ||
604 | if (SCM_IMP (lst) || SCM_NCONSP (lst)) | |
605 | return lst; | |
606 | ||
607 | if (SCM_CAR (lst) == item) | |
608 | return SCM_CDR (lst); | |
609 | ||
610 | start = lst; | |
611 | ||
612 | while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) | |
613 | { | |
614 | if (SCM_CAR (SCM_CDR (lst)) == item) | |
615 | { | |
616 | SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); | |
617 | return start; | |
618 | } | |
619 | lst = SCM_CDR (lst); | |
620 | } | |
621 | return start; | |
622 | } | |
623 | ||
624 | ||
625 | SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x); | |
626 | #ifdef __STDC__ | |
627 | SCM | |
628 | scm_delv_x (SCM item, SCM lst) | |
629 | #else | |
630 | SCM | |
631 | scm_delv_x (item, lst) | |
632 | SCM item; | |
633 | SCM lst; | |
634 | #endif | |
635 | { | |
636 | SCM start; | |
637 | ||
638 | if (SCM_IMP (lst) || SCM_NCONSP (lst)) | |
639 | return lst; | |
640 | ||
641 | if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (lst), item)) | |
642 | return SCM_CDR (lst); | |
643 | ||
644 | start = lst; | |
645 | ||
646 | while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) | |
647 | { | |
648 | if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (SCM_CDR (lst)), item)) | |
649 | { | |
650 | SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); | |
651 | return start; | |
652 | } | |
653 | lst = SCM_CDR (lst); | |
654 | } | |
655 | return start; | |
656 | } | |
657 | ||
658 | ||
659 | ||
660 | SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x); | |
661 | #ifdef __STDC__ | |
662 | SCM | |
663 | scm_delete_x (SCM item, SCM lst) | |
664 | #else | |
665 | SCM | |
666 | scm_delete_x (item, lst) | |
667 | SCM item; | |
668 | SCM lst; | |
669 | #endif | |
670 | { | |
671 | SCM start; | |
672 | ||
673 | if (SCM_IMP (lst) || SCM_NCONSP (lst)) | |
674 | return lst; | |
675 | ||
676 | if (SCM_BOOL_F != scm_equal_p (SCM_CAR (lst), item)) | |
677 | return SCM_CDR (lst); | |
678 | ||
679 | start = lst; | |
680 | ||
681 | while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) | |
682 | { | |
683 | if (SCM_BOOL_F != scm_equal_p (SCM_CAR (SCM_CDR (lst)), item)) | |
684 | { | |
685 | SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); | |
686 | return start; | |
687 | } | |
688 | lst = SCM_CDR (lst); | |
689 | } | |
690 | return start; | |
691 | } | |
692 | ||
693 | ||
694 | \f | |
695 | ||
696 | SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy); | |
697 | #ifdef __STDC__ | |
698 | SCM | |
699 | scm_list_copy (SCM lst) | |
700 | #else | |
701 | SCM | |
702 | scm_list_copy (lst) | |
703 | SCM lst; | |
704 | #endif | |
705 | { | |
706 | SCM newlst; | |
707 | SCM * fill_here; | |
708 | SCM from_here; | |
709 | ||
710 | newlst = SCM_EOL; | |
711 | fill_here = &newlst; | |
712 | from_here = lst; | |
713 | ||
714 | while (SCM_NIMP (from_here) && SCM_CONSP (from_here)) | |
715 | { | |
716 | SCM c; | |
717 | c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here)); | |
718 | *fill_here = c; | |
719 | fill_here = &SCM_CDR (c); | |
720 | from_here = SCM_CDR (from_here); | |
721 | } | |
722 | return newlst; | |
723 | } | |
724 | \f | |
725 | ||
726 | ||
727 | SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq); | |
728 | #ifdef __STDC__ | |
729 | SCM | |
730 | scm_delq (SCM item, SCM lst) | |
731 | #else | |
732 | SCM | |
733 | scm_delq (item, lst) | |
734 | SCM item; | |
735 | SCM lst; | |
736 | #endif | |
737 | { | |
738 | SCM copy; | |
739 | ||
740 | copy = scm_list_copy (lst); | |
741 | return scm_delq_x (item, copy); | |
742 | } | |
743 | ||
744 | SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv); | |
745 | #ifdef __STDC__ | |
746 | SCM | |
747 | scm_delv (SCM item, SCM lst) | |
748 | #else | |
749 | SCM | |
750 | scm_delv (item, lst) | |
751 | SCM item; | |
752 | SCM lst; | |
753 | #endif | |
754 | { | |
755 | SCM copy; | |
756 | ||
757 | copy = scm_list_copy (lst); | |
758 | return scm_delv_x (item, copy); | |
759 | } | |
760 | ||
761 | SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete); | |
762 | #ifdef __STDC__ | |
763 | SCM | |
764 | scm_delete (SCM item, SCM lst) | |
765 | #else | |
766 | SCM | |
767 | scm_delete (item, lst) | |
768 | SCM item; | |
769 | SCM lst; | |
770 | #endif | |
771 | { | |
772 | SCM copy; | |
773 | ||
774 | copy = scm_list_copy (lst); | |
775 | return scm_delete_x (item, copy); | |
776 | } | |
777 | ||
778 | ||
779 | \f | |
780 | ||
781 | #ifdef __STDC__ | |
782 | void | |
783 | scm_init_list (void) | |
784 | #else | |
785 | void | |
786 | scm_init_list () | |
787 | #endif | |
788 | { | |
789 | #include "list.x" | |
790 | } | |
791 |