[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-21-g931b4a6
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-21-g931b4a6 |
|
Date: |
Fri, 13 May 2011 14:02:20 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=931b4a6ddc7348ed828f525b3f0d35c10795d440
The branch, master has been updated
via 931b4a6ddc7348ed828f525b3f0d35c10795d440 (commit)
via 86fb1eb631d455aec634aa475a14d2c88052752c (commit)
via 2002f1f84797c2c46d0634eabd5ac5fd61e13d73 (commit)
via 4d40bea6c2526c58dad4162551360e9bf323461c (commit)
via a3069bace813901dc4efe189e37261d5de05ca6d (commit)
via 6ef437665cfcf1d2aca96833a7495c9d7bd5ae90 (commit)
via 34297700953a200e8a6a163b8a6a53e6ccf31173 (commit)
via 1b3daef0333c6036f217744511abeae1774e3e6a (commit)
via 6bb2c00a76732b399ff000779cbbc8f95d511c4e (commit)
via 0b0ac740fcef9644c3808c1d96f440a44a2fbea2 (commit)
via d3464bb6e2b3ce0411a24ffe02ef398b4bc37d0f (commit)
via 393baa8a4418ff404c6305fe84016fe3ed73da55 (commit)
via b2b33168b18c6c4fd65b0e77becba1a66a00dae1 (commit)
via d223c3fcdde81280ea8fb9a4b05897786014bbce (commit)
via b2feee6bc0d440a20c2c8cbb7b3d03c957c2c417 (commit)
via b5df9cda41231785feb548da46d97a1af2c79251 (commit)
via c98ce8f59994f596e3ea574091c01439cb629308 (commit)
via 2e16a342f226b97e47fd2cd30c367ebca2a3080c (commit)
via 210c0325d38abc7409b34b6b4724a297c5524eb5 (commit)
via 544a29de14c980e1357bda4a241eef7590c6c624 (commit)
via b5070556c568eae7c597331b60c1d21828b6cc99 (commit)
from fc7bd367ab4b5027a7f80686b1e229c62e43c90b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 931b4a6ddc7348ed828f525b3f0d35c10795d440
Author: Andy Wingo <address@hidden>
Date: Fri May 13 11:26:40 2011 +0200
Bump default typing strictness to 2.
* libguile/__scm.h (SCM_DEBUG_TYPING_STRICTNESS): Bump the default to
2.
commit 86fb1eb631d455aec634aa475a14d2c88052752c
Merge: fc7bd36 2002f1f
Author: Andy Wingo <address@hidden>
Date: Fri May 13 15:45:43 2011 +0200
merge strictness branch from 2.0
-----------------------------------------------------------------------
Summary of changes:
libguile/__scm.h | 2 +-
libguile/async.c | 94 +++++++++++++++++++++++----------------
libguile/boolean.c | 26 ++++++------
libguile/bytevectors.c | 8 ++--
libguile/continuations.c | 2 +-
libguile/control.c | 2 +-
libguile/debug.c | 4 +-
libguile/deprecated.c | 26 +++++++++++
libguile/deprecated.h | 11 +++++
libguile/deprecation.c | 2 +-
libguile/dynwind.c | 19 +--------
libguile/dynwind.h | 8 +---
libguile/eval.c | 7 ++-
libguile/expand.h | 7 ++-
libguile/fluids.c | 4 +-
libguile/frames.c | 6 +-
libguile/frames.h | 8 ++--
libguile/generalized-vectors.c | 4 +-
libguile/goops.c | 70 ++++++++++++++++--------------
libguile/guardians.c | 10 ++--
libguile/hash.c | 10 ++---
libguile/hashtab.c | 16 ++++---
libguile/i18n.c | 10 ++--
libguile/inline.h | 14 +++---
libguile/list.c | 8 ++--
libguile/load.c | 2 +-
libguile/macros.c | 14 +++---
libguile/memoize.c | 7 ++-
libguile/modules.c | 8 ++--
libguile/net_db.c | 4 +-
libguile/numbers.c | 2 +-
libguile/pairs.c | 6 +-
libguile/ports.c | 30 +++++++++----
libguile/posix.c | 34 +++++++-------
libguile/print.c | 8 ++--
libguile/promises.c | 4 +-
libguile/r6rs-ports.c | 4 +-
libguile/read.c | 8 ++--
libguile/snarf.h | 19 +++++---
libguile/socket.c | 10 ++--
libguile/srcprop.c | 10 ++--
libguile/stacks.c | 2 +-
libguile/tags.h | 57 ++++++++++++++----------
libguile/threads.c | 9 +++-
libguile/variable.c | 6 +-
libguile/vectors.c | 12 +++--
libguile/vm-engine.c | 12 +++---
libguile/vm-engine.h | 4 +-
libguile/vm-i-scheme.c | 30 ++++++------
libguile/vm-i-system.c | 26 ++++-------
libguile/vm.c | 4 +-
libguile/weaks.c | 30 +++++--------
libguile/weaks.h | 4 +-
53 files changed, 403 insertions(+), 341 deletions(-)
diff --git a/libguile/__scm.h b/libguile/__scm.h
index f5551ad..7458a10 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -283,7 +283,7 @@
* errors, and then do 'make clean; make'.
*/
#ifndef SCM_DEBUG_TYPING_STRICTNESS
-#define SCM_DEBUG_TYPING_STRICTNESS 1
+#define SCM_DEBUG_TYPING_STRICTNESS 2
#endif
/* If SCM_DEBUG_DEBUGGING_SUPPORT is set to 1, guile will provide a set of
diff --git a/libguile/async.c b/libguile/async.c
index 0a08d0c..ad14101 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 452b8ad..3bf672d 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 4ca3c4e..b9403ea 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 7d56c2a..cf8b6ac 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 dc3fed2..9121d17 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 e059a31..88a01d6 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 0c55316..3e2d88a 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 ddc97a8..d17be08 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 192667d..be5fffc 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 f4d19bd..14dd861 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 b178bc4..6e952c4 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 009f379..e008b3a 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 b5d90ed..02e6e17 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 3e71700..f42c0a4 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 62ba23f..2e83cde 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 3d8a4b2..47244c7 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 bb53dda..b65b654 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 2747490..899ba73 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 a341fbf..81313df 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 8448c7c..a79f03d 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 37d168c..d707993 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 6ee159b..b22b332 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 51a4db0..835edcc 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 7041515..221ee79 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 b0137a1..fa19a2a 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 aa6b9cd..556e60f 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 49d2948..0b1aa51 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 e060821..ca8875d 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 14722d5..61dd2f3 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 7e05119..057a69c 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 68fa4c9..5dbbab5 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 858c3dd..a4d3bd8 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 15b38e7..2923dc6 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 453c8a9..4afd12c 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 45a76a9..4aff150 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 015e0b5..308f17a 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 3e73958..098854b 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 7d22a36..b0800c4 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 2e59a15..d085d33 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 f9b000c..4eb1cca 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 31bd91b..86188f4 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 9169842..c90838e 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 f49696b..def9281 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 76fbf18..a9cc60e 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 2ab5b78..2805278 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 e449b43..22bd39c 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 146931e..48ab09a 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 60e4452..2d85012 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 0ff411f..1b4136f 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 e9d9619..8d1c375 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 1d5fcf4..92d351e 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 5cb8bc3..fc16f8b 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) \
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-21-g931b4a6,
Andy Wingo <=