srfi/srfi-1.c

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