libguile/alist.c

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