mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

merge strictness branch from 2.0

Browse source
This commit is contained in:
Andy Wingo 2011-05-13 15:45:43 +02:00
commit 86fb1eb631
52 changed files with 402 additions and 340 deletions
Download patch file Download diff file Expand all files Collapse all files

94
libguile/async.c
View file

@ -325,16 +325,37 @@ SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
static void static void
increase_block (void *data) increase_block (void *data)
{ {
((scm_i_thread *)data)->block_asyncs++; scm_i_thread *t = data;
t->block_asyncs++;
} }
static void static void
decrease_block (void *data) 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 (); 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_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
(SCM proc), (SCM proc),
"Call @var{proc} with no arguments and block the execution\n" "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") "it is running. Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_blocked_asyncs #define FUNC_NAME s_scm_call_with_blocked_asyncs
{ {
return scm_internal_dynamic_wind (increase_block, SCM ans;
(scm_t_inner) scm_call_0,
decrease_block, scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
(void *)proc, scm_dynwind_block_asyncs ();
SCM_I_CURRENT_THREAD); ans = scm_call_0 (proc);
scm_dynwind_end ();
return ans;
} }
#undef FUNC_NAME #undef FUNC_NAME
void * void *
scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data) scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
{ {
return (void *)scm_internal_dynamic_wind (increase_block, void* ans;
(scm_t_inner) proc,
decrease_block, scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
data, scm_dynwind_block_asyncs ();
SCM_I_CURRENT_THREAD); 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") "it is running. Return the value returned by @var{proc}.\n")
#define FUNC_NAME s_scm_call_with_unblocked_asyncs #define FUNC_NAME s_scm_call_with_unblocked_asyncs
{ {
SCM ans;
if (SCM_I_CURRENT_THREAD->block_asyncs == 0) if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL); SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
return scm_internal_dynamic_wind (decrease_block,
(scm_t_inner) scm_call_0, scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
increase_block, scm_dynwind_unblock_asyncs ();
(void *)proc, ans = scm_call_0 (proc);
SCM_I_CURRENT_THREAD); scm_dynwind_end ();
return ans;
} }
#undef FUNC_NAME #undef FUNC_NAME
void * void *
scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
{ {
void* ans;
if (SCM_I_CURRENT_THREAD->block_asyncs == 0) if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
scm_misc_error ("scm_c_call_with_unblocked_asyncs", scm_misc_error ("scm_c_call_with_unblocked_asyncs",
"asyncs already unblocked", SCM_EOL); "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_begin (SCM_F_DYNWIND_REWINDABLE);
scm_dynwind_block_asyncs () scm_dynwind_unblock_asyncs ();
{ ans = proc (data);
scm_i_thread *t = SCM_I_CURRENT_THREAD; scm_dynwind_end ();
scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
}
void return ans;
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);
} }

26
libguile/boolean.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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 * See the comments preceeding the definitions of SCM_BOOL_F and
* SCM_MATCHES_BITS_IN_COMMON in tags.h for more information. * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
*/ */
verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \ verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
(SCM_BOOL_F, SCM_BOOL_T)); (SCM_BOOL_F_BITS, SCM_BOOL_T_BITS));
verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \ verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
(SCM_ELISP_NIL, SCM_BOOL_F)); (SCM_ELISP_NIL_BITS, SCM_BOOL_F_BITS));
verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \ verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
(SCM_ELISP_NIL, SCM_EOL)); (SCM_ELISP_NIL_BITS, SCM_EOL_BITS));
verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \ verify (SCM_BITS_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
(SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, \ (SCM_ELISP_NIL_BITS, SCM_BOOL_F_BITS, SCM_BOOL_T_BITS, \
SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0)); SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0));
verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \ verify (SCM_BITS_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
(SCM_ELISP_NIL, SCM_BOOL_F, SCM_EOL, \ (SCM_ELISP_NIL_BITS, SCM_BOOL_F_BITS, SCM_EOL_BITS, \
SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE)); SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE));
SCM_DEFINE (scm_not, "not", 1, 0, 0, SCM_DEFINE (scm_not, "not", 1, 0, 0,
(SCM x), (SCM x),

8
libguile/bytevectors.c
View file

@ -479,7 +479,7 @@ SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
signed char c_fill = '\0'; signed char c_fill = '\0';
SCM_VALIDATE_UINT_COPY (1, len, c_len); SCM_VALIDATE_UINT_COPY (1, len, c_len);
if (fill != SCM_UNDEFINED) if (!scm_is_eq (fill, SCM_UNDEFINED))
{ {
int value; 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); bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
if (fill != SCM_UNDEFINED) if (!scm_is_eq (fill, SCM_UNDEFINED))
{ {
unsigned i; unsigned i;
signed char *contents; 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; \ size_t c_strlen, c_utf_len = 0; \
\ \
SCM_VALIDATE_STRING (1, str); \ SCM_VALIDATE_STRING (1, str); \
if (endianness == SCM_UNDEFINED) \ if (scm_is_eq (endianness, SCM_UNDEFINED)) \
endianness = scm_sym_big; \ endianness = scm_sym_big; \
else \ else \
SCM_VALIDATE_SYMBOL (2, endianness); \ 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; \ size_t c_strlen = 0, c_utf_len = 0; \
\ \
SCM_VALIDATE_BYTEVECTOR (1, utf); \ SCM_VALIDATE_BYTEVECTOR (1, utf); \
if (endianness == SCM_UNDEFINED) \ if (scm_is_eq (endianness, SCM_UNDEFINED)) \
endianness = scm_sym_big; \ endianness = scm_sym_big; \
else \ else \
SCM_VALIDATE_SYMBOL (2, endianness); \ SCM_VALIDATE_SYMBOL (2, endianness); \

2
libguile/continuations.c
View file

@ -410,7 +410,7 @@ scm_i_check_continuation (SCM cont)
scm_i_thread *thread = SCM_I_CURRENT_THREAD; scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont); 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 scm_misc_error
("%continuation-call", ("%continuation-call",
"invoking continuation would cross continuation barrier: ~A", "invoking continuation would cross continuation barrier: ~A",

2
libguile/control.c
View file

@ -163,7 +163,7 @@ reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
/* Since non-escape continuations should begin with a thunk application, the /* 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 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. */ 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) != SCM_PROMPT_REGISTERS (prompt)->fp)
abort (); abort ();

4
libguile/debug.c
View file

@ -1,5 +1,5 @@
/* Debugging extensions for Guile /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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. 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_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 " "Show file names and line numbers "
"in backtraces when not `#f'. A value of `base' " "in backtraces when not `#f'. A value of `base' "
"displays only base names, while `#t' displays full names."}, "displays only base names, while `#t' displays full names."},

26
libguile/deprecated.c
View file

@ -27,9 +27,35 @@
#define SCM_BUILDING_DEPRECATED_CODE #define SCM_BUILDING_DEPRECATED_CODE
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/deprecation.h"
#if (SCM_ENABLE_DEPRECATED == 1) #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 void
scm_i_init_deprecated () scm_i_init_deprecated ()
{ {

11
libguile/deprecated.h
View file

@ -31,6 +31,17 @@
#if (SCM_ENABLE_DEPRECATED == 1) #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_LIST0 SCM_EOL
#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) #define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL) #define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL)

2
libguile/deprecation.c
View file

@ -128,7 +128,7 @@ SCM_DEFINE(scm_issue_deprecation_warning,
char *c_msgs; char *c_msgs;
while (scm_is_pair (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 (nl, msgs_nl);
msgs_nl = scm_cons (SCM_CAR (msgs), msgs_nl); msgs_nl = scm_cons (SCM_CAR (msgs), msgs_nl);
msgs = SCM_CDR (msgs); msgs = SCM_CDR (msgs);

19
libguile/dynwind.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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 #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. */ /* Frames and winders. */
static scm_t_bits tc16_frame; static scm_t_bits tc16_frame;

8
libguile/dynwind.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_DYNWIND_H #ifndef SCM_DYNWIND_H
#define 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -28,14 +28,8 @@
typedef void (*scm_t_guard) (void *); 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_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_API void scm_dowinds (SCM to, long delta);
SCM_INTERNAL void scm_i_dowinds (SCM to, long delta, SCM_INTERNAL void scm_i_dowinds (SCM to, long delta,
void (*turn_func) (void *), void *data); void (*turn_func) (void *), void *data);

7
libguile/eval.c
View file

@ -102,7 +102,8 @@
*/ */
static scm_t_bits scm_tc16_boot_closure; 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_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x) #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (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. case, because further lexical contours should capture the current module.
*/ */
#define CAPTURE_ENV(env) \ #define CAPTURE_ENV(env) \
((env == SCM_EOL) ? scm_current_module () : \ (scm_is_null (env) ? scm_current_module () : \
((env == SCM_BOOL_F) ? scm_the_root_module () : env)) (scm_is_false (env) ? scm_the_root_module () : env))
static SCM static SCM
eval (SCM x, SCM env) eval (SCM x, SCM env)

7
libguile/expand.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_EXPAND_H #ifndef SCM_EXPAND_H
#define SCM_EXPAND_H #define SCM_EXPAND_H
/* Copyright (C) 2010 /* Copyright (C) 2010, 2011
* Free Software Foundation, Inc. * Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
@ -73,8 +73,9 @@ enum
SCM_EXPANDED_TYPE_FIELDS, SCM_EXPANDED_TYPE_FIELDS,
}; };
#define SCM_EXPANDED_P(x) \ #define SCM_EXPANDED_P(x) \
(SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE (SCM_STRUCT_VTABLE (x)) == scm_exp_vtable_vtable)) (SCM_STRUCTP (x) \
&& (scm_is_eq (SCM_STRUCT_VTABLE (SCM_STRUCT_VTABLE (x)), scm_exp_vtable_vtable)))
#define SCM_EXPANDED_REF(x,type,field) \ #define SCM_EXPANDED_REF(x,type,field) \
(scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field))) (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
#define SCM_EXPANDED_TYPE(x) \ #define SCM_EXPANDED_TYPE(x) \

4
libguile/fluids.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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--) while (j--)
for (i = 0; i < j; i++) 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 */ vals[i] = vals[j]; /* later bindings win */
n--; n--;

6
libguile/frames.c
View file

@ -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)); p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
while (p <= sp) while (p <= sp)
{ {
if (p[0] == (SCM)0) if (SCM_UNPACK (p[0]) == 0)
/* skip over not-yet-active frame */ /* skip over not-yet-active frame */
p += 3; p += 3;
else 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)); p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
while (p <= sp) while (p <= sp)
{ {
if (p[0] == (SCM)0) if (SCM_UNPACK (p[0]) == 0)
/* skip over not-yet-active frame */ /* skip over not-yet-active frame */
p += 3; p += 3;
else if (n == i) 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)); p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
while (p <= sp) while (p <= sp)
{ {
if (p[0] == (SCM)0) if (SCM_UNPACK (p[0]) == 0)
/* skip over not-yet-active frame */ /* skip over not-yet-active frame */
p += 3; p += 3;
else if (n == i) else if (n == i)

8
libguile/frames.h
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -70,15 +70,15 @@
#define SCM_FRAME_RETURN_ADDRESS(fp) \ #define SCM_FRAME_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2])) (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \ #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) \ #define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1])) (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
#define SCM_FRAME_SET_MV_RETURN_ADDRESS(fp, mvra) \ #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) \ #define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0])) (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \ #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_VARIABLE(fp,i) SCM_FRAME_STACK_ADDRESS (fp)[i]
#define SCM_FRAME_PROGRAM(fp) SCM_FRAME_STACK_ADDRESS (fp)[-1] #define SCM_FRAME_PROGRAM(fp) SCM_FRAME_STACK_ADDRESS (fp)[-1]

4
libguile/generalized-vectors.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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; int i;
for (i = 0; i < num_vector_ctors_registered; 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); return vector_ctors[i].ctor(len, fill);
scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type"); scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type");
} }

70
libguile/goops.c
View file

@ -124,7 +124,7 @@ SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
#define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2]) #define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
#define SCM_GOOPS_UNBOUND SCM_UNBOUND #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 int goops_loaded_p = 0;
static scm_t_rstate *goops_rstate; static scm_t_rstate *goops_rstate;
@ -293,7 +293,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return scm_class_fraction; return scm_class_fraction;
} }
case scm_tc7_program: 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; return scm_class_primitive_generic;
else else
return scm_class_procedure; return scm_class_procedure;
@ -494,8 +495,8 @@ compute_getters_n_setters (SCM slots)
SCM options = SCM_CDAR (slots); SCM options = SCM_CDAR (slots);
if (!scm_is_null (options)) if (!scm_is_null (options))
{ {
init = scm_get_keyword (k_init_value, options, 0); init = scm_get_keyword (k_init_value, options, SCM_PACK (0));
if (init) if (SCM_UNPACK (init))
{ {
init = scm_primitive_eval (scm_list_3 (scm_sym_lambda, init = scm_primitive_eval (scm_list_3 (scm_sym_lambda,
SCM_EOL, 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)) get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
{ {
SCM slot_name = SCM_CAR (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))) 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, tmp = scm_i_get_keyword (k_init_keyword,
SCM_CDR (slot_name), SCM_CDR (slot_name),
n, n,
0, SCM_PACK (0),
FUNC_NAME); FUNC_NAME);
slot_name = SCM_CAR (slot_name); slot_name = SCM_CAR (slot_name);
if (tmp) if (SCM_UNPACK (tmp))
{ {
/* an initarg was provided for this slot */ /* an initarg was provided for this slot */
if (!scm_is_keyword (tmp)) 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, slot_value = scm_i_get_keyword (tmp,
initargs, initargs,
n_initargs, n_initargs,
0, SCM_PACK (0),
FUNC_NAME); FUNC_NAME);
} }
} }
if (slot_value) if (SCM_UNPACK (slot_value))
/* set slot to provided value */ /* set slot to provided value */
set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value); set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
else 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); register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
for (; !scm_is_null (slots); slots = SCM_CDR (slots)) 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_CAR (slots);
return SCM_BOOL_F; return SCM_BOOL_F;
} }
@ -1599,7 +1600,7 @@ burnin (SCM o)
static void static void
go_to_hell (void *o) go_to_hell (void *o)
{ {
SCM obj = SCM_PACK ((scm_t_bits) o); SCM obj = *(SCM*)o;
scm_lock_mutex (hell_mutex); scm_lock_mutex (hell_mutex);
if (n_hell >= hell_size) if (n_hell >= hell_size)
{ {
@ -1613,8 +1614,9 @@ go_to_hell (void *o)
static void static void
go_to_heaven (void *o) go_to_heaven (void *o)
{ {
SCM obj = *(SCM*)o;
scm_lock_mutex (hell_mutex); 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); scm_unlock_mutex (hell_mutex);
} }
@ -1622,10 +1624,9 @@ go_to_heaven (void *o)
SCM_SYMBOL (scm_sym_change_class, "change-class"); SCM_SYMBOL (scm_sym_change_class, "change-class");
static SCM static SCM
purgatory (void *args) purgatory (SCM obj, SCM new_class)
{ {
return scm_apply_0 (SCM_VARIABLE_REF (var_change_class), return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
SCM_PACK ((scm_t_bits) args));
} }
/* This function calls the generic function change-class for all /* 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) scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
{ {
if (!burnin (obj)) if (!burnin (obj))
scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven, {
(void *) SCM_UNPACK (scm_list_2 (obj, new_class)), scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
(void *) SCM_UNPACK (obj)); 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) make_dispatch_procedure (SCM gf)
{ {
static SCM var = SCM_BOOL_F; 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"), var = scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
sym_delayed_compile); sym_delayed_compile);
return scm_call_1 (SCM_VARIABLE_REF (var), gf); 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_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)); scm_enable_primitive_generic_x (scm_list_1 (subr));
return *SCM_SUBR_GENERIC (subr); return *SCM_SUBR_GENERIC (subr);
} }
@ -1798,7 +1803,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension)
if (goops_loaded_p) if (goops_loaded_p)
{ {
SCM gf, gext; SCM gf, gext;
if (!*SCM_SUBR_GENERIC (extended)) if (!SCM_UNPACK (*SCM_SUBR_GENERIC (extended)))
scm_enable_primitive_generic_x (scm_list_1 (extended)); scm_enable_primitive_generic_x (scm_list_1 (extended));
gf = *SCM_SUBR_GENERIC (extended); gf = *SCM_SUBR_GENERIC (extended);
gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), 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 in the extensions list. O(N^2) algorithm, but
* extensions of primitive generics are rare. * extensions of primitive generics are rare.
*/ */
while (*loc && extension != (*loc)->extended) while (*loc && !scm_is_eq (extension, (*loc)->extended))
loc = &(*loc)->next; loc = &(*loc)->next;
e->next = *loc; e->next = *loc;
e->extended = extended; 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)) { 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(s1)) return 1;
if (scm_is_null(s2)) return 0; 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); register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) { 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; return 1;
if (cs2 == SCM_CAR(l)) if (scm_is_eq (cs2, SCM_CAR (l)))
return 0; return 0;
} }
return 0;/* should not occur! */ return 0;/* should not occur! */
@ -2106,7 +2111,8 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
class = SCM_CAR(args); class = SCM_CAR(args);
args = SCM_CDR(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, z = scm_make_struct (class, SCM_INUM0,
scm_list_4 (SCM_BOOL_F, scm_list_4 (SCM_BOOL_F,
@ -2118,7 +2124,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
args, args,
SCM_BOOL_F)); SCM_BOOL_F));
clear_method_cache (z); 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); SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
if (scm_is_true (setter)) if (scm_is_true (setter))
@ -2129,8 +2135,8 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
{ {
z = scm_sys_allocate_instance (class, args); z = scm_sys_allocate_instance (class, args);
if (class == scm_class_method if (scm_is_eq (class, scm_class_method)
|| class == scm_class_accessor_method) || scm_is_eq (class, scm_class_accessor_method))
{ {
SCM_SET_SLOT (z, scm_si_generic_function, SCM_SET_SLOT (z, scm_si_generic_function,
scm_i_get_keyword (k_gf, scm_i_get_keyword (k_gf,
@ -2513,7 +2519,7 @@ static SCM
make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
{ {
SCM class, name; 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 ("<"), name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
scm_symbol_to_string (type_name_sym), scm_symbol_to_string (type_name_sym),
@ -2595,12 +2601,12 @@ create_smob_classes (void)
long i; long i;
for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++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; scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
for (i = 0; i < scm_numsmob; ++i) 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_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
scm_smobs[i].apply != 0); scm_smobs[i].apply != 0);
} }

10
libguile/guardians.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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 /* Tell each guardian interested in OBJ that OBJ is no longer
reachable. */ reachable. */
for (; for (;
guardian_list != SCM_EOL; !scm_is_null (guardian_list);
guardian_list = SCM_CDR (guardian_list)) guardian_list = SCM_CDR (guardian_list))
{ {
SCM zombies; SCM zombies;
@ -151,7 +151,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
cell_pool = SCM_CDR (cell_pool); cell_pool = SCM_CDR (cell_pool);
/* Compute and update G's zombie list. */ /* Compute and update G's zombie list. */
SCM_SETCAR (zombies, SCM_PACK (obj)); SCM_SETCAR (zombies, obj);
SCM_SETCDR (zombies, g->zombies); SCM_SETCDR (zombies, g->zombies);
g->zombies = zombies; g->zombies = zombies;
@ -159,7 +159,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
g->zombies = zombies; 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 /* Re-register the finalizer that was in place before we installed this
one. */ one. */
@ -257,7 +257,7 @@ scm_i_get_one_zombie (SCM guardian)
t_guardian *g = GUARDIAN_DATA (guardian); t_guardian *g = GUARDIAN_DATA (guardian);
SCM res = SCM_BOOL_F; SCM res = SCM_BOOL_F;
if (g->zombies != SCM_EOL) if (!scm_is_null (g->zombies))
{ {
/* Note: We return zombies in reverse order. */ /* Note: We return zombies in reverse order. */
res = SCM_CAR (g->zombies); res = SCM_CAR (g->zombies);

10
libguile/hash.c
View file

@ -160,18 +160,16 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
if (SCM_CHARP(obj)) if (SCM_CHARP(obj))
return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n; return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
switch (SCM_UNPACK (obj)) { switch (SCM_UNPACK (obj)) {
#ifndef SICP case SCM_EOL_BITS:
case SCM_UNPACK(SCM_EOL):
d = 256; d = 256;
break; break;
#endif case SCM_BOOL_T_BITS:
case SCM_UNPACK(SCM_BOOL_T):
d = 257; d = 257;
break; break;
case SCM_UNPACK(SCM_BOOL_F): case SCM_BOOL_F_BITS:
d = 258; d = 258;
break; break;
case SCM_UNPACK(SCM_EOF_VAL): case SCM_EOF_VAL_BITS:
d = 259; d = 259;
break; break;
default: default:

16
libguile/hashtab.c
View file

@ -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 /* Remove from ALIST weak pair PAIR whose car/cdr has been
nullified by the GC. */ nullified by the GC. */
if (prev == SCM_EOL) if (scm_is_null (prev))
result = SCM_CDR (alist); result = SCM_CDR (alist);
else else
SCM_SETCDR (prev, SCM_CDR (alist)); 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); SCM_SIMPLE_VECTOR_SET (buckets, bucket_index, bucket);
result = assoc (object, bucket, closure); 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); 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)) 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); SCM_SETCDR (d->pair, d->new_val);
} }
else else
{ {
SCM_SETCDR (d->pair, d->new_val); SCM_SETCDR (d->pair, d->new_val);
SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (d->pair), SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) SCM_CDRLOC (d->pair),
SCM2PTR (d->new_val)); (GC_PTR) SCM2PTR (d->new_val));
} }
return NULL; 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 /* We hit a weak pair whose car/cdr has become
unreachable: unlink it from the bucket. */ unreachable: unlink it from the bucket. */
if (prev != SCM_BOOL_F) if (scm_is_true (prev))
SCM_SETCDR (prev, SCM_CDR (ls)); SCM_SETCDR (prev, SCM_CDR (ls));
else else
SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls)); SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls));

10
libguile/i18n.c
View file

@ -234,7 +234,7 @@ SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale");
#define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \ #define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \
do \ do \
{ \ { \
if ((_arg) != SCM_UNDEFINED) \ if (!scm_is_eq ((_arg), SCM_UNDEFINED)) \
SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \ SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \
else \ else \
(_c_locale) = NULL; \ (_c_locale) = NULL; \
@ -1143,7 +1143,7 @@ chr_to_case (SCM chr, scm_t_locale c_locale,
if (SCM_UNLIKELY (ret != 0)) if (SCM_UNLIKELY (ret != 0))
{ {
*err = ret; *err = ret;
return NULL; return SCM_BOOL_F;
} }
if (convlen == 1) if (convlen == 1)
@ -1262,7 +1262,7 @@ str_to_case (SCM str, scm_t_locale c_locale,
if (SCM_UNLIKELY (ret != 0)) if (SCM_UNLIKELY (ret != 0))
{ {
*err = ret; *err = ret;
return NULL; return SCM_BOOL_F;
} }
convstr = scm_i_make_wide_string (convlen, &c_buf, 0); 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); SCM_VALIDATE_STRING (1, str);
c_str = scm_i_string_chars (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); SCM_VALIDATE_INT_COPY (2, base, c_base);
else else
c_base = 10; c_base = 10;
@ -1591,7 +1591,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
if (*p == 0) if (*p == 0)
{ {
/* Cyclic grouping information. */ /* Cyclic grouping information. */
if (last_pair != SCM_EOL) if (!scm_is_null (last_pair))
SCM_SETCDR (last_pair, result); SCM_SETCDR (last_pair, result);
} }
} }

14
libguile/inline.h
View file

@ -123,7 +123,7 @@ SCM_C_EXTERN_INLINE
SCM SCM
scm_cell (scm_t_bits car, scm_t_bits cdr) 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 /* 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 until it is completely initialized. This is only relevant when the GC
@ -141,7 +141,7 @@ SCM_C_EXTERN_INLINE
SCM SCM
scm_immutable_cell (scm_t_bits car, scm_t_bits cdr) 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 /* 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 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, 1, cdr);
SCM_GC_SET_CELL_WORD (cell, 0, car); SCM_GC_SET_CELL_WORD (cell, 0, car);
GC_END_STUBBORN_CHANGE ((void *) cell); GC_END_STUBBORN_CHANGE (SCM2PTR (cell));
return cell; return cell;
} }
@ -164,7 +164,7 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr,
{ {
SCM z; 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 /* Initialize the type slot last so that the cell is ignored by the
GC until it is completely initialized. This is only relevant GC until it is completely initialized. This is only relevant
when the GC can actually run during this code, which it can't 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; 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 /* Initialize the type slot last so that the cell is ignored by the
GC until it is completely initialized. This is only relevant GC until it is completely initialized. This is only relevant
when the GC can actually run during this code, which it can't 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, 3, cdr);
SCM_GC_SET_CELL_WORD (z, 0, car); 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 /* When this function is inlined, it's possible that the last
SCM_GC_SET_CELL_WORD above will be adjacent to a following 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; 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); SCM_GC_SET_CELL_WORD (z, 0, car);
/* FIXME: is the following concern even relevant with BDW-GC? */ /* FIXME: is the following concern even relevant with BDW-GC? */

8
libguile/list.c
View file

@ -35,10 +35,10 @@
/* creating lists */ /* creating lists */
#define SCM_I_CONS(cell, x, y) \ #define SCM_I_CONS(cell, x, y) \
do { \ do { \
cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y); \ cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); \
} while (0) } while (0)
SCM SCM
scm_list_1 (SCM e1) scm_list_1 (SCM e1)

