libguile/alist.c

   1 /*      Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42 #include <stdio.h>
  43 #include "_scm.h"
  44 #include "eq.h"
  45 #include "list.h"
  46
  47 #include "alist.h"
  48
  49 \f
  50
  51 SCM_PROC(s_acons, "acons", 3, 0, 0, scm_acons);
  52
  53 SCM
  54 scm_acons (w, x, y)
  55      SCM w;
  56      SCM x;
  57      SCM y;
  58 {
  59   register SCM z;
  60   SCM_NEWCELL (z);
  61   SCM_SETCAR (z, w);
  62   SCM_SETCDR (z, x);
  63   x = z;
  64   SCM_NEWCELL (z);
  65   SCM_SETCAR (z, x);
  66   SCM_SETCDR (z, y);
  67   return z;
  68 }
  69
  70 \f
  71
  72 SCM_PROC (s_sloppy_assq, "sloppy-assq", 2, 0, 0, scm_sloppy_assq);
  73
  74 SCM
  75 scm_sloppy_assq(x, alist)
  76      SCM x;
  77      SCM alist;
  78 {
  79
  80   for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
  81     {
  82       SCM tmp = SCM_CAR(alist);
  83       if (SCM_NIMP (tmp) && SCM_CONSP (tmp) && (SCM_CAR (tmp)==x))
  84         return tmp;
  85     }
  86   return SCM_BOOL_F;
  87 }
  88
  89
  90
  91 SCM_PROC (s_sloppy_assv, "sloppy-assv", 2, 0, 0, scm_sloppy_assv);
  92
  93 SCM
  94 scm_sloppy_assv(x, alist)
  95      SCM x;
  96      SCM alist;
  97 {
  98   for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
  99     {
 100       SCM tmp = SCM_CAR(alist);
 101       if (SCM_NIMP (tmp)
 102           && SCM_CONSP (tmp)
 103           && SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), x)))
 104         return tmp;
 105     }
 106   return SCM_BOOL_F;
 107 }
 108
 109
 110 SCM_PROC (s_sloppy_assoc, "sloppy-assoc", 2, 0, 0, scm_sloppy_assoc);
 111
 112 SCM
 113 scm_sloppy_assoc(x, alist)
 114      SCM x;
 115      SCM alist;
 116 {
 117   for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
 118     {
 119       SCM tmp = SCM_CAR(alist);
 120       if (SCM_NIMP (tmp)
 121           && SCM_CONSP (tmp)
 122           && SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), x)))
 123         return tmp;
 124     }
 125   return SCM_BOOL_F;
 126 }
 127
 128
 129 \f
 130
 131 SCM_PROC(s_assq, "assq", 2, 0, 0, scm_assq);
 132
 133 SCM
 134 scm_assq(x, alist)
 135      SCM x;
 136      SCM alist;
 137 {
 138         SCM tmp;
 139         for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
 140                 SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assq);
 141                 tmp = SCM_CAR(alist);
 142                 SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assq);
 143                 if (SCM_CAR(tmp)==x) return tmp;
 144         }
 145         SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assq);
 146         return SCM_BOOL_F;
 147 }
 148
 149
 150 SCM_PROC(s_assv, "assv", 2, 0, 0, scm_assv);
 151
 152 SCM
 153 scm_assv(x, alist)
 154      SCM x;
 155      SCM alist;
 156 {
 157   SCM tmp;
 158   for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
 159     SCM_ASRTGO(SCM_CONSP(alist), badlst);
 160     tmp = SCM_CAR(alist);
 161     SCM_ASRTGO(SCM_NIMP(tmp) && SCM_CONSP(tmp), badlst);
 162     if SCM_NFALSEP(scm_eqv_p(SCM_CAR(tmp), x)) return tmp;
 163   }
 164 # ifndef SCM_RECKLESS
 165   if (!(SCM_NULLP(alist)))
 166     badlst: scm_wta(alist, (char *)SCM_ARG2, s_assv);
 167 # endif
 168   return SCM_BOOL_F;
 169 }
 170
 171
 172 SCM_PROC(s_assoc, "assoc", 2, 0, 0, scm_assoc);
 173
 174 SCM
 175 scm_assoc(x, alist)
 176      SCM x;
 177      SCM alist;
 178 {
 179         SCM tmp;
 180         for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
 181                 SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assoc);
 182                 tmp = SCM_CAR(alist);
 183                 SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assoc);
 184                 if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp;
 185         }
 186         SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assoc);
 187         return SCM_BOOL_F;
 188 }
 189
 190
 191 \f
 192
 193 SCM_PROC (s_assq_ref, "assq-ref", 2, 0, 0, scm_assq_ref);
 194
 195 SCM
 196 scm_assq_ref (alist, key)
 197      SCM alist;
 198      SCM key;
 199 {
 200   SCM handle;
 201
 202   handle = scm_sloppy_assq (key, alist);
 203   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 204     {
 205       return SCM_CDR (handle);
 206     }
 207   return SCM_BOOL_F;
 208 }
 209
 210
 211 SCM_PROC (s_assv_ref, "assv-ref", 2, 0, 0, scm_assv_ref);
 212
 213 SCM
 214 scm_assv_ref (alist, key)
 215      SCM alist;
 216      SCM key;
 217 {
 218   SCM handle;
 219
 220   handle = scm_sloppy_assv (key, alist);
 221   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 222     {
 223       return SCM_CDR (handle);
 224     }
 225   return SCM_BOOL_F;
 226 }
 227
 228
 229 SCM_PROC (s_assoc_ref, "assoc-ref", 2, 0, 0, scm_assoc_ref);
 230
 231 SCM
 232 scm_assoc_ref (alist, key)
 233      SCM alist;
 234      SCM key;
 235 {
 236   SCM handle;
 237
 238   handle = scm_sloppy_assoc (key, alist);
 239   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 240     {
 241       return SCM_CDR (handle);
 242     }
 243   return SCM_BOOL_F;
 244 }
 245
 246
 247
 248 \f
 249
 250
 251 SCM_PROC (s_assq_set_x, "assq-set!", 3, 0, 0, scm_assq_set_x);
 252
 253 SCM
 254 scm_assq_set_x (alist, key, val)
 255      SCM alist;
 256      SCM key;
 257      SCM val;
 258 {
 259   SCM handle;
 260
 261   handle = scm_sloppy_assq (key, alist);
 262   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 263     {
 264       SCM_SETCDR (handle, val);
 265       return alist;
 266     }
 267   else
 268     return scm_acons (key, val, alist);
 269 }
 270
 271 SCM_PROC (s_assv_set_x, "assv-set!", 3, 0, 0, scm_assv_set_x);
 272
 273 SCM
 274 scm_assv_set_x (alist, key, val)
 275      SCM alist;
 276      SCM key;
 277      SCM val;
 278 {
 279   SCM handle;
 280
 281   handle = scm_sloppy_assv (key, alist);
 282   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 283     {
 284       SCM_SETCDR (handle, val);
 285       return alist;
 286     }
 287   else
 288     return scm_acons (key, val, alist);
 289 }
 290
 291 SCM_PROC (s_assoc_set_x, "assoc-set!", 3, 0, 0, scm_assoc_set_x);
 292
 293 SCM
 294 scm_assoc_set_x (alist, key, val)
 295      SCM alist;
 296      SCM key;
 297      SCM val;
 298 {
 299   SCM handle;
 300
 301   handle = scm_sloppy_assoc (key, alist);
 302   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 303     {
 304       SCM_SETCDR (handle, val);
 305       return alist;
 306     }
 307   else
 308     return scm_acons (key, val, alist);
 309 }
 310
 311
 312 \f
 313
 314 SCM_PROC (s_assq_remove_x, "assq-remove!", 2, 0, 0, scm_assq_remove_x);
 315
 316 SCM
 317 scm_assq_remove_x (alist, key)
 318      SCM alist;
 319      SCM key;
 320 {
 321   SCM handle;
 322
 323   handle = scm_sloppy_assq (key, alist);
 324   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 325     {
 326       return scm_delq_x (handle, alist);
 327     }
 328   else
 329     return alist;
 330 }
 331
 332
 333 SCM_PROC (s_assv_remove_x, "assv-remove!", 2, 0, 0, scm_assv_remove_x);
 334
 335 SCM
 336 scm_assv_remove_x (alist, key)
 337      SCM alist;
 338      SCM key;
 339 {
 340   SCM handle;
 341
 342   handle = scm_sloppy_assv (key, alist);
 343   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 344     {
 345       return scm_delv_x (handle, alist);
 346     }
 347   else
 348     return alist;
 349 }
 350
 351
 352 SCM_PROC (s_assoc_remove_x, "assoc-remove!", 2, 0, 0, scm_assoc_remove_x);
 353
 354 SCM
 355 scm_assoc_remove_x (alist, key)
 356      SCM alist;
 357      SCM key;
 358 {
 359   SCM handle;
 360
 361   handle = scm_sloppy_assoc (key, alist);
 362   if (SCM_NIMP (handle) && SCM_CONSP (handle))
 363     {
 364       return scm_delete_x (handle, alist);
 365     }
 366   else
 367     return alist;
 368 }
 369
 370
 371 \f
 372
 373
 374
 375 void
 376 scm_init_alist ()
 377 {
 378 #include "alist.x"
 379 }
 380