mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-03 08:10:31 +02:00
Move pairs off of scm_cell
* libguile/pairs.h: Remove inline scm_cons, scm_car, scm_cdr defnitions; this is less important now with the VM. Add a "struct scm_pair", and make all SCM_CAR / SCM_CDR checks use it. For now it does type checking as well. * libguile/pairs.c (scm_cons, scm_car, scm_cdr): Implement here. * libguile/scm.h (SCM_DEBUG_PAIR_ACCESSES): No more macro!
This commit is contained in:
Andy Wingo
parent
fbbe5fa873
commit
7997496a32
4 changed files with 84 additions and 97 deletions
|
|
@ -120,6 +120,8 @@ SCM_DEPRECATED SCM scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags);
|
|||
#define SCM_RGXP(X) (scm_is_true (scm_regexp_p (x)))
|
||||
#define SCM_VALIDATE_RGXP(pos, a) SCM_MAKE_VALIDATE_MSG (pos, a, RGXP, "regexp")
|
||||
|
||||
#define SCM_VALIDATE_PAIR(cell, expr) SCM_VALIDATE_PAIR__Gone__Inline_second_argument_at_use
|
||||
|
||||
/* Deprecated declarations go here. */
|
||||
|
||||
void scm_i_init_deprecated (void);
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@
|
|||
#include "boolean.h"
|
||||
#include "gc-internal.h"
|
||||
#include "trace.h"
|
||||
#include "threads.h"
|
||||
#include "gsubr.h"
|
||||
|
||||
#include "pairs.h"
|
||||
|
|
@ -49,26 +50,33 @@ verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
|
|||
(SCM_ELISP_NIL_BITS, SCM_EOL_BITS));
|
||||
|
||||
|
||||
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
|
||||
|
||||
#include "ports.h"
|
||||
#include "strings.h"
|
||||
|
||||
void scm_error_pair_access (SCM non_pair)
|
||||
/* Return a newly allocated pair whose car is @var{x} and whose cdr is
|
||||
@var{y}. The pair is guaranteed to be different (in the sense of
|
||||
@code{eq?}) from every previously existing object. */
|
||||
SCM
|
||||
scm_cons (SCM x, SCM y)
|
||||
{
|
||||
static unsigned int running = 0;
|
||||
SCM message = scm_from_utf8_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n");
|
||||
|
||||
if (!running)
|
||||
{
|
||||
running = 1;
|
||||
scm_simple_format (scm_current_error_port (),
|
||||
message, scm_list_1 (non_pair));
|
||||
abort ();
|
||||
}
|
||||
struct scm_pair *p = scm_allocate_tagged (SCM_I_CURRENT_THREAD, sizeof (*p));
|
||||
p->car = x;
|
||||
p->cdr = y;
|
||||
return scm_from_pair (p);
|
||||
}
|
||||
|
||||
#endif
|
||||
SCM
|
||||
scm_car (SCM x)
|
||||
{
|
||||
if (SCM_UNLIKELY (!scm_is_pair (x)))
|
||||
scm_wrong_type_arg_msg ("car", 0, x, "pair");
|
||||
return SCM_CAR (x);
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_cdr (SCM x)
|
||||
{
|
||||
if (SCM_UNLIKELY (!scm_is_pair (x)))
|
||||
scm_wrong_type_arg_msg ("cdr", 0, x, "pair");
|
||||
return SCM_CDR (x);
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_cons2 (SCM w, SCM x, SCM y)
|
||||
|
|
|
|||
130
libguile/pairs.h
130
libguile/pairs.h
|
|
@ -67,11 +67,61 @@
|
|||
/* #nil is null. */
|
||||
#define scm_is_null(x) (scm_is_null_or_nil(x))
|
||||
|
||||
#define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x)))
|
||||
#define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x)))
|
||||
struct scm_pair
|
||||
{
|
||||
SCM car;
|
||||
SCM cdr;
|
||||
};
|
||||
|
||||
#define SCM_SETCAR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 ((x), (v))))
|
||||
#define SCM_SETCDR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 ((x), (v))))
|
||||
static inline int
|
||||
scm_is_pair (SCM x)
|
||||
{
|
||||
return SCM_I_CONSP (x);
|
||||
}
|
||||
|
||||
static inline struct scm_pair *
|
||||
scm_to_pair (SCM x)
|
||||
{
|
||||
if (!scm_is_pair (x))
|
||||
abort ();
|
||||
return (struct scm_pair *) SCM_UNPACK_POINTER (x);
|
||||
}
|
||||
|
||||
static inline SCM
|
||||
scm_from_pair (struct scm_pair *pair)
|
||||
{
|
||||
return SCM_PACK_POINTER (pair);
|
||||
}
|
||||
|
||||
static inline SCM
|
||||
scm_pair_car (struct scm_pair *pair)
|
||||
{
|
||||
return pair->car;
|
||||
}
|
||||
|
||||
static inline SCM
|
||||
scm_pair_cdr (struct scm_pair *pair)
|
||||
{
|
||||
return pair->cdr;
|
||||
}
|
||||
|
||||
static inline void
|
||||
scm_pair_set_car_x (struct scm_pair *pair, SCM car)
|
||||
{
|
||||
pair->car = car;
|
||||
}
|
||||
|
||||
static inline void
|
||||
scm_pair_set_cdr_x (struct scm_pair *pair, SCM cdr)
|
||||
{
|
||||
pair->cdr = cdr;
|
||||
}
|
||||
|
||||
#define SCM_CAR(x) (scm_pair_car (scm_to_pair (x)))
|
||||
#define SCM_CDR(x) (scm_pair_cdr (scm_to_pair (x)))
|
||||
|
||||
#define SCM_SETCAR(x, v) (scm_pair_set_car_x (scm_to_pair (x), v))
|
||||
#define SCM_SETCDR(x, v) (scm_pair_set_cdr_x (scm_to_pair (x), v))
|
||||
|
||||
#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ))
|
||||
#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ))
|
||||
|
|
@ -116,13 +166,6 @@
|
|||
#define SCM_VALIDATE_CONS(pos, scm) \
|
||||
SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_pair, "pair")
|
||||
|
||||
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
|
||||
# define SCM_VALIDATE_PAIR(cell, expr) \
|
||||
((!scm_is_pair (cell) ? scm_error_pair_access (cell), 0 : 0), (expr))
|
||||
#else
|
||||
# define SCM_VALIDATE_PAIR(cell, expr) (expr)
|
||||
#endif
|
||||
|
||||
#ifdef BUILDING_LIBGUILE
|
||||
#define SCM_VALIDATE_MUTABLE_PAIR(pos, scm) \
|
||||
SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_mutable_pair, "mutable pair")
|
||||
|
|
@ -136,68 +179,9 @@
|
|||
|
||||
|
||||
|
||||
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
|
||||
SCM_API void scm_error_pair_access (SCM);
|
||||
#endif
|
||||
|
||||
SCM_INLINE int scm_is_pair (SCM x);
|
||||
SCM_INLINE SCM scm_cons (SCM x, SCM y);
|
||||
SCM_INLINE SCM scm_car (SCM x);
|
||||
SCM_INLINE SCM scm_cdr (SCM x);
|
||||
|
||||
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
|
||||
/* Return a newly allocated pair whose car is @var{x} and whose cdr is
|
||||
@var{y}. The pair is guaranteed to be different (in the sense of
|
||||
@code{eq?}) from every previously existing object. */
|
||||
SCM_INLINE_IMPLEMENTATION SCM
|
||||
scm_cons (SCM x, SCM y)
|
||||
{
|
||||
return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
|
||||
}
|
||||
|
||||
SCM_INLINE_IMPLEMENTATION int
|
||||
scm_is_pair (SCM x)
|
||||
{
|
||||
/* The following "workaround_for_gcc_295" avoids bad code generated by
|
||||
i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).
|
||||
|
||||
Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
|
||||
the fetch of the tag word from x is done before confirming it's a
|
||||
non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a
|
||||
immediate. This was seen to afflict scm_srfi1_split_at and something
|
||||
deep in the bowels of ceval(). In both cases segvs resulted from
|
||||
deferencing a random immediate value. srfi-1.test exposes the problem
|
||||
through a short list, the immediate being SCM_EOL in that case.
|
||||
Something in syntax.test exposed the ceval() problem.
|
||||
|
||||
Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
|
||||
problem, without even using that variable. The "w=w" is just to
|
||||
prevent a warning about it being unused.
|
||||
*/
|
||||
#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
|
||||
volatile SCM workaround_for_gcc_295 = x;
|
||||
workaround_for_gcc_295 = workaround_for_gcc_295;
|
||||
#endif
|
||||
|
||||
return SCM_I_CONSP (x);
|
||||
}
|
||||
|
||||
SCM_INLINE_IMPLEMENTATION SCM
|
||||
scm_car (SCM x)
|
||||
{
|
||||
if (SCM_UNLIKELY (!scm_is_pair (x)))
|
||||
scm_wrong_type_arg_msg ("car", 0, x, "pair");
|
||||
return SCM_CAR (x);
|
||||
}
|
||||
|
||||
SCM_INLINE_IMPLEMENTATION SCM
|
||||
scm_cdr (SCM x)
|
||||
{
|
||||
if (SCM_UNLIKELY (!scm_is_pair (x)))
|
||||
scm_wrong_type_arg_msg ("cdr", 0, x, "pair");
|
||||
return SCM_CDR (x);
|
||||
}
|
||||
#endif
|
||||
SCM_API SCM scm_cons (SCM x, SCM y);
|
||||
SCM_API SCM scm_car (SCM x);
|
||||
SCM_API SCM scm_cdr (SCM x);
|
||||
|
||||
SCM_INTERNAL int scm_is_mutable_pair (SCM x);
|
||||
|
||||
|
|
|
|||
|
|
@ -39,13 +39,6 @@
|
|||
#define SCM_DEBUG 0
|
||||
#endif
|
||||
|
||||
/* If SCM_DEBUG_PAIR_ACCESSES is set to 1, accesses to cons cells will
|
||||
be exhaustively checked. Note: If this option is enabled, guile
|
||||
will run slower than normally. */
|
||||
#ifndef SCM_DEBUG_PAIR_ACCESSES
|
||||
#define SCM_DEBUG_PAIR_ACCESSES SCM_DEBUG
|
||||
#endif
|
||||
|
||||
/* If SCM_DEBUG_REST_ARGUMENT is set to 1, functions that take rest
|
||||
arguments will check whether the rest arguments are actually passed
|
||||
as a proper list. Otherwise, if SCM_DEBUG_REST_ARGUMENT is 0,
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue