libguile/alist.c

   1 /* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18
  19 \f
  20 #include "libguile/_scm.h"
  21 #include "libguile/eq.h"
  22 #include "libguile/list.h"
  23 #include "libguile/lang.h"
  24
  25 #include "libguile/validate.h"
  26 #include "libguile/pairs.h"
  27 #include "libguile/alist.h"
  28
  29 \f
  30
  31 SCM_DEFINE (scm_acons, "acons", 3, 0, 0,
  32            (SCM key, SCM value, SCM alist),
  33             "Add a new key-value pair to @var{alist}.  A new pair is\n"
  34             "created whose car is @var{key} and whose cdr is @var{value}, and the\n"
  35             "pair is consed onto @var{alist}, and the new list is returned.  This\n"
  36             "function is @emph{not} destructive; @var{alist} is not modified.")
  37 #define FUNC_NAME s_scm_acons
  38 {
  39   return scm_cell (SCM_UNPACK (scm_cell (SCM_UNPACK (key),
  40                                          SCM_UNPACK (value))),
  41                    SCM_UNPACK (alist));
  42 }
  43 #undef FUNC_NAME
  44
  45 \f
  46
  47 SCM_DEFINE (scm_sloppy_assq, "sloppy-assq", 2, 0, 0,
  48             (SCM key, SCM alist),
  49             "Behaves like @code{assq} but does not do any error checking.\n"
  50             "Recommended only for use in Guile internals.")
  51 #define FUNC_NAME s_scm_sloppy_assq
  52 {
  53   for (; scm_is_pair (alist); alist = SCM_CDR (alist))
  54     {
  55       SCM tmp = SCM_CAR (alist);
  56       if (scm_is_pair (tmp) && scm_is_eq (SCM_CAR (tmp), key))
  57         return tmp;
  58     }
  59   return SCM_BOOL_F;
  60 }
  61 #undef FUNC_NAME
  62
  63
  64
  65 SCM_DEFINE (scm_sloppy_assv, "sloppy-assv", 2, 0, 0,
  66             (SCM key, SCM alist),
  67             "Behaves like @code{assv} but does not do any error checking.\n"
  68             "Recommended only for use in Guile internals.")
  69 #define FUNC_NAME s_scm_sloppy_assv
  70 {
  71   for (; scm_is_pair (alist); alist = SCM_CDR (alist))
  72     {
  73       SCM tmp = SCM_CAR (alist);
  74       if (scm_is_pair (tmp)
  75           && scm_is_true (scm_eqv_p (SCM_CAR (tmp), key)))
  76         return tmp;
  77     }
  78   return SCM_BOOL_F;
  79 }
  80 #undef FUNC_NAME
  81
  82
  83 SCM_DEFINE (scm_sloppy_assoc, "sloppy-assoc", 2, 0, 0,
  84             (SCM key, SCM alist),
  85             "Behaves like @code{assoc} but does not do any error checking.\n"
  86             "Recommended only for use in Guile internals.")
  87 #define FUNC_NAME s_scm_sloppy_assoc
  88 {
  89   for (; scm_is_pair (alist); alist = SCM_CDR (alist))
  90     {
  91       SCM tmp = SCM_CAR (alist);
  92       if (scm_is_pair (tmp)
  93           && scm_is_true (scm_equal_p (SCM_CAR (tmp), key)))
  94         return tmp;
  95     }
  96   return SCM_BOOL_F;
  97 }
  98 #undef FUNC_NAME
  99
 100
 101 \f
 102
 103 SCM_DEFINE (scm_assq, "assq", 2, 0, 0,
 104            (SCM key, SCM alist),
 105             "@deffnx {Scheme Procedure} assv key alist\n"
 106             "@deffnx {Scheme Procedure} assoc key alist\n"
 107             "Fetch the entry in @var{alist} that is associated with @var{key}.  To\n"
 108             "decide whether the argument @var{key} matches a particular entry in\n"
 109             "@var{alist}, @code{assq} compares keys with @code{eq?}, @code{assv}\n"
 110             "uses @code{eqv?} and @code{assoc} uses @code{equal?}.  If @var{key}\n"
 111             "cannot be found in @var{alist} (according to whichever equality\n"
 112             "predicate is in use), then return @code{#f}.  These functions\n"
 113             "return the entire alist entry found (i.e. both the key and the value).")
 114 #define FUNC_NAME s_scm_assq
 115 {
 116   SCM ls = alist;
 117   for(; scm_is_pair (ls); ls = SCM_CDR (ls))
 118     {
 119       SCM tmp = SCM_CAR (ls);
 120       SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
 121                        "association list");
 122       if (scm_is_eq (SCM_CAR (tmp), key))
 123         return tmp;
 124     }
 125   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
 126                    "association list");
 127   return SCM_BOOL_F;
 128 }
 129 #undef FUNC_NAME
 130
 131
 132 SCM_DEFINE (scm_assv, "assv", 2, 0, 0,
 133            (SCM key, SCM alist),
 134             "Behaves like @code{assq} but uses @code{eqv?} for key comparison.")
 135 #define FUNC_NAME s_scm_assv
 136 {
 137   SCM ls = alist;
 138   for(; scm_is_pair (ls); ls = SCM_CDR (ls))
 139     {
 140       SCM tmp = SCM_CAR (ls);
 141       SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
 142                        "association list");
 143       if (scm_is_true (scm_eqv_p (SCM_CAR (tmp), key)))
 144         return tmp;
 145     }
 146   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
 147                    "association list");
 148   return SCM_BOOL_F;
 149 }
 150 #undef FUNC_NAME
 151
 152
 153 SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0,
 154            (SCM key, SCM alist),
 155             "Behaves like @code{assq} but uses @code{equal?} for key comparison.")
 156 #define FUNC_NAME s_scm_assoc
 157 {
 158   SCM ls = alist;
 159   for(; scm_is_pair (ls); ls = SCM_CDR (ls))
 160     {
 161       SCM tmp = SCM_CAR (ls);
 162       SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
 163                        "association list");
 164       if (scm_is_true (scm_equal_p (SCM_CAR (tmp), key)))
 165         return tmp;
 166     }
 167   SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
 168                    "association list");
 169   return SCM_BOOL_F;
 170 }
 171 #undef FUNC_NAME
 172
 173
 174 \f
 175
 176 /* Dirk:API2.0:: We should not return #f if the key was not found.  In the
 177  * current solution we can not distinguish between finding a (key . #f) pair
 178  * and not finding the key at all.
 179  *
 180  * Possible alternative solutions:
 181  * 1) Remove assq-ref from the API:  assq is sufficient.
 182  * 2) Signal an error (what error type?) if the key is not found.
 183  * 3) provide an additional 'default' parameter.
 184  * 3.1) The default parameter is mandatory.
 185  * 3.2) The default parameter is optional, but if no default is given and
 186  *      the key is not found, signal an error (what error type?).
 187  */
 188 SCM_DEFINE (scm_assq_ref, "assq-ref", 2, 0, 0,
 189             (SCM alist, SCM key),
 190             "@deffnx {Scheme Procedure} assv-ref alist key\n"
 191             "@deffnx {Scheme Procedure} assoc-ref alist key\n"
 192             "Like @code{assq}, @code{assv} and @code{assoc}, except that only the\n"
 193             "value associated with @var{key} in @var{alist} is returned.  These\n"
 194             "functions are equivalent to\n\n"
 195             "@lisp\n"
 196             "(let ((ent (@var{associator} @var{key} @var{alist})))\n"
 197             "  (and ent (cdr ent)))\n"
 198             "@end lisp\n\n"
 199             "where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}.")
 200 #define FUNC_NAME s_scm_assq_ref
 201 {
 202   SCM handle;
 203
 204   handle = scm_sloppy_assq (key, alist);
 205   if (scm_is_pair (handle))
 206     {
 207       return SCM_CDR (handle);
 208     }
 209   return SCM_BOOL_F;
 210 }
 211 #undef FUNC_NAME
 212
 213
 214 SCM_DEFINE (scm_assv_ref, "assv-ref", 2, 0, 0,
 215             (SCM alist, SCM key),
 216             "Behaves like @code{assq-ref} but uses @code{eqv?} for key comparison.")
 217 #define FUNC_NAME s_scm_assv_ref
 218 {
 219   SCM handle;
 220
 221   handle = scm_sloppy_assv (key, alist);
 222   if (scm_is_pair (handle))
 223     {
 224       return SCM_CDR (handle);
 225     }
 226   return SCM_BOOL_F;
 227 }
 228 #undef FUNC_NAME
 229
 230
 231 SCM_DEFINE (scm_assoc_ref, "assoc-ref", 2, 0, 0,
 232             (SCM alist, SCM key),
 233             "Behaves like @code{assq-ref} but uses @code{equal?} for key comparison.")
 234 #define FUNC_NAME s_scm_assoc_ref
 235 {
 236   SCM handle;
 237
 238   handle = scm_sloppy_assoc (key, alist);
 239   if (scm_is_pair (handle))
 240     {
 241       return SCM_CDR (handle);
 242     }
 243   return SCM_BOOL_F;
 244 }
 245 #undef FUNC_NAME
 246
 247
 248
 249 \f
 250
 251
 252 SCM_DEFINE (scm_assq_set_x, "assq-set!", 3, 0, 0,
 253             (SCM alist, SCM key, SCM val),
 254             "@deffnx {Scheme Procedure} assv-set! alist key value\n"
 255             "@deffnx {Scheme Procedure} assoc-set! alist key value\n"
 256             "Reassociate @var{key} in @var{alist} with @var{value}: find any existing\n"
 257             "@var{alist} entry for @var{key} and associate it with the new\n"
 258             "@var{value}.  If @var{alist} does not contain an entry for @var{key},\n"
 259             "add a new one.  Return the (possibly new) alist.\n\n"
 260             "These functions do not attempt to verify the structure of @var{alist},\n"
 261             "and so may cause unusual results if passed an object that is not an\n"
 262             "association list.")
 263 #define FUNC_NAME s_scm_assq_set_x
 264 {
 265   SCM handle;
 266
 267   handle = scm_sloppy_assq (key, alist);
 268   if (scm_is_pair (handle))
 269     {
 270       SCM_SETCDR (handle, val);
 271       return alist;
 272     }
 273   else
 274     return scm_acons (key, val, alist);
 275 }
 276 #undef FUNC_NAME
 277
 278 SCM_DEFINE (scm_assv_set_x, "assv-set!", 3, 0, 0,
 279             (SCM alist, SCM key, SCM val),
 280             "Behaves like @code{assq-set!} but uses @code{eqv?} for key comparison.")
 281 #define FUNC_NAME s_scm_assv_set_x
 282 {
 283   SCM handle;
 284
 285   handle = scm_sloppy_assv (key, alist);
 286   if (scm_is_pair (handle))
 287     {
 288       SCM_SETCDR (handle, val);
 289       return alist;
 290     }
 291   else
 292     return scm_acons (key, val, alist);
 293 }
 294 #undef FUNC_NAME
 295
 296 SCM_DEFINE (scm_assoc_set_x, "assoc-set!", 3, 0, 0,
 297             (SCM alist, SCM key, SCM val),
 298             "Behaves like @code{assq-set!} but uses @code{equal?} for key comparison.")
 299 #define FUNC_NAME s_scm_assoc_set_x
 300 {
 301   SCM handle;
 302
 303   handle = scm_sloppy_assoc (key, alist);
 304   if (scm_is_pair (handle))
 305     {
 306       SCM_SETCDR (handle, val);
 307       return alist;
 308     }
 309   else
 310     return scm_acons (key, val, alist);
 311 }
 312 #undef FUNC_NAME
 313
 314
 315 \f
 316
 317 SCM_DEFINE (scm_assq_remove_x, "assq-remove!", 2, 0, 0,
 318             (SCM alist, SCM key),
 319             "@deffnx {Scheme Procedure} assv-remove! alist key\n"
 320             "@deffnx {Scheme Procedure} assoc-remove! alist key\n"
 321             "Delete the first entry in @var{alist} associated with @var{key}, and return\n"
 322             "the resulting alist.")
 323 #define FUNC_NAME s_scm_assq_remove_x
 324 {
 325   SCM handle;
 326
 327   handle = scm_sloppy_assq (key, alist);
 328   if (scm_is_pair (handle))
 329     alist = scm_delq1_x (handle, alist);
 330
 331   return alist;
 332 }
 333 #undef FUNC_NAME
 334
 335
 336 SCM_DEFINE (scm_assv_remove_x, "assv-remove!", 2, 0, 0,
 337             (SCM alist, SCM key),
 338             "Behaves like @code{assq-remove!} but uses @code{eqv?} for key comparison.")
 339 #define FUNC_NAME s_scm_assv_remove_x
 340 {
 341   SCM handle;
 342
 343   handle = scm_sloppy_assv (key, alist);
 344   if (scm_is_pair (handle))
 345     alist = scm_delq1_x (handle, alist);
 346
 347   return alist;
 348 }
 349 #undef FUNC_NAME
 350
 351
 352 SCM_DEFINE (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0,
 353             (SCM alist, SCM key),
 354             "Behaves like @code{assq-remove!} but uses @code{equal?} for key comparison.")
 355 #define FUNC_NAME s_scm_assoc_remove_x
 356 {
 357   SCM handle;
 358
 359   handle = scm_sloppy_assoc (key, alist);
 360   if (scm_is_pair (handle))
 361     alist = scm_delq1_x (handle, alist);
 362
 363   return alist;
 364 }
 365 #undef FUNC_NAME
 366
 367
 368 \f
 369
 370
 371
 372 void
 373 scm_init_alist ()
 374 {
 375 #include "libguile/alist.x"
 376 }
 377
 378
 379 /*
 380   Local Variables:
 381   c-file-style: "gnu"
 382   End:
 383 */