2
libguile/load.c
View file

@ -116,7 +116,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
/* Lookup and use the current reader to read the next /* Lookup and use the current reader to read the next
expression. */ expression. */
reader = scm_fluid_ref (the_reader); reader = scm_fluid_ref (the_reader);
if (reader == SCM_BOOL_F) if (scm_is_false (reader))
form = scm_read (port); form = scm_read (port);
else else
form = scm_call_1 (reader, port); form = scm_call_1 (reader, port);

14
libguile/macros.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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 z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn); 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_OBJECT_N (z, 2, scm_from_locale_symbol (name));
SCM_SET_SMOB_DATA_N (z, 3, SCM_BOOL_F); SCM_SET_SMOB_OBJECT_N (z, 3, SCM_BOOL_F);
SCM_SET_SMOB_DATA_N (z, 4, SCM_BOOL_F); SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F);
return z; 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); z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, prim); SCM_SET_SMOB_DATA_N (z, 1, prim);
SCM_SET_SMOB_DATA_N (z, 2, name); SCM_SET_SMOB_OBJECT_N (z, 2, name);
SCM_SET_SMOB_DATA_N (z, 3, type); SCM_SET_SMOB_OBJECT_N (z, 3, type);
SCM_SET_SMOB_DATA_N (z, 4, binding); SCM_SET_SMOB_OBJECT_N (z, 4, binding);
return z; return z;
} }
#undef FUNC_NAME #undef FUNC_NAME

7
libguile/memoize.c
View file

@ -64,7 +64,8 @@ SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
scm_t_bits scm_tc16_memoized; 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) \ #define MAKMEMO_BEGIN(exps) \
MAKMEMO (SCM_M_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) \ #define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
(scm_cell (scm_tc16_memoizer, \ (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) \ #define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_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) \ #define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N) \
(scm_cell (scm_tc16_memoizer, \ (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) \ #define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N) \
SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N))) SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))

8
libguile/modules.c
View file

@ -304,8 +304,8 @@ resolve_duplicate_binding (SCM module, SCM sym,
val1 = SCM_VARIABLE_REF (var1); val1 = SCM_VARIABLE_REF (var1);
val2 = SCM_VARIABLE_REF (var2); val2 = SCM_VARIABLE_REF (var2);
val1 = (val1 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val1; val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
val2 = (val2 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val2; val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
handlers = SCM_MODULE_DUPLICATE_HANDLERS (module); handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
if (scm_is_false (handlers)) 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); 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. /* FIXME: We hit a weak pair whose car has become unreachable.
We should remove the pair in question or something. */ We should remove the pair in question or something. */
} }
else else
{ {
if (SCM_CDR (handle) == variable) if (scm_is_eq (SCM_CDR (handle), variable))
return SCM_CAR (handle); return SCM_CAR (handle);
} }

4
libguile/net_db.c
View file

