guile18/libguile/alist.c

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