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
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;
}

22
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
* modify it under the terms of the GNU Lesser General Public License
@ -40,17 +40,17 @@
* 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, \
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_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
(SCM_ELISP_NIL, SCM_BOOL_F, SCM_EOL, \
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,

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';
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); \

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_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",

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
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 ();

4
libguile/debug.c
View file

@ -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."},

26
libguile/deprecated.c
View file

@ -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 ()
{

11
libguile/deprecated.h
View file

@ -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)

2
libguile/deprecation.c
View file

@ -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);

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
* 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;

8
libguile/dynwind.h
View file

@ -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);

7
libguile/eval.c
View file

@ -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)

5
libguile/expand.h
View file

@ -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
@ -74,7 +74,8 @@ enum
};
#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) \
(scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
#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
* 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--;

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));
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)

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
* 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]

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
* 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");
}

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 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);
}

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
* 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);

10
libguile/hash.c
View file

@ -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:

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
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));

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) \
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);
}
}

14
libguile/inline.h
View file

@ -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? */

2
libguile/list.c
View file

@ -37,7 +37,7 @@
#define SCM_I_CONS(cell, x, y) \
do { \
cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y); \
cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); \
} while (0)
SCM

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
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);

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
* 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

7
libguile/memoize.c
View file

@ -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)))

8
libguile/modules.c
View file

@ -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);
}

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");
/* 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",

2
libguile/numbers.c
View file

@ -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 ();

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
* 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)

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(!). */
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);

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");
#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);

8
libguile/print.c
View file

@ -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;

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.
*
* 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

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_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))

8
libguile/read.c
View file

@ -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;
}

19
libguile/snarf.h
View file

@ -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 */

10
libguile/socket.c
View file

@ -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

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.
*/
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));
}

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))
{
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",

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:
*/
#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 */

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_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);
}

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
* 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

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
* 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

12
libguile/vm-engine.c
View file

@ -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;

4
libguile/vm-engine.h
View file

@ -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()

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

@ -172,8 +172,8 @@ VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
{ \
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))); \
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)); \
}
@ -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)))

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. */
#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;

4
libguile/vm.c
View file

@ -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++)

18
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
* 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));
}
(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));
}
(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));
}
(GC_PTR) SCM2PTR (car));
if (SCM_NIMP (cdr))
{
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
(GC_PTR) SCM_UNPACK (cdr));
}
(GC_PTR) SCM2PTR (cdr));
return (SCM_PACK (cell));
}

4
libguile/weaks.h
View file

@ -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) \