← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/list.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libguile/list.c
 
1
/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004
 
2
 * Free Software Foundation, Inc.
 
3
 * 
 
4
 * This library is free software; you can redistribute it and/or
 
5
 * modify it under the terms of the GNU Lesser General Public
 
6
 * License as published by the Free Software Foundation; either
 
7
 * version 2.1 of the License, or (at your option) any later version.
 
8
 *
 
9
 * This library is distributed in the hope that it will be useful,
 
10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
12
 * Lesser General Public License for more details.
 
13
 *
 
14
 * You should have received a copy of the GNU Lesser General Public
 
15
 * License along with this library; if not, write to the Free Software
 
16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
17
 */
 
18
 
 
19
 
 
20
 
 
21
#include "libguile/_scm.h"
 
22
#include "libguile/eq.h"
 
23
#include "libguile/lang.h"
 
24
 
 
25
#include "libguile/validate.h"
 
26
#include "libguile/list.h"
 
27
#include "libguile/eval.h"
 
28
 
 
29
#include <stdarg.h>
 
30
 
 
31
 
 
32
/* creating lists */
 
33
 
 
34
#define SCM_I_CONS(cell, x, y)                  \
 
35
do {                                            \
 
36
  cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y);                       \
 
37
} while (0)
 
38
 
 
39
SCM
 
40
scm_list_1 (SCM e1)
 
41
{
 
42
  SCM c1;
 
43
  SCM_I_CONS (c1, e1, SCM_EOL);
 
44
  return c1;
 
45
}
 
46
 
 
47
SCM
 
48
scm_list_2 (SCM e1, SCM e2)
 
49
{
 
50
  SCM c1, c2;
 
51
  SCM_I_CONS (c2, e2, SCM_EOL);
 
52
  SCM_I_CONS (c1, e1, c2);
 
53
  return c1;
 
54
}
 
55
 
 
56
SCM
 
57
scm_list_3 (SCM e1, SCM e2, SCM e3)
 
58
{
 
59
  SCM c1, c2, c3;
 
60
  SCM_I_CONS (c3, e3, SCM_EOL);
 
61
  SCM_I_CONS (c2, e2, c3);
 
62
  SCM_I_CONS (c1, e1, c2);
 
63
  return c1;
 
64
}
 
65
 
 
66
SCM
 
67
scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4)
 
68
{
 
69
  return scm_cons2 (e1, e2, scm_list_2 (e3, e4));
 
70
}
 
71
 
 
72
SCM
 
73
scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5)
 
74
{
 
75
  return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5));
 
76
}
 
77
 
 
78
SCM
 
79
scm_list_n (SCM elt, ...)
 
80
{
 
81
  va_list foo;
 
82
  SCM answer = SCM_EOL;
 
83
  SCM *pos = &answer;
 
84
 
 
85
  va_start (foo, elt);
 
86
  while (! SCM_UNBNDP (elt))
 
87
    {
 
88
#if (SCM_DEBUG_CELL_ACCESSES == 1)
 
89
      if (SCM_NIMP (elt))
 
90
        SCM_VALIDATE_CELL(elt, 0);
 
91
#endif      
 
92
      *pos = scm_cons (elt, SCM_EOL);
 
93
      pos = SCM_CDRLOC (*pos);
 
94
      elt = va_arg (foo, SCM);
 
95
    }
 
96
  va_end (foo);
 
97
  return answer;
 
98
}
 
99
 
 
100
 
 
101
SCM_DEFINE (scm_make_list, "make-list", 1, 1, 0,
 
102
            (SCM n, SCM init),
 
103
            "Create a list containing of @var{n} elements, where each\n"
 
104
            "element is initialized to @var{init}.  @var{init} defaults to\n"
 
105
            "the empty list @code{()} if not given.")
 
106
#define FUNC_NAME s_scm_make_list
 
107
{
 
108
  unsigned nn = scm_to_uint (n);
 
109
  unsigned i;
 
110
  SCM ret = SCM_EOL;
 
111
 
 
112
  if (SCM_UNBNDP (init))
 
113
    init = SCM_EOL;
 
114
 
 
115
  for (i = 0; i < nn; i++)
 
116
    ret = scm_cons (init, ret);
 
117
  return ret;
 
118
}
 
119
#undef FUNC_NAME
 
120
 
 
121
 
 
122
SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1,
 
123
            (SCM arg, SCM rest),
 
124
            "Like @code{list}, but the last arg provides the tail of the\n"
 
125
            "constructed list, returning @code{(cons @var{arg1} (cons\n"
 
126
            "@var{arg2} (cons @dots{} @var{argn})))}.  Requires at least one\n"
 
127
            "argument.  If given one argument, that argument is returned as\n"
 
128
            "result.  This function is called @code{list*} in some other\n"
 
129
            "Schemes and in Common LISP.")
 
130
#define FUNC_NAME s_scm_cons_star
 
131
{
 
132
  SCM ret = SCM_EOL;
 
133
  SCM *p = &ret;
 
134
 
 
135
  SCM_VALIDATE_REST_ARGUMENT (rest);
 
136
 
 
137
  for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
 
138
    {
 
139
      *p = scm_cons (arg, SCM_EOL);
 
140
      p = SCM_CDRLOC (*p);
 
141
      arg = SCM_CAR (rest);
 
142
    }
 
143
 
 
144
  *p = arg;
 
145
  return ret;
 
146
}
 
147
#undef FUNC_NAME
 
148
 
 
149
 
 
150
 
 
151
/* general questions about lists --- null?, list?, length, etc.  */
 
152
 
 
153
SCM_DEFINE (scm_null_p, "null?", 1, 0, 0, 
 
154
           (SCM x),
 
155
            "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
 
156
#define FUNC_NAME s_scm_null_p
 
157
{
 
158
  return scm_from_bool (SCM_NULL_OR_NIL_P (x));
 
159
}
 
160
#undef FUNC_NAME
 
161
 
 
162
 
 
163
SCM_DEFINE (scm_list_p, "list?", 1, 0, 0, 
 
164
           (SCM x),
 
165
            "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
 
166
#define FUNC_NAME s_scm_list_p
 
167
{
 
168
  return scm_from_bool (scm_ilength (x) >= 0);
 
169
}
 
170
#undef FUNC_NAME
 
171
 
 
172
 
 
173
/* Return the length of SX, or -1 if it's not a proper list.
 
174
   This uses the "tortoise and hare" algorithm to detect "infinitely
 
175
   long" lists (i.e. lists with cycles in their cdrs), and returns -1
 
176
   if it does find one.  */
 
177
long
 
178
scm_ilength(SCM sx)
 
179
{
 
180
  long i = 0;
 
181
  SCM tortoise = sx;
 
182
  SCM hare = sx;
 
183
 
 
184
  do {
 
185
    if (SCM_NULL_OR_NIL_P(hare)) return i;
 
186
    if (!scm_is_pair (hare)) return -1;
 
187
    hare = SCM_CDR(hare);
 
188
    i++;
 
189
    if (SCM_NULL_OR_NIL_P(hare)) return i;
 
190
    if (!scm_is_pair (hare)) return -1;
 
191
    hare = SCM_CDR(hare);
 
192
    i++;
 
193
    /* For every two steps the hare takes, the tortoise takes one.  */
 
194
    tortoise = SCM_CDR(tortoise);
 
195
  }
 
196
  while (!scm_is_eq (hare, tortoise));
 
197
 
 
198
  /* If the tortoise ever catches the hare, then the list must contain
 
199
     a cycle.  */
 
200
  return -1;
 
201
}
 
202
 
 
203
 
 
204
SCM_DEFINE (scm_length, "length", 1, 0, 0, 
 
205
           (SCM lst),
 
206
            "Return the number of elements in list @var{lst}.")
 
207
#define FUNC_NAME s_scm_length
 
208
{
 
209
  long i;
 
210
  SCM_VALIDATE_LIST_COPYLEN (1, lst, i);
 
211
  return scm_from_long (i);
 
212
}
 
213
#undef FUNC_NAME
 
214
 
 
215
 
 
216
 
 
217
/* appending lists */
 
218
 
 
219
SCM_DEFINE (scm_append, "append", 0, 0, 1, 
 
220
            (SCM args),
 
221
            "Return a list consisting of the elements the lists passed as\n"
 
222
            "arguments.\n"
 
223
            "@lisp\n"
 
224
            "(append '(x) '(y))          @result{}  (x y)\n"
 
225
            "(append '(a) '(b c d))      @result{}  (a b c d)\n"
 
226
            "(append '(a (b)) '((c)))    @result{}  (a (b) (c))\n"
 
227
            "@end lisp\n"
 
228
            "The resulting list is always newly allocated, except that it\n"
 
229
            "shares structure with the last list argument.  The last\n"
 
230
            "argument may actually be any object; an improper list results\n"
 
231
            "if the last argument is not a proper list.\n"
 
232
            "@lisp\n"
 
233
            "(append '(a b) '(c . d))    @result{}  (a b c . d)\n"
 
234
            "(append '() 'a)             @result{}  a\n"
 
235
            "@end lisp")
 
236
#define FUNC_NAME s_scm_append
 
237
{
 
238
  SCM_VALIDATE_REST_ARGUMENT (args);
 
239
  if (scm_is_null (args)) {
 
240
    return SCM_EOL;
 
241
  } else {
 
242
    SCM res = SCM_EOL;
 
243
    SCM *lloc = &res;
 
244
    SCM arg = SCM_CAR (args);
 
245
    int argnum = 1;
 
246
    args = SCM_CDR (args);
 
247
    while (!scm_is_null (args)) {
 
248
      while (scm_is_pair (arg)) {
 
249
        *lloc = scm_cons (SCM_CAR (arg), SCM_EOL);
 
250
        lloc = SCM_CDRLOC (*lloc);
 
251
        arg = SCM_CDR (arg);
 
252
      }
 
253
      SCM_VALIDATE_NULL_OR_NIL (argnum, arg);
 
254
      arg = SCM_CAR (args);
 
255
      args = SCM_CDR (args);
 
256
      argnum++;
 
257
    };
 
258
    *lloc = arg;
 
259
    return res;
 
260
  }
 
261
}
 
262
#undef FUNC_NAME
 
263
 
 
264
 
 
265
SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, 
 
266
            (SCM lists),
 
267
            "A destructive version of @code{append} (@pxref{Pairs and\n"
 
268
            "Lists,,,r5rs, The Revised^5 Report on Scheme}).  The cdr field\n"
 
269
            "of each list's final pair is changed to point to the head of\n"
 
270
            "the next list, so no consing is performed.  Return\n"
 
271
            "the mutated list.")
 
272
#define FUNC_NAME s_scm_append_x
 
273
{
 
274
  SCM ret, *loc;
 
275
  SCM_VALIDATE_REST_ARGUMENT (lists);
 
276
 
 
277
  if (scm_is_null (lists))
 
278
    return SCM_EOL;
 
279
 
 
280
  loc = &ret;
 
281
  for (;;)
 
282
    {
 
283
      SCM arg = SCM_CAR (lists);
 
284
      *loc = arg;
 
285
 
 
286
      lists = SCM_CDR (lists);
 
287
      if (scm_is_null (lists))
 
288
        return ret;
 
289
 
 
290
      if (!SCM_NULL_OR_NIL_P (arg))
 
291
        {
 
292
          SCM_VALIDATE_CONS (SCM_ARG1, arg);
 
293
          loc = SCM_CDRLOC (scm_last_pair (arg));
 
294
        }
 
295
    }
 
296
}
 
297
#undef FUNC_NAME
 
298
 
 
299
 
 
300
SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, 
 
301
           (SCM lst),
 
302
            "Return the last pair in @var{lst}, signalling an error if\n"
 
303
            "@var{lst} is circular.")
 
304
#define FUNC_NAME s_scm_last_pair
 
305
{
 
306
  SCM tortoise = lst;
 
307
  SCM hare = lst;
 
308
 
 
309
  if (SCM_NULL_OR_NIL_P (lst))
 
310
    return lst;
 
311
 
 
312
  SCM_VALIDATE_CONS (SCM_ARG1, lst);
 
313
  do {
 
314
    SCM ahead = SCM_CDR(hare);
 
315
    if (!scm_is_pair (ahead)) return hare;
 
316
    hare = ahead;
 
317
    ahead = SCM_CDR(hare);
 
318
    if (!scm_is_pair (ahead)) return hare;
 
319
    hare = ahead;
 
320
    tortoise = SCM_CDR(tortoise);
 
321
  }
 
322
  while (!scm_is_eq (hare, tortoise));
 
323
  SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
 
324
}
 
325
#undef FUNC_NAME
 
326
 
 
327
 
 
328
/* reversing lists */
 
329
 
 
330
SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
 
331
            (SCM lst),
 
332
            "Return a new list that contains the elements of @var{lst} but\n"
 
333
            "in reverse order.")
 
334
#define FUNC_NAME s_scm_reverse
 
335
{
 
336
  SCM result = SCM_EOL;
 
337
  SCM tortoise = lst;
 
338
  SCM hare = lst;
 
339
 
 
340
  do {
 
341
      if (SCM_NULL_OR_NIL_P(hare)) return result;
 
342
      SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
 
343
      result = scm_cons (SCM_CAR (hare), result);
 
344
      hare = SCM_CDR (hare);
 
345
      if (SCM_NULL_OR_NIL_P(hare)) return result;
 
346
      SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
 
347
      result = scm_cons (SCM_CAR (hare), result);
 
348
      hare = SCM_CDR (hare);
 
349
      tortoise = SCM_CDR (tortoise);
 
350
    }
 
351
  while (!scm_is_eq (hare, tortoise));
 
352
  SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
 
353
}
 