@ -457,7 +457,7 @@ SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
SCM_SYMBOL (sym_getaddrinfo_error, "getaddrinfo-error"); SCM_SYMBOL (sym_getaddrinfo_error, "getaddrinfo-error");
/* Make sure the `AI_*' flags can be stored as INUMs. */ /* 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'. */ /* Valid values for the `ai_flags' to `struct addrinfo'. */
SCM_VARIABLE_INIT (sym_ai_passive, "AI_PASSIVE", SCM_VARIABLE_INIT (sym_ai_passive, "AI_PASSIVE",
@ -677,7 +677,7 @@ SCM_DEFINE (scm_getaddrinfo, "getaddrinfo", 1, 5, 0,
#undef FUNC_NAME #undef FUNC_NAME
/* Make sure the `EAI_*' flags can be stored as INUMs. */ /* 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'. */ /* Error codes returned by `getaddrinfo'. */
SCM_VARIABLE_INIT (sym_eai_badflags, "EAI_BADFLAGS", SCM_VARIABLE_INIT (sym_eai_badflags, "EAI_BADFLAGS",

2
libguile/numbers.c
View file

@ -4112,7 +4112,7 @@ SCM scm_logand (SCM n1, SCM n2)
else if SCM_BIGP (n2) else if SCM_BIGP (n2)
{ {
intbig: intbig:
if (n1 == 0) if (nn1 == 0)
return SCM_INUM0; return SCM_INUM0;
{ {
SCM result_z = scm_i_mkbig (); SCM result_z = scm_i_mkbig ();

6
libguile/pairs.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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 * See the comments preceeding the definitions of SCM_BOOL_F and
* SCM_MATCHES_BITS_IN_COMMON in tags.h for more information. * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
*/ */
verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \ verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
(SCM_ELISP_NIL, SCM_EOL)); (SCM_ELISP_NIL_BITS, SCM_EOL_BITS));
#if (SCM_DEBUG_PAIR_ACCESSES == 1) #if (SCM_DEBUG_PAIR_ACCESSES == 1)

30
libguile/ports.c
View file

@ -365,10 +365,10 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
/* Standard ports --- current input, output, error, and more(!). */ /* Standard ports --- current input, output, error, and more(!). */
static SCM cur_inport_fluid = 0; static SCM cur_inport_fluid = SCM_BOOL_F;
static SCM cur_outport_fluid = 0; static SCM cur_outport_fluid = SCM_BOOL_F;
static SCM cur_errport_fluid = 0; static SCM cur_errport_fluid = SCM_BOOL_F;
static SCM cur_loadport_fluid = 0; static SCM cur_loadport_fluid = SCM_BOOL_F;
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0, 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.") "returns the @dfn{standard input} in Unix and C terminology.")
#define FUNC_NAME s_scm_current_input_port #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); return scm_fluid_ref (cur_inport_fluid);
else else
return SCM_BOOL_F; return SCM_BOOL_F;
@ -392,7 +392,7 @@ SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
"Unix and C terminology.") "Unix and C terminology.")
#define FUNC_NAME s_scm_current_output_port #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); return scm_fluid_ref (cur_outport_fluid);
else else
return SCM_BOOL_F; 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).") "@dfn{standard error} in Unix and C terminology).")
#define FUNC_NAME s_scm_current_error_port #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); return scm_fluid_ref (cur_errport_fluid);
else else
return SCM_BOOL_F; 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.") "have no effect as far as @var{port-for-each} is concerned.")
#define FUNC_NAME s_scm_port_for_each #define FUNC_NAME s_scm_port_for_each
{ {
SCM ports;
SCM_VALIDATE_PROC (1, proc); 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; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -2294,7 +2306,7 @@ scm_i_set_conversion_strategy_x (SCM port,
if (scm_is_false (port)) if (scm_is_false (port))
{ {
/* Set the default encoding for future ports. */ /* 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_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized", scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
SCM_EOL); SCM_EOL);

34
libguile/posix.c
View file

@ -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"); SCM_ASSERT_TYPE (scm_is_symbol (s), s, pos, func, "symbol");
#ifdef RLIMIT_AS #ifdef RLIMIT_AS
if (s == sym_as) if (scm_is_eq (s, sym_as))
return RLIMIT_AS; return RLIMIT_AS;
#endif #endif
#ifdef RLIMIT_CORE #ifdef RLIMIT_CORE
if (s == sym_core) if (scm_is_eq (s, sym_core))
return RLIMIT_CORE; return RLIMIT_CORE;
#endif #endif
#ifdef RLIMIT_CPU #ifdef RLIMIT_CPU
if (s == sym_cpu) if (scm_is_eq (s, sym_cpu))
return RLIMIT_CPU; return RLIMIT_CPU;
#endif #endif
#ifdef RLIMIT_DATA #ifdef RLIMIT_DATA
if (s == sym_data) if (scm_is_eq (s, sym_data))
return RLIMIT_DATA; return RLIMIT_DATA;
#endif #endif
#ifdef RLIMIT_FSIZE #ifdef RLIMIT_FSIZE
if (s == sym_fsize) if (scm_is_eq (s, sym_fsize))
return RLIMIT_FSIZE; return RLIMIT_FSIZE;
#endif #endif
#ifdef RLIMIT_MEMLOCK #ifdef RLIMIT_MEMLOCK
if (s == sym_memlock) if (scm_is_eq (s, sym_memlock))
return RLIMIT_MEMLOCK; return RLIMIT_MEMLOCK;
#endif #endif
#ifdef RLIMIT_MSGQUEUE #ifdef RLIMIT_MSGQUEUE
if (s == sym_msgqueue) if (scm_is_eq (s, sym_msgqueue))
return RLIMIT_MSGQUEUE; return RLIMIT_MSGQUEUE;
#endif #endif
#ifdef RLIMIT_NICE #ifdef RLIMIT_NICE
if (s == sym_nice) if (scm_is_eq (s, sym_nice))
return RLIMIT_NICE; return RLIMIT_NICE;
#endif #endif
#ifdef RLIMIT_NOFILE #ifdef RLIMIT_NOFILE
if (s == sym_nofile) if (scm_is_eq (s, sym_nofile))
return RLIMIT_NOFILE; return RLIMIT_NOFILE;
#endif #endif
#ifdef RLIMIT_NPROC #ifdef RLIMIT_NPROC
if (s == sym_nproc) if (scm_is_eq (s, sym_nproc))
return RLIMIT_NPROC; return RLIMIT_NPROC;
#endif #endif
#ifdef RLIMIT_RSS #ifdef RLIMIT_RSS
if (s == sym_rss) if (scm_is_eq (s, sym_rss))
return RLIMIT_RSS; return RLIMIT_RSS;
#endif #endif
#ifdef RLIMIT_RTPRIO #ifdef RLIMIT_RTPRIO
if (s == sym_rtprio) if (scm_is_eq (s, sym_rtprio))
return RLIMIT_RTPRIO; return RLIMIT_RTPRIO;
#endif #endif
#ifdef RLIMIT_RTPRIO #ifdef RLIMIT_RTPRIO
if (s == sym_rttime) if (scm_is_eq (s, sym_rttime))
return RLIMIT_RTPRIO; return RLIMIT_RTPRIO;
#endif #endif
#ifdef RLIMIT_SIGPENDING #ifdef RLIMIT_SIGPENDING
if (s == sym_sigpending) if (scm_is_eq (s, sym_sigpending))
return RLIMIT_SIGPENDING; return RLIMIT_SIGPENDING;
#endif #endif
#ifdef RLIMIT_STACK #ifdef RLIMIT_STACK
if (s == sym_stack) if (scm_is_eq (s, sym_stack))
return RLIMIT_STACK; return RLIMIT_STACK;
#endif #endif
@ -615,8 +615,8 @@ SCM_DEFINE (scm_setrlimit, "setrlimit", 3, 0, 0,
iresource = scm_to_resource (resource, FUNC_NAME, 1); iresource = scm_to_resource (resource, FUNC_NAME, 1);
lim.rlim_cur = (soft == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (soft); lim.rlim_cur = scm_is_false (soft) ? RLIM_INFINITY : scm_to_long (soft);
lim.rlim_max = (hard == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (hard); lim.rlim_max = scm_is_false (hard) ? RLIM_INFINITY : scm_to_long (hard);
if (setrlimit (iresource, &lim) != 0) if (setrlimit (iresource, &lim) != 0)
scm_syserror (FUNC_NAME); scm_syserror (FUNC_NAME);

8
libguile/print.c
View file

@ -100,11 +100,11 @@ static const char *iflagnames[] =
SCM_SYMBOL (sym_reader, "reader"); SCM_SYMBOL (sym_reader, "reader");
scm_t_option scm_print_opts[] = { 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." }, "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." }, "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. " "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; " "The value '#f' does not quote the colons; '#t' quotes them; "
"'reader' quotes them when the reader option 'keywords' is not '#f'." "'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) if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
{ {
SCM pwps, print = pstate->writingp ? g_write : g_display; SCM pwps, print = pstate->writingp ? g_write : g_display;
if (!print) if (SCM_UNPACK (print) == 0)
goto print_struct; goto print_struct;
pwps = scm_i_port_with_print_state (port, pstate->handle); pwps = scm_i_port_with_print_state (port, pstate->handle);
pstate->revealed = 1; pstate->revealed = 1;

4
libguile/promises.c
View file

@ -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. * Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * 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_VALIDATE_THUNK (1, thunk);
SCM_RETURN_NEWSMOB2 (scm_tc16_promise, SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
SCM_UNPACK (thunk), SCM_UNPACK (thunk),
scm_make_recursive_mutex ()); SCM_UNPACK (scm_make_recursive_mutex ()));
} }
#undef FUNC_NAME #undef FUNC_NAME

4
libguile/r6rs-ports.c
View file

@ -726,11 +726,11 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
c_len = SCM_BYTEVECTOR_LENGTH (bv); c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (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); c_start = scm_to_uint (start);
if (count != SCM_UNDEFINED) if (!scm_is_eq (count, SCM_UNDEFINED))
{ {
c_count = scm_to_uint (count); c_count = scm_to_uint (count);
if (SCM_UNLIKELY (c_start + c_count > c_len)) if (SCM_UNLIKELY (c_start + c_count > c_len))

8
libguile/read.c
View file

@ -70,7 +70,7 @@ scm_t_option scm_read_opts[] = {
"Record positions of source code expressions." }, "Record positions of source code expressions." },
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0, { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
"Convert symbols to lower case."}, "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."}, "Style of keyword recognition: #f, 'prefix or 'postfix."},
{ SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0, { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
"Use R6RS variable-length character and string hex escapes."}, "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)) { if (!scm_is_pair(obj)) {
return obj; return obj;
} else { } else {
SCM tmp = obj, copy; SCM tmp, copy;
/* If this sexpr is visible in the read:sharp source, we want to /* If this sexpr is visible in the read:sharp source, we want to
keep that information, so only record non-constant cons cells keep that information, so only record non-constant cons cells
which haven't previously been read by the reader. */ 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), copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
SCM_UNDEFINED); 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), SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
line, line,
@ -1562,7 +1562,7 @@ recsexpr (SCM obj, long line, int column, SCM filename)
else else
{ {
recsexpr (SCM_CAR (obj), line, column, filename); 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); recsexpr (SCM_CAR (tmp), line, column, filename);
copy = SCM_UNDEFINED; copy = SCM_UNDEFINED;
} }

19
libguile/snarf.h
View file

@ -30,7 +30,7 @@
#define SCM_FUNC_CAST_ARBITRARY_ARGS scm_t_subr #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. */ /* We support static allocation of some `SCM' objects. */
# define SCM_SUPPORT_STATIC_ALLOCATION # define SCM_SUPPORT_STATIC_ALLOCATION
#endif #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, \ (scm_t_bits) &scm_i_paste (c_name, \
_stringbuf), \ _stringbuf), \
(scm_t_bits) 0, \ (scm_t_bits) 0, \
(scm_t_bits) sizeof (contents) - 1) (scm_t_bits) (sizeof (contents) - 1))
#define SCM_IMMUTABLE_POINTER(c_name, ptr) \ #define SCM_IMMUTABLE_POINTER(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, 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) \ #define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
SCM_STATIC_DOUBLE_CELL (c_name, \ static SCM_ALIGNED (8) SCM_UNUSED SCM \
scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE, \ scm_i_paste (c_name, _raw_cell)[] = \
(scm_t_bits) objcode, \ { \
(scm_t_bits) objtable, \ SCM_PACK (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE), \
(scm_t_bits) freevars) objcode, \
objtable, \
freevars \
}; \
static SCM_UNUSED const SCM c_name = \
SCM_PACK (& scm_i_paste (c_name, _raw_cell))
#endif /* SCM_SUPPORT_STATIC_ALLOCATION */ #endif /* SCM_SUPPORT_STATIC_ALLOCATION */

