summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/async.c94
-rw-r--r--libguile/boolean.c26
-rw-r--r--libguile/bytevectors.c8
-rw-r--r--libguile/continuations.c2
-rw-r--r--libguile/control.c2
-rw-r--r--libguile/debug.c4
-rw-r--r--libguile/deprecated.c26
-rw-r--r--libguile/deprecated.h11
-rw-r--r--libguile/deprecation.c2
-rw-r--r--libguile/dynwind.c19
-rw-r--r--libguile/dynwind.h8
-rw-r--r--libguile/eval.c7
-rw-r--r--libguile/expand.h7
-rw-r--r--libguile/fluids.c4
-rw-r--r--libguile/frames.c6
-rw-r--r--libguile/frames.h8
-rw-r--r--libguile/generalized-vectors.c4
-rw-r--r--libguile/goops.c70
-rw-r--r--libguile/guardians.c10
-rw-r--r--libguile/hash.c10
-rw-r--r--libguile/hashtab.c16
-rw-r--r--libguile/i18n.c10
-rw-r--r--libguile/inline.h14
-rw-r--r--libguile/list.c8
-rw-r--r--libguile/load.c2
-rw-r--r--libguile/macros.c14
-rw-r--r--libguile/memoize.c7
-rw-r--r--libguile/modules.c8
-rw-r--r--libguile/net_db.c4
-rw-r--r--libguile/numbers.c2
-rw-r--r--libguile/pairs.c6
-rw-r--r--libguile/ports.c30
-rw-r--r--libguile/posix.c34
-rw-r--r--libguile/print.c8
-rw-r--r--libguile/promises.c4
-rw-r--r--libguile/r6rs-ports.c4
-rw-r--r--libguile/read.c8
-rw-r--r--libguile/snarf.h19
-rw-r--r--libguile/socket.c10
-rw-r--r--libguile/srcprop.c10
-rw-r--r--libguile/stacks.c2
-rw-r--r--libguile/tags.h57
-rw-r--r--libguile/threads.c9
-rw-r--r--libguile/variable.c6
-rw-r--r--libguile/vectors.c12
-rw-r--r--libguile/vm-engine.c12
-rw-r--r--libguile/vm-engine.h4
-rw-r--r--libguile/vm-i-scheme.c30
-rw-r--r--libguile/vm-i-system.c26
-rw-r--r--libguile/vm.c4
-rw-r--r--libguile/weaks.c30
-rw-r--r--libguile/weaks.h4
52 files changed, 402 insertions, 340 deletions
diff --git a/libguile/async.c b/libguile/async.c
index 0a08d0c0e..ad14101df 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -325,16 +325,37 @@ SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
static void
increase_block (void *data)
{
- ((scm_i_thread *)data)->block_asyncs++;
+ scm_i_thread *t = data;
+ t->block_asyncs++;
}
static void
decrease_block (void *data)
{
- if (--((scm_i_thread *)data)->block_asyncs == 0)
+ scm_i_thread *t = data;
+ if (--t->block_asyncs == 0)
scm_async_click ();
}
+void
+scm_dynwind_block_asyncs (void)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
+}
+
+void
+scm_dynwind_unblock_asyncs (void)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ if (t->block_asyncs == 0)
+ scm_misc_error ("scm_with_unblocked_asyncs",
+ "asyncs already unblocked", SCM_EOL);
+ scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
+}
+
SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
(SCM proc),
"Call @var{proc} with no arguments and block the execution\n"
@@ -342,22 +363,28 @@ SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
"it is running. Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_blocked_asyncs
{
- return scm_internal_dynamic_wind (increase_block,
- (scm_t_inner) scm_call_0,
- decrease_block,
- (void *)proc,
- SCM_I_CURRENT_THREAD);
+ SCM ans;
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_block_asyncs ();
+ ans = scm_call_0 (proc);
+ scm_dynwind_end ();
+
+ return ans;
}
#undef FUNC_NAME
void *
scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
{
- return (void *)scm_internal_dynamic_wind (increase_block,
- (scm_t_inner) proc,
- decrease_block,
- data,
- SCM_I_CURRENT_THREAD);
+ void* ans;
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_block_asyncs ();
+ ans = proc (data);
+ scm_dynwind_end ();
+
+ return ans;
}
@@ -368,46 +395,35 @@ SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0,
"it is running. Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_unblocked_asyncs
{
+ SCM ans;
+
if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
- return scm_internal_dynamic_wind (decrease_block,
- (scm_t_inner) scm_call_0,
- increase_block,
- (void *)proc,
- SCM_I_CURRENT_THREAD);
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_unblock_asyncs ();
+ ans = scm_call_0 (proc);
+ scm_dynwind_end ();
+
+ return ans;
}
#undef FUNC_NAME
void *
scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
{
+ void* ans;
+
if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
scm_misc_error ("scm_c_call_with_unblocked_asyncs",
"asyncs already unblocked", SCM_EOL);
- return (void *)scm_internal_dynamic_wind (decrease_block,
- (scm_t_inner) proc,
- increase_block,
- data,
- SCM_I_CURRENT_THREAD);
-}
-void
-scm_dynwind_block_asyncs ()
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
- scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
-}
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_unblock_asyncs ();
+ ans = proc (data);
+ scm_dynwind_end ();
-void
-scm_dynwind_unblock_asyncs ()
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
- if (t->block_asyncs == 0)
- scm_misc_error ("scm_with_unblocked_asyncs",
- "asyncs already unblocked", SCM_EOL);
- scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
+ return ans;
}
diff --git a/libguile/boolean.c b/libguile/boolean.c
index 452b8adda..3bf672d6d 100644
--- a/libguile/boolean.c
+++ b/libguile/boolean.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -40,18 +40,18 @@
* See the comments preceeding the definitions of SCM_BOOL_F and
* SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
*/
-verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
- (SCM_BOOL_F, SCM_BOOL_T));
-verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
- (SCM_ELISP_NIL, SCM_BOOL_F));
-verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
- (SCM_ELISP_NIL, SCM_EOL));
-verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
- (SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, \
- SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0));
-verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
- (SCM_ELISP_NIL, SCM_BOOL_F, SCM_EOL, \
- SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE));
+verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_BOOL_F_BITS, SCM_BOOL_T_BITS));
+verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL_BITS, SCM_BOOL_F_BITS));
+verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL_BITS, SCM_EOL_BITS));
+verify (SCM_BITS_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
+ (SCM_ELISP_NIL_BITS, SCM_BOOL_F_BITS, SCM_BOOL_T_BITS, \
+ SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0));
+verify (SCM_BITS_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
+ (SCM_ELISP_NIL_BITS, SCM_BOOL_F_BITS, SCM_EOL_BITS, \
+ SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE));
SCM_DEFINE (scm_not, "not", 1, 0, 0,
(SCM x),
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 4ca3c4e25..b9403ea5b 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -479,7 +479,7 @@ SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
signed char c_fill = '\0';
SCM_VALIDATE_UINT_COPY (1, len, c_len);
- if (fill != SCM_UNDEFINED)
+ if (!scm_is_eq (fill, SCM_UNDEFINED))
{
int value;
@@ -490,7 +490,7 @@ SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
}
bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
- if (fill != SCM_UNDEFINED)
+ if (!scm_is_eq (fill, SCM_UNDEFINED))
{
unsigned i;
signed char *contents;
@@ -1924,7 +1924,7 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness)
size_t c_strlen, c_utf_len = 0; \
\
SCM_VALIDATE_STRING (1, str); \
- if (endianness == SCM_UNDEFINED) \
+ if (scm_is_eq (endianness, SCM_UNDEFINED)) \
endianness = scm_sym_big; \
else \
SCM_VALIDATE_SYMBOL (2, endianness); \
@@ -2037,7 +2037,7 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32",
size_t c_strlen = 0, c_utf_len = 0; \
\
SCM_VALIDATE_BYTEVECTOR (1, utf); \
- if (endianness == SCM_UNDEFINED) \
+ if (scm_is_eq (endianness, SCM_UNDEFINED)) \
endianness = scm_sym_big; \
else \
SCM_VALIDATE_SYMBOL (2, endianness); \
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 7d56c2a59..cf8b6ac03 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -410,7 +410,7 @@ scm_i_check_continuation (SCM cont)
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont);
- if (continuation->root != thread->continuation_root)
+ if (!scm_is_eq (continuation->root, thread->continuation_root))
scm_misc_error
("%continuation-call",
"invoking continuation would cross continuation barrier: ~A",
diff --git a/libguile/control.c b/libguile/control.c
index dc3fed250..9121d1791 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -163,7 +163,7 @@ reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
/* Since non-escape continuations should begin with a thunk application, the
first bit of the stack should be a frame, with the saved fp equal to the fp
that was current when the prompt was made. */
- if ((SCM*)(SCM_PROMPT_REGISTERS (prompt)->sp[1])
+ if ((SCM*)SCM_UNPACK (SCM_PROMPT_REGISTERS (prompt)->sp[1])
!= SCM_PROMPT_REGISTERS (prompt)->fp)
abort ();
diff --git a/libguile/debug.c b/libguile/debug.c
index e059a3135..88a01d6aa 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -1,5 +1,5 @@
/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -82,7 +82,7 @@ scm_t_option scm_debug_opts[] = {
for anyone!) or a whoppin' 1280 KB on 64-bit arches.
*/
{ SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
- { SCM_OPTION_SCM, "show-file-name", (scm_t_bits)SCM_BOOL_T,
+ { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T_BITS,
"Show file names and line numbers "
"in backtraces when not `#f'. A value of `base' "
"displays only base names, while `#t' displays full names."},
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 0c5531630..3e2d88a7f 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -27,9 +27,35 @@
#define SCM_BUILDING_DEPRECATED_CODE
#include "libguile/_scm.h"
+#include "libguile/deprecation.h"
#if (SCM_ENABLE_DEPRECATED == 1)
+
+
+SCM
+scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data)
+{
+ SCM ans;
+
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_dynamic_wind' is deprecated. "
+ "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
+ ans = inner (inner_data);
+ scm_dynwind_end ();
+ return ans;
+}
+
+
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index ddc97a8fe..d17be085b 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -31,6 +31,17 @@
#if (SCM_ENABLE_DEPRECATED == 1)
+/* Deprecated 13-05-2011 because it's better just to scm_dynwind_begin.
+ That also avoids the temptation to stuff pointers in an SCM. */
+
+typedef SCM (*scm_t_inner) (void *);
+SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data);
+
+
#define SCM_LIST0 SCM_EOL
#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL)
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index 192667dde..be5fffc90 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -128,7 +128,7 @@ SCM_DEFINE(scm_issue_deprecation_warning,
char *c_msgs;
while (scm_is_pair (msgs))
{
- if (msgs_nl != SCM_EOL)
+ if (!scm_is_null (msgs_nl))
msgs_nl = scm_cons (nl, msgs_nl);
msgs_nl = scm_cons (SCM_CAR (msgs), msgs_nl);
msgs = SCM_CDR (msgs);
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index f4d19bd0a..14dd861dc 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -68,23 +68,6 @@ scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
}
#undef FUNC_NAME
-SCM
-scm_internal_dynamic_wind (scm_t_guard before,
- scm_t_inner inner,
- scm_t_guard after,
- void *inner_data,
- void *guard_data)
-{
- SCM ans;
-
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
- ans = inner (inner_data);
- scm_dynwind_end ();
- return ans;
-}
-
/* Frames and winders. */
static scm_t_bits tc16_frame;
diff --git a/libguile/dynwind.h b/libguile/dynwind.h
index b178bc429..6e952c4db 100644
--- a/libguile/dynwind.h
+++ b/libguile/dynwind.h
@@ -3,7 +3,7 @@
#ifndef SCM_DYNWIND_H
#define SCM_DYNWIND_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -28,14 +28,8 @@
typedef void (*scm_t_guard) (void *);
-typedef SCM (*scm_t_inner) (void *);
SCM_API SCM scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3);
-SCM_API SCM scm_internal_dynamic_wind (scm_t_guard before,
- scm_t_inner inner,
- scm_t_guard after,
- void *inner_data,
- void *guard_data);
SCM_API void scm_dowinds (SCM to, long delta);
SCM_INTERNAL void scm_i_dowinds (SCM to, long delta,
void (*turn_func) (void *), void *data);
diff --git a/libguile/eval.c b/libguile/eval.c
index 009f3790b..e008b3a08 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -102,7 +102,8 @@
*/
static scm_t_bits scm_tc16_boot_closure;
-#define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, (code), (env))
+#define RETURN_BOOT_CLOSURE(code, env) \
+ SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, SCM_UNPACK (code), SCM_UNPACK (env))
#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
@@ -210,8 +211,8 @@ truncate_values (SCM x)
case, because further lexical contours should capture the current module.
*/
#define CAPTURE_ENV(env) \
- ((env == SCM_EOL) ? scm_current_module () : \
- ((env == SCM_BOOL_F) ? scm_the_root_module () : env))
+ (scm_is_null (env) ? scm_current_module () : \
+ (scm_is_false (env) ? scm_the_root_module () : env))
static SCM
eval (SCM x, SCM env)
diff --git a/libguile/expand.h b/libguile/expand.h
index b5d90edce..02e6e179e 100644
--- a/libguile/expand.h
+++ b/libguile/expand.h
@@ -3,7 +3,7 @@
#ifndef SCM_EXPAND_H
#define SCM_EXPAND_H
-/* Copyright (C) 2010
+/* Copyright (C) 2010, 2011
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -73,8 +73,9 @@ enum
SCM_EXPANDED_TYPE_FIELDS,
};
-#define SCM_EXPANDED_P(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE (SCM_STRUCT_VTABLE (x)) == scm_exp_vtable_vtable))
+#define SCM_EXPANDED_P(x) \
+ (SCM_STRUCTP (x) \
+ && (scm_is_eq (SCM_STRUCT_VTABLE (SCM_STRUCT_VTABLE (x)), scm_exp_vtable_vtable)))
#define SCM_EXPANDED_REF(x,type,field) \
(scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
#define SCM_EXPANDED_TYPE(x) \
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 3e717006e..f42c0a484 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -304,7 +304,7 @@ scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
while (j--)
for (i = 0; i < j; i++)
- if (fluids[i] == fluids[j])
+ if (scm_is_eq (fluids[i], fluids[j]))
{
vals[i] = vals[j]; /* later bindings win */
n--;
diff --git a/libguile/frames.c b/libguile/frames.c
index 62ba23fff..2e83cde9a 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -124,7 +124,7 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
while (p <= sp)
{
- if (p[0] == (SCM)0)
+ if (SCM_UNPACK (p[0]) == 0)
/* skip over not-yet-active frame */
p += 3;
else
@@ -154,7 +154,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
while (p <= sp)
{
- if (p[0] == (SCM)0)
+ if (SCM_UNPACK (p[0]) == 0)
/* skip over not-yet-active frame */
p += 3;
else if (n == i)
@@ -186,7 +186,7 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
while (p <= sp)
{
- if (p[0] == (SCM)0)
+ if (SCM_UNPACK (p[0]) == 0)
/* skip over not-yet-active frame */
p += 3;
else if (n == i)
diff --git a/libguile/frames.h b/libguile/frames.h
index 3d8a4b27a..47244c7a3 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -70,15 +70,15 @@
#define SCM_FRAME_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \
- ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(ra);
+ ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = SCM_PACK (ra)
#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
#define SCM_FRAME_SET_MV_RETURN_ADDRESS(fp, mvra) \
- ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(mvra);
+ ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = SCM_PACK (mvra)
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
- ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
+ ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = SCM_PACK (dl)
#define SCM_FRAME_VARIABLE(fp,i) SCM_FRAME_STACK_ADDRESS (fp)[i]
#define SCM_FRAME_PROGRAM(fp) SCM_FRAME_STACK_ADDRESS (fp)[-1]
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
index bb53dda15..b65b654fb 100644
--- a/libguile/generalized-vectors.c
+++ b/libguile/generalized-vectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -62,7 +62,7 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
{
int i;
for (i = 0; i < num_vector_ctors_registered; i++)
- if (vector_ctors[i].tag == type)
+ if (scm_is_eq (vector_ctors[i].tag, type))
return vector_ctors[i].ctor(len, fill);
scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type");
}
diff --git a/libguile/goops.c b/libguile/goops.c
index 274749048..899ba7329 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -124,7 +124,7 @@ SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
#define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
#define SCM_GOOPS_UNBOUND SCM_UNBOUND
-#define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
+#define SCM_GOOPS_UNBOUNDP(x) (scm_is_eq (x, SCM_GOOPS_UNBOUND))
static int goops_loaded_p = 0;
static scm_t_rstate *goops_rstate;
@@ -293,7 +293,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return scm_class_fraction;
}
case scm_tc7_program:
- if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) && *SCM_SUBR_GENERIC (x))
+ if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
+ && SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
return scm_class_primitive_generic;
else
return scm_class_procedure;
@@ -494,8 +495,8 @@ compute_getters_n_setters (SCM slots)
SCM options = SCM_CDAR (slots);
if (!scm_is_null (options))
{
- init = scm_get_keyword (k_init_value, options, 0);
- if (init)
+ init = scm_get_keyword (k_init_value, options, SCM_PACK (0));
+ if (SCM_UNPACK (init))
{
init = scm_primitive_eval (scm_list_3 (scm_sym_lambda,
SCM_EOL,
@@ -592,7 +593,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
{
SCM slot_name = SCM_CAR (slots);
- SCM slot_value = 0;
+ SCM slot_value = SCM_PACK (0);
if (!scm_is_null (SCM_CDR (slot_name)))
{
@@ -604,10 +605,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
tmp = scm_i_get_keyword (k_init_keyword,
SCM_CDR (slot_name),
n,
- 0,
+ SCM_PACK (0),
FUNC_NAME);
slot_name = SCM_CAR (slot_name);
- if (tmp)
+ if (SCM_UNPACK (tmp))
{
/* an initarg was provided for this slot */
if (!scm_is_keyword (tmp))
@@ -616,12 +617,12 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
slot_value = scm_i_get_keyword (tmp,
initargs,
n_initargs,
- 0,
+ SCM_PACK (0),
FUNC_NAME);
}
}
- if (slot_value)
+ if (SCM_UNPACK (slot_value))
/* set slot to provided value */
set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
else
@@ -1231,7 +1232,7 @@ slot_definition_using_name (SCM class, SCM slot_name)
{
register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
for (; !scm_is_null (slots); slots = SCM_CDR (slots))
- if (SCM_CAAR (slots) == slot_name)
+ if (scm_is_eq (SCM_CAAR (slots), slot_name))
return SCM_CAR (slots);
return SCM_BOOL_F;
}
@@ -1599,7 +1600,7 @@ burnin (SCM o)
static void
go_to_hell (void *o)
{
- SCM obj = SCM_PACK ((scm_t_bits) o);
+ SCM obj = *(SCM*)o;
scm_lock_mutex (hell_mutex);
if (n_hell >= hell_size)
{
@@ -1613,8 +1614,9 @@ go_to_hell (void *o)
static void
go_to_heaven (void *o)
{
+ SCM obj = *(SCM*)o;
scm_lock_mutex (hell_mutex);
- hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell];
+ hell[burnin (obj)] = hell[--n_hell];
scm_unlock_mutex (hell_mutex);
}
@@ -1622,10 +1624,9 @@ go_to_heaven (void *o)
SCM_SYMBOL (scm_sym_change_class, "change-class");
static SCM
-purgatory (void *args)
+purgatory (SCM obj, SCM new_class)
{
- return scm_apply_0 (SCM_VARIABLE_REF (var_change_class),
- SCM_PACK ((scm_t_bits) args));
+ return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
}
/* This function calls the generic function change-class for all
@@ -1636,9 +1637,13 @@ void
scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
{
if (!burnin (obj))
- scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven,
- (void *) SCM_UNPACK (scm_list_2 (obj, new_class)),
- (void *) SCM_UNPACK (obj));
+ {
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY);
+ purgatory (obj, new_class);
+ scm_dynwind_end ();
+ }
}
/******************************************************************************
@@ -1697,7 +1702,7 @@ static SCM
make_dispatch_procedure (SCM gf)
{
static SCM var = SCM_BOOL_F;
- if (var == SCM_BOOL_F)
+ if (scm_is_false (var))
var = scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
sym_delayed_compile);
return scm_call_1 (SCM_VARIABLE_REF (var), gf);
@@ -1771,7 +1776,7 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
{
if (SCM_PRIMITIVE_GENERIC_P (subr))
{
- if (!*SCM_SUBR_GENERIC (subr))
+ if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr)))
scm_enable_primitive_generic_x (scm_list_1 (subr));
return *SCM_SUBR_GENERIC (subr);
}
@@ -1798,7 +1803,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension)
if (goops_loaded_p)
{
SCM gf, gext;
- if (!*SCM_SUBR_GENERIC (extended))
+ if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended)))
scm_enable_primitive_generic_x (scm_list_1 (extended));
gf = *SCM_SUBR_GENERIC (extended);
gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
@@ -1815,7 +1820,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension)
* extensions in the extensions list. O(N^2) algorithm, but
* extensions of primitive generics are rare.
*/
- while (*loc && extension != (*loc)->extended)
+ while (*loc && !scm_is_eq (extension, (*loc)->extended))
loc = &(*loc)->next;
e->next = *loc;
e->extended = extended;
@@ -1883,13 +1888,13 @@ more_specificp (SCM m1, SCM m2, SCM const *targs)
for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
if (scm_is_null(s1)) return 1;
if (scm_is_null(s2)) return 0;
- if (SCM_CAR(s1) != SCM_CAR(s2)) {
+ if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
- if (cs1 == SCM_CAR(l))
+ if (scm_is_eq (cs1, SCM_CAR (l)))
return 1;
- if (cs2 == SCM_CAR(l))
+ if (scm_is_eq (cs2, SCM_CAR (l)))
return 0;
}
return 0;/* should not occur! */
@@ -2106,7 +2111,8 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
class = SCM_CAR(args);
args = SCM_CDR(args);
- if (class == scm_class_generic || class == scm_class_accessor)
+ if (scm_is_eq (class, scm_class_generic)
+ || scm_is_eq (class, scm_class_accessor))
{
z = scm_make_struct (class, SCM_INUM0,
scm_list_4 (SCM_BOOL_F,
@@ -2118,7 +2124,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
args,
SCM_BOOL_F));
clear_method_cache (z);
- if (class == scm_class_accessor)
+ if (scm_is_eq (class, scm_class_accessor))
{
SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
if (scm_is_true (setter))
@@ -2129,8 +2135,8 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
{
z = scm_sys_allocate_instance (class, args);
- if (class == scm_class_method
- || class == scm_class_accessor_method)
+ if (scm_is_eq (class, scm_class_method)
+ || scm_is_eq (class, scm_class_accessor_method))
{
SCM_SET_SLOT (z, scm_si_generic_function,
scm_i_get_keyword (k_gf,
@@ -2513,7 +2519,7 @@ static SCM
make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
{
SCM class, name;
- if (type_name_sym != SCM_BOOL_F)
+ if (scm_is_true (type_name_sym))
{
name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
scm_symbol_to_string (type_name_sym),
@@ -2595,12 +2601,12 @@ create_smob_classes (void)
long i;
for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
- scm_smob_class[i] = 0;
+ scm_smob_class[i] = SCM_BOOL_F;
scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
for (i = 0; i < scm_numsmob; ++i)
- if (!scm_smob_class[i])
+ if (scm_is_false (scm_smob_class[i]))
scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
scm_smobs[i].apply != 0);
}
diff --git a/libguile/guardians.c b/libguile/guardians.c
index a341fbfdc..81313df31 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -127,7 +127,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
/* Tell each guardian interested in OBJ that OBJ is no longer
reachable. */
for (;
- guardian_list != SCM_EOL;
+ !scm_is_null (guardian_list);
guardian_list = SCM_CDR (guardian_list))
{
SCM zombies;
@@ -151,7 +151,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
cell_pool = SCM_CDR (cell_pool);
/* Compute and update G's zombie list. */
- SCM_SETCAR (zombies, SCM_PACK (obj));
+ SCM_SETCAR (zombies, obj);
SCM_SETCDR (zombies, g->zombies);
g->zombies = zombies;
@@ -159,7 +159,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
g->zombies = zombies;
}
- if (proxied_finalizer != SCM_BOOL_F)
+ if (scm_is_true (proxied_finalizer))
{
/* Re-register the finalizer that was in place before we installed this
one. */
@@ -257,7 +257,7 @@ scm_i_get_one_zombie (SCM guardian)
t_guardian *g = GUARDIAN_DATA (guardian);
SCM res = SCM_BOOL_F;
- if (g->zombies != SCM_EOL)
+ if (!scm_is_null (g->zombies))
{
/* Note: We return zombies in reverse order. */
res = SCM_CAR (g->zombies);
diff --git a/libguile/hash.c b/libguile/hash.c
index 8448c7ce9..a79f03d95 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -160,18 +160,16 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
if (SCM_CHARP(obj))
return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
switch (SCM_UNPACK (obj)) {
-#ifndef SICP
- case SCM_UNPACK(SCM_EOL):
+ case SCM_EOL_BITS:
d = 256;
break;
-#endif
- case SCM_UNPACK(SCM_BOOL_T):
+ case SCM_BOOL_T_BITS:
d = 257;
break;
- case SCM_UNPACK(SCM_BOOL_F):
+ case SCM_BOOL_F_BITS:
d = 258;
break;
- case SCM_UNPACK(SCM_EOF_VAL):
+ case SCM_EOF_VAL_BITS:
d = 259;
break;
default:
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 37d168cf4..d70799380 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -105,7 +105,7 @@ scm_fixup_weak_alist (SCM alist, size_t *removed_items)
{
/* Remove from ALIST weak pair PAIR whose car/cdr has been
nullified by the GC. */
- if (prev == SCM_EOL)
+ if (scm_is_null (prev))
result = SCM_CDR (alist);
else
SCM_SETCDR (prev, SCM_CDR (alist));
@@ -211,8 +211,10 @@ weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index,
SCM_SIMPLE_VECTOR_SET (buckets, bucket_index, bucket);
result = assoc (object, bucket, closure);
- assert (!scm_is_pair (result) ||
- !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result)));
+
+ /* If we got a result, it should not have NULL fields. */
+ if (scm_is_pair (result) && SCM_WEAK_PAIR_DELETED_P (result))
+ abort ();
scm_remember_upto_here_1 (strong_refs);
@@ -774,14 +776,14 @@ set_weak_cdr (void *data)
if (SCM_NIMP (SCM_WEAK_PAIR_CDR (d->pair)) && !SCM_NIMP (d->new_val))
{
- GC_unregister_disappearing_link ((void *) SCM_CDRLOC (d->pair));
+ GC_unregister_disappearing_link ((GC_PTR) SCM_CDRLOC (d->pair));
SCM_SETCDR (d->pair, d->new_val);
}
else
{
SCM_SETCDR (d->pair, d->new_val);
- SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (d->pair),
- SCM2PTR (d->new_val));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) SCM_CDRLOC (d->pair),
+ (GC_PTR) SCM2PTR (d->new_val));
}
return NULL;
}
@@ -1396,7 +1398,7 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
{
/* We hit a weak pair whose car/cdr has become
unreachable: unlink it from the bucket. */
- if (prev != SCM_BOOL_F)
+ if (scm_is_true (prev))
SCM_SETCDR (prev, SCM_CDR (ls));
else
SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls));
diff --git a/libguile/i18n.c b/libguile/i18n.c
index 6ee159b73..b22b33222 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -234,7 +234,7 @@ SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale");
#define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \
do \
{ \
- if ((_arg) != SCM_UNDEFINED) \
+ if (!scm_is_eq ((_arg), SCM_UNDEFINED)) \
SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \
else \
(_c_locale) = NULL; \
@@ -1143,7 +1143,7 @@ chr_to_case (SCM chr, scm_t_locale c_locale,
if (SCM_UNLIKELY (ret != 0))
{
*err = ret;
- return NULL;
+ return SCM_BOOL_F;
}
if (convlen == 1)
@@ -1262,7 +1262,7 @@ str_to_case (SCM str, scm_t_locale c_locale,
if (SCM_UNLIKELY (ret != 0))
{
*err = ret;
- return NULL;
+ return SCM_BOOL_F;
}
convstr = scm_i_make_wide_string (convlen, &c_buf, 0);
@@ -1378,7 +1378,7 @@ SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
SCM_VALIDATE_STRING (1, str);
c_str = scm_i_string_chars (str);
- if (base != SCM_UNDEFINED)
+ if (!scm_is_eq (base, SCM_UNDEFINED))
SCM_VALIDATE_INT_COPY (2, base, c_base);
else
c_base = 10;
@@ -1591,7 +1591,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
if (*p == 0)
{
/* Cyclic grouping information. */
- if (last_pair != SCM_EOL)
+ if (!scm_is_null (last_pair))
SCM_SETCDR (last_pair, result);
}
}
diff --git a/libguile/inline.h b/libguile/inline.h
index 51a4db0ab..835edcc9a 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -123,7 +123,7 @@ SCM_C_EXTERN_INLINE
SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
- SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_cell))));
+ SCM cell = PTR2SCM (GC_MALLOC (sizeof (scm_t_cell)));
/* Initialize the type slot last so that the cell is ignored by the GC
until it is completely initialized. This is only relevant when the GC
@@ -141,7 +141,7 @@ SCM_C_EXTERN_INLINE
SCM
scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
{
- SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC_STUBBORN (sizeof (scm_t_cell))));
+ SCM cell = PTR2SCM (GC_MALLOC_STUBBORN (sizeof (scm_t_cell)));
/* Initialize the type slot last so that the cell is ignored by the GC
until it is completely initialized. This is only relevant when the GC
@@ -150,7 +150,7 @@ scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
SCM_GC_SET_CELL_WORD (cell, 1, cdr);
SCM_GC_SET_CELL_WORD (cell, 0, car);
- GC_END_STUBBORN_CHANGE ((void *) cell);
+ GC_END_STUBBORN_CHANGE (SCM2PTR (cell));
return cell;
}
@@ -164,7 +164,7 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr,
{
SCM z;
- z = SCM_PACK ((scm_t_bits) (GC_MALLOC (2 * sizeof (scm_t_cell))));
+ z = PTR2SCM (GC_MALLOC (2 * sizeof (scm_t_cell)));
/* Initialize the type slot last so that the cell is ignored by the
GC until it is completely initialized. This is only relevant
when the GC can actually run during this code, which it can't
@@ -207,7 +207,7 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
{
SCM z;
- z = SCM_PACK ((scm_t_bits) (GC_MALLOC_STUBBORN (2 * sizeof (scm_t_cell))));
+ z = PTR2SCM (GC_MALLOC_STUBBORN (2 * sizeof (scm_t_cell)));
/* Initialize the type slot last so that the cell is ignored by the
GC until it is completely initialized. This is only relevant
when the GC can actually run during this code, which it can't
@@ -218,7 +218,7 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
SCM_GC_SET_CELL_WORD (z, 3, cdr);
SCM_GC_SET_CELL_WORD (z, 0, car);
- GC_END_STUBBORN_CHANGE ((void *) z);
+ GC_END_STUBBORN_CHANGE (SCM2PTR (z));
/* When this function is inlined, it's possible that the last
SCM_GC_SET_CELL_WORD above will be adjacent to a following
@@ -251,7 +251,7 @@ scm_words (scm_t_bits car, scm_t_uint16 n_words)
{
SCM z;
- z = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_bits) * n_words)));
+ z = PTR2SCM (GC_MALLOC (sizeof (scm_t_bits) * n_words));
SCM_GC_SET_CELL_WORD (z, 0, car);
/* FIXME: is the following concern even relevant with BDW-GC? */
diff --git a/libguile/list.c b/libguile/list.c
index 704151519..221ee79d0 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -35,10 +35,10 @@
/* creating lists */
-#define SCM_I_CONS(cell, x, y) \
-do { \
- cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y); \
-} while (0)
+#define SCM_I_CONS(cell, x, y) \
+ do { \
+ cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); \
+ } while (0)
SCM
scm_list_1 (SCM e1)
diff --git a/libguile/load.c b/libguile/load.c
index b0137a11b..fa19a2a66 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -116,7 +116,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
/* Lookup and use the current reader to read the next
expression. */
reader = scm_fluid_ref (the_reader);
- if (reader == SCM_BOOL_F)
+ if (scm_is_false (reader))
form = scm_read (port);
else
form = scm_call_1 (reader, port);
diff --git a/libguile/macros.c b/libguile/macros.c
index aa6b9cd1c..556e60f57 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -64,9 +64,9 @@ scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn)
{
SCM z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn);
- SCM_SET_SMOB_DATA_N (z, 2, scm_from_locale_symbol (name));
- SCM_SET_SMOB_DATA_N (z, 3, SCM_BOOL_F);
- SCM_SET_SMOB_DATA_N (z, 4, SCM_BOOL_F);
+ SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_locale_symbol (name));
+ SCM_SET_SMOB_OBJECT_N (z, 3, SCM_BOOL_F);
+ SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F);
return z;
}
@@ -104,9 +104,9 @@ SCM_DEFINE (scm_make_syntax_transformer, "make-syntax-transformer", 3, 0, 0,
z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, prim);
- SCM_SET_SMOB_DATA_N (z, 2, name);
- SCM_SET_SMOB_DATA_N (z, 3, type);
- SCM_SET_SMOB_DATA_N (z, 4, binding);
+ SCM_SET_SMOB_OBJECT_N (z, 2, name);
+ SCM_SET_SMOB_OBJECT_N (z, 3, type);
+ SCM_SET_SMOB_OBJECT_N (z, 4, binding);
return z;
}
#undef FUNC_NAME
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 49d294861..0b1aa5194 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -64,7 +64,8 @@ SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
scm_t_bits scm_tc16_memoized;
-#define MAKMEMO(n, args) (scm_cell (scm_tc16_memoized | ((n) << 16), (scm_t_bits)(args)))
+#define MAKMEMO(n, args) \
+ (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
#define MAKMEMO_BEGIN(exps) \
MAKMEMO (SCM_M_BEGIN, exps)
@@ -448,13 +449,13 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
(scm_cell (scm_tc16_memoizer, \
- (scm_t_bits)(scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
+ SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
#define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N) \
(scm_cell (scm_tc16_memoizer, \
- (scm_t_bits)(scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER))))
+ SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER)))))
#define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N) \
SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))
diff --git a/libguile/modules.c b/libguile/modules.c
index e06082186..ca8875dab 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -304,8 +304,8 @@ resolve_duplicate_binding (SCM module, SCM sym,
val1 = SCM_VARIABLE_REF (var1);
val2 = SCM_VARIABLE_REF (var2);
- val1 = (val1 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
- val2 = (val2 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
+ val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
+ val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
if (scm_is_false (handlers))
@@ -947,14 +947,14 @@ SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
{
handle = SCM_CAR (ls);
- if (SCM_CAR (handle) == SCM_PACK (NULL))
+ if (SCM_UNPACK (SCM_CAR (handle)) == 0)
{
/* FIXME: We hit a weak pair whose car has become unreachable.
We should remove the pair in question or something. */
}
else
{
- if (SCM_CDR (handle) == variable)
+ if (scm_is_eq (SCM_CDR (handle), variable))
return SCM_CAR (handle);
}
diff --git a/libguile/net_db.c b/libguile/net_db.c
index 14722d516..61dd2f386 100644
--- a/libguile/net_db.c
+++ b/libguile/net_db.c
@@ -457,7 +457,7 @@ SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
SCM_SYMBOL (sym_getaddrinfo_error, "getaddrinfo-error");
/* Make sure the `AI_*' flags can be stored as INUMs. */
-verify (SCM_I_INUM (SCM_I_MAKINUM (AI_ALL)) == AI_ALL);
+verify (AI_ALL < SCM_MOST_POSITIVE_FIXNUM);
/* Valid values for the `ai_flags' to `struct addrinfo'. */
SCM_VARIABLE_INIT (sym_ai_passive, "AI_PASSIVE",
@@ -677,7 +677,7 @@ SCM_DEFINE (scm_getaddrinfo, "getaddrinfo", 1, 5, 0,
#undef FUNC_NAME
/* Make sure the `EAI_*' flags can be stored as INUMs. */
-verify (SCM_I_INUM (SCM_I_MAKINUM (EAI_BADFLAGS)) == EAI_BADFLAGS);
+verify (EAI_BADFLAGS < SCM_MOST_POSITIVE_FIXNUM);
/* Error codes returned by `getaddrinfo'. */
SCM_VARIABLE_INIT (sym_eai_badflags, "EAI_BADFLAGS",
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 7e0511918..057a69ca6 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -4112,7 +4112,7 @@ SCM scm_logand (SCM n1, SCM n2)
else if SCM_BIGP (n2)
{
intbig:
- if (n1 == 0)
+ if (nn1 == 0)
return SCM_INUM0;
{
SCM result_z = scm_i_mkbig ();
diff --git a/libguile/pairs.c b/libguile/pairs.c
index 68fa4c901..5dbbab566 100644
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -42,8 +42,8 @@
* See the comments preceeding the definitions of SCM_BOOL_F and
* SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
*/
-verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
- (SCM_ELISP_NIL, SCM_EOL));
+verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL_BITS, SCM_EOL_BITS));
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
diff --git a/libguile/ports.c b/libguile/ports.c
index 858c3dd54..a4d3bd847 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -365,10 +365,10 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
/* Standard ports --- current input, output, error, and more(!). */
-static SCM cur_inport_fluid = 0;
-static SCM cur_outport_fluid = 0;
-static SCM cur_errport_fluid = 0;
-static SCM cur_loadport_fluid = 0;
+static SCM cur_inport_fluid = SCM_BOOL_F;
+static SCM cur_outport_fluid = SCM_BOOL_F;
+static SCM cur_errport_fluid = SCM_BOOL_F;
+static SCM cur_loadport_fluid = SCM_BOOL_F;
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
(),
@@ -377,7 +377,7 @@ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
"returns the @dfn{standard input} in Unix and C terminology.")
#define FUNC_NAME s_scm_current_input_port
{
- if (cur_inport_fluid)
+ if (scm_is_true (cur_inport_fluid))
return scm_fluid_ref (cur_inport_fluid);
else
return SCM_BOOL_F;
@@ -392,7 +392,7 @@ SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
"Unix and C terminology.")
#define FUNC_NAME s_scm_current_output_port
{
- if (cur_outport_fluid)
+ if (scm_is_true (cur_outport_fluid))
return scm_fluid_ref (cur_outport_fluid);
else
return SCM_BOOL_F;
@@ -405,7 +405,7 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
"@dfn{standard error} in Unix and C terminology).")
#define FUNC_NAME s_scm_current_error_port
{
- if (cur_errport_fluid)
+ if (scm_is_true (cur_errport_fluid))
return scm_fluid_ref (cur_errport_fluid);
else
return SCM_BOOL_F;
@@ -898,9 +898,21 @@ SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
"have no effect as far as @var{port-for-each} is concerned.")
#define FUNC_NAME s_scm_port_for_each
{
+ SCM ports;
+
SCM_VALIDATE_PROC (1, proc);
- scm_c_port_for_each ((void (*)(void*,SCM))scm_call_1, proc);
+ /* Copy out the port table as a list so that we get strong references
+ to all the values. */
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+ ports = scm_internal_hash_fold (collect_keys, NULL,
+ SCM_EOL, scm_i_port_weak_hash);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ for (; scm_is_pair (ports); ports = scm_cdr (ports))
+ if (SCM_PORTP (SCM_CAR (ports)))
+ scm_call_1 (proc, SCM_CAR (ports));
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -2294,7 +2306,7 @@ scm_i_set_conversion_strategy_x (SCM port,
if (scm_is_false (port))
{
/* Set the default encoding for future ports. */
- if (!scm_conversion_strategy
+ if (!scm_conversion_strategy_init
|| !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
SCM_EOL);
diff --git a/libguile/posix.c b/libguile/posix.c
index 15b38e79c..2923dc6f8 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -511,63 +511,63 @@ scm_to_resource (SCM s, const char *func, int pos)
SCM_ASSERT_TYPE (scm_is_symbol (s), s, pos, func, "symbol");
#ifdef RLIMIT_AS
- if (s == sym_as)
+ if (scm_is_eq (s, sym_as))
return RLIMIT_AS;
#endif
#ifdef RLIMIT_CORE
- if (s == sym_core)
+ if (scm_is_eq (s, sym_core))
return RLIMIT_CORE;
#endif
#ifdef RLIMIT_CPU
- if (s == sym_cpu)
+ if (scm_is_eq (s, sym_cpu))
return RLIMIT_CPU;
#endif
#ifdef RLIMIT_DATA
- if (s == sym_data)
+ if (scm_is_eq (s, sym_data))
return RLIMIT_DATA;
#endif
#ifdef RLIMIT_FSIZE
- if (s == sym_fsize)
+ if (scm_is_eq (s, sym_fsize))
return RLIMIT_FSIZE;
#endif
#ifdef RLIMIT_MEMLOCK
- if (s == sym_memlock)
+ if (scm_is_eq (s, sym_memlock))
return RLIMIT_MEMLOCK;
#endif
#ifdef RLIMIT_MSGQUEUE
- if (s == sym_msgqueue)
+ if (scm_is_eq (s, sym_msgqueue))
return RLIMIT_MSGQUEUE;
#endif
#ifdef RLIMIT_NICE
- if (s == sym_nice)
+ if (scm_is_eq (s, sym_nice))
return RLIMIT_NICE;
#endif
#ifdef RLIMIT_NOFILE
- if (s == sym_nofile)
+ if (scm_is_eq (s, sym_nofile))
return RLIMIT_NOFILE;
#endif
#ifdef RLIMIT_NPROC
- if (s == sym_nproc)
+ if (scm_is_eq (s, sym_nproc))
return RLIMIT_NPROC;
#endif
#ifdef RLIMIT_RSS
- if (s == sym_rss)
+ if (scm_is_eq (s, sym_rss))
return RLIMIT_RSS;
#endif
#ifdef RLIMIT_RTPRIO
- if (s == sym_rtprio)
+ if (scm_is_eq (s, sym_rtprio))
return RLIMIT_RTPRIO;
#endif
#ifdef RLIMIT_RTPRIO
- if (s == sym_rttime)
+ if (scm_is_eq (s, sym_rttime))
return RLIMIT_RTPRIO;
#endif
#ifdef RLIMIT_SIGPENDING
- if (s == sym_sigpending)
+ if (scm_is_eq (s, sym_sigpending))
return RLIMIT_SIGPENDING;
#endif
#ifdef RLIMIT_STACK
- if (s == sym_stack)
+ if (scm_is_eq (s, sym_stack))
return RLIMIT_STACK;
#endif
@@ -615,8 +615,8 @@ SCM_DEFINE (scm_setrlimit, "setrlimit", 3, 0, 0,
iresource = scm_to_resource (resource, FUNC_NAME, 1);
- lim.rlim_cur = (soft == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (soft);
- lim.rlim_max = (hard == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (hard);
+ lim.rlim_cur = scm_is_false (soft) ? RLIM_INFINITY : scm_to_long (soft);
+ lim.rlim_max = scm_is_false (hard) ? RLIM_INFINITY : scm_to_long (hard);
if (setrlimit (iresource, &lim) != 0)
scm_syserror (FUNC_NAME);
diff --git a/libguile/print.c b/libguile/print.c
index 453c8a9f0..4afd12c92 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -100,11 +100,11 @@ static const char *iflagnames[] =
SCM_SYMBOL (sym_reader, "reader");
scm_t_option scm_print_opts[] = {
- { SCM_OPTION_SCM, "highlight-prefix", (scm_t_bits)SCM_BOOL_F,
+ { SCM_OPTION_SCM, "highlight-prefix", (scm_t_bits)SCM_BOOL_F_BITS,
"The string to print before highlighted values." },
- { SCM_OPTION_SCM, "highlight-suffix", (scm_t_bits)SCM_BOOL_F,
+ { SCM_OPTION_SCM, "highlight-suffix", (scm_t_bits)SCM_BOOL_F_BITS,
"The string to print after highlighted values." },
- { SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F,
+ { SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F_BITS,
"How to print symbols that have a colon as their first or last character. "
"The value '#f' does not quote the colons; '#t' quotes them; "
"'reader' quotes them when the reader option 'keywords' is not '#f'."
@@ -525,7 +525,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
{
SCM pwps, print = pstate->writingp ? g_write : g_display;
- if (!print)
+ if (SCM_UNPACK (print) == 0)
goto print_struct;
pwps = scm_i_port_with_print_state (port, pstate->handle);
pstate->revealed = 1;
diff --git a/libguile/promises.c b/libguile/promises.c
index 45a76a9e5..4aff15092 100644
--- a/libguile/promises.c
+++ b/libguile/promises.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -80,7 +80,7 @@ SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0,
SCM_VALIDATE_THUNK (1, thunk);
SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
SCM_UNPACK (thunk),
- scm_make_recursive_mutex ());
+ SCM_UNPACK (scm_make_recursive_mutex ()));
}
#undef FUNC_NAME
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 015e0b526..308f17a94 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -726,11 +726,11 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
- if (start != SCM_UNDEFINED)
+ if (!scm_is_eq (start, SCM_UNDEFINED))
{
c_start = scm_to_uint (start);
- if (count != SCM_UNDEFINED)
+ if (!scm_is_eq (count, SCM_UNDEFINED))
{
c_count = scm_to_uint (count);
if (SCM_UNLIKELY (c_start + c_count > c_len))
diff --git a/libguile/read.c b/libguile/read.c
index 3e739586a..098854bb4 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -70,7 +70,7 @@ scm_t_option scm_read_opts[] = {
"Record positions of source code expressions." },
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0,
"Convert symbols to lower case."},
- { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F,
+ { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
"Style of keyword recognition: #f, 'prefix or 'postfix."},
{ SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
"Use R6RS variable-length character and string hex escapes."},
@@ -1538,7 +1538,7 @@ recsexpr (SCM obj, long line, int column, SCM filename)
if (!scm_is_pair(obj)) {
return obj;
} else {
- SCM tmp = obj, copy;
+ SCM tmp, copy;
/* If this sexpr is visible in the read:sharp source, we want to
keep that information, so only record non-constant cons cells
which haven't previously been read by the reader. */
@@ -1548,7 +1548,7 @@ recsexpr (SCM obj, long line, int column, SCM filename)
{
copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
SCM_UNDEFINED);
- while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
+ for (tmp = obj; scm_is_pair (tmp); tmp = SCM_CDR (tmp))
{
SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
line,
@@ -1562,7 +1562,7 @@ recsexpr (SCM obj, long line, int column, SCM filename)
else
{
recsexpr (SCM_CAR (obj), line, column, filename);
- while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
+ for (tmp = obj; scm_is_pair (tmp); tmp = SCM_CDR (tmp))
recsexpr (SCM_CAR (tmp), line, column, filename);
copy = SCM_UNDEFINED;
}
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 7d22a3617..b0800c42c 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -30,7 +30,7 @@
#define SCM_FUNC_CAST_ARBITRARY_ARGS scm_t_subr
-#if (defined SCM_ALIGNED) && (SCM_DEBUG_TYPING_STRICTNESS <= 1)
+#ifdef SCM_ALIGNED
/* We support static allocation of some `SCM' objects. */
# define SCM_SUPPORT_STATIC_ALLOCATION
#endif
@@ -359,7 +359,7 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
(scm_t_bits) &scm_i_paste (c_name, \
_stringbuf), \
(scm_t_bits) 0, \
- (scm_t_bits) sizeof (contents) - 1)
+ (scm_t_bits) (sizeof (contents) - 1))
#define SCM_IMMUTABLE_POINTER(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr)
@@ -375,11 +375,16 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
}; \
#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
- SCM_STATIC_DOUBLE_CELL (c_name, \
- scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE, \
- (scm_t_bits) objcode, \
- (scm_t_bits) objtable, \
- (scm_t_bits) freevars)
+ static SCM_ALIGNED (8) SCM_UNUSED SCM \
+ scm_i_paste (c_name, _raw_cell)[] = \
+ { \
+ SCM_PACK (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE), \
+ objcode, \
+ objtable, \
+ freevars \
+ }; \
+ static SCM_UNUSED const SCM c_name = \
+ SCM_PACK (& scm_i_paste (c_name, _raw_cell))
#endif /* SCM_SUPPORT_STATIC_ALLOCATION */
diff --git a/libguile/socket.c b/libguile/socket.c
index 2e59a15c9..d085d330e 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -910,7 +910,7 @@ SCM_DEFINE (scm_connect, "connect", 2, 1, 1,
SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock);
- if (address == SCM_UNDEFINED)
+ if (scm_is_eq (address, SCM_UNDEFINED))
/* No third argument was passed to FAM_OR_SOCKADDR must actually be a
`socket address' object. */
soka = scm_to_sockaddr (fam_or_sockaddr, &size);
@@ -979,7 +979,7 @@ SCM_DEFINE (scm_bind, "bind", 2, 1, 1,
SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock);
- if (address == SCM_UNDEFINED)
+ if (scm_is_eq (address, SCM_UNDEFINED))
/* No third argument was passed to FAM_OR_SOCKADDR must actually be a
`socket address' object. */
soka = scm_to_sockaddr (fam_or_sockaddr, &size);
@@ -1192,14 +1192,14 @@ scm_to_sockaddr (SCM address, size_t *address_size)
size_t path_len = 0;
path = SCM_SIMPLE_VECTOR_REF (address, 1);
- if ((!scm_is_string (path)) && (path != SCM_BOOL_F))
+ if (!scm_is_string (path) && !scm_is_false (path))
scm_misc_error (FUNC_NAME, "invalid unix address "
"path: ~A", scm_list_1 (path));
else
{
struct sockaddr_un c_unix;
- if (path == SCM_BOOL_F)
+ if (scm_is_false (path))
path_len = 0;
else
path_len = scm_c_string_length (path);
@@ -1594,7 +1594,7 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1,
means that the following arguments, i.e. ADDRESS and those listed in
ARGS_AND_FLAGS, are the `MSG_' flags. */
soka = scm_to_sockaddr (fam_or_sockaddr, &size);
- if (address != SCM_UNDEFINED)
+ if (!scm_is_eq (address, SCM_UNDEFINED))
args_and_flags = scm_cons (address, args_and_flags);
}
else
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index f9b000c47..4eb1ccaac 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -125,23 +125,23 @@ scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
thread safety.
*/
SCM last_acons = SCM_CDR (scm_last_alist_filename);
- if (old_alist == SCM_EOL
- && SCM_CDAR (last_acons) == filename)
+ if (scm_is_null (old_alist)
+ && scm_is_eq (SCM_CDAR (last_acons), filename))
{
alist = last_acons;
}
else
{
alist = scm_acons (scm_sym_filename, filename, alist);
- if (old_alist == SCM_EOL)
+ if (scm_is_null (old_alist))
SCM_SETCDR (scm_last_alist_filename, alist);
}
}
SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
SRCPROPMAKPOS (line, col),
- copy,
- alist);
+ SCM_UNPACK (copy),
+ SCM_UNPACK (alist));
}
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 31bd91b13..86188f416 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -102,7 +102,7 @@ find_prompt (SCM key)
for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
{
SCM elt = scm_car (winds);
- if (SCM_PROMPT_P (elt) && SCM_PROMPT_TAG (elt) == key)
+ if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), key))
return elt;
}
scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
diff --git a/libguile/tags.h b/libguile/tags.h
index 916984262..c90838ef1 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -74,10 +74,9 @@ typedef scm_t_uintptr scm_t_bits;
* desired level of type checking, be defined in several ways:
*/
#if (SCM_DEBUG_TYPING_STRICTNESS == 2)
- typedef union { struct { scm_t_bits n; } n; } SCM;
- static SCM scm_pack(scm_t_bits b) { SCM s; s.n.n = b; return s; }
+typedef union SCM { struct { scm_t_bits n; } n; } SCM;
# define SCM_UNPACK(x) ((x).n.n)
-# define SCM_PACK(x) (scm_pack ((scm_t_bits) (x)))
+# define SCM_PACK(x) ((SCM) { { (scm_t_bits) (x) } })
#elif (SCM_DEBUG_TYPING_STRICTNESS == 1)
/* This is the default, which provides an intermediate level of compile time
* type checking while still resulting in very efficient code.
@@ -465,7 +464,8 @@ enum scm_tc8_tags
};
#define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff)
-#define SCM_MAKE_ITAG8(X, TAG) SCM_PACK (((X) << 8) + TAG)
+#define SCM_MAKE_ITAG8_BITS(X, TAG) (((X) << 8) + TAG)
+#define SCM_MAKE_ITAG8(X, TAG) (SCM_PACK (SCM_MAKE_ITAG8_BITS (X, TAG)))
#define SCM_ITAG8_DATA(X) (SCM_UNPACK (X) >> 8)
@@ -474,7 +474,7 @@ enum scm_tc8_tags
* declarations in print.c: iflagnames. */
#define SCM_IFLAGP(n) (SCM_ITAG8 (n) == scm_tc8_flag)
-#define SCM_MAKIFLAG(n) SCM_MAKE_ITAG8 ((n), scm_tc8_flag)
+#define SCM_MAKIFLAG_BITS(n) (SCM_MAKE_ITAG8_BITS ((n), scm_tc8_flag))
#define SCM_IFLAGNUM(n) (SCM_ITAG8_DATA (n))
/*
@@ -508,25 +508,35 @@ enum scm_tc8_tags
* defined below. The properties are checked at compile-time using
* `verify' macros near the top of boolean.c and pairs.c.
*/
-#define SCM_BOOL_F SCM_MAKIFLAG (0)
-#define SCM_ELISP_NIL SCM_MAKIFLAG (1)
+#define SCM_BOOL_F_BITS SCM_MAKIFLAG_BITS (0)
+#define SCM_ELISP_NIL_BITS SCM_MAKIFLAG_BITS (1)
+
+#define SCM_BOOL_F SCM_PACK (SCM_BOOL_F_BITS)
+#define SCM_ELISP_NIL SCM_PACK (SCM_ELISP_NIL_BITS)
#ifdef BUILDING_LIBGUILE
-#define SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE SCM_MAKIFLAG (2)
+#define SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE SCM_MAKIFLAG_BITS (2)
#endif
-#define SCM_EOL SCM_MAKIFLAG (3)
-#define SCM_BOOL_T SCM_MAKIFLAG (4)
+#define SCM_EOL_BITS SCM_MAKIFLAG_BITS (3)
+#define SCM_BOOL_T_BITS SCM_MAKIFLAG_BITS (4)
+
+#define SCM_EOL SCM_PACK (SCM_EOL_BITS)
+#define SCM_BOOL_T SCM_PACK (SCM_BOOL_T_BITS)
#ifdef BUILDING_LIBGUILE
-#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0 SCM_MAKIFLAG (5)
-#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_1 SCM_MAKIFLAG (6)
-#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_2 SCM_MAKIFLAG (7)
+#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0 SCM_MAKIFLAG_BITS (5)
+#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_1 SCM_MAKIFLAG_BITS (6)
+#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_2 SCM_MAKIFLAG_BITS (7)
#endif
-#define SCM_UNSPECIFIED SCM_MAKIFLAG (8)
-#define SCM_UNDEFINED SCM_MAKIFLAG (9)
-#define SCM_EOF_VAL SCM_MAKIFLAG (10)
+#define SCM_UNSPECIFIED_BITS SCM_MAKIFLAG_BITS (8)
+#define SCM_UNDEFINED_BITS SCM_MAKIFLAG_BITS (9)
+#define SCM_EOF_VAL_BITS SCM_MAKIFLAG_BITS (10)
+
+#define SCM_UNSPECIFIED SCM_PACK (SCM_UNSPECIFIED_BITS)
+#define SCM_UNDEFINED SCM_PACK (SCM_UNDEFINED_BITS)
+#define SCM_EOF_VAL SCM_PACK (SCM_EOF_VAL_BITS)
/* When a variable is unbound this is marked by the SCM_UNDEFINED
* value. The following is an unbound value which can be handled on
@@ -536,7 +546,8 @@ enum scm_tc8_tags
* the code which handles this value in C so that SCM_UNDEFINED can be
* used instead. It is not ideal to let this kind of unique and
* strange values loose on the Scheme level. */
-#define SCM_UNBOUND SCM_MAKIFLAG (11)
+#define SCM_UNBOUND_BITS SCM_MAKIFLAG_BITS (11)
+#define SCM_UNBOUND SCM_PACK (SCM_UNBOUND_BITS)
#define SCM_UNBNDP(x) (scm_is_eq ((x), SCM_UNDEFINED))
@@ -575,12 +586,12 @@ enum scm_tc8_tags
#define SCM_HAS_EXACTLY_TWO_BITS_SET(x) \
(SCM_HAS_EXACTLY_ONE_BIT_SET (SCM_WITH_LEAST_SIGNIFICANT_1_BIT_CLEARED (x)))
-#define SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION(a,b) \
- (SCM_HAS_EXACTLY_ONE_BIT_SET (SCM_UNPACK(a) ^ SCM_UNPACK(b)))
-#define SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS(a,b,c,d) \
- (SCM_HAS_EXACTLY_TWO_BITS_SET ((SCM_UNPACK(a) ^ SCM_UNPACK(b)) | \
- (SCM_UNPACK(b) ^ SCM_UNPACK(c)) | \
- (SCM_UNPACK(c) ^ SCM_UNPACK(d))))
+#define SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION(a,b) \
+ (SCM_HAS_EXACTLY_ONE_BIT_SET ((a) ^ (b)))
+#define SCM_BITS_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS(a,b,c,d) \
+ (SCM_HAS_EXACTLY_TWO_BITS_SET (((a) ^ (b)) | \
+ ((b) ^ (c)) | \
+ ((c) ^ (d))))
#endif /* BUILDING_LIBGUILE */
diff --git a/libguile/threads.c b/libguile/threads.c
index f49696b1d..def92811b 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -607,6 +607,13 @@ typedef struct {
#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
+static SCM
+call_cleanup (void *data)
+{
+ SCM *proc_p = data;
+ return scm_call_0 (*proc_p);
+}
+
/* Perform thread tear-down, in guile mode.
*/
static void *
@@ -624,7 +631,7 @@ do_thread_exit (void *v)
t->cleanup_handler = SCM_BOOL_F;
t->result = scm_internal_catch (SCM_BOOL_T,
- (scm_t_catch_body) scm_call_0, ptr,
+ call_cleanup, &ptr,
scm_handle_by_message_noexit, NULL);
}
diff --git a/libguile/variable.c b/libguile/variable.c
index 76fbf1821..a9cc60e20 100644
--- a/libguile/variable.c
+++ b/libguile/variable.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -92,7 +92,7 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0,
SCM val;
SCM_VALIDATE_VARIABLE (1, var);
val = SCM_VARIABLE_REF (var);
- if (val == SCM_UNDEFINED)
+ if (scm_is_eq (val, SCM_UNDEFINED))
SCM_MISC_ERROR ("variable is unbound: ~S", scm_list_1 (var));
return val;
}
@@ -130,7 +130,7 @@ SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0,
#define FUNC_NAME s_scm_variable_bound_p
{
SCM_VALIDATE_VARIABLE (1, var);
- return scm_from_bool (SCM_VARIABLE_REF (var) != SCM_UNDEFINED);
+ return scm_from_bool (!scm_is_eq (SCM_VARIABLE_REF (var), SCM_UNDEFINED));
}
#undef FUNC_NAME
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 2ab5b78ea..2805278f0 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -213,7 +213,7 @@ scm_c_vector_ref (SCM v, size_t k)
scm_out_of_range (NULL, scm_from_size_t (k));
elt = (SCM_I_VECTOR_ELTS(v))[k];
- if ((elt == SCM_PACK (NULL)) && SCM_I_WVECTP (v))
+ if (SCM_UNPACK (elt) == 0 && SCM_I_WVECTP (v))
/* ELT was a weak pointer and got nullified by the GC. */
return SCM_BOOL_F;
@@ -232,7 +232,7 @@ scm_c_vector_ref (SCM v, size_t k)
k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
elt = (SCM_I_VECTOR_ELTS (vv))[k];
- if ((elt == SCM_PACK (NULL)) && (SCM_I_WVECTP (vv)))
+ if (SCM_UNPACK (elt) == 0 && (SCM_I_WVECTP (vv)))
/* ELT was a weak pointer and got nullified by the GC. */
return SCM_BOOL_F;
@@ -278,7 +278,8 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
{
/* Make it a weak pointer. */
GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
- SCM_I_REGISTER_DISAPPEARING_LINK (link, obj);
+ SCM_I_REGISTER_DISAPPEARING_LINK (link,
+ (GC_PTR) SCM2PTR (obj));
}
}
else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
@@ -296,7 +297,8 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
{
/* Make it a weak pointer. */
GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
- SCM_I_REGISTER_DISAPPEARING_LINK (link, obj);
+ SCM_I_REGISTER_DISAPPEARING_LINK (link,
+ (GC_PTR) SCM2PTR (obj));
}
}
else
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e449b4372..22bd39c0e 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -89,17 +89,17 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* Initial frame */
CACHE_REGISTER ();
- PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* mvra */
- PUSH ((SCM)ip); /* ra */
+ PUSH (SCM_PACK (fp)); /* dynamic link */
+ PUSH (SCM_PACK (0)); /* mvra */
+ PUSH (SCM_PACK (ip)); /* ra */
CACHE_PROGRAM ();
PUSH (program);
fp = sp + 1;
ip = SCM_C_OBJCODE_BASE (bp);
/* MV-call frame, function & arguments */
- PUSH (0); /* dynamic link */
- PUSH (0); /* mvra */
- PUSH (0); /* ra */
+ PUSH (SCM_PACK (0)); /* dynamic link */
+ PUSH (SCM_PACK (0)); /* mvra */
+ PUSH (SCM_PACK (0)); /* ra */
PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args;
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 146931eb6..48ab09a12 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -126,7 +126,7 @@
} while (0)
#define ASSERT_BOUND_VARIABLE(x) \
do { ASSERT_VARIABLE (x); \
- if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED) \
+ if (scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED)) \
{ SYNC_REGISTER (); abort(); } \
} while (0)
@@ -136,7 +136,7 @@
#define ASSERT_ALIGNED_PROCEDURE() \
do { if ((scm_t_bits)bp % 8) abort (); } while (0)
#define ASSERT_BOUND(x) \
- do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
+ do { if (scm_is_eq ((x), SCM_UNDEFINED)) { SYNC_REGISTER (); abort(); } \
} while (0)
#else
#define CHECK_IP()
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 60e44521e..2d8501253 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -168,15 +168,15 @@ VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
*/
#undef REL
-#define REL(crel,srel) \
-{ \
- ARGS2 (x, y); \
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
- RETURN (scm_from_bool ((scm_t_signed_bits) (x) \
- crel (scm_t_signed_bits) (y))); \
- SYNC_REGISTER (); \
- RETURN (srel (x, y)); \
-}
+#define REL(crel,srel) \
+ { \
+ ARGS2 (x, y); \
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
+ RETURN (scm_from_bool (((scm_t_signed_bits) SCM_UNPACK (x)) \
+ crel ((scm_t_signed_bits) SCM_UNPACK (y)))); \
+ SYNC_REGISTER (); \
+ RETURN (srel (x, y)); \
+ }
VM_DEFINE_FUNCTION (145, ee, "ee?", 2)
{
@@ -297,13 +297,13 @@ VM_DEFINE_FUNCTION (151, add1, "add1", 1)
ARGS1 (x);
/* Check for overflow. */
- if (SCM_LIKELY ((scm_t_intptr) x < INUM_MAX))
+ if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) < INUM_MAX))
{
SCM result;
/* Add the integers without untagging. */
- result = SCM_PACK ((scm_t_intptr) x
- + (scm_t_intptr) SCM_I_MAKINUM (1)
+ result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
+ + (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
- scm_tc2_int);
if (SCM_LIKELY (SCM_I_INUMP (result)))
@@ -331,13 +331,13 @@ VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
ARGS1 (x);
/* Check for underflow. */
- if (SCM_LIKELY ((scm_t_intptr) x > INUM_MIN))
+ if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) > INUM_MIN))
{
SCM result;
/* Substract the integers without untagging. */
- result = SCM_PACK ((scm_t_intptr) x
- - (scm_t_intptr) SCM_I_MAKINUM (1)
+ result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
+ - (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
+ scm_tc2_int);
if (SCM_LIKELY (SCM_I_INUMP (result)))
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 0ff411f9a..1b4136f3f 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -233,7 +233,7 @@ VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
nothing more than the corresponding macros. */
#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
-#define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED)
+#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
#define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
@@ -277,10 +277,7 @@ VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
{
- if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED)
- PUSH (SCM_BOOL_F);
- else
- PUSH (SCM_BOOL_T);
+ PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED)));
NEXT;
}
@@ -289,10 +286,7 @@ VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
unsigned int i = FETCH ();
i <<= 8;
i += FETCH ();
- if (LOCAL_REF (i) == SCM_UNDEFINED)
- PUSH (SCM_BOOL_F);
- else
- PUSH (SCM_BOOL_T);
+ PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED)));
NEXT;
}
@@ -771,9 +765,9 @@ VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
know that this frame will point to the current fp: it could be
placed elsewhere on the stack if captured in a partial
continuation, and invoked from some other context. */
- PUSH (0); /* dynamic link */
- PUSH (0); /* mvra */
- PUSH (0); /* ra */
+ PUSH (SCM_PACK (0)); /* dynamic link */
+ PUSH (SCM_PACK (0)); /* mvra */
+ PUSH (SCM_PACK (0)); /* ra */
NEXT;
}
@@ -1188,9 +1182,9 @@ VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first)
{
- PUSH (0); /* dynamic link */
- PUSH (0); /* mvra */
- PUSH (0); /* ra */
+ PUSH (SCM_PACK (0)); /* dynamic link */
+ PUSH (SCM_PACK (0)); /* mvra */
+ PUSH (SCM_PACK (0)); /* ra */
PUSH (proc);
PUSH (cont);
nargs = 1;
@@ -1666,7 +1660,7 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
else
{
SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
- if (SCM_UNLIKELY (val == SCM_UNDEFINED))
+ if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
{
finish_args = *sp;
goto vm_error_unbound_fluid;
diff --git a/libguile/vm.c b/libguile/vm.c
index e9d96194c..8d1c37570 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -402,9 +402,9 @@ really_make_boot_program (long nargs)
static SCM
vm_make_boot_program (long nargs)
{
- static SCM programs[NUM_BOOT_PROGS] = { 0, };
+ static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
- if (SCM_UNLIKELY (!programs[0]))
+ if (SCM_UNLIKELY (scm_is_false (programs[0])))
{
int i;
for (i = 0; i < NUM_BOOT_PROGS; i++)
diff --git a/libguile/weaks.c b/libguile/weaks.c
index 1d5fcf469..92d351e51 100644
--- a/libguile/weaks.c
+++ b/libguile/weaks.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -62,11 +62,9 @@ scm_weak_car_pair (SCM car, SCM cdr)
cell->word_1 = cdr;
if (SCM_NIMP (car))
- {
- /* Weak car cells make sense iff the car is non-immediate. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
- (GC_PTR) SCM_UNPACK (car));
- }
+ /* Weak car cells make sense iff the car is non-immediate. */
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
+ (GC_PTR) SCM2PTR (car));
return (SCM_PACK (cell));
}
@@ -83,11 +81,9 @@ scm_weak_cdr_pair (SCM car, SCM cdr)
cell->word_1 = cdr;
if (SCM_NIMP (cdr))
- {
- /* Weak cdr cells make sense iff the cdr is non-immediate. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
- (GC_PTR) SCM_UNPACK (cdr));
- }
+ /* Weak cdr cells make sense iff the cdr is non-immediate. */
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
+ (GC_PTR) SCM2PTR (cdr));
return (SCM_PACK (cell));
}
@@ -103,15 +99,11 @@ scm_doubly_weak_pair (SCM car, SCM cdr)
cell->word_1 = cdr;
if (SCM_NIMP (car))
- {
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
- (GC_PTR) SCM_UNPACK (car));
- }
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
+ (GC_PTR) SCM2PTR (car));
if (SCM_NIMP (cdr))
- {
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
- (GC_PTR) SCM_UNPACK (cdr));
- }
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
+ (GC_PTR) SCM2PTR (cdr));
return (SCM_PACK (cell));
}
diff --git a/libguile/weaks.h b/libguile/weaks.h
index 5cb8bc388..fc16f8bf8 100644
--- a/libguile/weaks.h
+++ b/libguile/weaks.h
@@ -3,7 +3,7 @@
#ifndef SCM_WEAKS_H
#define SCM_WEAKS_H
-/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -50,7 +50,7 @@ SCM_INTERNAL SCM scm_doubly_weak_pair (SCM car, SCM cdr);
/* Testing the weak component(s) of a cell for reachability. */
#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \
- (SCM_CELL_OBJECT ((_cell), (_word)) == SCM_PACK (NULL))
+ (SCM_UNPACK (SCM_CELL_OBJECT ((_cell), (_word))) == 0)
#define SCM_WEAK_PAIR_CAR_DELETED_P(_cell) \
(SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0))
#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \