srfi/srfi-1.c

   1 /* srfi-1.c --- SRFI-1 procedures for Guile
   2  *
   3  *      Copyright (C) 2002, 2003 Free Software Foundation, Inc.
   4  *
   5  * This library is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU Lesser General Public
   7  * License as published by the Free Software Foundation; either
   8  * version 2.1 of the License, or (at your option) any later version.
   9  *
  10  * This library is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18  */
  19
  20 #include <libguile.h>
  21 #include <libguile/lang.h>
  22
  23 #include "srfi-1.h"
  24
  25 /* The intent of this file is to gradually replace those Scheme
  26  * procedures in srfi-1.scm which extends core primitive procedures,
  27  * so that using srfi-1 won't have performance penalties.
  28  *
  29  * Please feel free to contribute any new replacements!
  30  */
  31
  32 static long
  33 srfi1_ilength (SCM sx)
  34 {
  35   long i = 0;
  36   SCM tortoise = sx;
  37   SCM hare = sx;
  38
  39   do {
  40     if (SCM_NULL_OR_NIL_P(hare)) return i;
  41     if (SCM_NCONSP(hare)) return -2;
  42     hare = SCM_CDR(hare);
  43     i++;
  44     if (SCM_NULL_OR_NIL_P(hare)) return i;
  45     if (SCM_NCONSP(hare)) return -2;
  46     hare = SCM_CDR(hare);
  47     i++;
  48     /* For every two steps the hare takes, the tortoise takes one.  */
  49     tortoise = SCM_CDR(tortoise);
  50   }
  51   while (! SCM_EQ_P (hare, tortoise));
  52
  53   /* If the tortoise ever catches the hare, then the list must contain
  54      a cycle.  */
  55   return -1;
  56 }
  57
  58 /* Typechecking for multi-argument MAP and FOR-EACH.
  59
  60    Verify that each element of the vector ARGV, except for the first,
  61    is a list and return minimum length.  Attribute errors to WHO,
  62    and claim that the i'th element of ARGV is WHO's i+2'th argument.  */
  63 static inline int
  64 check_map_args (SCM argv,
  65                 long len,
  66                 SCM gf,
  67                 SCM proc,
  68                 SCM args,
  69                 const char *who)
  70 {
  71   SCM const *ve = SCM_VELTS (argv);
  72   long i;
  73
  74   for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
  75     {
  76       long elt_len;
  77
  78       if (!(SCM_NULLP (ve[i]) || SCM_CONSP (ve[i])))
  79         {
  80         check_map_error:
  81           if (gf)
  82             scm_apply_generic (gf, scm_cons (proc, args));
  83           else
  84             scm_wrong_type_arg (who, i + 2, ve[i]);
  85         }
  86
  87       elt_len = srfi1_ilength (ve[i]);
  88       if (elt_len < -1)
  89         goto check_map_error;
  90
  91       if (len < 0 || (elt_len >= 0 && elt_len < len))
  92         len = elt_len;
  93     }
  94   if (len < 0)
  95     /* i == 0 */
  96     goto check_map_error;
  97
  98   scm_remember_upto_here_1 (argv);
  99   return len;
 100 }
 101
 102
 103 SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map);
 104
 105 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
 106    sequentially, starting with the first element(s).  This is used in
 107    the Scheme procedure `map-in-order', which guarantees sequential
 108    behaviour, is implemented using scm_map.  If the behaviour changes,
 109    we need to update `map-in-order'.
 110 */
 111
 112 SCM
 113 scm_srfi1_map (SCM proc, SCM arg1, SCM args)
 114 #define FUNC_NAME s_srfi1_map
 115 {
 116   long i, len;
 117   SCM res = SCM_EOL;
 118   SCM *pres = &res;
 119   SCM const *ve = &args;                /* Keep args from being optimized away. */
 120
 121   len = srfi1_ilength (arg1);
 122   SCM_GASSERTn ((SCM_NULLP (arg1) || SCM_CONSP (arg1)) && len >= -1,
 123                 g_srfi1_map,
 124                 scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map);
 125   SCM_VALIDATE_REST_ARGUMENT (args);
 126   if (SCM_NULLP (args))
 127     {
 128       scm_t_trampoline_1 call = scm_trampoline_1 (proc);
 129       SCM_GASSERT2 (call, g_srfi1_map, proc, arg1, SCM_ARG1, s_srfi1_map);
 130       SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map);
 131       while (SCM_NIMP (arg1))
 132         {
 133           *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
 134           pres = SCM_CDRLOC (*pres);
 135           arg1 = SCM_CDR (arg1);
 136         }
 137       return res;
 138     }
 139   if (SCM_NULLP (SCM_CDR (args)))
 140     {
 141       SCM arg2 = SCM_CAR (args);
 142       int len2 = srfi1_ilength (arg2);
 143       scm_t_trampoline_2 call = scm_trampoline_2 (proc);
 144       SCM_GASSERTn (call, g_srfi1_map,
 145                     scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map);
 146       if (len < 0 || (len2 >= 0 && len2 < len))
 147         len = len2;
 148       SCM_GASSERTn ((SCM_NULLP (arg2) || SCM_CONSP (arg2))
 149                     && len >= 0 && len2 >= -1,
 150                     g_srfi1_map,
 151                     scm_cons2 (proc, arg1, args),
 152                     len2 >= 0 ? SCM_ARG2 : SCM_ARG3,
 153                     s_srfi1_map);
 154       while (len > 0)
 155         {
 156           *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
 157           pres = SCM_CDRLOC (*pres);
 158           arg1 = SCM_CDR (arg1);
 159           arg2 = SCM_CDR (arg2);
 160           --len;
 161         }
 162       return res;
 163     }
 164   args = scm_vector (arg1 = scm_cons (arg1, args));
 165   ve = SCM_VELTS (args);
 166   len = check_map_args (args, len, g_srfi1_map, proc, arg1, s_srfi1_map);
 167   while (len > 0)
 168     {
 169       arg1 = SCM_EOL;
 170       for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
 171         {
 172           arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
 173           SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
 174         }
 175       *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
 176       pres = SCM_CDRLOC (*pres);
 177       --len;
 178     }
 179   return res;
 180 }
 181 #undef FUNC_NAME
 182
 183 SCM_REGISTER_PROC (s_srfi1_map_in_order, "map-in-order", 2, 0, 1, scm_srfi1_map);
 184
 185 SCM_GPROC (s_srfi1_for_each, "for-each", 2, 0, 1, scm_srfi1_for_each, g_srfi1_for_each);
 186
 187 SCM
 188 scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
 189 #define FUNC_NAME s_srfi1_for_each
 190 {
 191   SCM const *ve = &args;                /* Keep args from being optimized away. */
 192   long i, len;
 193   len = srfi1_ilength (arg1);
 194   SCM_GASSERTn ((SCM_NULLP (arg1) || SCM_CONSP (arg1)) && len >= -1,
 195                 g_srfi1_for_each, scm_cons2 (proc, arg1, args),
 196                 SCM_ARG2, s_srfi1_for_each);
 197   SCM_VALIDATE_REST_ARGUMENT (args);
 198   if (SCM_NULLP (args))
 199     {
 200       scm_t_trampoline_1 call = scm_trampoline_1 (proc);
 201       SCM_GASSERT2 (call, g_srfi1_for_each, proc, arg1,
 202                     SCM_ARG1, s_srfi1_for_each);
 203       SCM_GASSERT2 (len >= 0, g_srfi1_for_each, proc, arg1,
 204                     SCM_ARG2, s_srfi1_map);
 205       while (SCM_NIMP (arg1))
 206         {
 207           call (proc, SCM_CAR (arg1));
 208           arg1 = SCM_CDR (arg1);
 209         }
 210       return SCM_UNSPECIFIED;
 211     }
 212   if (SCM_NULLP (SCM_CDR (args)))
 213     {
 214       SCM arg2 = SCM_CAR (args);
 215       int len2 = srfi1_ilength (arg2);
 216       scm_t_trampoline_2 call = scm_trampoline_2 (proc);
 217       SCM_GASSERTn (call, g_srfi1_for_each,
 218                     scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each);
 219       if (len < 0 || (len2 >= 0 && len2 < len))
 220         len = len2;
 221       SCM_GASSERTn ((SCM_NULLP (arg2) || SCM_CONSP (arg2))
 222                     && len >= 0 && len2 >= -1,
 223                     g_srfi1_for_each,
 224                     scm_cons2 (proc, arg1, args),
 225                     len2 >= 0 ? SCM_ARG2 : SCM_ARG3,
 226                     s_srfi1_for_each);
 227       while (len > 0)
 228         {
 229           call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
 230           arg1 = SCM_CDR (arg1);
 231           arg2 = SCM_CDR (arg2);
 232           --len;
 233         }
 234       return SCM_UNSPECIFIED;
 235     }
 236   args = scm_vector (arg1 = scm_cons (arg1, args));
 237   ve = SCM_VELTS (args);
 238   len = check_map_args (args, len, g_srfi1_for_each, proc, arg1,
 239                         s_srfi1_for_each);
 240   while (len > 0)
 241     {
 242       arg1 = SCM_EOL;
 243       for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
 244         {
 245           arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
 246           SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
 247         }
 248       scm_apply (proc, arg1, SCM_EOL);
 249       --len;
 250     }
 251   return SCM_UNSPECIFIED;
 252 }
 253 #undef FUNC_NAME
 254
 255
 256 static SCM
 257 equal_trampoline (SCM proc, SCM arg1, SCM arg2)
 258 {
 259   return scm_equal_p (arg1, arg2);
 260 }
 261
 262 SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
 263            (SCM x, SCM lst, SCM pred),
 264             "Return the first sublist of @var{lst} whose car is\n"
 265             "@var{equal?} to @var{x} where the sublists of @var{lst} are\n"
 266             "the non-empty lists returned by @code{(list-tail @var{lst}\n"
 267             "@var{k})} for @var{k} less than the length of @var{lst}.  If\n"
 268             "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
 269             "empty list) is returned.  If optional third argument @var{equal?}\n"
 270             "isn't given, @code{equal?} is used for comparison.\n"
 271             "(Extended from R5RS.)\n")
 272 #define FUNC_NAME s_scm_srfi1_member
 273 {
 274   scm_t_trampoline_2 equal_p;
 275   SCM_VALIDATE_LIST (2, lst);
 276   if (SCM_UNBNDP (pred))
 277     equal_p = equal_trampoline;
 278   else
 279     {
 280       equal_p = scm_trampoline_2 (pred);
 281       SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
 282     }
 283   for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
 284     {
 285       if (!SCM_FALSEP (equal_p (pred, SCM_CAR (lst), x)))
 286         return lst;
 287     }
 288   return SCM_BOOL_F;
 289 }
 290 #undef FUNC_NAME
 291
 292 SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
 293             (SCM key, SCM alist, SCM pred),
 294             "Behaves like @code{assq} but uses third argument @var{pred?}\n"
 295             "for key comparison.  If @var{pred?} is not supplied,\n"
 296             "@code{equal?} is used.  (Extended from R5RS.)\n")
 297 #define FUNC_NAME s_scm_srfi1_assoc
 298 {
 299   SCM ls = alist;
 300   scm_t_trampoline_2 equal_p;
 301   if (SCM_UNBNDP (pred))
 302     equal_p = equal_trampoline;
 303   else
 304     {
 305       equal_p = scm_trampoline_2 (pred);
 306       SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
 307     }
 308   for(; SCM_CONSP (ls); ls = SCM_CDR (ls))
 309     {
 310       SCM tmp = SCM_CAR (ls);
 311       SCM_ASSERT_TYPE (SCM_CONSP (tmp), alist, SCM_ARG2, FUNC_NAME,
 312                        "association list");
 313       if (SCM_NFALSEP (equal_p (pred, SCM_CAR (tmp), key)))
 314         return tmp;
 315     }
 316   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
 317                    "association list");
 318   return SCM_BOOL_F;
 319 }
 320 #undef FUNC_NAME
 321
 322 void
 323 scm_init_srfi_1 (void)
 324 {
 325   SCM the_root_module = scm_lookup_closure_module (SCM_BOOL_F);
 326 #ifndef SCM_MAGIC_SNARFER
 327 #include "srfi/srfi-1.x"
 328 #endif
 329   scm_c_extend_primitive_generic
 330     (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "map")),
 331      SCM_VARIABLE_REF (scm_c_lookup ("map")));
 332   scm_c_extend_primitive_generic
 333     (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "for-each")),
 334      SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
 335 }
 336
 337 /* End of srfi-1.c.  */