354
#undef FUNC_NAME
 
355
 
 
356
SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
 
357
            (SCM lst, SCM new_tail),
 
358
            "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
 
359
            "The Revised^5 Report on Scheme}).  The cdr of each cell in @var{lst} is\n"
 
360
            "modified to point to the previous list element.  Return the\n"
 
361
            "reversed list.\n\n"
 
362
            "Caveat: because the list is modified in place, the tail of the original\n"
 
363
            "list now becomes its head, and the head of the original list now becomes\n"
 
364
            "the tail.  Therefore, the @var{lst} symbol to which the head of the\n"
 
365
            "original list was bound now points to the tail.  To ensure that the head\n"
 
366
            "of the modified list is not lost, it is wise to save the return value of\n"
 
367
            "@code{reverse!}")
 
368
#define FUNC_NAME s_scm_reverse_x
 
369
{
 
370
  SCM_VALIDATE_LIST (1, lst);
 
371
  if (SCM_UNBNDP (new_tail))
 
372
    new_tail = SCM_EOL;
 
373
  else
 
374
    SCM_VALIDATE_LIST (2, new_tail);
 
375
 
 
376
  while (!SCM_NULL_OR_NIL_P (lst))
 
377
    {
 
378
      SCM old_tail = SCM_CDR (lst);
 
379
      SCM_SETCDR (lst, new_tail);
 
380
      new_tail = lst;
 
381
      lst = old_tail;
 
382
    }
 
383
  return new_tail;
 
384
}
 
385
#undef FUNC_NAME
 
386
 
 
387
 
 
388
 
 
389
/* indexing lists by element number */
 
390
 
 
391
SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
 
392
            (SCM list, SCM k),
 
393
            "Return the @var{k}th element from @var{list}.")
 
394
#define FUNC_NAME s_scm_list_ref
 
395
{
 
396
  SCM lst = list;
 
397
  unsigned long int i;
 
398
  i = scm_to_ulong (k);
 
399
  while (scm_is_pair (lst)) {
 
400
    if (i == 0)
 
401
      return SCM_CAR (lst);
 
402
    else {
 
403
      --i;
 
404
      lst = SCM_CDR (lst);
 
405
    }
 
406
  };
 
407
  if (SCM_NULL_OR_NIL_P (lst))
 
408
    SCM_OUT_OF_RANGE (2, k);
 
409
  else
 
410
    SCM_WRONG_TYPE_ARG (1, list);
 
411
}
 
412
#undef FUNC_NAME
 
413
 
 
414
 
 
415
SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
 
416
            (SCM list, SCM k, SCM val),
 
417
            "Set the @var{k}th element of @var{list} to @var{val}.")
 
418
#define FUNC_NAME s_scm_list_set_x
 
419
{
 
420
  SCM lst = list;
 
421
  unsigned long int i = scm_to_ulong (k);
 
422
  while (scm_is_pair (lst)) {
 
423
    if (i == 0) {
 
424
      SCM_SETCAR (lst, val);
 
425
      return val;
 
426
    } else {
 
427
      --i;
 
428
      lst = SCM_CDR (lst);
 
429
    }
 
430
  };
 
431
  if (SCM_NULL_OR_NIL_P (lst))
 
432
    SCM_OUT_OF_RANGE (2, k);
 
433
  else
 
434
    SCM_WRONG_TYPE_ARG (1, list);
 
435
}
 
436
#undef FUNC_NAME
 
437
 
 
438
 
 
439
SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
 
440
 
 
441
SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
 
442
           (SCM lst, SCM k),
 
443
            "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
 
444
            "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
 
445
            "The first element of the list is considered to be element 0.\n\n"
 
446
            "@code{list-tail} and @code{list-cdr-ref} are identical.  It may help to\n"
 
447
            "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
 
448
            "or returning the results of cdring @var{k} times down @var{lst}.")
 
449
#define FUNC_NAME s_scm_list_tail
 
450
{
 
451
  size_t i = scm_to_size_t (k);
 
452
  while (i-- > 0) {
 
453
    SCM_VALIDATE_CONS (1, lst);
 
454
    lst = SCM_CDR(lst);
 
455
  }
 
456
  return lst;
 
457
}
 
458
#undef FUNC_NAME
 
459
 
 
460
 
 
461
SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
 
462
           (SCM list, SCM k, SCM val),
 
463
            "Set the @var{k}th cdr of @var{list} to @var{val}.")
 
464
#define FUNC_NAME s_scm_list_cdr_set_x
 
465
{
 
466
  SCM lst = list;
 
467
  size_t i = scm_to_size_t (k);
 
468
  while (scm_is_pair (lst)) {
 
469
    if (i == 0) {
 
470
      SCM_SETCDR (lst, val);
 
471
      return val;
 
472
    } else {
 
473
      --i;
 
474
      lst = SCM_CDR (lst);
 
475
    }
 
476
  };
 
477
  if (SCM_NULL_OR_NIL_P (lst))
 
478
    SCM_OUT_OF_RANGE (2, k);
 
479
  else
 
480
    SCM_WRONG_TYPE_ARG (1, list);
 
481
}
 
482
#undef FUNC_NAME
 
483
 
 
484
 
 
485
 
 
486
/* copying lists, perhaps partially */
 
487
 
 
488
SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
 
489
           (SCM lst, SCM k),
 
490
            "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
 
491
            "return it.")
 
492
#define FUNC_NAME s_scm_list_head
 
493
{
 
494
  SCM answer;
 
495
  SCM * pos;
 
496
  size_t i = scm_to_size_t (k);
 
497
 
 
498
  answer = SCM_EOL;
 
499
  pos = &answer;
 
500
  while (i-- > 0)
 
501
    {
 
502
      SCM_VALIDATE_CONS (1, lst);
 
503
      *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
 
504
      pos = SCM_CDRLOC (*pos);
 
505
      lst = SCM_CDR(lst);
 
506
    }
 
507
  return answer;
 
508
}
 
509
#undef FUNC_NAME
 
510
 
 
511
 
 
512
/* Copy a list which is known to be finite.  The last pair may or may not have
 
513
 * a '() in its cdr.  That is, improper lists are accepted.  */
 
514
SCM
 
515
scm_i_finite_list_copy (SCM list)
 
516
{
 
517
  if (!scm_is_pair (list))
 
518
    {
 
519
      return list;
 
520
    }
 
521
  else
 
522
    {
 
523
      SCM tail;
 
524
      const SCM result = tail = scm_list_1 (SCM_CAR (list));
 
525
      list = SCM_CDR (list);
 
526
      while (scm_is_pair (list))
 
527
        {
 
528
          const SCM new_tail = scm_list_1 (SCM_CAR (list));
 
529
          SCM_SETCDR (tail, new_tail);
 
530
          tail = new_tail;
 
531
          list = SCM_CDR (list);
 
532
        }
 
533
      SCM_SETCDR (tail, list);
 
534
 
 
535
      return result;
 
536
    }
 
537
}
 
538
 
 
539
 
 
540
SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, 
 
541
            (SCM lst),
 
542
            "Return a (newly-created) copy of @var{lst}.")
 
543
#define FUNC_NAME s_scm_list_copy
 
544
{
 
545
  SCM newlst;
 
546
  SCM * fill_here;
 
547
  SCM from_here;
 
548
 
 
549
  SCM_VALIDATE_LIST (1, lst);
 
550
 
 
551
  newlst = SCM_EOL;
 
552
  fill_here = &newlst;
 
553
  from_here = lst;
 
554
 
 
555
  while (scm_is_pair (from_here))
 
556
    {
 
557
      SCM c;
 
558
      c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
 
559
      *fill_here = c;
 
560
      fill_here = SCM_CDRLOC (c);
 
561
      from_here = SCM_CDR (from_here);
 
562
    }
 
563
  return newlst;
 
564
}
 
565
#undef FUNC_NAME
 
566
 
 
567
 
 
568
SCM_PROC (s_list, "list", 0, 0, 1, scm_list_copy);
 
569
SCM_SNARF_DOCS (primitive, scm_list_copy, "list", (SCM objs), 0, 0, 1,
 
570
                "Return a list containing @var{objs}, the arguments to\n"
 
571
                "@code{list}.")
 
572
 
 
573
/* This used to be the code for "list", but it's wrong when used via apply
 
574
   (it should copy the list).  It seems pretty unlikely anyone would have
 
575
   been using this from C code, since it's a no-op, but keep it for strict
 
576
   binary compatibility.  */
 
577
SCM
 
578
scm_list (SCM objs)
 
579
{
 
580
  return objs;
 
581
}
 
582
 
 
583
 
 
584
 
 
585
/* membership tests (memq, memv, etc.) */ 
 
586
 
 
587
/* The function scm_c_memq returns the first sublist of list whose car is
 
588
 * 'eq?' obj, where the sublists of list are the non-empty lists returned by
 
589
 * (list-tail list k) for k less than the length of list.  If obj does not
 
590
 * occur in list, then #f (not the empty list) is returned.
 
591
 * List must be a proper list, otherwise scm_c_memq may crash or loop
 
592
 * endlessly.
 
593
 */
 
594
SCM
 
595
scm_c_memq (SCM obj, SCM list)
 
596
{
 
597
  for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list))
 
598
    {
 
599
      if (scm_is_eq (SCM_CAR (list), obj))
 
600
        return list;
 
601
    }
 
602
  return SCM_BOOL_F;
 
603
}
 
604
 
 
605
 
 
606
SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
 
607
           (SCM x, SCM lst),
 
608
            "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
 
609
            "to @var{x} where the sublists of @var{lst} are the non-empty\n"
 
610
            "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
 
611
            "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
 
612
            "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
 
613
            "returned.")
 
614
#define FUNC_NAME s_scm_memq
 
615
{
 
616
  SCM_VALIDATE_LIST (2, lst);
 
617
  return scm_c_memq (x, lst);
 
618
}
 
619
#undef FUNC_NAME
 
620
 
 
621
 
 
622
SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
 
623
           (SCM x, SCM lst),
 
624
            "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
 
625
            "to @var{x} where the sublists of @var{lst} are the non-empty\n"
 
626
            "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
 
627
            "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
 
628
            "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
 
629
            "returned.")
 
630
#define FUNC_NAME s_scm_memv
 
631
{
 
632
  SCM_VALIDATE_LIST (2, lst);
 
633
  for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
 
634
    {
 
635
      if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
 
636
        return lst;
 
637
    }
 
638
  return SCM_BOOL_F;
 
639
}
 
640
#undef FUNC_NAME
 
641
 
 
642
 
 
643
SCM_DEFINE (scm_member, "member", 2, 0, 0,
 
644
           (SCM x, SCM lst),
 
645
            "Return the first sublist of @var{lst} whose car is\n"
 
646
            "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
 
647
            "the non-empty lists returned by @code{(list-tail @var{lst}\n"
 
648
            "@var{k})} for @var{k} less than the length of @var{lst}.  If\n"
 
649
            "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
 
650
            "empty list) is returned.")
 
651
#define FUNC_NAME s_scm_member
 
652
{
 
653
  SCM_VALIDATE_LIST (2, lst);
 
654
  for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
 
655
    {
 
656
      if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
 
657
        return lst;
 
658
    }
 
659
  return SCM_BOOL_F;
 
660
}
 
661
#undef FUNC_NAME
 
662
 
 
663
 
 
664
/* deleting elements from a list (delq, etc.) */
 
665
 
 
666
SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
 
667
           (SCM item, SCM lst),
 
668
            "@deffnx {Scheme Procedure} delv! item lst\n"
 
669
            "@deffnx {Scheme Procedure} delete! item lst\n"
 
670
            "These procedures are destructive versions of @code{delq}, @code{delv}\n"
 
671
            "and @code{delete}: they modify the existing @var{lst}\n"
 
672
            "rather than creating a new list.  Caveat evaluator: Like other\n"
 
673
            "destructive list functions, these functions cannot modify the binding of\n"
 
674
            "@var{lst}, and so cannot be used to delete the first element of\n"
 
675
            "@var{lst} destructively.")
 
676
#define FUNC_NAME s_scm_delq_x
 
677
{
 
678
  SCM walk;
 
679
  SCM *prev;
 
680
 
 
681
  for (prev = &lst, walk = lst;
 
682
       scm_is_pair (walk);
 
683
       walk = SCM_CDR (walk))
 
684
    {
 
685
      if (scm_is_eq (SCM_CAR (walk), item))
 
686
        *prev = SCM_CDR (walk);
 
687
      else
 
688
        prev = SCM_CDRLOC (walk);
 
689
    }
 
690
    
 
691
  return lst;
 
692
}
 
693
#undef FUNC_NAME
 
694
 
 
695
 
 
696
SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
 
697
            (SCM item, SCM lst),
 
698
            "Destructively remove all elements from @var{lst} that are\n"
 
699
            "@code{eqv?} to @var{item}.")
 
700
#define FUNC_NAME s_scm_delv_x
 
701
{
 
702
  SCM walk;
 
703
  SCM *prev;
 
704
 
 
705
  for (prev = &lst, walk = lst;
 
706
       scm_is_pair (walk);
 
707
       walk = SCM_CDR (walk))
 
708
    {
 
709
      if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
 
710
        *prev = SCM_CDR (walk);
 
711
      else
 
712
        prev = SCM_CDRLOC (walk);
 
713
    }
 
714
    
 
715
  return lst;
 
716
}
 
717
#undef FUNC_NAME
 
718
 
 
719
 
 
720
 
 
721
SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
 
722
            (SCM item, SCM lst),
 
723
            "Destructively remove all elements from @var{lst} that are\n"
 
724
            "@code{equal?} to @var{item}.")
 
725
#define FUNC_NAME s_scm_delete_x
 
726
{
 
727
  SCM walk;
 
728
  SCM *prev;
 
729
 
 
730
  for (prev = &lst, walk = lst;
 
731
       scm_is_pair (walk);
 
732
       walk = SCM_CDR (walk))
 
733
    {
 
734
      if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
 
735
        *prev = SCM_CDR (walk);
 
736
      else
 
737
        prev = SCM_CDRLOC (walk);
 
738
    }
 
739
 
 
740
  return lst;
 
741
}
 
742
#undef FUNC_NAME
 
743
 
 
744
 
 
745
 
 
746
 
 
747
 
 
748
SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
 
749
            (SCM item, SCM lst),
 
750
            "Return a newly-created copy of @var{lst} with elements\n"
 
751
            "@code{eq?} to @var{item} removed.  This procedure mirrors\n"
 
752
            "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
 
753
            "@var{item} with @code{eq?}.")
 
754
#define FUNC_NAME s_scm_delq
 
755
{
 
756
  SCM copy = scm_list_copy (lst);
 
757
  return scm_delq_x (item, copy);
 
758
}
 
759
#undef FUNC_NAME
 
760
 
 
761
SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
 
762
            (SCM item, SCM lst),
 
763
            "Return a newly-created copy of @var{lst} with elements\n"
 
764
            "@code{eqv?}  to @var{item} removed.  This procedure mirrors\n"
 
765
            "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
 
766
            "@var{item} with @code{eqv?}.")
 
767
#define FUNC_NAME s_scm_delv
 
768
{
 
769
  SCM copy = scm_list_copy (lst);
 
770
  return scm_delv_x (item, copy);
 
771
}
 
772
#undef FUNC_NAME
 
773
 
 
774
SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
 
775
            (SCM item, SCM lst),
 
776
            "Return a newly-created copy of @var{lst} with elements\n"
 
777
            "@code{equal?}  to @var{item} removed.  This procedure mirrors\n"
 
778
            "@code{member}: @code{delete} compares elements of @var{lst}\n"
 
779
            "against @var{item} with @code{equal?}.")
 
780
#define FUNC_NAME s_scm_delete
 
781
{
 
782
  SCM copy = scm_list_copy (lst);
 
783
  return scm_delete_x (item, copy);
 
784
}
 
785
#undef FUNC_NAME
 
786
 
 
787
 
 
788
SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
 
789
           (SCM item, SCM lst),
 
790
            "Like @code{delq!}, but only deletes the first occurrence of\n"
 
791
            "@var{item} from @var{lst}.  Tests for equality using\n"
 
792
            "@code{eq?}.  See also @code{delv1!} and @code{delete1!}.")
 
793
#define FUNC_NAME s_scm_delq1_x
 
794
{
 
795
  SCM walk;
 
796
  SCM *prev;
 
797
 
 
798
  for (prev = &lst, walk = lst;
 
799
       scm_is_pair (walk);
 
800
       walk = SCM_CDR (walk))
 
801
    {
 
802
      if (scm_is_eq (SCM_CAR (walk), item))
 
803
        {
 
804
          *prev = SCM_CDR (walk);
 
805
          break;
 
806
        }
 
807
      else
 
808
        prev = SCM_CDRLOC (walk);
 
809
    }
 
810
    
 
811
  return lst;
 
812
}
 
813
#undef FUNC_NAME
 
814
 
 
815
 
 
816
SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
 
817
            (SCM item, SCM lst),
 
818
            "Like @code{delv!}, but only deletes the first occurrence of\n"
 
819
            "@var{item} from @var{lst}.  Tests for equality using\n"
 
820
            "@code{eqv?}.  See also @code{delq1!} and @code{delete1!}.")
 
821
#define FUNC_NAME s_scm_delv1_x
 
822
{
 
823
  SCM walk;
 
824
  SCM *prev;
 
825
 
 
826
  for (prev = &lst, walk = lst;
 
827
       scm_is_pair (walk);
 
828
       walk = SCM_CDR (walk))
 
829
    {
 
830
      if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
 
831
        {
 
832
          *prev = SCM_CDR (walk);
 
833
          break;
 
834
        }
 
835
      else
 
836
        prev = SCM_CDRLOC (walk);
 
837
    }
 
838
    
 
839
  return lst;
 
840
}
 
841
#undef FUNC_NAME
 
842
 
 
843
 
 
844
SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
 
845
            (SCM item, SCM lst),
 
846
            "Like @code{delete!}, but only deletes the first occurrence of\n"
 
847
            "@var{item} from @var{lst}.  Tests for equality using\n"
 
848
            "@code{equal?}.  See also @code{delq1!} and @code{delv1!}.")
 
849
#define FUNC_NAME s_scm_delete1_x
 
850
{
 
851
  SCM walk;
 
852
  SCM *prev;
 
853
 
 
854
  for (prev = &lst, walk = lst;
 
855
       scm_is_pair (walk);
 
856
       walk = SCM_CDR (walk))
 
857
    {
 
858
      if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
 
859
        {
 
860
          *prev = SCM_CDR (walk);
 
861
          break;
 
862
        }
 
863
      else
 
864
        prev = SCM_CDRLOC (walk);
 
865
    }
 
866
 
 
867
  return lst;
 
868
}
 
869
#undef FUNC_NAME
 
870
 
 
871
SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
 
872
            (SCM pred, SCM list),
 
873
            "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
 
874
            "The list is not disordered -- elements that appear in the result list occur\n"
 
875
            "in the same order as they occur in the argument list. The returned list may\n"
 
876
            "share a common tail with the argument list. The dynamic order in which the\n"
 
877
            "various applications of pred are made is not specified.\n\n"
 
878
            "@lisp\n"
 
879
            "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
 
880
            "@end lisp")
 
881
#define FUNC_NAME s_scm_filter
 
882
{
 
883
  scm_t_trampoline_1 call = scm_trampoline_1 (pred);
 
884
  SCM walk;
 
885
  SCM *prev;
 
886
  SCM res = SCM_EOL;
 
887
  SCM_ASSERT (call, pred, 1, FUNC_NAME);
 
888
  SCM_VALIDATE_LIST (2, list);
 
889
  
 
890
  for (prev = &res, walk = list;
 
891
       scm_is_pair (walk);
 
892
       walk = SCM_CDR (walk))
 
893
    {
 
894
      if (scm_is_true (call (pred, SCM_CAR (walk))))
 
895
        {
 
896
          *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
 
897
          prev = SCM_CDRLOC (*prev);
 
898
        }
 
899
    }
 
900
 
 
901
  return res;
 
902
}
 
903
#undef FUNC_NAME
 
904
 
 
905
SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
 
906
            (SCM pred, SCM list),
 
907
            "Linear-update variant of @code{filter}.")
 
908
#define FUNC_NAME s_scm_filter_x
 
909
{
 
910
  scm_t_trampoline_1 call = scm_trampoline_1 (pred);
 
911
  SCM walk;
 
912
  SCM *prev;
 
913
  SCM_ASSERT (call, pred, 1, FUNC_NAME);
 
914
  SCM_VALIDATE_LIST (2, list);
 
915
  
 
916
  for (prev = &list, walk = list;
 
917
       scm_is_pair (walk);
 
918
       walk = SCM_CDR (walk))
 
919
    {
 
920
      if (scm_is_true (call (pred, SCM_CAR (walk))))
 
921
        prev = SCM_CDRLOC (walk);
 
922
      else
 
923
        *prev = SCM_CDR (walk);
 
924
    }
 
925
 
 
926
  return list;
 
927
}
 
928
#undef FUNC_NAME
 
929
 
 
930
 
 
931
void
 
932
scm_init_list ()
 
933
{
 
934
#include "libguile/list.x"
 
935
}
 
936
 
 
937
/*
 
938
  Local Variables:
 
939
  c-file-style: "gnu"
 
940
  End:
 
941
*/