[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-5-129-g72
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-129-g7230aaf |
|
Date: |
Wed, 09 Dec 2009 09:06:38 +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=7230aaf9610e8654c9395a3207c91663da78a873
The branch, master has been updated
via 7230aaf9610e8654c9395a3207c91663da78a873 (commit)
via 735bcfe579606eddb1700462e56918d48affe36e (commit)
via 75a029aa2553a24e4804722521f1e5db9690fbe3 (commit)
via 0b1733c7d18cd39c11868a7b091de4c72f69ea8d (commit)
via 0e163c06f26f1ec8930183a9e1618eb9f1f0402b (commit)
via 00f8b368ca9690af45ff47bb7309061578cc6016 (commit)
via 9e9e54eb19067f327c1ebc7ee847cac354b35979 (commit)
via bbd41a6a217b53b0382da81c47d7f7110de31273 (commit)
via 96a44c1cab34e2cc3cf5a04a0c026f0863386137 (commit)
via 485d13670be5ae5594cf04d87fb64c239c2c9b80 (commit)
via 72ab4b2e2b9f5aa35378ba82ac99b863f7a63d95 (commit)
via db5ed68588fc0c4086da1715c8aa13e85fa173ee (commit)
via 34dfef5135a8f65b85f5b3c72168ca2900d9dbcc (commit)
via 4afe4ab42ab8a6b0f869cfc2b4d0ff0d8e0a8f48 (commit)
via 4834078b079e8135bb042ac8a2f7f908433cda79 (commit)
via b9ef8e66eec1da83e0587c2d454c04ca5532817d (commit)
via 4dc2165b356d6f360f8d82fc04c916b7240eec19 (commit)
via 0236bc683d288f64089819064030fb8e93bd3781 (commit)
via e779fef7eecb2637f1e8b4952a1bd018b8839346 (commit)
via a253eec010c6ec598cb67ad61f6e2f8991691142 (commit)
via c395cb78134188b1e8c19d4c36045fcd5a411373 (commit)
via 56164dc47f6616b359f0ad23be208f01a77b55fa (commit)
via 66e78727d602b0c59bf4633951eac17d3697bfc0 (commit)
from ea68d342f18c3d2082ce6a4fb39bd38b6af932cc (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 7230aaf9610e8654c9395a3207c91663da78a873
Author: Andy Wingo <address@hidden>
Date: Wed Dec 9 10:07:04 2009 +0100
fix FUNC_NAME of scm_memoize_variable_access_x
* libguile/memoize.c (scm_memoize_variable_access_x): Fix FUNC_NAME
definition.
commit 735bcfe579606eddb1700462e56918d48affe36e
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 22:53:21 2009 +0100
add SCM_SMOB_TYPE_BITS and SCM_SMOB_TYPE_MASK
* libguile/smob.h (SCM_SMOB_TYPE_BITS, SCM_SMOB_TYPE_MASK): New macros,
for when you want to identify a SMOB by type and mask.
* libguile/arrays.c:
* libguile/bitvectors.c:
* libguile/srfi-4.c: Use the new macros.
commit 75a029aa2553a24e4804722521f1e5db9690fbe3
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:59:42 2009 +0100
fix SCM_CELL macro usage.
* libguile/vm.h (SCM_VM_CONT_DATA): Fix SCM_CELL macro usage.
commit 0b1733c7d18cd39c11868a7b091de4c72f69ea8d
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:59:01 2009 +0100
SCM_CELL in throw.c
* libguile/throw.c (JBACTIVE, ACTIVATEJB, DEACTIVATEJB, JBJMPBUF)
(SETJBJMPBUF, SCM_JBPREUNWIND, SCM_SETJBPREUNWIND)
(pre_unwind_data_print, scm_ithrow): Fix SCM_CELL macro usage.
commit 0e163c06f26f1ec8930183a9e1618eb9f1f0402b
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:55:20 2009 +0100
SCM_VALIDATE_SMOB uses SCM_SMOB_PREDICATE
* libguile/validate.h (SCM_VALIDATE_SMOB): Change to use
SCM_SMOB_PREDICATE instead of SCM_TYP16_PREDICATE.
commit 00f8b368ca9690af45ff47bb7309061578cc6016
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:54:27 2009 +0100
SCM_CELL in srfi-4.c
* libguile/srfi-4.c (SCM_UVEC_TYPE, SCM_UVEC_LENGTH, SCM_UVEC_BASE): Fix
SCM_CELL macro usage.
commit 9e9e54eb19067f327c1ebc7ee847cac354b35979
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:53:15 2009 +0100
SCM_CELL in srcprop.c
* libguile/srcprop.c (SRCPROPPOS, SRCPROPCOPY, SRCPROPALIST)
(SETSRCPROPPOS, SETSRCPROPCOPY, SETSRCPROPALIST): Fix erroneous
SCM_CELL macro usage.
commit bbd41a6a217b53b0382da81c47d7f7110de31273
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:52:15 2009 +0100
use the new public metatables from struct.c
* libguile/procs.c (scm_init_procs): No need to lookup the
applicable-struct-with-setter vtable, as it is now exported.
commit 96a44c1cab34e2cc3cf5a04a0c026f0863386137
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:50:40 2009 +0100
scm_i_alloc_struct does not take a "what" arg
* libguile/struct.h:
* libguile/struct.c (scm_i_alloc_struct): Change to not take a "what"
argument. Callers changed.
commit 485d13670be5ae5594cf04d87fb64c239c2c9b80
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:48:33 2009 +0100
reserve a vtable flag for smobs.
* libguile/struct.h (SCM_VTABLE_FLAG_SMOB_0): Reserve a vtable flag for
smobs.
commit 72ab4b2e2b9f5aa35378ba82ac99b863f7a63d95
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:47:47 2009 +0100
add vtable finalizer and printer setter macros
* libguile/struct.h (SCM_VTABLE_INSTANCE_FINALIZER): Use DATA_REF, not
SLOT_REF.
(SCM_SET_VTABLE_INSTANCE_FINALIZER, SCM_SET_VTABLE_INSTANCE_PRINTER):
New accessor macros.
commit db5ed68588fc0c4086da1715c8aa13e85fa173ee
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:46:47 2009 +0100
make some applicable struct vtable-vtable public to C
* libguile/struct.h (scm_standard_vtable_vtable)
(scm_applicable_struct_vtable_vtable)
(scm_applicable_struct_with_setter_vtable_vtable)
* libguile/struct.c: Make these stock meta-tables public to C.
commit 34dfef5135a8f65b85f5b3c72168ca2900d9dbcc
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:41:48 2009 +0100
SCM_CELL in modules.c
* libguile/modules.c (SCM_F_EVAL_CLOSURE_INTERFACE)
(SCM_EVAL_CLOSURE_INTERFACE_P, scm_standard_interface_eval_closure):
Fix to not use SCM_CELL macros.
commit 4afe4ab42ab8a6b0f869cfc2b4d0ff0d8e0a8f48
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:38:51 2009 +0100
initialize smobs after structs
* libguile/init.c (scm_i_init_guile): Move SMOB prehistory after structs
init. No effect for now.
commit 4834078b079e8135bb042ac8a2f7f908433cda79
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:37:25 2009 +0100
SCM_CELL in guardians.c
* libguile/guardians.c (GUARDIAN_DATA): Fix SCM_CELL macro usage.
commit b9ef8e66eec1da83e0587c2d454c04ca5532817d
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:31:42 2009 +0100
SCM_CELL in filesys.[ch]
* libguile/filesys.h (SCM_DIR_FLAG_OPEN, SCM_DIR_OPEN_P)
* libguile/filesys.c (scm_readdir, scm_rewinddir, scm_closedir)
(scm_dir_print, scm_dir_free): Fix SCM_CELL macro usage.
commit 4dc2165b356d6f360f8d82fc04c916b7240eec19
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:28:34 2009 +0100
SCM_CELL in deprecated.c
* libguile/deprecated.c (scm_smob_free): Fix SCM_CELL macro usage.
commit 0236bc683d288f64089819064030fb8e93bd3781
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:27:26 2009 +0100
fix SCM_CELL macro usage in continuations.[ch]
* libguile/continuations.h (SCM_CONTREGS):
* libguile/continuations.c (continuation_print): Fix SCM_CELL macro
usage.
commit e779fef7eecb2637f1e8b4952a1bd018b8839346
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:25:31 2009 +0100
fix SCM_CELL_* macro usage in async.c
* libguile/async.c (ASYNC_GOT_IT, SET_ASYNC_GOT_IT, ASYNC_THUNK): Fix
SCM_CELL_* macro usage.
commit a253eec010c6ec598cb67ad61f6e2f8991691142
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:23:25 2009 +0100
fix SCM_CELL_* macro usage in arbiters.c
* libguile/arbiters.c (scm_try_arbiter, scm_release_arbiter): Fix
erroneous SCM_CELL_* macro usage.
commit c395cb78134188b1e8c19d4c36045fcd5a411373
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 21:21:37 2009 +0100
fix erroneous SCM_CELL_* usage in arrays.[ch]
* libguile/arrays.h (SCM_I_ARRAY_FLAG_CONTIGUOUS, SCM_I_ARRAY_NDIM):
(SCM_I_ARRAY_CONTP, SCM_I_ARRAY_MEM):
* libguile/arrays.c (SCM_SET_ARRAY_CONTIGUOUS_FLAG):
(SCM_CLR_ARRAY_CONTIGUOUS_FLAG): Fix macros to use SCM_SMOB macros
instead of SCM_CELL macros.
commit 56164dc47f6616b359f0ad23be208f01a77b55fa
Author: Andy Wingo <address@hidden>
Date: Tue Dec 8 22:14:26 2009 +0100
clean up smob macro implementation
* libguile/smob.h: Regularize the SCM_SMOB macros, and make them all go
through some generic SMOB accessor macros.
* libguile/smob.c (scm_i_set_smob_flags): Remove, as it is unused.
commit 66e78727d602b0c59bf4633951eac17d3697bfc0
Author: Andy Wingo <address@hidden>
Date: Mon Dec 7 11:14:01 2009 +0100
add scm_c_make_struct[v]
* libguile/struct.h (scm_c_make_struct, scm_c_make_structv): New
functions with which you can make a struct without consing a rest
list.
* libguile/struct.c (scm_struct_init): Refactor to take an array of init
values, not a list.
(scm_make_struct, scm_make_vtable_vtable): Pull the rest arg out into
a list and pass it down to the new array-taking functions.
* libguile/memoize.c: Remove a neeless #include <alloca>.
-----------------------------------------------------------------------
Summary of changes:
libguile/arbiters.c | 4 +-
libguile/arrays.c | 7 +-
libguile/arrays.h | 8 +-
libguile/async.c | 6 +-
libguile/bitvectors.c | 3 +-
libguile/continuations.c | 2 +-
libguile/continuations.h | 2 +-
libguile/deprecated.c | 2 +-
libguile/filesys.c | 16 ++--
libguile/filesys.h | 6 +-
libguile/goops.c | 2 +-
libguile/guardians.c | 2 +-
libguile/init.c | 2 +-
libguile/memoize.c | 4 +-
libguile/modules.c | 6 +-
libguile/procs.c | 9 +-
libguile/smob.c | 8 --
libguile/smob.h | 61 ++++++++++-----
libguile/srcprop.c | 12 ++--
libguile/srfi-4.c | 9 +-
libguile/struct.c | 192 ++++++++++++++++++++++++++++------------------
libguile/struct.h | 16 +++-
libguile/throw.c | 22 +++---
libguile/validate.h | 2 +-
libguile/vm.h | 2 +-
25 files changed, 234 insertions(+), 171 deletions(-)
diff --git a/libguile/arbiters.c b/libguile/arbiters.c
index 3567c90..a53b702 100644
--- a/libguile/arbiters.c
+++ b/libguile/arbiters.c
@@ -122,7 +122,7 @@ SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0,
{
scm_t_bits old;
SCM_VALIDATE_SMOB (1, arb, arbiter);
- FETCH_STORE (old, * (scm_t_bits *) SCM_CELL_OBJECT_LOC(arb,0), SCM_LOCK_VAL);
+ FETCH_STORE (old, SCM_SMOB_DATA_0 (arb), SCM_LOCK_VAL);
return scm_from_bool (old == SCM_UNLOCK_VAL);
}
#undef FUNC_NAME
@@ -148,7 +148,7 @@ SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0,
{
scm_t_bits old;
SCM_VALIDATE_SMOB (1, arb, arbiter);
- FETCH_STORE (old, *(scm_t_bits*)SCM_CELL_OBJECT_LOC(arb,0), SCM_UNLOCK_VAL);
+ FETCH_STORE (old, SCM_SMOB_DATA_0 (arb), SCM_UNLOCK_VAL);
return scm_from_bool (old == SCM_LOCK_VAL);
}
#undef FUNC_NAME
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 8dc1d78..741cc56 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -56,9 +56,9 @@
scm_t_bits scm_i_tc16_array;
#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) |
SCM_I_ARRAY_FLAG_CONTIGUOUS))
+ (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) &
~SCM_I_ARRAY_FLAG_CONTIGUOUS))
+ (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
@@ -1126,7 +1126,8 @@ array_get_handle (SCM array, scm_t_array_handle *h)
h->base = SCM_I_ARRAY_BASE (array);
}
-SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array),
+ SCM_SMOB_TYPE_MASK,
array_handle_ref, array_handle_set,
array_get_handle);
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 35e5471..325bb9c 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -65,13 +65,13 @@ typedef struct scm_i_t_array
SCM_API scm_t_bits scm_i_tc16_array;
-#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16)
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
-#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17))
-#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
+#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_SMOB_FLAGS (x)>>1))
+#define SCM_I_ARRAY_CONTP(x) (SCM_SMOB_FLAGS(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
-#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
+#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_SMOB_DATA_1 (a))
#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
#define SCM_I_ARRAY_DIMS(a) \
diff --git a/libguile/async.c b/libguile/async.c
index 7ec8b6e..ddb2a21 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -87,9 +87,9 @@ static scm_t_bits tc16_async;
#define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
#define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user
async")
-#define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16)
-#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V)
<< 16)))
-#define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X)
+#define ASYNC_GOT_IT(X) (SCM_SMOB_FLAGS (X))
+#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V))))
+#define ASYNC_THUNK(X) SCM_SMOB_OBJECT_1 (X)
SCM_DEFINE (scm_async, "async", 1, 0, 0,
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index c3b6f3e..3e23adf 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -878,7 +878,8 @@ bitvector_get_handle (SCM bv, scm_t_array_handle *h)
h->elements = h->writable_elements = BITVECTOR_BITS (bv);
}
-SCM_ARRAY_IMPLEMENTATION (scm_tc16_bitvector, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_bitvector),
+ SCM_SMOB_TYPE_MASK,
bitvector_handle_ref, bitvector_handle_set,
bitvector_get_handle);
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector);
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 7013e3d..aeff62e 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -57,7 +57,7 @@ continuation_print (SCM obj, SCM port, scm_print_state *state
SCM_UNUSED)
scm_puts ("#<continuation ", port);
scm_intprint (continuation->num_stack_items, 10, port);
scm_puts (" @ ", port);
- scm_uintprint (SCM_CELL_WORD_1 (obj), 16, port);
+ scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
scm_putc ('>', port);
return 1;
}
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 8f7e38e..a04c53f 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -69,7 +69,7 @@ typedef struct
#define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x)
-#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_CELL_WORD_1 (x))
+#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
#define SCM_SET_CONTINUATION_LENGTH(x, n)\
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index ac10c7a..c53776c 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -625,7 +625,7 @@ scm_smob_free (SCM obj)
"It is no longer needed.");
if (scm_smobs[n].size > 0)
- scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
+ scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj),
scm_smobs[n].size, SCM_SMOBNAME (n));
return 0;
}
diff --git a/libguile/filesys.c b/libguile/filesys.c
index e60efdd..02f2da6 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -852,7 +852,7 @@ SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
if (ds == NULL)
SCM_SYSERROR;
- SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_DIR_FLAG_OPEN, ds);
+ SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
}
#undef FUNC_NAME
@@ -893,7 +893,7 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
somewhere in the smob, or just the dirent size calculated once. */
{
struct dirent_or_dirent64 de; /* just for sizeof */
- DIR *ds = (DIR *) SCM_CELL_WORD_1 (port);
+ DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
size_t namlen;
#ifdef NAME_MAX
char buf [SCM_MAX (sizeof (de),
@@ -926,7 +926,7 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
errno = 0;
- SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_CELL_WORD_1
(port)));
+ SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1
(port)));
if (errno != 0)
SCM_SYSERROR;
@@ -951,7 +951,7 @@ SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0,
if (!SCM_DIR_OPEN_P (port))
SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
- rewinddir ((DIR *) SCM_CELL_WORD_1 (port));
+ rewinddir ((DIR *) SCM_SMOB_DATA_1 (port));
return SCM_UNSPECIFIED;
}
@@ -970,11 +970,11 @@ SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
{
int sts;
- SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port)));
+ SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
if (sts != 0)
SCM_SYSERROR;
- SCM_SET_CELL_WORD_0 (port, scm_tc16_dir);
+ SCM_SET_SMOB_DATA_0 (port, scm_tc16_dir);
}
return SCM_UNSPECIFIED;
@@ -989,7 +989,7 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
if (!SCM_DIR_OPEN_P (exp))
scm_puts ("closed: ", port);
scm_puts ("directory stream ", port);
- scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
+ scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
scm_putc ('>', port);
return 1;
}
@@ -999,7 +999,7 @@ static size_t
scm_dir_free (SCM p)
{
if (SCM_DIR_OPEN_P (p))
- closedir ((DIR *) SCM_CELL_WORD_1 (p));
+ closedir ((DIR *) SCM_SMOB_DATA_1 (p));
return 0;
}
diff --git a/libguile/filesys.h b/libguile/filesys.h
index b9a6ca8..a07f204 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -3,7 +3,7 @@
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
-/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009 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
@@ -29,10 +29,10 @@
SCM_API scm_t_bits scm_tc16_dir;
-#define SCM_DIR_FLAG_OPEN (1L << 16)
+#define SCM_DIR_FLAG_OPEN (1L << 0)
#define SCM_DIRP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_dir))
-#define SCM_DIR_OPEN_P(x) (SCM_CELL_WORD_0 (x) & SCM_DIR_FLAG_OPEN)
+#define SCM_DIR_OPEN_P(x) (SCM_SMOB_FLAGS (x) & SCM_DIR_FLAG_OPEN)
diff --git a/libguile/goops.c b/libguile/goops.c
index 1472e47..a402fc5 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1431,7 +1431,7 @@ SCM_DEFINE (scm_sys_allocate_instance,
"%allocate-instance", 2, 0, 0,
/* FIXME: duplicates some of scm_make_struct. */
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n, "struct");
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n);
layout = SCM_VTABLE_LAYOUT (class);
diff --git a/libguile/guardians.c b/libguile/guardians.c
index b85ec02..a341fbf 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -77,7 +77,7 @@ typedef struct t_guardian
} t_guardian;
#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
-#define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))
+#define GUARDIAN_DATA(x) ((t_guardian *) SCM_SMOB_DATA_1 (x))
diff --git a/libguile/init.c b/libguile/init.c
index 33857b7..0571d6b 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -440,7 +440,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
#endif
- scm_smob_prehistory ();
scm_symbols_prehistory (); /* requires weaks_prehistory */
scm_modules_prehistory ();
scm_init_array_handle ();
@@ -448,6 +447,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_generalized_vectors ();
scm_init_strings (); /* Requires array-handle,
generalized-vectors */
scm_init_struct (); /* Requires strings */
+ scm_smob_prehistory ();
scm_init_variable ();
scm_init_continuations (); /* requires smob_prehistory */
scm_init_root (); /* requires continuations */
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 7dd5cd8..ae3bbea 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -23,8 +23,6 @@
# include <config.h>
#endif
-#include <alloca.h>
-
#include "libguile/__scm.h"
#include <assert.h>
@@ -1169,7 +1167,7 @@ static void error_unbound_variable (SCM symbol)
SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0,
0,
(SCM m, SCM mod),
"Look up and cache the variable that @var{m} will access, returning
the variable.")
-#define FUNC_NAME s_scm_memoized_expression_data
+#define FUNC_NAME s_scm_memoize_variable_access_x
{
SCM mx;
SCM_VALIDATE_MEMOIZED (1, m);
diff --git a/libguile/modules.c b/libguile/modules.c
index 58c5248..545281a 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -483,9 +483,9 @@ SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
scm_t_bits scm_tc16_eval_closure;
-#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
+#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
- (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
+ (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
/* NOTE: This function may be called by a smob application
or from another C function directly. */
@@ -521,7 +521,7 @@ SCM_DEFINE (scm_standard_interface_eval_closure,
"Such a closure does not allow new bindings to be added.")
#define FUNC_NAME s_scm_standard_interface_eval_closure
{
- SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure |
(SCM_F_EVAL_CLOSURE_INTERFACE<<16),
SCM_UNPACK (module));
}
#undef FUNC_NAME
diff --git a/libguile/procs.c b/libguile/procs.c
index f620063..6c03911 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -234,10 +234,11 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
void
scm_init_procs ()
{
- SCM setter_vtable_vtable =
- scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-vtable>"));
- pws_vtable = scm_make_struct (setter_vtable_vtable, SCM_INUM0,
- scm_list_1 (scm_from_locale_symbol ("pwpw")));
+ pws_vtable =
+ scm_c_make_struct (scm_applicable_struct_with_setter_vtable_vtable,
+ 0,
+ 1,
+ SCM_UNPACK (scm_from_locale_symbol ("pwpw")));
#include "libguile/procs.x"
}
diff --git a/libguile/smob.c b/libguile/smob.c
index 31f6dd0..d96a043 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -54,14 +54,6 @@
long scm_numsmob;
scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
-/* Lower 16 bit of data must be zero.
-*/
-void
-scm_i_set_smob_flags (SCM x, scm_t_bits data)
-{
- SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
-}
-
void
scm_assert_smob_type (scm_t_bits tag, SCM val)
{
diff --git a/libguile/smob.h b/libguile/smob.h
index ee0e53e..f9b5110 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -122,25 +122,47 @@ while (0)
} while (0)
-#define SCM_SMOB_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 16)
-#define SCM_SMOB_DATA(x) (SCM_CELL_WORD_1 (x))
-#define SCM_SMOB_DATA_2(x) (SCM_CELL_WORD_2 (x))
-#define SCM_SMOB_DATA_3(x) (SCM_CELL_WORD_3 (x))
-#define SCM_SET_SMOB_DATA(x, data) (SCM_SET_CELL_WORD_1 ((x), (data)))
-#define SCM_SET_SMOB_DATA_2(x, data) (SCM_SET_CELL_WORD_2 ((x), (data)))
-#define SCM_SET_SMOB_DATA_3(x, data) (SCM_SET_CELL_WORD_3 ((x), (data)))
-#define SCM_SET_SMOB_FLAGS(x, data) (scm_i_set_smob_flags((x),(data)<<16))
-
-#define SCM_SMOB_OBJECT(x) (SCM_CELL_OBJECT_1 (x))
-#define SCM_SMOB_OBJECT_2(x) (SCM_CELL_OBJECT_2 (x))
-#define SCM_SMOB_OBJECT_3(x) (SCM_CELL_OBJECT_3 (x))
-#define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_CELL_OBJECT_1 ((x), (obj)))
-#define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_CELL_OBJECT_2 ((x), (obj)))
-#define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_CELL_OBJECT_3 ((x), (obj)))
-#define SCM_SMOB_OBJECT_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 1))
-#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 2))
-#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 3))
-
+#define SCM_SMOB_DATA_N(x, n) (SCM_CELL_WORD ((x), (n)))
+#define SCM_SET_SMOB_DATA_N(x, n, data) (SCM_SET_CELL_WORD ((x), (n),
(data)))
+
+#define SCM_SMOB_DATA_0(x) (SCM_SMOB_DATA_N ((x), 0))
+#define SCM_SMOB_DATA_1(x) (SCM_SMOB_DATA_N ((x), 1))
+#define SCM_SMOB_DATA_2(x) (SCM_SMOB_DATA_N ((x), 2))
+#define SCM_SMOB_DATA_3(x) (SCM_SMOB_DATA_N ((x), 3))
+#define SCM_SET_SMOB_DATA_0(x, data) (SCM_SET_SMOB_DATA_N ((x), 0, (data)))
+#define SCM_SET_SMOB_DATA_1(x, data) (SCM_SET_SMOB_DATA_N ((x), 1, (data)))
+#define SCM_SET_SMOB_DATA_2(x, data) (SCM_SET_SMOB_DATA_N ((x), 2, (data)))
+#define SCM_SET_SMOB_DATA_3(x, data) (SCM_SET_SMOB_DATA_N ((x), 3, (data)))
+
+#define SCM_SMOB_FLAGS(x) (SCM_SMOB_DATA_0 (x) >> 16)
+#define SCM_SMOB_DATA(x) (SCM_SMOB_DATA_1 (x))
+#define SCM_SET_SMOB_FLAGS(x, data) (SCM_SET_SMOB_DATA_0 ((x),
(SCM_CELL_TYPE (x)&0xffff)|((data)<<16)))
+#define SCM_SET_SMOB_DATA(x, data) (SCM_SET_SMOB_DATA_1 ((x), (data)))
+
+#define SCM_SMOB_OBJECT_N(x,n) (SCM_CELL_OBJECT ((x), (n)))
+#define SCM_SET_SMOB_OBJECT_N(x,n,obj) (SCM_SET_CELL_OBJECT ((x), (n), (obj)))
+#define SCM_SMOB_OBJECT_N_LOC(x,n) (SCM_CELL_OBJECT_LOC ((x), (n)))
+
+/*#define SCM_SMOB_OBJECT_0(x) (SCM_SMOB_OBJECT_N ((x), 0))*/
+#define SCM_SMOB_OBJECT_1(x) (SCM_SMOB_OBJECT_N ((x), 1))
+#define SCM_SMOB_OBJECT_2(x) (SCM_SMOB_OBJECT_N ((x), 2))
+#define SCM_SMOB_OBJECT_3(x) (SCM_SMOB_OBJECT_N ((x), 3))
+/*#define SCM_SET_SMOB_OBJECT_0(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 0,
(obj)))*/
+#define SCM_SET_SMOB_OBJECT_1(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 1, (obj)))
+#define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 2, (obj)))
+#define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 3, (obj)))
+#define SCM_SMOB_OBJECT_0_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 0)))
+#define SCM_SMOB_OBJECT_1_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 1)))
+#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 2)))
+#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 3)))
+
+#define SCM_SMOB_OBJECT(x) (SCM_SMOB_OBJECT_1 (x))
+#define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_SMOB_OBJECT_1 ((x), (obj)))
+#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x)))
+
+
+#define SCM_SMOB_TYPE_MASK 0xffff
+#define SCM_SMOB_TYPE_BITS(tc) (tc)
#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
/* SCM_SMOBNAME can be 0 if name is missing */
@@ -159,7 +181,6 @@ while (0)
SCM_API long scm_numsmob;
SCM_API scm_smob_descriptor scm_smobs[];
-SCM_API void scm_i_set_smob_flags (SCM x, scm_t_bits data);
SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR data);
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index b57fc32..8ea7bf7 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -75,11 +75,11 @@ SCM scm_source_whash;
#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
-#define SRCPROPPOS(p) (SCM_CELL_WORD(p,1))
+#define SRCPROPPOS(p) (SCM_SMOB_DATA(p))
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
-#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
-#define SRCPROPALIST(p) (SCM_CELL_OBJECT_3(p))
+#define SRCPROPCOPY(p) (SCM_SMOB_OBJECT_2(p))
+#define SRCPROPALIST(p) (SCM_SMOB_OBJECT_3(p))
#define SETSRCPROPBRK(p) \
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
@@ -87,11 +87,11 @@ SCM scm_source_whash;
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
-#define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c)))
+#define SETSRCPROPPOS(p, l, c) (SCM_SET_SMOB_DATA_1 (p, SRCPROPMAKPOS (l, c)))
#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
-#define SETSRCPROPCOPY(p, c) (SCM_SET_CELL_WORD(p, 2, c))
-#define SETSRCPROPALIST(p, l) (SCM_SET_CELL_WORD(p, 3, l))
+#define SETSRCPROPCOPY(p, c) (SCM_SET_SMOB_OBJECT_2 (p, c))
+#define SETSRCPROPALIST(p, l) (SCM_SET_SMOB_OBJECT_3 (p, l))
static SCM scm_srcprops_to_alist (SCM obj);
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index b247991..45b9de0 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -65,9 +65,9 @@ int scm_tc16_uvec = 0;
- The vector's length (counted in elements).
- The address of the data area (holding the elements of the
vector). */
-#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u))
-#define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
-#define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u))
+#define SCM_UVEC_TYPE(u) (SCM_SMOB_DATA_1(u))
+#define SCM_UVEC_LENGTH(u) ((size_t)SCM_SMOB_DATA_2(u))
+#define SCM_UVEC_BASE(u) ((void *)SCM_SMOB_DATA_3(u))
/* Symbolic constants encoding the various types of uniform
@@ -883,7 +883,8 @@ uvec_get_handle (SCM v, scm_t_array_handle *h)
h->elements = h->writable_elements = SCM_UVEC_BASE (v);
}
-SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_uvec),
+ SCM_SMOB_TYPE_MASK,
uvec_handle_ref, uvec_handle_set,
uvec_get_handle);
diff --git a/libguile/struct.c b/libguile/struct.c
index cd2c441..321f2f1 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -21,6 +21,8 @@
# include <config.h>
#endif
+#include <alloca.h>
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
@@ -52,6 +54,10 @@ static SCM required_vtable_fields = SCM_BOOL_F;
static SCM required_applicable_fields = SCM_BOOL_F;
static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
SCM scm_struct_table = SCM_BOOL_F;
+SCM scm_applicable_struct_vtable_vtable;
+SCM scm_applicable_struct_with_setter_vtable_vtable;
+SCM scm_standard_vtable_vtable;
+
SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
@@ -206,12 +212,14 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
static void
-scm_struct_init (SCM handle, SCM layout, int tail_elts, SCM inits)
+scm_struct_init (SCM handle, SCM layout, size_t n_tail,
+ size_t n_inits, scm_t_bits *inits)
{
scm_t_wchar prot = 0;
int n_fields = scm_i_symbol_length (layout) / 2;
int tailp = 0;
int i;
+ size_t inits_idx = 0;
scm_t_bits *mem = SCM_STRUCT_DATA (handle);
i = -2;
@@ -225,60 +233,35 @@ scm_struct_init (SCM handle, SCM layout, int tail_elts,
SCM inits)
{
tailp = 1;
prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = tail_elts;
- n_fields += tail_elts - 1;
+ *mem++ = (scm_t_bits)n_tail;
+ n_fields += n_tail - 1;
if (n_fields == 0)
break;
}
}
switch (scm_i_symbol_ref (layout, i))
{
-#if 0
- case 'i':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *mem = 0;
- else
- {
- *mem = scm_to_long (SCM_CAR (inits));
- inits = SCM_CDR (inits);
- }
- break;
-#endif
-
case 'u':
- if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
*mem = 0;
else
{
- *mem = scm_to_ulong (SCM_CAR (inits));
- inits = SCM_CDR (inits);
+ *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
+ inits_idx++;
}
break;
case 'p':
- if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
*mem = SCM_UNPACK (SCM_BOOL_F);
else
{
- *mem = SCM_UNPACK (SCM_CAR (inits));
- inits = SCM_CDR (inits);
+ *mem = inits[inits_idx];
+ inits_idx++;
}
break;
-#if 0
- case 'd':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *((double *)mem) = 0.0;
- else
- {
- *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
- inits = SCM_CDR (inits);
- }
- fields_desc += 2;
- break;
-#endif
-
case 's':
*mem = SCM_UNPACK (handle);
break;
@@ -338,7 +321,7 @@ struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
points to the given vtable data, then a data pointer, then n_words of data.
*/
SCM
-scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what)
+scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
{
scm_t_bits ret;
ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2),
"struct");
@@ -363,40 +346,20 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words,
const char *what)
}
-SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
- (SCM vtable, SCM tail_array_size, SCM init),
- "Create a new structure.\n\n"
- "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
- "@var{tail-elts} must be a non-negative integer. If the layout\n"
- "specification indicated by @var{type} includes a tail-array,\n"
- "this is the number of elements allocated to that array.\n\n"
- "The @var{init1}, @dots{} are optional arguments describing how\n"
- "successive fields of the structure should be initialized. Only
fields\n"
- "with protection 'r' or 'w' can be initialized, except for fields
of\n"
- "type 's', which are automatically initialized to point to the
new\n"
- "structure itself. Fields with protection 'o' can not be
initialized by\n"
- "Scheme programs.\n\n"
- "If fewer optional arguments than initializable fields are
supplied,\n"
- "fields of type 'p' get default value #f while fields of type 'u'
are\n"
- "initialized to 0.\n\n"
- "For more information, see the documentation for
@code{make-vtable-vtable}.")
-#define FUNC_NAME s_scm_make_struct
+SCM
+scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init)
+#define FUNC_NAME "make-struct"
{
SCM layout;
size_t basic_size;
- size_t tail_elts;
SCM obj;
SCM_VALIDATE_VTABLE (1, vtable);
- SCM_VALIDATE_REST_ARGUMENT (init);
layout = SCM_VTABLE_LAYOUT (vtable);
basic_size = scm_i_symbol_length (layout) / 2;
- tail_elts = scm_to_size_t (tail_array_size);
- /* A tail array is only allowed if the layout fields string ends in "R",
- "W" or "O". */
- if (tail_elts != 0)
+ if (n_tail != 0)
{
SCM layout_str, last_char;
@@ -413,10 +376,9 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
goto bad_tail;
}
- obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
- "struct");
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + n_tail);
- scm_struct_init (obj, layout, tail_elts, init);
+ scm_struct_init (obj, layout, n_tail, n_init, init);
/* only check things and inherit magic if the layout was passed as an
initarg.
something of a hack, but it's for back-compatibility. */
@@ -428,6 +390,70 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
}
#undef FUNC_NAME
+SCM
+scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init,
...)
+{
+ va_list foo;
+ scm_t_bits *v;
+ size_t i;
+
+ v = alloca (sizeof (scm_t_bits) * n_init);
+
+ va_start (foo, init);
+ for (i = 0; i < n_init; i++)
+ {
+ v[i] = init;
+ init = va_arg (foo, scm_t_bits);
+ }
+ va_end (foo);
+
+ return scm_c_make_structv (vtable, n_tail, n_init, v);
+}
+
+SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
+ (SCM vtable, SCM tail_array_size, SCM init),
+ "Create a new structure.\n\n"
+ "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "@var{tail-elts} must be a non-negative integer. If the layout\n"
+ "specification indicated by @var{type} includes a tail-array,\n"
+ "this is the number of elements allocated to that array.\n\n"
+ "The @var{init1}, @dots{} are optional arguments describing how\n"
+ "successive fields of the structure should be initialized. Only
fields\n"
+ "with protection 'r' or 'w' can be initialized, except for fields
of\n"
+ "type 's', which are automatically initialized to point to the
new\n"
+ "structure itself. Fields with protection 'o' can not be
initialized by\n"
+ "Scheme programs.\n\n"
+ "If fewer optional arguments than initializable fields are
supplied,\n"
+ "fields of type 'p' get default value #f while fields of type 'u'
are\n"
+ "initialized to 0.\n\n"
+ "For more information, see the documentation for
@code{make-vtable-vtable}.")
+#define FUNC_NAME s_scm_make_struct
+{
+ size_t i, n_init;
+ long ilen;
+ scm_t_bits *v;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen;
+
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
+ else
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
+
+ for (i = 0; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
+
+ return scm_c_make_structv (vtable, scm_to_size_t (tail_array_size), n_init,
v);
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
@@ -481,31 +507,48 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
SCM fields;
SCM layout;
size_t basic_size;
- size_t tail_elts;
+ size_t n_tail, i, n_init;
SCM obj;
+ long ilen;
+ scm_t_bits *v;
SCM_VALIDATE_STRING (1, user_fields);
- SCM_VALIDATE_REST_ARGUMENT (init);
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen + 1; /* + 1 for the layout */
+
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
+ else
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
fields = scm_string_append (scm_list_2 (required_vtable_fields,
user_fields));
layout = scm_make_struct_layout (fields);
basic_size = scm_i_symbol_length (layout) / 2;
- tail_elts = scm_to_size_t (tail_array_size);
+ n_tail = scm_to_size_t (tail_array_size);
+
+ i = 0;
+ v[i++] = SCM_UNPACK (layout);
+ for (; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
+
SCM_CRITICAL_SECTION_START;
- obj = scm_i_alloc_struct (NULL, basic_size + tail_elts, "struct");
+ obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
/* magic magic magic */
SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) |
scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
- scm_struct_init (obj, layout, tail_elts, scm_cons (layout, init));
+ scm_struct_init (obj, layout, n_tail, n_init, v);
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
return obj;
}
#undef FUNC_NAME
-static SCM scm_i_vtable_vtable_no_extra_fields;
-
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
"Create a vtable, for creating structures with the given\n"
@@ -519,7 +562,7 @@ SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
if (SCM_UNBNDP (printer))
printer = SCM_BOOL_F;
- return scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ return scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_2 (scm_make_struct_layout (fields),
printer));
}
@@ -856,9 +899,6 @@ scm_print_struct (SCM exp, SCM port, scm_print_state
*pstate)
void
scm_init_struct ()
{
- SCM scm_applicable_struct_vtable_vtable;
- SCM scm_applicable_struct_with_setter_vtable_vtable;
-
GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)); /* for the self data
pointer */
GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)
+ scm_tc3_struct); /* for the vtable data pointer
*/
@@ -868,18 +908,18 @@ scm_init_struct ()
required_applicable_fields = scm_from_locale_string
(SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string
(SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
- scm_i_vtable_vtable_no_extra_fields =
+ scm_standard_vtable_vtable =
scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
scm_applicable_struct_vtable_vtable =
- scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_make_struct_layout
(required_vtable_fields)));
SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
scm_c_define ("<applicable-struct-vtable>",
scm_applicable_struct_vtable_vtable);
scm_applicable_struct_with_setter_vtable_vtable =
- scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_make_struct_layout
(required_vtable_fields)));
SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE |
SCM_VTABLE_FLAG_SETTER_VTABLE);
diff --git a/libguile/struct.h b/libguile/struct.h
index 5955e59..537ef90 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -81,7 +81,7 @@
#define SCM_VTABLE_FLAG_SETTER (1L << 4) /* instances of this vtable are
applicable-with-setters? */
#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 5)
#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 6)
-#define SCM_VTABLE_FLAG_RESERVED_2 (1L << 7)
+#define SCM_VTABLE_FLAG_SMOB_0 (1L << 7)
#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 8)
#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 9)
#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 10)
@@ -110,8 +110,10 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_SET_VTABLE_FLAGS(X,F) (SCM_STRUCT_DATA_REF (X,
scm_vtable_index_flags) |= (F))
#define SCM_CLEAR_VTABLE_FLAGS(X,F) (SCM_STRUCT_DATA_REF (X,
scm_vtable_index_flags) &= (~(F)))
#define SCM_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_DATA_REF (X,
scm_vtable_index_flags) & (F))
-#define SCM_VTABLE_INSTANCE_FINALIZER(X)
((scm_t_struct_finalize)SCM_STRUCT_SLOT_REF (X,
scm_vtable_index_instance_finalize))
+#define SCM_VTABLE_INSTANCE_FINALIZER(X)
((scm_t_struct_finalize)SCM_STRUCT_DATA_REF (X,
scm_vtable_index_instance_finalize))
+#define SCM_SET_VTABLE_INSTANCE_FINALIZER(X,P) (SCM_STRUCT_DATA_SET (X,
scm_vtable_index_instance_finalize, (scm_t_bits)(P)))
#define SCM_VTABLE_INSTANCE_PRINTER(X) (SCM_STRUCT_SLOT_REF (X,
scm_vtable_index_instance_printer))
+#define SCM_SET_VTABLE_INSTANCE_PRINTER(X,P) (SCM_STRUCT_SLOT_SET (X,
scm_vtable_index_instance_printer, (P)))
#define SCM_VTABLE_NAME(X) (SCM_STRUCT_SLOT_REF (X,
scm_vtable_index_name))
#define SCM_SET_VTABLE_NAME(X,V) (SCM_STRUCT_SLOT_SET (X,
scm_vtable_index_name, V))
@@ -141,12 +143,20 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
SCM_API SCM scm_struct_table;
+SCM_API SCM scm_standard_vtable_vtable;
+SCM_API SCM scm_applicable_struct_vtable_vtable;
+SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable;
+
SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x);
SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
+SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
+ scm_t_bits init, ...);
+SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
+ scm_t_bits init[]);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM
init);
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
@@ -160,7 +170,7 @@ SCM_API void scm_print_struct (SCM exp, SCM port,
scm_print_state *);
SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
-SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words,
const char *what);
+SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words);
SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
SCM_INTERNAL void scm_init_struct (void);
diff --git a/libguile/throw.c b/libguile/throw.c
index 051f6d3..fd08e6e 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -54,16 +54,14 @@ static scm_t_bits tc16_jmpbuffer;
#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
-#define ACTIVATEJB(x) \
- (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
-#define DEACTIVATEJB(x) \
- (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
+#define JBACTIVE(OBJ) (SCM_SMOB_FLAGS (OBJ) & 1L)
+#define ACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 1L))
+#define DEACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 0L))
-#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
-#define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
-#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3
(x))
-#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
+#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_SMOB_DATA_1 (OBJ))
+#define SETJBJMPBUF(x, v) (SCM_SET_SMOB_DATA_1 ((x), (scm_t_bits) (v)))
+#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_SMOB_DATA_3
(x))
+#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_SMOB_DATA_3 ((x), (scm_t_bits) (v)))
static int
jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
@@ -269,7 +267,7 @@ static scm_t_bits tc16_pre_unwind_data;
static int
pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate
SCM_UNUSED)
{
- struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1
(closure);
+ struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_SMOB_DATA_1
(closure);
char buf[200];
sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
@@ -783,7 +781,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
else
{
struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
if (!c->running)
break;
}
@@ -816,7 +814,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
if (SCM_PRE_UNWIND_DATA_P (jmpbuf))
{
struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
SCM handle, answer;
/* For old-style lazy-catch behaviour, we unwind the dynamic
diff --git a/libguile/validate.h b/libguile/validate.h
index 0945658..b0e502a 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -278,7 +278,7 @@
#define SCM_VALIDATE_SMOB(pos, obj, type) \
do { \
- SCM_ASSERT (SCM_TYP16_PREDICATE (scm_tc16_ ## type, obj), \
+ SCM_ASSERT (SCM_SMOB_PREDICATE (scm_tc16_ ## type, obj), \
obj, pos, FUNC_NAME); \
} while (0)
diff --git a/libguile/vm.h b/libguile/vm.h
index 8ec2682..9479ba7 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -99,7 +99,7 @@ struct scm_vm_cont {
SCM_API scm_t_bits scm_tc16_vm_cont;
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
+#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_SMOB_DATA_1 (CONT))
SCM_API SCM scm_vm_capture_continuations (void);
SCM_API void scm_vm_reinstate_continuations (SCM conts);
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-5-129-g7230aaf,
Andy Wingo <=