mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
4638e08794
SCM_NUM2ULONG instead of scm_num2ulong; SCM_NUM2LONG instead of scm_num2long; SCM_WTA instead of scm_wta. Only done for when FUNC_NAME was used as an argument of the macro and the formal argument name was the explicit argument in the old function call. These were just missed in my first pass of changes.
398 lines
9.9 KiB
C
398 lines
9.9 KiB
C
/* Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
|
||
*
|
||
* This program is free software; you can redistribute it and/or modify
|
||
* it under the terms of the GNU General Public License as published by
|
||
* the Free Software Foundation; either version 2, or (at your option)
|
||
* any later version.
|
||
*
|
||
* This program is distributed in the hope that it will be useful,
|
||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
* GNU General Public License for more details.
|
||
*
|
||
* You should have received a copy of the GNU General Public License
|
||
* along with this software; see the file COPYING. If not, write to
|
||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||
* Boston, MA 02111-1307 USA
|
||
*
|
||
* As a special exception, the Free Software Foundation gives permission
|
||
* for additional uses of the text contained in its release of GUILE.
|
||
*
|
||
* The exception is that, if you link the GUILE library with other files
|
||
* to produce an executable, this does not by itself cause the
|
||
* resulting executable to be covered by the GNU General Public License.
|
||
* Your use of that executable is in no way restricted on account of
|
||
* linking the GUILE library code into it.
|
||
*
|
||
* This exception does not however invalidate any other reasons why
|
||
* the executable file might be covered by the GNU General Public License.
|
||
*
|
||
* This exception applies only to the code released by the
|
||
* Free Software Foundation under the name GUILE. If you copy
|
||
* code from other Free Software Foundation releases into a copy of
|
||
* GUILE, as the General Public License permits, the exception does
|
||
* not apply to the code that you add in this way. To avoid misleading
|
||
* anyone as to the status of such modified files, you must delete
|
||
* this exception notice from them.
|
||
*
|
||
* If you write modifications of your own for GUILE, it is your choice
|
||
* whether to permit this exception to apply to your modifications.
|
||
* If you do not wish that, delete this exception notice. */
|
||
|
||
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
|
||
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
|
||
|
||
|
||
#include <stdio.h>
|
||
#include "_scm.h"
|
||
#include "eq.h"
|
||
#include "list.h"
|
||
|
||
#include "scm_validate.h"
|
||
#include "alist.h"
|
||
|
||
|
||
|
||
GUILE_PROC(scm_acons, "acons", 3, 0, 0,
|
||
(SCM w, SCM x, SCM y),
|
||
"Adds a new key-value pair to @var{alist}. A new pair is
|
||
created whose car is @var{key} and whose cdr is @var{value}, and the
|
||
pair is consed onto @var{alist}, and the new list is returned. This
|
||
function is @emph{not} destructive; @var{alist} is not modified.")
|
||
#define FUNC_NAME s_scm_acons
|
||
{
|
||
register SCM z;
|
||
SCM_NEWCELL (z);
|
||
SCM_SETCAR (z, w);
|
||
SCM_SETCDR (z, x);
|
||
x = z;
|
||
SCM_NEWCELL (z);
|
||
SCM_SETCAR (z, x);
|
||
SCM_SETCDR (z, y);
|
||
return z;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
GUILE_PROC (scm_sloppy_assq, "sloppy-assq", 2, 0, 0,
|
||
(SCM x, SCM alist),
|
||
"Behaves like @code{assq} but does not do any error checking.
|
||
Recommended only for use in Guile internals.")
|
||
#define FUNC_NAME s_scm_sloppy_assq
|
||
{
|
||
|
||
for (; SCM_CONSP (alist); alist = SCM_CDR (alist))
|
||
{
|
||
SCM tmp = SCM_CAR(alist);
|
||
if (SCM_CONSP (tmp) && (SCM_CAR (tmp)==x))
|
||
return tmp;
|
||
}
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
GUILE_PROC (scm_sloppy_assv, "sloppy-assv", 2, 0, 0,
|
||
(SCM x, SCM alist),
|
||
"Behaves like @code{assv} but does not do any error checking.
|
||
Recommended only for use in Guile internals.")
|
||
#define FUNC_NAME s_scm_sloppy_assv
|
||
{
|
||
for (; SCM_CONSP (alist); alist = SCM_CDR (alist))
|
||
{
|
||
SCM tmp = SCM_CAR(alist);
|
||
if (SCM_NIMP (tmp)
|
||
&& SCM_CONSP (tmp)
|
||
&& SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), x)))
|
||
return tmp;
|
||
}
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
GUILE_PROC (scm_sloppy_assoc, "sloppy-assoc", 2, 0, 0,
|
||
(SCM x, SCM alist),
|
||
"Behaves like @code{assoc} but does not do any error checking.
|
||
Recommended only for use in Guile internals.")
|
||
#define FUNC_NAME s_scm_sloppy_assoc
|
||
{
|
||
for (; SCM_CONSP (alist); alist = SCM_CDR (alist))
|
||
{
|
||
SCM tmp = SCM_CAR(alist);
|
||
if (SCM_NIMP (tmp)
|
||
&& SCM_CONSP (tmp)
|
||
&& SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), x)))
|
||
return tmp;
|
||
}
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
GUILE_PROC(scm_assq, "assq", 2, 0, 0,
|
||
(SCM x, SCM alist),
|
||
"@deffnx primitive assv key alist
|
||
@deffnx primitive assoc key alist
|
||
Fetches the entry in @var{alist} that is associated with @var{key}. To
|
||
decide whether the argument @var{key} matches a particular entry in
|
||
@var{alist}, @code{assq} compares keys with @code{eq?}, @code{assv}
|
||
uses @code{eqv?} and @code{assoc} uses @code{equal?}. If @var{key}
|
||
cannot be found in @var{alist} (according to whichever equality
|
||
predicate is in use), then @code{#f} is returned. These functions
|
||
return the entire alist entry found (i.e. both the key and the value).")
|
||
#define FUNC_NAME s_scm_assq
|
||
{
|
||
SCM tmp;
|
||
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
|
||
SCM_VALIDATE_ALISTCELL_COPYSCM(2,alist,tmp);
|
||
if (SCM_CAR(tmp)==x) return tmp;
|
||
}
|
||
SCM_VALIDATE_NULL(2,alist);
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
GUILE_PROC(scm_assv, "assv", 2, 0, 0,
|
||
(SCM x, SCM alist),
|
||
"")
|
||
#define FUNC_NAME s_scm_assv
|
||
{
|
||
SCM tmp;
|
||
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
|
||
SCM_ASRTGO(SCM_CONSP(alist), badlst);
|
||
tmp = SCM_CAR(alist);
|
||
SCM_ASRTGO(SCM_CONSP(tmp), badlst);
|
||
if SCM_NFALSEP(scm_eqv_p(SCM_CAR(tmp), x)) return tmp;
|
||
}
|
||
# ifndef SCM_RECKLESS
|
||
if (!(SCM_NULLP(alist)))
|
||
badlst: SCM_WTA(2,alist);
|
||
# endif
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
GUILE_PROC(scm_assoc, "assoc", 2, 0, 0,
|
||
(SCM x, SCM alist),
|
||
"See @code{assq}.")
|
||
#define FUNC_NAME s_scm_assoc
|
||
{
|
||
SCM tmp;
|
||
for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
|
||
SCM_VALIDATE_ALISTCELL_COPYSCM(2,alist,tmp);
|
||
if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp;
|
||
}
|
||
SCM_VALIDATE_NULL(2,alist);
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
GUILE_PROC (scm_assq_ref, "assq-ref", 2, 0, 0,
|
||
(SCM alist, SCM key),
|
||
"@deffnx primitive assv-ref alist key
|
||
@deffnx primitive assoc-ref alist key
|
||
Like @code{assq}, @code{assv} and @code{assoc}, except that only the
|
||
value associated with @var{key} in @var{alist} is returned. These
|
||
functions are equivalent to
|
||
|
||
@lisp
|
||
(let ((ent (@var{associator} @var{key} @var{alist})))
|
||
(and ent (cdr ent)))
|
||
@end lisp
|
||
|
||
where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}.")
|
||
#define FUNC_NAME s_scm_assq_ref
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assq (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
return SCM_CDR (handle);
|
||
}
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
GUILE_PROC (scm_assv_ref, "assv-ref", 2, 0, 0,
|
||
(SCM alist, SCM key),
|
||
"See @code{assq-ref}.")
|
||
#define FUNC_NAME s_scm_assv_ref
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assv (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
return SCM_CDR (handle);
|
||
}
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
GUILE_PROC (scm_assoc_ref, "assoc-ref", 2, 0, 0,
|
||
(SCM alist, SCM key),
|
||
"See @code{assq-ref}.")
|
||
#define FUNC_NAME s_scm_assoc_ref
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assoc (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
return SCM_CDR (handle);
|
||
}
|
||
return SCM_BOOL_F;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
|
||
|
||
GUILE_PROC (scm_assq_set_x, "assq-set!", 3, 0, 0,
|
||
(SCM alist, SCM key, SCM val),
|
||
"@deffnx primitive assv-set! alist key value
|
||
@deffnx primitive assoc-set! alist key value
|
||
Reassociate @var{key} in @var{alist} with @var{value}: find any existing
|
||
@var{alist} entry for @var{key} and associate it with the new
|
||
@var{value}. If @var{alist} does not contain an entry for @var{key},
|
||
add a new one. Return the (possibly new) alist.
|
||
|
||
These functions do not attempt to verify the structure of @var{alist},
|
||
and so may cause unusual results if passed an object that is not an
|
||
association list.")
|
||
#define FUNC_NAME s_scm_assq_set_x
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assq (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
SCM_SETCDR (handle, val);
|
||
return alist;
|
||
}
|
||
else
|
||
return scm_acons (key, val, alist);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
GUILE_PROC (scm_assv_set_x, "assv-set!", 3, 0, 0,
|
||
(SCM alist, SCM key, SCM val),
|
||
"See @code{assq-set!}.")
|
||
#define FUNC_NAME s_scm_assv_set_x
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assv (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
SCM_SETCDR (handle, val);
|
||
return alist;
|
||
}
|
||
else
|
||
return scm_acons (key, val, alist);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
GUILE_PROC (scm_assoc_set_x, "assoc-set!", 3, 0, 0,
|
||
(SCM alist, SCM key, SCM val),
|
||
"See @code{assq-set!}.")
|
||
#define FUNC_NAME s_scm_assoc_set_x
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assoc (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
SCM_SETCDR (handle, val);
|
||
return alist;
|
||
}
|
||
else
|
||
return scm_acons (key, val, alist);
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
GUILE_PROC (scm_assq_remove_x, "assq-remove!", 2, 0, 0,
|
||
(SCM alist, SCM key),
|
||
"@deffnx primitive assv-remove! alist key
|
||
@deffnx primitive assoc-remove! alist key
|
||
Delete any entry in @var{alist} associated with @var{key}, and return
|
||
the resulting alist.")
|
||
#define FUNC_NAME s_scm_assq_remove_x
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assq (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
return scm_delq_x (handle, alist);
|
||
}
|
||
else
|
||
return alist;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
GUILE_PROC (scm_assv_remove_x, "assv-remove!", 2, 0, 0,
|
||
(SCM alist, SCM key),
|
||
"See @code{assq-remove!}.")
|
||
#define FUNC_NAME s_scm_assv_remove_x
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assv (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
return scm_delv_x (handle, alist);
|
||
}
|
||
else
|
||
return alist;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
GUILE_PROC (scm_assoc_remove_x, "assoc-remove!", 2, 0, 0,
|
||
(SCM alist, SCM key),
|
||
"See @code{assq-remove!}.")
|
||
#define FUNC_NAME s_scm_assoc_remove_x
|
||
{
|
||
SCM handle;
|
||
|
||
handle = scm_sloppy_assoc (key, alist);
|
||
if (SCM_CONSP (handle))
|
||
{
|
||
return scm_delete_x (handle, alist);
|
||
}
|
||
else
|
||
return alist;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
|
||
|
||
void
|
||
scm_init_alist ()
|
||
{
|
||
#include "alist.x"
|
||
}
|
||
|