10
libguile/socket.c
View file

@ -910,7 +910,7 @@ SCM_DEFINE (scm_connect, "connect", 2, 1, 1,
SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (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 /* No third argument was passed to FAM_OR_SOCKADDR must actually be a
`socket address' object. */ `socket address' object. */
soka = scm_to_sockaddr (fam_or_sockaddr, &size); 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); SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (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 /* No third argument was passed to FAM_OR_SOCKADDR must actually be a
`socket address' object. */ `socket address' object. */
soka = scm_to_sockaddr (fam_or_sockaddr, &size); 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; size_t path_len = 0;
path = SCM_SIMPLE_VECTOR_REF (address, 1); 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 " scm_misc_error (FUNC_NAME, "invalid unix address "
"path: ~A", scm_list_1 (path)); "path: ~A", scm_list_1 (path));
else else
{ {
struct sockaddr_un c_unix; struct sockaddr_un c_unix;
if (path == SCM_BOOL_F) if (scm_is_false (path))
path_len = 0; path_len = 0;
else else
path_len = scm_c_string_length (path); 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 means that the following arguments, i.e. ADDRESS and those listed in
ARGS_AND_FLAGS, are the `MSG_' flags. */ ARGS_AND_FLAGS, are the `MSG_' flags. */
soka = scm_to_sockaddr (fam_or_sockaddr, &size); 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); args_and_flags = scm_cons (address, args_and_flags);
} }
else else

10
libguile/srcprop.c
View file

@ -125,23 +125,23 @@ scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
thread safety. thread safety.
*/ */
SCM last_acons = SCM_CDR (scm_last_alist_filename); SCM last_acons = SCM_CDR (scm_last_alist_filename);
if (old_alist == SCM_EOL if (scm_is_null (old_alist)
&& SCM_CDAR (last_acons) == filename) && scm_is_eq (SCM_CDAR (last_acons), filename))
{ {
alist = last_acons; alist = last_acons;
} }
else else
{ {
alist = scm_acons (scm_sym_filename, filename, alist); 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_SETCDR (scm_last_alist_filename, alist);
} }
} }
SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops, SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
SRCPROPMAKPOS (line, col), SRCPROPMAKPOS (line, col),
copy, SCM_UNPACK (copy),
alist); SCM_UNPACK (alist));
} }

2
libguile/stacks.c
View file

@ -102,7 +102,7 @@ find_prompt (SCM key)
for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds)) for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
{ {
SCM elt = scm_car (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; return elt;
} }
scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack", scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",

57
libguile/tags.h
View file

@ -74,10 +74,9 @@ typedef scm_t_uintptr scm_t_bits;
* desired level of type checking, be defined in several ways: * desired level of type checking, be defined in several ways:
*/ */
#if (SCM_DEBUG_TYPING_STRICTNESS == 2) #if (SCM_DEBUG_TYPING_STRICTNESS == 2)
typedef union { struct { scm_t_bits n; } n; } SCM; typedef union SCM { struct { scm_t_bits n; } n; } SCM;
static SCM scm_pack(scm_t_bits b) { SCM s; s.n.n = b; return s; }
# define SCM_UNPACK(x) ((x).n.n) # 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) #elif (SCM_DEBUG_TYPING_STRICTNESS == 1)
/* This is the default, which provides an intermediate level of compile time /* This is the default, which provides an intermediate level of compile time
* type checking while still resulting in very efficient code. * 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_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) #define SCM_ITAG8_DATA(X) (SCM_UNPACK (X) >> 8)
@ -474,7 +474,7 @@ enum scm_tc8_tags
* declarations in print.c: iflagnames. */ * declarations in print.c: iflagnames. */
#define SCM_IFLAGP(n) (SCM_ITAG8 (n) == scm_tc8_flag) #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)) #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 * defined below. The properties are checked at compile-time using
* `verify' macros near the top of boolean.c and pairs.c. * `verify' macros near the top of boolean.c and pairs.c.
*/ */
#define SCM_BOOL_F SCM_MAKIFLAG (0) #define SCM_BOOL_F_BITS SCM_MAKIFLAG_BITS (0)
#define SCM_ELISP_NIL SCM_MAKIFLAG (1) #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 #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 #endif
#define SCM_EOL SCM_MAKIFLAG (3) #define SCM_EOL_BITS SCM_MAKIFLAG_BITS (3)
#define SCM_BOOL_T SCM_MAKIFLAG (4) #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 #ifdef BUILDING_LIBGUILE
#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0 SCM_MAKIFLAG (5) #define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_0 SCM_MAKIFLAG_BITS (5)
#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_1 SCM_MAKIFLAG (6) #define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_1 SCM_MAKIFLAG_BITS (6)
#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_2 SCM_MAKIFLAG (7) #define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE_2 SCM_MAKIFLAG_BITS (7)
#endif #endif
#define SCM_UNSPECIFIED SCM_MAKIFLAG (8) #define SCM_UNSPECIFIED_BITS SCM_MAKIFLAG_BITS (8)
#define SCM_UNDEFINED SCM_MAKIFLAG (9) #define SCM_UNDEFINED_BITS SCM_MAKIFLAG_BITS (9)
#define SCM_EOF_VAL SCM_MAKIFLAG (10) #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 /* When a variable is unbound this is marked by the SCM_UNDEFINED
* value. The following is an unbound value which can be handled on * 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 * 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 * used instead. It is not ideal to let this kind of unique and
* strange values loose on the Scheme level. */ * 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)) #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) \ #define SCM_HAS_EXACTLY_TWO_BITS_SET(x) \
(SCM_HAS_EXACTLY_ONE_BIT_SET (SCM_WITH_LEAST_SIGNIFICANT_1_BIT_CLEARED (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) \ #define SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION(a,b) \
(SCM_HAS_EXACTLY_ONE_BIT_SET (SCM_UNPACK(a) ^ SCM_UNPACK(b))) (SCM_HAS_EXACTLY_ONE_BIT_SET ((a) ^ (b)))
#define SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS(a,b,c,d) \ #define SCM_BITS_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS(a,b,c,d) \
(SCM_HAS_EXACTLY_TWO_BITS_SET ((SCM_UNPACK(a) ^ SCM_UNPACK(b)) | \ (SCM_HAS_EXACTLY_TWO_BITS_SET (((a) ^ (b)) | \
(SCM_UNPACK(b) ^ SCM_UNPACK(c)) | \ ((b) ^ (c)) | \
(SCM_UNPACK(c) ^ SCM_UNPACK(d)))) ((c) ^ (d))))
#endif /* BUILDING_LIBGUILE */ #endif /* BUILDING_LIBGUILE */

9
libguile/threads.c
View file

@ -607,6 +607,13 @@ typedef struct {
#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (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. /* Perform thread tear-down, in guile mode.
*/ */
static void * static void *
@ -624,7 +631,7 @@ do_thread_exit (void *v)
t->cleanup_handler = SCM_BOOL_F; t->cleanup_handler = SCM_BOOL_F;
t->result = scm_internal_catch (SCM_BOOL_T, 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); scm_handle_by_message_noexit, NULL);
} }

6
libguile/variable.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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 val;
SCM_VALIDATE_VARIABLE (1, var); SCM_VALIDATE_VARIABLE (1, var);
val = SCM_VARIABLE_REF (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)); SCM_MISC_ERROR ("variable is unbound: ~S", scm_list_1 (var));
return val; 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 #define FUNC_NAME s_scm_variable_bound_p
{ {
SCM_VALIDATE_VARIABLE (1, var); 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 #undef FUNC_NAME

12
libguile/vectors.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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)); scm_out_of_range (NULL, scm_from_size_t (k));
elt = (SCM_I_VECTOR_ELTS(v))[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. */ /* ELT was a weak pointer and got nullified by the GC. */
return SCM_BOOL_F; 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; k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
elt = (SCM_I_VECTOR_ELTS (vv))[k]; 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. */ /* ELT was a weak pointer and got nullified by the GC. */
return SCM_BOOL_F; 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. */ /* Make it a weak pointer. */
GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]); 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) 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. */ /* Make it a weak pointer. */
GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]); 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 else

12
libguile/vm-engine.c
View file

@ -89,17 +89,17 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* Initial frame */ /* Initial frame */
CACHE_REGISTER (); CACHE_REGISTER ();
PUSH ((SCM)fp); /* dynamic link */ PUSH (SCM_PACK (fp)); /* dynamic link */
PUSH (0); /* mvra */ PUSH (SCM_PACK (0)); /* mvra */
PUSH ((SCM)ip); /* ra */ PUSH (SCM_PACK (ip)); /* ra */
CACHE_PROGRAM (); CACHE_PROGRAM ();
PUSH (program); PUSH (program);
fp = sp + 1; fp = sp + 1;
ip = SCM_C_OBJCODE_BASE (bp); ip = SCM_C_OBJCODE_BASE (bp);
/* MV-call frame, function & arguments */ /* MV-call frame, function & arguments */
PUSH (0); /* dynamic link */ PUSH (SCM_PACK (0)); /* dynamic link */
PUSH (0); /* mvra */ PUSH (SCM_PACK (0)); /* mvra */
PUSH (0); /* ra */ PUSH (SCM_PACK (0)); /* ra */
PUSH (prog); PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit)) if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args; goto vm_error_too_many_args;

4
libguile/vm-engine.h
View file

@ -126,7 +126,7 @@
} while (0) } while (0)
#define ASSERT_BOUND_VARIABLE(x) \ #define ASSERT_BOUND_VARIABLE(x) \
do { ASSERT_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(); } \ { SYNC_REGISTER (); abort(); } \
} while (0) } while (0)
@ -136,7 +136,7 @@
#define ASSERT_ALIGNED_PROCEDURE() \ #define ASSERT_ALIGNED_PROCEDURE() \
do { if ((scm_t_bits)bp % 8) abort (); } while (0) do { if ((scm_t_bits)bp % 8) abort (); } while (0)
#define ASSERT_BOUND(x) \ #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) } while (0)
#else #else
#define CHECK_IP() #define CHECK_IP()

30
libguile/vm-i-scheme.c
View file

@ -168,15 +168,15 @@ VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
*/ */
#undef REL #undef REL
#define REL(crel,srel) \ #define REL(crel,srel) \
{ \ { \
ARGS2 (x, y); \ ARGS2 (x, y); \
if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
RETURN (scm_from_bool ((scm_t_signed_bits) (x) \ RETURN (scm_from_bool (((scm_t_signed_bits) SCM_UNPACK (x)) \
crel (scm_t_signed_bits) (y))); \ crel ((scm_t_signed_bits) SCM_UNPACK (y)))); \
SYNC_REGISTER (); \ SYNC_REGISTER (); \
RETURN (srel (x, y)); \ RETURN (srel (x, y)); \
} }
VM_DEFINE_FUNCTION (145, ee, "ee?", 2) VM_DEFINE_FUNCTION (145, ee, "ee?", 2)
{ {
@ -297,13 +297,13 @@ VM_DEFINE_FUNCTION (151, add1, "add1", 1)
ARGS1 (x); ARGS1 (x);
/* Check for overflow. */ /* 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; SCM result;
/* Add the integers without untagging. */ /* Add the integers without untagging. */
result = SCM_PACK ((scm_t_intptr) x result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
+ (scm_t_intptr) SCM_I_MAKINUM (1) + (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
- scm_tc2_int); - scm_tc2_int);
if (SCM_LIKELY (SCM_I_INUMP (result))) if (SCM_LIKELY (SCM_I_INUMP (result)))
@ -331,13 +331,13 @@ VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
ARGS1 (x); ARGS1 (x);
/* Check for underflow. */ /* 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; SCM result;
/* Substract the integers without untagging. */ /* Substract the integers without untagging. */
result = SCM_PACK ((scm_t_intptr) x result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x)
- (scm_t_intptr) SCM_I_MAKINUM (1) - (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1))
+ scm_tc2_int); + scm_tc2_int);
if (SCM_LIKELY (SCM_I_INUMP (result))) if (SCM_LIKELY (SCM_I_INUMP (result)))

26
libguile/vm-i-system.c
View file

@ -233,7 +233,7 @@ VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
nothing more than the corresponding macros. */ nothing more than the corresponding macros. */
#define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #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) #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) VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
{ {
if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED) PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED)));
PUSH (SCM_BOOL_F);
else
PUSH (SCM_BOOL_T);
NEXT; NEXT;
} }
@ -289,10 +286,7 @@ VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
unsigned int i = FETCH (); unsigned int i = FETCH ();
i <<= 8; i <<= 8;
i += FETCH (); i += FETCH ();
if (LOCAL_REF (i) == SCM_UNDEFINED) PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED)));
PUSH (SCM_BOOL_F);
else
PUSH (SCM_BOOL_T);
NEXT; 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 know that this frame will point to the current fp: it could be
placed elsewhere on the stack if captured in a partial placed elsewhere on the stack if captured in a partial
continuation, and invoked from some other context. */ continuation, and invoked from some other context. */
PUSH (0); /* dynamic link */ PUSH (SCM_PACK (0)); /* dynamic link */
PUSH (0); /* mvra */ PUSH (SCM_PACK (0)); /* mvra */
PUSH (0); /* ra */ PUSH (SCM_PACK (0)); /* ra */
NEXT; 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); cont = scm_i_make_continuation (&first, vm, vm_cont);
if (first) if (first)
{ {
PUSH (0); /* dynamic link */ PUSH (SCM_PACK (0)); /* dynamic link */
PUSH (0); /* mvra */ PUSH (SCM_PACK (0)); /* mvra */
PUSH (0); /* ra */ PUSH (SCM_PACK (0)); /* ra */
PUSH (proc); PUSH (proc);
PUSH (cont); PUSH (cont);
nargs = 1; nargs = 1;
@ -1666,7 +1660,7 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
else else
{ {
SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num); 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; finish_args = *sp;
goto vm_error_unbound_fluid; goto vm_error_unbound_fluid;

4
libguile/vm.c
View file

@ -402,9 +402,9 @@ really_make_boot_program (long nargs)
static SCM static SCM
vm_make_boot_program (long nargs) 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; int i;
for (i = 0; i < NUM_BOOT_PROGS; i++) for (i = 0; i < NUM_BOOT_PROGS; i++)

30
libguile/weaks.c
View file

@ -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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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; cell->word_1 = cdr;
if (SCM_NIMP (car)) if (SCM_NIMP (car))
{ /* Weak car cells make sense iff the car is non-immediate. */
/* Weak car cells make sense iff the car is non-immediate. */ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0, (GC_PTR) SCM2PTR (car));
(GC_PTR) SCM_UNPACK (car));
}
return (SCM_PACK (cell)); return (SCM_PACK (cell));
} }
@ -83,11 +81,9 @@ scm_weak_cdr_pair (SCM car, SCM cdr)
cell->word_1 = cdr; cell->word_1 = cdr;
if (SCM_NIMP (cdr)) if (SCM_NIMP (cdr))
{ /* Weak cdr cells make sense iff the cdr is non-immediate. */
/* Weak cdr cells make sense iff the cdr is non-immediate. */ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1, (GC_PTR) SCM2PTR (cdr));
(GC_PTR) SCM_UNPACK (cdr));
}
return (SCM_PACK (cell)); return (SCM_PACK (cell));
} }
@ -103,15 +99,11 @@ scm_doubly_weak_pair (SCM car, SCM cdr)
cell->word_1 = cdr; cell->word_1 = cdr;
if (SCM_NIMP (car)) if (SCM_NIMP (car))
{ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0, (GC_PTR) SCM2PTR (car));
(GC_PTR) SCM_UNPACK (car));
}
if (SCM_NIMP (cdr)) if (SCM_NIMP (cdr))
{ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1, (GC_PTR) SCM2PTR (cdr));
(GC_PTR) SCM_UNPACK (cdr));
}
return (SCM_PACK (cell)); return (SCM_PACK (cell));
} }

4
libguile/weaks.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_WEAKS_H #ifndef SCM_WEAKS_H
#define 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * 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. */ /* Testing the weak component(s) of a cell for reachability. */
#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \ #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) \ #define SCM_WEAK_PAIR_CAR_DELETED_P(_cell) \
(SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0)) (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0))
#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \ #define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \