[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-87-g40
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-87-g402c35a |
|
Date: |
Fri, 19 Nov 2010 14:25:46 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=402c35ac8115a48ee1fe300eb87b3ed43518be94
The branch, master has been updated
via 402c35ac8115a48ee1fe300eb87b3ed43518be94 (commit)
via cd8c35193cb2e772889f799b458497bc6e6986d1 (commit)
via 57ced5b97a794cb75ab273e47c68b05b1b86357e (commit)
via f7f62d3ac58119a110ecf46a54c9039edf727029 (commit)
via 8d4f5e8f92b8f0effead923648b274554f54e4df (commit)
via e25f37271acde5b9e3c34420ad9d0faa62b7503d (commit)
via d2aed81f7cb8b703b000962a1b9dddc8de91212e (commit)
via 3d27ef4bd312750f8edca81f09644eab21a3d8e0 (commit)
from f0c56cadfda6f8e9691d5e12cbd1778f36bfde2a (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 402c35ac8115a48ee1fe300eb87b3ed43518be94
Author: Andy Wingo <address@hidden>
Date: Fri Nov 19 15:08:07 2010 +0100
deprecate process-define-module
* module/ice-9/boot-9.scm:
* module/ice-9/deprecated.scm (process-define-module): Deprecate.
commit cd8c35193cb2e772889f799b458497bc6e6986d1
Author: Andy Wingo <address@hidden>
Date: Fri Nov 19 14:43:31 2010 +0100
define-module compiles to define-module*
* module/ice-9/boot-9.scm (define-module): Compile down to a call to
define-module*, not process-define-module.
commit 57ced5b97a794cb75ab273e47c68b05b1b86357e
Author: Andy Wingo <address@hidden>
Date: Fri Nov 19 13:11:47 2010 +0100
scm_c_define_module uses define-module*
* libguile/modules.c (scm_c_define_module):
* module/ice-9/boot-9.scm: Update to have the C function call
define-module*.
commit f7f62d3ac58119a110ecf46a54c9039edf727029
Author: Andy Wingo <address@hidden>
Date: Fri Nov 19 13:06:03 2010 +0100
make module definition procedure more structured
* module/ice-9/boot-9.scm (define-module*): New procedure, like
process-define-modules but more structured.
(process-define-module): Reimplement in terms of define-module*.
commit 8d4f5e8f92b8f0effead923648b274554f54e4df
Author: Andy Wingo <address@hidden>
Date: Fri Nov 19 11:39:06 2010 +0100
relax sizeof(long) restriction in configure.ac
* configure.ac: Relax the sizeof(long)==sizeof(void*) restriction,
instead asserting that the sizeof(long)<=sizeof(void*). There will
still be problems on nonstandard platforms related to the interface
with gmp, but those are confined to numbers.c.
commit e25f37271acde5b9e3c34420ad9d0faa62b7503d
Author: Andy Wingo <address@hidden>
Date: Fri Nov 19 11:29:26 2010 +0100
fix a number of assuptions that a long could hold an inum
* libguile/bytevectors.c:
* libguile/goops.c:
* libguile/instructions.c:
* libguile/numbers.c:
* libguile/random.c:
* libguile/read.c:
* libguile/vm-i-scheme.c: Fix a number of assumptions that a long could
hold an inum. This is not the case on platforms whose void* is larger
than their long.
* libguile/numbers.c (scm_i_inum2big): New helper, only implemented for
sizeof(void*) == sizeof(long); produces a compile error on other
platforms. Basically gmp doesn't have a nice interface for converting
between mpz values and intmax_t.
commit d2aed81f7cb8b703b000962a1b9dddc8de91212e
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 22:31:34 2010 +0100
simpos tweak
* libguile/simpos.c (scm_system_star): Use scm_from_ulong, as we do cast
to ulong.
commit 3d27ef4bd312750f8edca81f09644eab21a3d8e0
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 22:30:27 2010 +0100
fix a number of assumptions that a pointer could fit into a long
* libguile/debug.c:
* libguile/eval.c:
* libguile/frames.c:
* libguile/objcodes.c:
* libguile/print.c:
* libguile/programs.c:
* libguile/read.c:
* libguile/struct.c:
* libguile/vm.c: Fix a number of instances in which we assumed we could
fit a pointer into a long.
-----------------------------------------------------------------------
Summary of changes:
configure.ac | 4 +-
libguile/bytevectors.c | 8 +-
libguile/debug.c | 2 +-
libguile/eval.c | 2 +-
libguile/frames.c | 21 ++--
libguile/goops.c | 7 +-
libguile/instructions.c | 2 +-
libguile/modules.c | 8 +-
libguile/numbers.c | 220 ++++++++++++++++--------------
libguile/objcodes.c | 11 +-
libguile/print.c | 6 +-
libguile/programs.c | 2 +-
libguile/random.c | 8 +-
libguile/read.c | 6 +-
libguile/simpos.c | 4 +-
libguile/struct.c | 3 +-
libguile/vm-i-scheme.c | 26 +++--
libguile/vm.c | 6 +-
module/ice-9/boot-9.scm | 314 +++++++++++++++++++------------------------
module/ice-9/deprecated.scm | 104 ++++++++++++++-
20 files changed, 427 insertions(+), 337 deletions(-)
diff --git a/configure.ac b/configure.ac
index 4b4323f..3446992 100644
--- a/configure.ac
+++ b/configure.ac
@@ -281,8 +281,8 @@ AC_CHECK_SIZEOF(ptrdiff_t)
AC_CHECK_SIZEOF(size_t)
AC_CHECK_SIZEOF(off_t)
-if test "$ac_cv_sizeof_long" -ne "$ac_cv_sizeof_void_p"; then
- AC_MSG_ERROR(sizes of long and void* are not identical)
+if test "$ac_cv_sizeof_long" -gt "$ac_cv_sizeof_void_p"; then
+ AC_MSG_ERROR(long does not fit into a void*)
fi
if test "$ac_cv_sizeof_ptrdiff_t" -ne 0; then
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index de8077e..31703bf 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -131,7 +131,7 @@
SCM_VALIDATE_SYMBOL (3, endianness); \
\
{ \
- _sign long c_value; \
+ scm_t_signed_bits c_value; \
INT_TYPE (_len, _sign) c_value_short; \
\
if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
@@ -156,7 +156,7 @@
INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
\
{ \
- _sign long c_value; \
+ scm_t_signed_bits c_value; \
INT_TYPE (_len, _sign) c_value_short; \
\
if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
@@ -735,7 +735,7 @@ SCM_DEFINE (scm_u8_list_to_bytevector,
"u8-list->bytevector", 1, 0, 0,
if (SCM_LIKELY (SCM_I_INUMP (item)))
{
- long c_item;
+ scm_t_signed_bits c_item;
c_item = SCM_I_INUM (item);
if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
@@ -951,7 +951,7 @@ bytevector_unsigned_ref (const char *c_bv, size_t c_size,
SCM endianness)
#define GENERIC_INTEGER_SET(_sign) \
if (c_size < 3) \
{ \
- _sign int c_value; \
+ scm_t_signed_bits c_value; \
\
if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
goto range_error; \
diff --git a/libguile/debug.c b/libguile/debug.c
index dd65de4..e059a31 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -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", (unsigned long)SCM_BOOL_T,
+ { SCM_OPTION_SCM, "show-file-name", (scm_t_bits)SCM_BOOL_T,
"Show file names and line numbers "
"in backtraces when not `#f'. A value of `base' "
"displays only base names, while `#t' displays full names."},
diff --git a/libguile/eval.c b/libguile/eval.c
index 293612e..414645f 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1009,7 +1009,7 @@ boot_closure_print (SCM closure, SCM port,
scm_print_state *pstate)
{
SCM args;
scm_puts ("#<boot-closure ", port);
- scm_uintprint ((unsigned long)SCM2PTR (closure), 16, port);
+ scm_uintprint ((scm_t_bits)SCM2PTR (closure), 16, port);
scm_putc (' ', port);
args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS
(closure)),
scm_from_locale_symbol ("_"));
diff --git a/libguile/frames.c b/libguile/frames.c
index 67ddd1a..2f87084 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -209,7 +209,7 @@ SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
#define FUNC_NAME s_scm_frame_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_ulong ((unsigned long) SCM_VM_FRAME_FP (frame));
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_FRAME_FP (frame));
}
#undef FUNC_NAME
@@ -220,7 +220,7 @@ SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer",
1, 0, 0,
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_ulong ((unsigned long) SCM_VM_FRAME_SP (frame));
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_FRAME_SP (frame));
}
#undef FUNC_NAME
@@ -234,9 +234,8 @@ SCM_DEFINE (scm_frame_instruction_pointer,
"frame-instruction-pointer", 1, 0, 0,
SCM_VALIDATE_VM_FRAME (1, frame);
c_objcode = SCM_PROGRAM_DATA (scm_frame_procedure (frame));
- return scm_from_ulong ((unsigned long)
- (SCM_VM_FRAME_IP (frame)
- - SCM_C_OBJCODE_BASE (c_objcode)));
+ return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
+ - SCM_C_OBJCODE_BASE (c_objcode)));
}
#undef FUNC_NAME
@@ -246,9 +245,9 @@ SCM_DEFINE (scm_frame_return_address,
"frame-return-address", 1, 0, 0,
#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_ulong ((unsigned long)
- (SCM_FRAME_RETURN_ADDRESS
- (SCM_VM_FRAME_FP (frame))));
+ return scm_from_unsigned_integer ((scm_t_bits)
+ (SCM_FRAME_RETURN_ADDRESS
+ (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
@@ -258,9 +257,9 @@ SCM_DEFINE (scm_frame_mv_return_address,
"frame-mv-return-address", 1, 0, 0,
#define FUNC_NAME s_scm_frame_mv_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_ulong ((unsigned long)
- (SCM_FRAME_MV_RETURN_ADDRESS
- (SCM_VM_FRAME_FP (frame))));
+ return scm_from_unsigned_integer ((scm_t_bits)
+ (SCM_FRAME_MV_RETURN_ADDRESS
+ (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
diff --git a/libguile/goops.c b/libguile/goops.c
index 5e4b496..bc250fc 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1167,7 +1167,7 @@ SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2,
0, 0,
"Return the slot value with index @var{index} from @var{obj}.")
#define FUNC_NAME s_scm_sys_fast_slot_ref
{
- unsigned long int i;
+ scm_t_bits i;
SCM_VALIDATE_INSTANCE (1, obj);
i = scm_to_unsigned_integer (index, 0,
@@ -1184,7 +1184,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!",
3, 0, 0,
"@var{value}.")
#define FUNC_NAME s_scm_sys_fast_slot_set_x
{
- unsigned long int i;
+ scm_t_bits i;
SCM_VALIDATE_INSTANCE (1, obj);
i = scm_to_unsigned_integer (index, 0,
@@ -1442,8 +1442,7 @@ SCM_DEFINE (scm_sys_allocate_instance,
"%allocate-instance", 2, 0, 0,
#define FUNC_NAME s_scm_sys_allocate_instance
{
SCM obj;
- long n;
- long i;
+ scm_t_signed_bits n, i;
SCM layout;
SCM_VALIDATE_CLASS (1, class);
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 4981635..72e1fa1 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -177,7 +177,7 @@ SCM_DEFINE (scm_opcode_to_instruction,
"opcode->instruction", 1, 0, 0,
"")
#define FUNC_NAME s_scm_opcode_to_instruction
{
- int opcode;
+ scm_t_signed_bits opcode;
SCM ret = SCM_BOOL_F;
SCM_MAKE_VALIDATE (1, op, I_INUMP);
diff --git a/libguile/modules.c b/libguile/modules.c
index 6c3d0e8..43e2373 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -49,7 +49,7 @@ static SCM the_module;
boot-9 are needed to provide the Scheme interface. */
static SCM the_root_module_var;
static SCM module_make_local_var_x_var;
-static SCM process_define_module_var;
+static SCM define_module_star_var;
static SCM process_use_modules_var;
static SCM resolve_module_var;
static SCM module_public_interface_var;
@@ -176,8 +176,8 @@ SCM
scm_c_define_module (const char *name,
void (*init)(void *), void *data)
{
- SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var),
- scm_list_1 (convert_module_name (name)));
+ SCM module = scm_call_1 (SCM_VARIABLE_REF (define_module_star_var),
+ convert_module_name (name));
if (init)
scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
return module;
@@ -894,7 +894,7 @@ scm_post_boot_init_modules ()
scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
resolve_module_var = scm_c_lookup ("resolve-module");
- process_define_module_var = scm_c_lookup ("process-define-module");
+ define_module_star_var = scm_c_lookup ("define-module*");
process_use_modules_var = scm_c_lookup ("process-use-modules");
module_export_x_var = scm_c_lookup ("module-export!");
the_root_module_var = scm_c_lookup ("the-root-module");
diff --git a/libguile/numbers.c b/libguile/numbers.c
index bc9cb91..d5ebf9c 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -76,6 +76,9 @@
#define M_PI 3.14159265358979323846
#endif
+typedef scm_t_signed_bits scm_t_inum;
+#define scm_from_inum(x) (scm_from_signed_integer (x))
+
/*
@@ -193,6 +196,21 @@ scm_i_mkbig ()
return z;
}
+static SCM
+scm_i_inum2big (scm_t_inum x)
+{
+ /* Return a newly created bignum initialized to X. */
+ SCM z = make_bignum ();
+#if SIZEOF_VOID_P == SIZEOF_LONG
+ mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
+#else
+ /* Note that in this case, you'll also have to check all mpz_*_ui and
+ mpz_*_si invocations in Guile. */
+#error creation of mpz not implemented for this inum size
+#endif
+ return z;
+}
+
SCM
scm_i_long2big (long x)
{
@@ -262,7 +280,7 @@ scm_i_dbl2num (double u)
if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
&& u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
- return SCM_I_MAKINUM ((long) u);
+ return SCM_I_MAKINUM ((scm_t_inum) u);
else
return scm_i_dbl2big (u);
}
@@ -347,7 +365,7 @@ scm_i_normbig (SCM b)
/* presume b is a bignum */
if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
{
- long val = mpz_get_si (SCM_I_BIG_MPZ (b));
+ scm_t_inum val = mpz_get_si (SCM_I_BIG_MPZ (b));
if (SCM_FIXABLE (val))
b = SCM_I_MAKINUM (val);
}
@@ -360,7 +378,7 @@ scm_i_mpz2num (mpz_t b)
/* convert a mpz number to a SCM number. */
if (mpz_fits_slong_p (b))
{
- long val = mpz_get_si (b);
+ scm_t_inum val = mpz_get_si (b);
if (SCM_FIXABLE (val))
return SCM_I_MAKINUM (val);
}
@@ -409,12 +427,12 @@ scm_i_make_ratio (SCM numerator, SCM denominator)
*/
if (SCM_I_INUMP (numerator))
{
- long x = SCM_I_INUM (numerator);
+ scm_t_inum x = SCM_I_INUM (numerator);
if (scm_is_eq (numerator, SCM_INUM0))
return SCM_INUM0;
if (SCM_I_INUMP (denominator))
{
- long y;
+ scm_t_inum y;
y = SCM_I_INUM (denominator);
if (x == y)
return SCM_I_MAKINUM(1);
@@ -437,7 +455,7 @@ scm_i_make_ratio (SCM numerator, SCM denominator)
{
if (SCM_I_INUMP (denominator))
{
- long yy = SCM_I_INUM (denominator);
+ scm_t_inum yy = SCM_I_INUM (denominator);
if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy))
return scm_divide (numerator, denominator);
}
@@ -502,7 +520,7 @@ SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
{
if (SCM_I_INUMP (n))
{
- long val = SCM_I_INUM (n);
+ scm_t_inum val = SCM_I_INUM (n);
return scm_from_bool ((val & 1L) != 0);
}
else if (SCM_BIGP (n))
@@ -537,7 +555,7 @@ SCM_DEFINE (scm_even_p, "even?", 1, 0, 0,
{
if (SCM_I_INUMP (n))
{
- long val = SCM_I_INUM (n);
+ scm_t_inum val = SCM_I_INUM (n);
return scm_from_bool ((val & 1L) == 0);
}
else if (SCM_BIGP (n))
@@ -682,13 +700,13 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
{
if (SCM_I_INUMP (x))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (xx >= 0)
return x;
else if (SCM_POSFIXABLE (-xx))
return SCM_I_MAKINUM (-xx);
else
- return scm_i_long2big (-xx);
+ return scm_i_inum2big (-xx);
}
else if (SCM_BIGP (x))
{
@@ -728,19 +746,19 @@ scm_quotient (SCM x, SCM y)
{
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_quotient);
else
{
- long z = xx / yy;
+ scm_t_inum z = xx / yy;
if (SCM_FIXABLE (z))
return SCM_I_MAKINUM (z);
else
- return scm_i_long2big (z);
+ return scm_i_inum2big (z);
}
}
else if (SCM_BIGP (y))
@@ -763,7 +781,7 @@ scm_quotient (SCM x, SCM y)
{
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_quotient);
else if (yy == 1)
@@ -814,12 +832,12 @@ scm_remainder (SCM x, SCM y)
{
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_remainder);
else
{
- long z = SCM_I_INUM (x) % yy;
+ scm_t_inum z = SCM_I_INUM (x) % yy;
return SCM_I_MAKINUM (z);
}
}
@@ -843,7 +861,7 @@ scm_remainder (SCM x, SCM y)
{
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_remainder);
else
@@ -885,10 +903,10 @@ scm_modulo (SCM x, SCM y)
{
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_modulo);
else
@@ -896,8 +914,8 @@ scm_modulo (SCM x, SCM y)
/* C99 specifies that "%" is the remainder corresponding to a
quotient rounded towards zero, and that's also traditional
for machine division, so z here should be well defined. */
- long z = xx % yy;
- long result;
+ scm_t_inum z = xx % yy;
+ scm_t_inum result;
if (yy < 0)
{
@@ -962,7 +980,7 @@ scm_modulo (SCM x, SCM y)
{
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
scm_num_overflow (s_modulo);
else
@@ -1033,19 +1051,19 @@ scm_gcd (SCM x, SCM y)
{
if (SCM_I_INUMP (y))
{
- long xx = SCM_I_INUM (x);
- long yy = SCM_I_INUM (y);
- long u = xx < 0 ? -xx : xx;
- long v = yy < 0 ? -yy : yy;
- long result;
+ scm_t_inum xx = SCM_I_INUM (x);
+ scm_t_inum yy = SCM_I_INUM (y);
+ scm_t_inum u = xx < 0 ? -xx : xx;
+ scm_t_inum v = yy < 0 ? -yy : yy;
+ scm_t_inum result;
if (xx == 0)
result = v;
else if (yy == 0)
result = u;
else
{
- long k = 1;
- long t;
+ scm_t_inum k = 1;
+ scm_t_inum t;
/* Determine a common factor 2^k */
while (!(1 & (u | v)))
{
@@ -1075,7 +1093,7 @@ scm_gcd (SCM x, SCM y)
}
return (SCM_POSFIXABLE (result)
? SCM_I_MAKINUM (result)
- : scm_i_long2big (result));
+ : scm_i_inum2big (result));
}
else if (SCM_BIGP (y))
{
@@ -1089,8 +1107,8 @@ scm_gcd (SCM x, SCM y)
{
if (SCM_I_INUMP (y))
{
- unsigned long result;
- long yy;
+ scm_t_bits result;
+ scm_t_inum yy;
big_inum:
yy = SCM_I_INUM (y);
if (yy == 0)
@@ -1101,7 +1119,7 @@ scm_gcd (SCM x, SCM y)
scm_remember_upto_here_1 (x);
return (SCM_POSFIXABLE (result)
? SCM_I_MAKINUM (result)
- : scm_from_ulong (result));
+ : scm_from_unsigned_integer (result));
}
else if (SCM_BIGP (y))
{
@@ -1168,7 +1186,7 @@ scm_lcm (SCM n1, SCM n2)
inumbig:
{
SCM result = scm_i_mkbig ();
- long nn1 = SCM_I_INUM (n1);
+ scm_t_inum nn1 = SCM_I_INUM (n1);
if (nn1 == 0) return SCM_INUM0;
if (nn1 < 0) nn1 = - nn1;
mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
@@ -1258,7 +1276,7 @@ SCM_DEFINE (scm_i_logand, "logand", 0, 2, 1,
SCM scm_logand (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logand
{
- long int nn1;
+ scm_t_inum nn1;
if (SCM_UNBNDP (n2))
{
@@ -1277,7 +1295,7 @@ SCM scm_logand (SCM n1, SCM n2)
nn1 = SCM_I_INUM (n1);
if (SCM_I_INUMP (n2))
{
- long nn2 = SCM_I_INUM (n2);
+ scm_t_inum nn2 = SCM_I_INUM (n2);
return SCM_I_MAKINUM (nn1 & nn2);
}
else if SCM_BIGP (n2)
@@ -1348,7 +1366,7 @@ SCM_DEFINE (scm_i_logior, "logior", 0, 2, 1,
SCM scm_logior (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logior
{
- long int nn1;
+ scm_t_inum nn1;
if (SCM_UNBNDP (n2))
{
@@ -1438,7 +1456,7 @@ SCM_DEFINE (scm_i_logxor, "logxor", 0, 2, 1,
SCM scm_logxor (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logxor
{
- long int nn1;
+ scm_t_inum nn1;
if (SCM_UNBNDP (n2))
{
@@ -1455,7 +1473,7 @@ SCM scm_logxor (SCM n1, SCM n2)
nn1 = SCM_I_INUM (n1);
if (SCM_I_INUMP (n2))
{
- long nn2 = SCM_I_INUM (n2);
+ scm_t_inum nn2 = SCM_I_INUM (n2);
return SCM_I_MAKINUM (nn1 ^ nn2);
}
else if (SCM_BIGP (n2))
@@ -1513,14 +1531,14 @@ SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_logtest
{
- long int nj;
+ scm_t_inum nj;
if (SCM_I_INUMP (j))
{
nj = SCM_I_INUM (j);
if (SCM_I_INUMP (k))
{
- long nk = SCM_I_INUM (k);
+ scm_t_inum nk = SCM_I_INUM (k);
return scm_from_bool (nj & nk);
}
else if (SCM_BIGP (k))
@@ -1774,7 +1792,7 @@ SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_integer_expt
{
- long i2 = 0;
+ scm_t_inum i2 = 0;
SCM z_i2 = SCM_BOOL_F;
int i2_is_big = 0;
SCM acc = SCM_I_MAKINUM (1L);
@@ -1871,7 +1889,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
if (SCM_I_INUMP (n))
{
- long nn = SCM_I_INUM (n);
+ scm_t_inum nn = SCM_I_INUM (n);
if (bits_to_shift > 0)
{
@@ -1886,7 +1904,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
return n;
if (bits_to_shift < SCM_I_FIXNUM_BIT-1
- && ((unsigned long)
+ && ((scm_t_bits)
(SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
<= 1))
{
@@ -1894,7 +1912,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
}
else
{
- SCM result = scm_i_long2big (nn);
+ SCM result = scm_i_inum2big (nn);
mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
bits_to_shift);
return result;
@@ -1967,7 +1985,7 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
if (SCM_I_INUMP (n))
{
- long int in = SCM_I_INUM (n);
+ scm_t_inum in = SCM_I_INUM (n);
/* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
@@ -1979,7 +1997,7 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
* special case requires us to produce a result that has
* more bits than can be stored in a fixnum.
*/
- SCM result = scm_i_long2big (in);
+ SCM result = scm_i_inum2big (in);
mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
bits);
return result;
@@ -2038,8 +2056,8 @@ SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
{
if (SCM_I_INUMP (n))
{
- unsigned long int c = 0;
- long int nn = SCM_I_INUM (n);
+ unsigned long c = 0;
+ scm_t_inum nn = SCM_I_INUM (n);
if (nn < 0)
nn = -1 - nn;
while (nn)
@@ -2086,9 +2104,9 @@ SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
{
if (SCM_I_INUMP (n))
{
- unsigned long int c = 0;
+ unsigned long c = 0;
unsigned int l = 4;
- long int nn = SCM_I_INUM (n);
+ scm_t_inum nn = SCM_I_INUM (n);
if (nn < 0)
nn = -1 - nn;
while (nn)
@@ -3353,10 +3371,10 @@ scm_num_eq_p (SCM x, SCM y)
again:
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_signed_bits xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_signed_bits yy = SCM_I_INUM (y);
return scm_from_bool (xx == yy);
}
else if (SCM_BIGP (y))
@@ -3375,13 +3393,13 @@ scm_num_eq_p (SCM x, SCM y)
An alternative (for any size system actually) would be to check
yy is an integer (with floor) and is in range of an inum
(compare against appropriate powers of 2) then test
- xx==(long)yy. It's just a matter of which casts/comparisons
- might be fastest or easiest for the cpu. */
+ xx==(scm_t_signed_bits)yy. It's just a matter of which
+ casts/comparisons might be fastest or easiest for the cpu. */
double yy = SCM_REAL_VALUE (y);
return scm_from_bool ((double) xx == yy
&& (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
- || xx == (long) yy));
+ || xx == (scm_t_signed_bits) yy));
}
else if (SCM_COMPLEXP (y))
return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y))
@@ -3432,10 +3450,10 @@ scm_num_eq_p (SCM x, SCM y)
if (SCM_I_INUMP (y))
{
/* see comments with inum/real above */
- long yy = SCM_I_INUM (y);
+ scm_t_signed_bits yy = SCM_I_INUM (y);
return scm_from_bool (xx == (double) yy
&& (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
- || (long) xx == yy));
+ || (scm_t_signed_bits) xx == yy));
}
else if (SCM_BIGP (y))
{
@@ -3573,10 +3591,10 @@ scm_less_p (SCM x, SCM y)
again:
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
return scm_from_bool (xx < yy);
}
else if (SCM_BIGP (y))
@@ -3907,10 +3925,10 @@ scm_max (SCM x, SCM y)
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
return (xx < yy) ? y : x;
}
else if (SCM_BIGP (y))
@@ -4053,10 +4071,10 @@ scm_min (SCM x, SCM y)
if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
return (xx < yy) ? x : y;
}
else if (SCM_BIGP (y))
@@ -4199,10 +4217,10 @@ scm_sum (SCM x, SCM y)
{
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
- long xx = SCM_I_INUM (x);
- long yy = SCM_I_INUM (y);
- long int z = xx + yy;
- return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_long2big (z);
+ scm_t_inum xx = SCM_I_INUM (x);
+ scm_t_inum yy = SCM_I_INUM (y);
+ scm_t_inum z = xx + yy;
+ return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_inum2big (z);
}
else if (SCM_BIGP (y))
{
@@ -4211,12 +4229,12 @@ scm_sum (SCM x, SCM y)
}
else if (SCM_REALP (y))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
return scm_from_double (xx + SCM_REAL_VALUE (y));
}
else if (SCM_COMPLEXP (y))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
return scm_c_make_rectangular (xx + SCM_COMPLEX_REAL (y),
SCM_COMPLEX_IMAG (y));
}
@@ -4230,7 +4248,7 @@ scm_sum (SCM x, SCM y)
{
if (SCM_I_INUMP (y))
{
- long int inum;
+ scm_t_inum inum;
int bigsgn;
add_big_inum:
inum = SCM_I_INUM (y);
@@ -4404,11 +4422,11 @@ scm_difference (SCM x, SCM y)
else
if (SCM_I_INUMP (x))
{
- long xx = -SCM_I_INUM (x);
+ scm_t_inum xx = -SCM_I_INUM (x);
if (SCM_FIXABLE (xx))
return SCM_I_MAKINUM (xx);
else
- return scm_i_long2big (xx);
+ return scm_i_inum2big (xx);
}
else if (SCM_BIGP (x))
/* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
@@ -4430,18 +4448,18 @@ scm_difference (SCM x, SCM y)
{
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
- long int xx = SCM_I_INUM (x);
- long int yy = SCM_I_INUM (y);
- long int z = xx - yy;
+ scm_t_inum xx = SCM_I_INUM (x);
+ scm_t_inum yy = SCM_I_INUM (y);
+ scm_t_inum z = xx - yy;
if (SCM_FIXABLE (z))
return SCM_I_MAKINUM (z);
else
- return scm_i_long2big (z);
+ return scm_i_inum2big (z);
}
else if (SCM_BIGP (y))
{
/* inum-x - big-y */
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (xx == 0)
return scm_i_clonebig (y, 0);
@@ -4469,12 +4487,12 @@ scm_difference (SCM x, SCM y)
}
else if (SCM_REALP (y))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
return scm_from_double (xx - SCM_REAL_VALUE (y));
}
else if (SCM_COMPLEXP (y))
{
- long int xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y),
- SCM_COMPLEX_IMAG (y));
}
@@ -4491,13 +4509,13 @@ scm_difference (SCM x, SCM y)
if (SCM_I_INUMP (y))
{
/* big-x - inum-y */
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
scm_remember_upto_here_1 (x);
if (sgn_x == 0)
return (SCM_FIXABLE (-yy) ?
- SCM_I_MAKINUM (-yy) : scm_from_long (-yy));
+ SCM_I_MAKINUM (-yy) : scm_from_inum (-yy));
else
{
SCM result = scm_i_mkbig ();
@@ -4667,7 +4685,7 @@ scm_product (SCM x, SCM y)
if (SCM_LIKELY (SCM_I_INUMP (x)))
{
- long xx;
+ scm_t_inum xx;
intbig:
xx = SCM_I_INUM (x);
@@ -4680,14 +4698,14 @@ scm_product (SCM x, SCM y)
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
- long yy = SCM_I_INUM (y);
- long kk = xx * yy;
+ scm_t_inum yy = SCM_I_INUM (y);
+ scm_t_inum kk = xx * yy;
SCM k = SCM_I_MAKINUM (kk);
if ((kk == SCM_I_INUM (k)) && (kk / xx == yy))
return k;
else
{
- SCM result = scm_i_long2big (xx);
+ SCM result = scm_i_inum2big (xx);
mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
return scm_i_normbig (result);
}
@@ -4899,7 +4917,7 @@ do_divide (SCM x, SCM y, int inexact)
SCM_WTA_DISPATCH_0 (g_divide, s_divide);
else if (SCM_I_INUMP (x))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (xx == 1 || xx == -1)
return x;
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
@@ -4955,10 +4973,10 @@ do_divide (SCM x, SCM y, int inexact)
if (SCM_LIKELY (SCM_I_INUMP (x)))
{
- long xx = SCM_I_INUM (x);
+ scm_t_inum xx = SCM_I_INUM (x);
if (SCM_LIKELY (SCM_I_INUMP (y)))
{
- long yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
{
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
@@ -4975,11 +4993,11 @@ do_divide (SCM x, SCM y, int inexact)
}
else
{
- long z = xx / yy;
+ scm_t_inum z = xx / yy;
if (SCM_FIXABLE (z))
return SCM_I_MAKINUM (z);
else
- return scm_i_long2big (z);
+ return scm_i_inum2big (z);
}
}
else if (SCM_BIGP (y))
@@ -5030,7 +5048,7 @@ do_divide (SCM x, SCM y, int inexact)
{
if (SCM_I_INUMP (y))
{
- long int yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
if (yy == 0)
{
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
@@ -5053,7 +5071,7 @@ do_divide (SCM x, SCM y, int inexact)
middle ground: test, then if divisible, use the faster div
func. */
- long abs_yy = yy < 0 ? -yy : yy;
+ scm_t_inum abs_yy = yy < 0 ? -yy : yy;
int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
if (divisible_p)
@@ -5144,7 +5162,7 @@ do_divide (SCM x, SCM y, int inexact)
double rx = SCM_REAL_VALUE (x);
if (SCM_I_INUMP (y))
{
- long int yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0)
scm_num_overflow (s_divide);
@@ -5184,7 +5202,7 @@ do_divide (SCM x, SCM y, int inexact)
double ix = SCM_COMPLEX_IMAG (x);
if (SCM_I_INUMP (y))
{
- long int yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0)
scm_num_overflow (s_divide);
@@ -5240,7 +5258,7 @@ do_divide (SCM x, SCM y, int inexact)
{
if (SCM_I_INUMP (y))
{
- long int yy = SCM_I_INUM (y);
+ scm_t_inum yy = SCM_I_INUM (y);
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
if (yy == 0)
scm_num_overflow (s_divide);
@@ -5881,13 +5899,13 @@ scm_magnitude (SCM z)
{
if (SCM_I_INUMP (z))
{
- long int zz = SCM_I_INUM (z);
+ scm_t_inum zz = SCM_I_INUM (z);
if (zz >= 0)
return z;
else if (SCM_POSFIXABLE (-zz))
return SCM_I_MAKINUM (-zz);
else
- return scm_i_long2big (-zz);
+ return scm_i_inum2big (-zz);
}
else if (SCM_BIGP (z))
{
@@ -6355,7 +6373,7 @@ scm_from_double (double val)
#if SCM_ENABLE_DEPRECATED == 1
float
-scm_num2float (SCM num, unsigned long int pos, const char *s_caller)
+scm_num2float (SCM num, unsigned long pos, const char *s_caller)
{
scm_c_issue_deprecation_warning
("`scm_num2float' is deprecated. Use scm_to_double instead.");
@@ -6373,7 +6391,7 @@ scm_num2float (SCM num, unsigned long int pos, const char
*s_caller)
}
double
-scm_num2double (SCM num, unsigned long int pos, const char *s_caller)
+scm_num2double (SCM num, unsigned long pos, const char *s_caller)
{
scm_c_issue_deprecation_warning
("`scm_num2double' is deprecated. Use scm_to_double instead.");
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index f54e79b..5f3079c 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -123,11 +123,12 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8
*ptr)
if (ptr < parent_base
|| ptr >= (parent_base + parent_data->len + parent_data->metalen
- sizeof (struct scm_objcode)))
- scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
- scm_list_4 (scm_from_ulong ((unsigned long) ptr),
- scm_from_ulong ((unsigned long) parent_base),
- scm_from_uint32 (parent_data->len),
- scm_from_uint32 (parent_data->metalen)));
+ scm_misc_error
+ (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
+ scm_list_4 (scm_from_unsigned_integer ((scm_t_bits) ptr),
+ scm_from_unsigned_integer ((scm_t_bits) parent_base),
+ scm_from_uint32 (parent_data->len),
+ scm_from_uint32 (parent_data->metalen)));
/* Make sure bytecode for the objcode-meta is suitable aligned. Failing to
do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */
diff --git a/libguile/print.c b/libguile/print.c
index 8c807bb..f62378f 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -89,11 +89,11 @@ static const char *iflagnames[] =
SCM_SYMBOL (sym_reader, "reader");
scm_t_option scm_print_opts[] = {
- { SCM_OPTION_SCM, "highlight-prefix", (unsigned long)SCM_BOOL_F,
+ { SCM_OPTION_SCM, "highlight-prefix", (scm_t_bits)SCM_BOOL_F,
"The string to print before highlighted values." },
- { SCM_OPTION_SCM, "highlight-suffix", (unsigned long)SCM_BOOL_F,
+ { SCM_OPTION_SCM, "highlight-suffix", (scm_t_bits)SCM_BOOL_F,
"The string to print after highlighted values." },
- { SCM_OPTION_SCM, "quote-keywordish-symbols", (unsigned long)SCM_BOOL_F,
+ { SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F,
"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'."
diff --git a/libguile/programs.c b/libguile/programs.c
index 4404f83..8b769a5 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -131,7 +131,7 @@ SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
SCM_VALIDATE_PROGRAM (1, program);
c_objcode = SCM_PROGRAM_DATA (program);
- return scm_from_ulong ((unsigned long) SCM_C_OBJCODE_BASE (c_objcode));
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_C_OBJCODE_BASE
(c_objcode));
}
#undef FUNC_NAME
diff --git a/libguile/random.c b/libguile/random.c
index c0a3e04..f487eb8 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -392,16 +392,16 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0,
SCM_VALIDATE_RSTATE (2, state);
if (SCM_I_INUMP (n))
{
- unsigned long m = (unsigned long) SCM_I_INUM (n);
+ scm_t_bits m = (scm_t_bits) SCM_I_INUM (n);
SCM_ASSERT_RANGE (1, n, SCM_I_INUM (n) > 0);
-#if SCM_SIZEOF_UNSIGNED_LONG <= 4
+#if SCM_SIZEOF_UINTPTR_T <= 4
return scm_from_uint32 (scm_c_random (SCM_RSTATE (state),
(scm_t_uint32) m));
-#elif SCM_SIZEOF_UNSIGNED_LONG <= 8
+#elif SCM_SIZEOF_UINTPTR_T <= 8
return scm_from_uint64 (scm_c_random64 (SCM_RSTATE (state),
(scm_t_uint64) m));
#else
-#error "Cannot deal with this platform's unsigned long size"
+#error "Cannot deal with this platform's scm_t_bits size"
#endif
}
SCM_VALIDATE_NIM (1, n);
diff --git a/libguile/read.c b/libguile/read.c
index 52ec20d..4a9b5ea 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -69,7 +69,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", (unsigned long) SCM_BOOL_F,
+ { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F,
"Style of keyword recognition: #f, 'prefix or 'postfix."},
{ SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
"Use R6RS variable-length character and string hex escapes."},
@@ -965,7 +965,7 @@ scm_read_character (scm_t_wchar chr, SCM port)
SCM p = scm_string_to_number (charname, scm_from_uint (8));
if (SCM_I_INUMP (p))
{
- scm_t_wchar c = SCM_I_INUM (p);
+ scm_t_wchar c = scm_to_uint32 (p);
if (SCM_IS_UNICODE_CHAR (c))
return SCM_MAKE_CHAR (c);
else
@@ -984,7 +984,7 @@ scm_read_character (scm_t_wchar chr, SCM port)
scm_from_uint (16));
if (SCM_I_INUMP (p))
{
- scm_t_wchar c = SCM_I_INUM (p);
+ scm_t_wchar c = scm_to_uint32 (p);
if (SCM_IS_UNICODE_CHAR (c))
return SCM_MAKE_CHAR (c);
else
diff --git a/libguile/simpos.c b/libguile/simpos.c
index 41af233..84b8b9d 100644
--- a/libguile/simpos.c
+++ b/libguile/simpos.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009 Free Software
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009, 2010 Free
Software
* Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -127,7 +127,7 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
execargv = scm_i_allocate_string_pointers (args);
/* make sure the child can't kill us (as per normal system call) */
- sig_ign = scm_from_long ((unsigned long) SIG_IGN);
+ sig_ign = scm_from_ulong ((unsigned long) SIG_IGN);
sigint = scm_from_int (SIGINT);
sigquit = scm_from_int (SIGQUIT);
oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED);
diff --git a/libguile/struct.c b/libguile/struct.c
index c784f59..e5ecc1a 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -926,7 +926,8 @@ SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1,
0, 0,
#define FUNC_NAME s_scm_struct_vtable_tag
{
SCM_VALIDATE_VTABLE (1, handle);
- return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle)) >> 3);
+ return scm_from_unsigned_integer
+ (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
}
#undef FUNC_NAME
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index ec22673..19b48c5 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -399,13 +399,13 @@ VM_DEFINE_FUNCTION (159, ash, "ash", 2)
else
/* Left shift. See comments in scm_ash. */
{
- long nn, bits_to_shift;
+ scm_t_signed_bits nn, bits_to_shift;
nn = SCM_I_INUM (x);
bits_to_shift = SCM_I_INUM (y);
if (bits_to_shift < SCM_I_FIXNUM_BIT-1
- && ((unsigned long)
+ && ((scm_t_bits)
(SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
<= 1))
RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
@@ -451,7 +451,7 @@ VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
{
- long i = 0;
+ scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
&& SCM_I_INUMP (idx)
@@ -467,7 +467,7 @@ VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
{
- long i = 0;
+ scm_t_signed_bits i = 0;
SCM vect, idx, val;
POP (val); POP (idx); POP (vect);
if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
@@ -570,6 +570,9 @@ VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
SCM vtable;
scm_t_bits index, len;
+ /* True, an inum is a signed value, but cast to unsigned it will
+ certainly be more than the length, so we will fall through if
+ index is negative. */
index = SCM_I_INUM (pos);
vtable = SCM_STRUCT_VTABLE (obj);
len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
@@ -599,6 +602,7 @@ VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
SCM vtable;
scm_t_bits index, len;
+ /* See above regarding index being >= 0. */
index = SCM_I_INUM (pos);
vtable = SCM_STRUCT_VTABLE (obj);
len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
@@ -627,6 +631,7 @@ VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
RETURN (scm_class_of (obj));
}
+/* FIXME: No checking whatsoever. */
VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
{
size_t slot;
@@ -635,6 +640,7 @@ VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
}
+/* FIXME: No checking whatsoever. */
VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
{
SCM instance, idx, val;
@@ -701,7 +707,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
{ \
- long i; \
+ scm_t_signed_bits i; \
const scm_t_ ## type *int_ptr; \
ARGS2 (bv, idx); \
\
@@ -723,7 +729,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#define BV_INT_REF(stem, type, size) \
{ \
- long i; \
+ scm_t_signed_bits i; \
const scm_t_ ## type *int_ptr; \
ARGS2 (bv, idx); \
\
@@ -754,7 +760,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#define BV_FLOAT_REF(stem, fn_stem, type, size)
\
{ \
- long i; \
+ scm_t_signed_bits i; \
const type *float_ptr; \
ARGS2 (bv, idx); \
\
@@ -841,7 +847,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size)
\
{ \
- long i, j = 0; \
+ scm_t_signed_bits i, j = 0; \
SCM bv, idx, val; \
scm_t_ ## type *int_ptr; \
\
@@ -865,7 +871,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#define BV_INT_SET(stem, type, size) \
{ \
- long i = 0; \
+ scm_t_signed_bits i = 0; \
SCM bv, idx, val; \
scm_t_ ## type *int_ptr; \
\
@@ -886,7 +892,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#define BV_FLOAT_SET(stem, fn_stem, type, size) \
{ \
- long i = 0; \
+ scm_t_signed_bits i = 0; \
SCM bv, idx, val; \
type *float_ptr; \
\
diff --git a/libguile/vm.c b/libguile/vm.c
index e1a90e1..c08b084 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -606,7 +606,7 @@ SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
#define FUNC_NAME s_scm_vm_ip
{
SCM_VALIDATE_VM (1, vm);
- return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
}
#undef FUNC_NAME
@@ -616,7 +616,7 @@ SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
#define FUNC_NAME s_scm_vm_sp
{
SCM_VALIDATE_VM (1, vm);
- return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
}
#undef FUNC_NAME
@@ -626,7 +626,7 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
#define FUNC_NAME s_scm_vm_fp
{
SCM_VALIDATE_VM (1, vm);
- return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
}
#undef FUNC_NAME
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 24ce621..6da81a7 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2137,7 +2137,7 @@ If there is no handler at all, Guile prints an error and
then exits."
;; Cheat. These bindings are needed by modules.c, but we don't want
;; to move their real definition here because that would be unnatural.
;;
-(define process-define-module #f)
+(define define-module* #f)
(define process-use-modules #f)
(define module-export! #f)
(define default-duplicate-binding-procedures #f)
@@ -2360,135 +2360,78 @@ If there is no handler at all, Guile prints an error
and then exits."
;; This function is called from "modules.c". If you change it, be
;; sure to update "modules.c" as well.
-(define (process-define-module args)
- (let* ((module-id (car args))
- (module (resolve-module module-id #f))
- (kws (cdr args))
- (unrecognized (lambda (arg)
- (error "unrecognized define-module argument" arg))))
+(define* (define-module* name
+ #:key filename pure version (duplicates '())
+ (imports '()) (exports '()) (replacements '())
+ (re-exports '()) (autoloads '()) transformer)
+ (define (list-of pred l)
+ (or (null? l)
+ (and (pair? l) (pred (car l)) (list-of pred (cdr l)))))
+ (define (valid-export? x)
+ (or (symbol? x) (and (pair? x) (symbol? (car x)) (symbol? (cdr x)))))
+ (define (valid-autoload? x)
+ (and (pair? x) (list-of symbol? (car x)) (list-of symbol? (cdr x))))
+
+ (define (resolve-imports imports)
+ (define (resolve-import import-spec)
+ (if (list? import-spec)
+ (apply resolve-interface import-spec)
+ (error "unexpected use-module specification" import-spec)))
+ (let lp ((imports imports) (out '()))
+ (cond
+ ((null? imports) (reverse! out))
+ ((pair? imports)
+ (lp (cdr imports)
+ (cons (resolve-import (car imports)) out)))
+ (else (error "unexpected tail of imports list" imports)))))
+
+ ;; We could add a #:no-check arg, set by the define-module macro, if
+ ;; these checks are taking too much time.
+ ;;
+ (let ((module (resolve-module name #f)))
(beautify-user-module! module)
- (let loop ((kws kws)
- (reversed-interfaces '())
- (exports '())
- (re-exports '())
- (replacements '())
- (autoloads '()))
-
- (if (null? kws)
- (call-with-deferred-observers
- (lambda ()
- (module-use-interfaces! module (reverse reversed-interfaces))
- (module-export! module exports)
- (module-replace! module replacements)
- (module-re-export! module re-exports)
- (if (not (null? autoloads))
- (apply module-autoload! module autoloads))))
- (case (car kws)
- ((#:use-module #:use-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (cond
- ((equal? (caadr kws) '(ice-9 syncase))
- (issue-deprecation-warning
- "(ice-9 syncase) is deprecated. Support for syntax-case is now
in Guile core.")
- (loop (cddr kws)
- reversed-interfaces
- exports
- re-exports
- replacements
- autoloads))
- (else
- (let* ((interface-args (cadr kws))
- (interface (apply resolve-interface interface-args)))
- (and (eq? (car kws) #:use-syntax)
- (or (symbol? (caar interface-args))
- (error "invalid module name for use-syntax"
- (car interface-args)))
- (set-module-transformer!
- module
- (module-ref interface
- (car (last-pair (car interface-args)))
- #f)))
- (loop (cddr kws)
- (cons interface reversed-interfaces)
- exports
- re-exports
- replacements
- autoloads)))))
- ((#:autoload)
- (or (and (pair? (cdr kws)) (pair? (cddr kws)))
- (unrecognized kws))
- (loop (cdddr kws)
- reversed-interfaces
- exports
- re-exports
- replacements
- (let ((name (cadr kws))
- (bindings (caddr kws)))
- (cons* name bindings autoloads))))
- ((#:no-backtrace)
- (set-system-module! module #t)
- (loop (cdr kws) reversed-interfaces exports re-exports
- replacements autoloads))
- ((#:pure)
- (purify-module! module)
- (loop (cdr kws) reversed-interfaces exports re-exports
- replacements autoloads))
- ((#:version)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (let ((version (cadr kws)))
- (set-module-version! module version)
- (set-module-version! (module-public-interface module) version))
- (loop (cddr kws) reversed-interfaces exports re-exports
- replacements autoloads))
- ((#:duplicates)
- (if (not (pair? (cdr kws)))
- (unrecognized kws))
- (set-module-duplicates-handlers!
- module
- (lookup-duplicates-handlers (cadr kws)))
- (loop (cddr kws) reversed-interfaces exports re-exports
- replacements autoloads))
- ((#:export #:export-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- (append (cadr kws) exports)
- re-exports
- replacements
- autoloads))
- ((#:re-export #:re-export-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- exports
- (append (cadr kws) re-exports)
- replacements
- autoloads))
- ((#:replace #:replace-syntax)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (loop (cddr kws)
- reversed-interfaces
- exports
- re-exports
- (append (cadr kws) replacements)
- autoloads))
- ((#:filename)
- (or (pair? (cdr kws))
- (unrecognized kws))
- (set-module-filename! module (cadr kws))
- (loop (cddr kws)
- reversed-interfaces
- exports
- re-exports
- replacements
- autoloads))
- (else
- (unrecognized kws)))))
+ (if filename
+ (set-module-filename! module filename))
+ (if pure
+ (purify-module! module))
+ (if version
+ (begin
+ (if (not (list-of integer? version))
+ (error "expected list of integers for version"))
+ (set-module-version! module version)
+ (set-module-version! (module-public-interface module) version)))
+ (if (pair? duplicates)
+ (let ((handlers (lookup-duplicates-handlers duplicates)))
+ (set-module-duplicates-handlers! module handlers)))
+
+ (let ((imports (resolve-imports imports)))
+ (call-with-deferred-observers
+ (lambda ()
+ (if (pair? imports)
+ (module-use-interfaces! module imports))
+ (if (list-of valid-export? exports)
+ (if (pair? exports)
+ (module-export! module exports))
+ (error "expected exports to be a list of symbols or symbol
pairs"))
+ (if (list-of valid-export? replacements)
+ (if (pair? replacements)
+ (module-replace! module replacements))
+ (error "expected replacements to be a list of symbols or symbol
pairs"))
+ (if (list-of valid-export? re-exports)
+ (if (pair? re-exports)
+ (module-re-export! module re-exports))
+ (error "expected re-exports to be a list of symbols or symbol
pairs"))
+ ;; FIXME
+ (if (not (null? autoloads))
+ (apply module-autoload! module autoloads)))))
+
+ (if transformer
+ (if (and (pair? transformer) (list-of symbol? transformer))
+ (let ((iface (resolve-interface transformer))
+ (sym (car (last-pair transformer))))
+ (set-module-transformer! module (module-ref iface sym)))
+ (error "expected transformer to be a module name" transformer)))
+
(run-hook module-defined-hook module)
module))
@@ -2813,9 +2756,6 @@ module '(ice-9 q) '(make-q q-length))}."
(define (keyword-like-symbol->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
-;; FIXME: we really need to clean up the guts of the module system.
-;; We can compile to something better than process-define-module.
-;;
(define-syntax define-module
(lambda (x)
(define (keyword-like? stx)
@@ -2825,7 +2765,7 @@ module '(ice-9 q) '(make-q q-length))}."
(define (->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
- (define (quotify-iface args)
+ (define (parse-iface args)
(let loop ((in args) (out '()))
(syntax-case in ()
(() (reverse! out))
@@ -2835,59 +2775,83 @@ module '(ice-9 q) '(make-q q-length))}."
((kw . in) (not (keyword? (syntax->datum #'kw)))
(syntax-violation 'define-module "expected keyword arg" x #'kw))
((#:renamer renamer . in)
- (loop #'in (cons* #'renamer #:renamer out)))
+ (loop #'in (cons* #',renamer #:renamer out)))
((kw val . in)
- (loop #'in (cons* #''val #'kw out))))))
+ (loop #'in (cons* #'val #'kw out))))))
- (define (quotify args)
+ (define (parse args imp exp rex rep aut)
;; Just quote everything except #:use-module and #:use-syntax. We
;; need to know about all arguments regardless since we want to turn
;; symbols that look like keywords into real keywords, and the
;; keyword args in a define-module form are not regular
;; (i.e. no-backtrace doesn't take a value).
- (let loop ((in args) (out '()))
- (syntax-case in ()
- (() (reverse! out))
- ;; The user wanted #:foo, but wrote :foo. Fix it.
- ((sym . in) (keyword-like? #'sym)
- (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
- ((kw . in) (not (keyword? (syntax->datum #'kw)))
- (syntax-violation 'define-module "expected keyword arg" x #'kw))
- ((#:no-backtrace . in)
- (loop #'in (cons #:no-backtrace out)))
- ((#:pure . in)
- (loop #'in (cons #:pure out)))
- ((kw)
- (syntax-violation 'define-module "keyword arg without value" x
#'kw))
- ((use-module (name name* ...) . in)
- (and (memq (syntax->datum #'use-module) '(#:use-module
#:use-syntax))
- (and-map symbol? (syntax->datum #'(name name* ...))))
- (loop #'in
- (cons* #''((name name* ...))
- #'use-module
- out)))
- ((use-module ((name name* ...) arg ...) . in)
- (and (memq (syntax->datum #'use-module) '(#:use-module
#:use-syntax))
- (and-map symbol? (syntax->datum #'(name name* ...))))
- (loop #'in
- (cons* #`(list '(name name* ...) #,@(quotify-iface #'(arg
...)))
- #'use-module
- out)))
- ((#:autoload name bindings . in)
- (loop #'in (cons* #''bindings #''name #:autoload out)))
- ((kw val . in)
- (loop #'in (cons* #''val #'kw out))))))
+ (syntax-case args ()
+ (()
+ (let ((imp (if (null? imp) '() #`(#:imports `#,imp)))
+ (exp (if (null? exp) '() #`(#:exports '#,exp)))
+ (rex (if (null? rex) '() #`(#:re-exports '#,rex)))
+ (rep (if (null? rep) '() #`(#:replacements '#,rep)))
+ (aut (if (null? aut) '() #`(#:autoloads '#,aut))))
+ #`(#,@imp #,@exp #,@rex #,@rep #,@aut)))
+ ;; The user wanted #:foo, but wrote :foo. Fix it.
+ ((sym . args) (keyword-like? #'sym)
+ (parse #`(#,(->keyword (syntax->datum #'sym)) . args)
+ imp exp rex rep aut))
+ ((kw . args) (not (keyword? (syntax->datum #'kw)))
+ (syntax-violation 'define-module "expected keyword arg" x #'kw))
+ ((#:no-backtrace . args)
+ ;; Ignore this one.
+ (parse #'args imp exp rex rep aut))
+ ((#:pure . args)
+ #`(#:pure #t . #,(parse #'args imp exp rex rep aut)))
+ ((kw)
+ (syntax-violation 'define-module "keyword arg without value" x #'kw))
+ ((#:version (v ...) . args)
+ #`(#:version '(v ...) . #,(parse #'args imp exp rex rep aut)))
+ ((#:duplicates (d ...) . args)
+ #`(#:duplicates '(d ...) . #,(parse #'args imp exp rex rep aut)))
+ ((#:filename f . args)
+ #`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
+ ((#:use-module (name name* ...) . args)
+ (and (and-map symbol? (syntax->datum #'(name name* ...))))
+ (parse #'args (cons #'((name name* ...)) imp) exp rex rep aut))
+ ((#:use-syntax (name name* ...) . args)
+ (and (and-map symbol? (syntax->datum #'(name name* ...))))
+ #`(#:transformer '(name name* ...)
+ . #,(parse #'args (cons #'((name name* ...)) imp) exp rex rep
aut)))
+ ((#:use-module ((name name* ...) arg ...) . args)
+ (and (and-map symbol? (syntax->datum #'(name name* ...))))
+ (parse #'args
+ (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
+ exp rex rep aut))
+ ((#:export (ex ...) . args)
+ (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+ ((#:export-syntax (ex ...) . args)
+ (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+ ((#:re-export (re ...) . args)
+ (parse #'args imp exp #`(#,@rex re ...) rep aut))
+ ((#:re-export-syntax (re ...) . args)
+ (parse #'args imp exp #`(#,@rex re ...) rep aut))
+ ((#:replace (r ...) . args)
+ (parse #'args imp exp rex #`(#,@rep r ...) aut))
+ ((#:replace-syntax (r ...) . args)
+ (parse #'args imp exp rex #`(#,@rep r ...) aut))
+ ((#:autoload name bindings . args)
+ (parse #'args imp exp rex rep #`(#,@aut name bindings)))
+ ((kw val . args)
+ (syntax-violation 'define-module "unknown keyword or bad argument"
+ #'kw #'val))))
(syntax-case x ()
((_ (name name* ...) arg ...)
- (with-syntax (((quoted-arg ...) (quotify #'(arg ...))))
+ (and-map symbol? (syntax->datum #'(name name* ...)))
+ (with-syntax (((quoted-arg ...)
+ (parse #'(arg ...) '() '() '() '() '()))
+ (filename (assq-ref (or (syntax-source x) '())
+ 'filename)))
#'(eval-when (eval load compile expand)
- (let ((m (process-define-module
- (list '(name name* ...)
- #:filename (assq-ref
- (or (current-source-location) '())
- 'filename)
- quoted-arg ...))))
+ (let ((m (define-module* '(name name* ...)
+ #:filename filename quoted-arg ...)))
(set-current-module m)
m)))))))
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 07ad6d2..d6dd837 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -66,7 +66,8 @@
named-module-use!
top-repl
turn-on-debugging
- read-hash-procedures))
+ read-hash-procedures
+ process-define-module))
;;;; Deprecated definitions.
@@ -697,3 +698,104 @@ it.")
((set! _ expr)
(begin (read-hash-procedures-warning)
(fluid-set! %read-hash-procedures expr)))))
+
+(define (process-define-module args)
+ (define (missing kw)
+ (error "missing argument to define-module keyword" kw))
+ (define (unrecognized arg)
+ (error "unrecognized define-module argument" arg))
+
+ (let ((name (car args))
+ (filename #f)
+ (pure? #f)
+ (version #f)
+ (system? #f)
+ (duplicates '())
+ (transformer #f))
+ (let loop ((kws (cdr args))
+ (imports '())
+ (exports '())
+ (re-exports '())
+ (replacements '())
+ (autoloads '()))
+ (if (null? kws)
+ (define-module* name
+ #:filename filename #:pure pure? #:version version
+ #:duplicates duplicates #:transformer transformer
+ #:imports (reverse! imports)
+ #:exports exports
+ #:re-exports re-exports
+ #:replacements replacements
+ #:autoloads autoloads)
+ (case (car kws)
+ ((#:use-module #:use-syntax)
+ (or (pair? (cdr kws))
+ (missing (car kws)))
+ (cond
+ ((equal? (cadr kws) '(ice-9 syncase))
+ (issue-deprecation-warning
+ "(ice-9 syncase) is deprecated. Support for syntax-case is now
in Guile core.")
+ (loop (cddr kws)
+ imports exports re-exports replacements autoloads))
+ (else
+ (let ((iface-spec (cadr kws)))
+ (if (eq? (car kws) #:use-syntax)
+ (set! transformer iface-spec))
+ (loop (cddr kws)
+ (cons iface-spec imports) exports re-exports
+ replacements autoloads)))))
+ ((#:autoload)
+ (or (and (pair? (cdr kws)) (pair? (cddr kws)))
+ (missing (car kws)))
+ (let ((name (cadr kws))
+ (bindings (caddr kws)))
+ (loop (cdddr kws)
+ imports exports re-exports
+ replacements (cons* name bindings autoloads))))
+ ((#:no-backtrace)
+ ;; FIXME: deprecate?
+ (set! system? #t)
+ (loop (cdr kws)
+ imports exports re-exports replacements autoloads))
+ ((#:pure)
+ (set! pure? #t)
+ (loop (cdr kws)
+ imports exports re-exports replacements autoloads))
+ ((#:version)
+ (or (pair? (cdr kws))
+ (missing (car kws)))
+ (set! version (cadr kws))
+ (loop (cddr kws)
+ imports exports re-exports replacements autoloads))
+ ((#:duplicates)
+ (if (not (pair? (cdr kws)))
+ (missing (car kws)))
+ (set! duplicates (cadr kws))
+ (loop (cddr kws)
+ imports exports re-exports replacements autoloads))
+ ((#:export #:export-syntax)
+ (or (pair? (cdr kws))
+ (missing (car kws)))
+ (loop (cddr kws)
+ imports (append exports (cadr kws)) re-exports
+ replacements autoloads))
+ ((#:re-export #:re-export-syntax)
+ (or (pair? (cdr kws))
+ (missing (car kws)))
+ (loop (cddr kws)
+ imports exports (append re-exports (cadr kws))
+ replacements autoloads))
+ ((#:replace #:replace-syntax)
+ (or (pair? (cdr kws))
+ (missing (car kws)))
+ (loop (cddr kws)
+ imports exports re-exports
+ (append replacements (cadr kws)) autoloads))
+ ((#:filename)
+ (or (pair? (cdr kws))
+ (missing (car kws)))
+ (set! filename (cadr kws))
+ (loop (cddr kws)
+ imports exports re-exports replacements autoloads))
+ (else
+ (unrecognized kws)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-87-g402c35a,
Andy Wingo <=