/[guile]/guile/guile-core/srfi/srfi-1.c
ViewVC logotype

Diff of /guile/guile-core/srfi/srfi-1.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by dirk, Mon Apr 21 01:59:57 2003 UTC revision 1.7 by kryde, Tue Jul 8 00:09:17 2003 UTC
# Line 1  Line 1 
1  /* srfi-1.c --- SRFI-1 procedures for Guile  /* srfi-1.c --- SRFI-1 procedures for Guile
2   *   *
3   *      Copyright (C) 2002, 2003 Free Software Foundation, Inc.   *      Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003 Free Software
4     *      Foundation, Inc.
5   *   *
6   * This library is free software; you can redistribute it and/or   * This library is free software; you can redistribute it and/or
7   * modify it under the terms of the GNU Lesser General Public   * modify it under the terms of the GNU Lesser General Public
# Line 55  srfi1_ilength (SCM sx) Line 56  srfi1_ilength (SCM sx)
56    return -1;    return -1;
57  }  }
58    
59    static SCM
60    equal_trampoline (SCM proc, SCM arg1, SCM arg2)
61    {
62      return scm_equal_p (arg1, arg2);
63    }
64    
65    
66    SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
67                (SCM x, SCM lst, SCM pred),
68                "Return a list containing the elements of @var{lst} but with\n"
69                "those equal to @var{x} deleted.  The returned elements will be\n"
70                "in the same order as they were in @var{lst}.\n"
71                "\n"
72                "Equality is determined by @var{pred}, or @code{equal?} if not\n"
73                "given.  An equality call is made just once for each element,\n"
74                "but the order in which the calls are made on the elements is\n"
75                "unspecified.\n"
76                "\n"
77                "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
78                "given @var{x} is first.  This means for instance elements\n"
79                "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
80                "\n"
81                "@var{lst} is not modified, but the returned list might share a\n"
82                "common tail with @var{lst}.")
83    #define FUNC_NAME s_scm_srfi1_delete
84    {
85      scm_t_trampoline_2 equal_p;
86      SCM  ret, *p, keeplst;
87    
88      if (SCM_UNBNDP (pred))
89        return scm_delete (x, lst);
90    
91      equal_p = scm_trampoline_2 (pred);
92      SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
93    
94      /* ret is the return list being constructed.  p is where to append to it,
95         initially &ret then SCM_CDRLOC of the last pair.  lst progresses as
96         elements are considered.
97    
98         Elements to be retained are not immediately copied, instead keeplst is
99         the last pair in lst which is to be retained but not yet copied.  When
100         there's no more deletions, *p can be set to keeplst to share the
101         remainder of the original lst.  (The entire original lst if there's no
102         deletions at all.)  */
103    
104      keeplst = lst;
105      ret = SCM_EOL;
106      p = &ret;
107    
108      for ( ; SCM_CONSP (lst); lst = SCM_CDR (lst))
109        {
110          if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (lst))))
111            {
112              /* delete this element, so copy from keeplst (inclusive) to lst
113                 (exclusive) onto ret */
114              while (! SCM_EQ_P (keeplst, lst))
115                {
116                  SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
117                  *p = c;
118                  p = SCM_CDRLOC (c);
119                  keeplst = SCM_CDR (keeplst);
120                }
121    
122              keeplst = SCM_CDR (lst);
123            }
124        }
125    
126      /* final retained elements */
127      *p = keeplst;
128    
129      /* demand that lst was a proper list */
130      SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
131    
132      return ret;
133    }
134    #undef FUNC_NAME
135    
136    
137    SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0,
138                (SCM x, SCM lst, SCM pred),
139                "Return a list containing the elements of @var{lst} but with\n"
140                "those equal to @var{x} deleted.  The returned elements will be\n"
141                "in the same order as they were in @var{lst}.\n"
142                "\n"
143                "Equality is determined by @var{pred}, or @code{equal?} if not\n"
144                "given.  An equality call is made just once for each element,\n"
145                "but the order in which the calls are made on the elements is\n"
146                "unspecified.\n"
147                "\n"
148                "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
149                "given @var{x} is first.  This means for instance elements\n"
150                "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
151                "\n"
152                "@var{lst} may be modified to construct the returned list.")
153    #define FUNC_NAME s_scm_srfi1_delete_x
154    {
155      scm_t_trampoline_2 equal_p;
156      SCM walk;
157      SCM *prev;
158    
159      if (SCM_UNBNDP (pred))
160        return scm_delete_x (x, lst);
161    
162      equal_p = scm_trampoline_2 (pred);
163      SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
164    
165      for (prev = &lst, walk = lst;
166           SCM_CONSP (walk);
167           walk = SCM_CDR (walk))
168        {
169          if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (walk))))
170            *prev = SCM_CDR (walk);
171          else
172            prev = SCM_CDRLOC (walk);
173        }
174    
175      /* demand the input was a proper list */
176      SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list");
177      return lst;
178    }
179    #undef FUNC_NAME
180    
181    
182    SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
183                (SCM lst, SCM pred),
184                "Return a list containing the elements of @var{lst} but without\n"
185                "duplicates.\n"
186                "\n"
187                "When elements are equal, only the first in @var{lst} is\n"
188                "retained.  Equal elements can be anywhere in @var{lst}, they\n"
189                "don't have to be adjacent.  The returned list will have the\n"
190                "retained elements in the same order as they were in @var{lst}.\n"
191                "\n"
192                "Equality is determined by @var{pred}, or @code{equal?} if not\n"
193                "given.  Calls @code{(pred x y)} are made with element @var{x}\n"
194                "being before @var{y} in @var{lst}.  A call is made at most once\n"
195                "for each combination, but the sequence of the calls across the\n"
196                "elements is unspecified.\n"
197                "\n"
198                "@var{lst} is not modified, but the return might share a common\n"
199                "tail with @var{lst}.\n"
200                "\n"
201                "In the worst case, this is an @math{O(N^2)} algorithm because\n"
202                "it must check each element against all those preceding it.  For\n"
203                "long lists it is more efficient to sort and then compare only\n"
204                "adjacent elements.")
205    #define FUNC_NAME s_scm_srfi1_delete_duplicates
206    {
207      scm_t_trampoline_2 equal_p;
208      SCM  ret, *p, keeplst, item, l;
209    
210      /* ret is the new list constructed.  p is where to append, initially &ret
211         then SCM_CDRLOC of the last pair.  lst is advanced as each element is
212         considered.
213    
214         Elements retained are not immediately appended to ret, instead keeplst
215         is the last pair in lst which is to be kept but is not yet copied.
216         Initially this is the first pair of lst, since the first element is
217         always retained.
218    
219         *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
220         the elements retained, making the equality search loop easy.
221    
222         If an item must be deleted, elements from keeplst (inclusive) to lst
223         (exclusive) must be copied and appended to ret.  When there's no more
224         deletions, *p is left set to keeplst, so ret shares structure with the
225         original lst.  (ret will be the entire original lst if there are no
226         deletions.)  */
227    
228      /* skip to end if an empty list (or something invalid) */
229      ret = lst;
230      if (SCM_CONSP (lst))
231        {
232          if (SCM_UNBNDP (pred))
233            equal_p = equal_trampoline;
234          else
235            {
236              equal_p = scm_trampoline_2 (pred);
237              SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
238            }
239    
240          keeplst = lst;
241          p = &ret;
242    
243          /* loop over lst elements starting from second */
244          for (;;)
245            {
246              lst = SCM_CDR (lst);
247              if (! SCM_CONSP (lst))
248                break;
249              item = SCM_CAR (lst);
250    
251              /* loop searching ret upto lst */
252              for (l = ret; ! SCM_EQ_P (l, lst); l = SCM_CDR (l))
253                {
254                  if (! SCM_FALSEP (equal_p (pred, SCM_CAR (l), item)))
255                    {
256                      /* duplicate, don't want this element, so copy keeplst
257                         (inclusive) to lst (exclusive) onto ret */
258                      while (! SCM_EQ_P (keeplst, lst))
259                        {
260                          SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
261                          *p = c;
262                          p = SCM_CDRLOC (c);
263                          keeplst = SCM_CDR (keeplst);
264                        }
265    
266                      keeplst = SCM_CDR (lst);  /* elem after the one deleted */
267                      *p = keeplst;
268                      break;
269                    }
270                }
271            }
272        }
273    
274      /* demand that lst was a proper list */
275      SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
276    
277      return ret;
278    }
279    #undef FUNC_NAME
280    
281    
282    SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
283                (SCM lst, SCM pred),
284                "Return a list containing the elements of @var{lst} but without\n"
285                "duplicates.\n"
286                "\n"
287                "When elements are equal, only the first in @var{lst} is\n"
288                "retained.  Equal elements can be anywhere in @var{lst}, they\n"
289                "don't have to be adjacent.  The returned list will have the\n"
290                "retained elements in the same order as they were in @var{lst}.\n"
291                "\n"
292                "Equality is determined by @var{pred}, or @code{equal?} if not\n"
293                "given.  Calls @code{(pred x y)} are made with element @var{x}\n"
294                "being before @var{y} in @var{lst}.  A call is made at most once\n"
295                "for each combination, but the sequence of the calls across the\n"
296                "elements is unspecified.\n"
297                "\n"
298                "@var{lst} may be modified to construct the returned list.\n"
299                "\n"
300                "In the worst case, this is an @math{O(N^2)} algorithm because\n"
301                "it must check each element against all those preceding it.  For\n"
302                "long lists it is more efficient to sort and then compare only\n"
303                "adjacent elements.")
304    #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
305    {
306      scm_t_trampoline_2 equal_p;
307      SCM  ret, endret, item, l;
308    
309      /* ret is the return list, constructed from the pairs in lst.  endret is
310         the last pair of ret, initially the first pair.  lst is advanced as
311         elements are considered.  */
312    
313      /* skip to end if an empty list (or something invalid) */
314      ret = lst;
315      if (SCM_CONSP (lst))
316        {
317          if (SCM_UNBNDP (pred))
318            equal_p = equal_trampoline;
319          else
320            {
321              equal_p = scm_trampoline_2 (pred);
322              SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
323            }
324    
325          endret = ret;
326    
327          /* loop over lst elements starting from second */
328          for (;;)
329            {
330              lst = SCM_CDR (lst);
331              if (! SCM_CONSP (lst))
332                break;
333              item = SCM_CAR (lst);
334    
335              /* is item equal to any element from ret to endret (inclusive)? */
336              l = ret;
337              for (;;)
338                {
339                  if (! SCM_FALSEP (equal_p (pred, SCM_CAR (l), item)))
340                    break;  /* equal, forget this element */
341    
342                  if (SCM_EQ_P (l, endret))
343                    {
344                      /* not equal to any, so append this pair */
345                      SCM_SETCDR (endret, lst);
346                      endret = lst;
347                      break;
348                    }
349                  l = SCM_CDR (l);
350                }
351            }
352    
353          /* terminate, in case last element was deleted */
354          SCM_SETCDR (endret, SCM_EOL);
355        }
356    
357      /* demand that lst was a proper list */
358      SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
359    
360      return ret;
361    }
362    #undef FUNC_NAME
363    
364    
365  /* Typechecking for multi-argument MAP and FOR-EACH.  /* Typechecking for multi-argument MAP and FOR-EACH.
366    
367     Verify that each element of the vector ARGV, except for the first,     Verify that each element of the vector ARGV, except for the first,
# Line 253  scm_srfi1_for_each (SCM proc, SCM arg1, Line 560  scm_srfi1_for_each (SCM proc, SCM arg1,
560  #undef FUNC_NAME  #undef FUNC_NAME
561    
562    
 static SCM  
 equal_trampoline (SCM proc, SCM arg1, SCM arg2)  
 {  
   return scm_equal_p (arg1, arg2);  
 }  
   
563  SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,  SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
564             (SCM x, SCM lst, SCM pred),             (SCM x, SCM lst, SCM pred),
565              "Return the first sublist of @var{lst} whose car is\n"              "Return the first sublist of @var{lst} whose car is\n"

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26