[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-41-g285
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-41-g2858dea |
|
Date: |
Wed, 25 Nov 2009 23:27:44 +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=2858deaf47f339eff71574e42536f8d6955fb5a9
The branch, master has been updated
via 2858deaf47f339eff71574e42536f8d6955fb5a9 (commit)
via 71fc6438934cf275d2a16b6317119787a6bc23b9 (commit)
via eb721b3b1032d450be7c65955b266cce76cf1062 (commit)
via c06e3eb0c23926b02af5269bb956ad0fdd275187 (commit)
via 9022ff183c44976b7f28503f9f78c523b578846a (commit)
via 5bdea5bd3de9a592e91c194d73bfd0681894a2ca (commit)
via 2f652c6884d2ae58b4177fef2f306f0312e7b347 (commit)
via 9f63ce021c567056c02b81d96742ff91416b886f (commit)
via 72d2e7e65f1895df9c527e792a05674d02dcac9a (commit)
via 2c38adf863f3aa378d1d37d907d493bc76204c47 (commit)
via 51f66c912078a25ab0380c8fc070abb73d178d98 (commit)
via e29db33c14bc2cb21b7c044fcd0d61a68ad150bb (commit)
via cfe55d3e819930e5aaaf9fd94c4495fe9f15ed4a (commit)
via ab455d1f1b14347e1445161eeafec919235af92e (commit)
via a9a90a8820e6f6a36d0f17cdca5f8ba0d7ca735b (commit)
via 2aecf4cfe22962118e945a9a4b6ab52e063a7119 (commit)
via c40944c9ff4f22ccae7c54628bf0057d9a0032f2 (commit)
via 6d33e90f0ccf96f5a9f6403768daf24f84481046 (commit)
via 0f84ac3fe6da365c9580ea2d475c4fb8fa58b1a7 (commit)
via b6cf4d026506b8e5042671f7503d4d9e9a810d49 (commit)
from 9bd48cb17b4ce685f94f974442d452485a1017d6 (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 2858deaf47f339eff71574e42536f8d6955fb5a9
Author: Andy Wingo <address@hidden>
Date: Thu Nov 26 00:13:53 2009 +0100
header tidyings
* libguile/goops.h:
* libguile/struct.h: c-backslash-region some vars.
commit 71fc6438934cf275d2a16b6317119787a6bc23b9
Author: Andy Wingo <address@hidden>
Date: Thu Nov 26 00:12:12 2009 +0100
brace placement fixes
* libguile/goops.c (scm_sys_allocate_instance):
* libguile/vm-i-loader.c (load-wide-string): Fix some brace placements.
commit eb721b3b1032d450be7c65955b266cce76cf1062
Author: Andy Wingo <address@hidden>
Date: Fri Nov 20 17:25:13 2009 +0100
push goops compile delay out to 30 invocations, for great justice
* module/oop/goops/dispatch.scm (timer-init): Init to 30 for faster
goops load time.
commit c06e3eb0c23926b02af5269bb956ad0fdd275187
Author: Andy Wingo <address@hidden>
Date: Fri Nov 20 13:42:13 2009 +0100
generic method cache begone
* libguile/goops.h (SCM_GENERIC_METHOD_CACHE)
(SCM_SET_GENERIC_METHOD_CACHE, scm_si_generic_cache)
* libguile/goops.c (create_standard_classes): Remove slot for generic
method cache. Yay!
commit 9022ff183c44976b7f28503f9f78c523b578846a
Author: Andy Wingo <address@hidden>
Date: Fri Nov 20 13:31:07 2009 +0100
remove code that manages the method cache
* libguile/goops.h (SCM_MCACHE_N_SPECIALIZED)
(SCM_SET_MCACHE_N_SPECIALIZED, SCM_INITIAL_MCACHE_SIZE)
(scm_make_method_cache, scm_memoize_method, scm_mcache_lookup_cmethod)
(scm_mcache_compute_cmethod):
* libguile/goops.c: Remove these procedures which managed the method
cache. There's still a slot there but it's not initialized. The method
cache is no longer necessary.
* module/oop/goops/dispatch.scm (memoize-method!): Change to not take a
"cache" argument.
* libguile/eval.i.c:
* libguile/vm-i-system.c: Remove dispatch via the method cache.
commit 5bdea5bd3de9a592e91c194d73bfd0681894a2ca
Author: Andy Wingo <address@hidden>
Date: Fri Nov 20 13:18:07 2009 +0100
remove method cache management code from (oop goops dispatch)
* module/oop/goops/dispatch.scm: Remove old method cache things.
commit 2f652c6884d2ae58b4177fef2f306f0312e7b347
Author: Andy Wingo <address@hidden>
Date: Fri Nov 20 13:11:52 2009 +0100
generics now dispatch as applicable structs
* libguile/eval.i.c (CEVAL, SCM_APPLY): Dispatch applicable structs
before pure generics. In practice what this means is that we never hit
the mcache case, because all pure generics are applicable structs.
We're moving over to having generics dispatch themselves. Also, they
don't prepend the struct as an arg; in order to have that effect, the
user has closures.
* libguile/goops.c (scm_apply_generic, scm_call_generic_0):
(scm_call_generic_1, scm_call_generic_2, scm_call_generic_3): Dispatch
directly to the struct procedures.
(scm_var_make_extended_generic): Remove a duplicate definition for
scm_var_make_extended_generic.
(create_standard_classes): Mark all instances of
<applicable-struct-class> (themselves classes) as applicable classes.
Meaning: generics are now applicable structs.
* libguile/goops.h (SCM_CLASS_CLASS_LAYOUT): The hashsets are actually
uw slots -- or at least, making subclasses maps the int slots to be uw
slots
* libguile/vm-i-system.c (call, goto/args, mv-call): Dispatch applicable
structs in the VM.
* module/oop/goops/dispatch.scm (emit-linear-dispatch): Fix bug in the
non-rest cache miss case.
(delayed-compile): Rework to avoid fluids.
(cache-dispatch): Don't call `equal?', it causes bootstrapping
problems with the primitive-generic equal?. Using our own version is
faster anyway.
commit 9f63ce021c567056c02b81d96742ff91416b886f
Author: Andy Wingo <address@hidden>
Date: Sun Nov 8 11:49:06 2009 +0100
make sure that when equal? is extended, that the generic has a method
* libguile/goops.h:
* libguile/goops.c (scm_set_primitive_generic_x): New function, for now
local to the goops module.
* module/oop/goops.scm (equal?): Make sure that when equal? is extended,
that the generic already has a default method.
commit 72d2e7e65f1895df9c527e792a05674d02dcac9a
Author: Andy Wingo <address@hidden>
Date: Sun Nov 8 11:34:30 2009 +0100
remove cache-mutex slot from generics
* libguile/goops.c:
* libguile/goops.h: Remove cache-mutex slot from generics, and renumber
other slots.
commit 2c38adf863f3aa378d1d37d907d493bc76204c47
Author: Andy Wingo <address@hidden>
Date: Sun Nov 8 11:29:48 2009 +0100
remove locking in method memoization
* libguile/goops.c (scm_memoize_method): Don't lock around method
memoization, as the new protocol will be reeentrant and lock-free.
commit 51f66c912078a25ab0380c8fc070abb73d178d98
Author: Andy Wingo <address@hidden>
Date: Sun Nov 8 11:24:23 2009 +0100
limn goops flags, remove foreign objs, rename entity to applicable-struct
* libguile/goops.c (scm_class_applicable_struct)
(scm_class_applicable_struct_with_setter)
(scm_class_applicable_struct_class): Rename from
scm_class_entity, scm_class_entity_with_setter, and
scm_class_entity_class.
(scm_class_simple_method): Removed; this abstraction is not used.
(scm_class_foreign_class, scm_class_foreign_object): Remove these,
they are undocumented and unused. They might come back later.
(scm_sys_inherit_magic_x): Simply inherit the vtable flags from the
class's class. Flags are about layout, and it is the class that
determines the layout of the instance.
(scm_basic_basic_make_class): Don't bother setting GOOPS_OR_VALID,
inherit-magic will do that.
(scm_basic_make_class): Inherit magic after setting the layout. Allows
the struct magic checker to do its job.
(scm_accessor_method_slot_definition): Move implementation to Scheme.
Removes the need for the accessor flag.
(scm_sys_allocate_instance): Adapt to scm_i_alloc_struct name change,
and that alloc-struct will handle finalization.
(scm_compute_applicable_methods): Remove accessor check, as it's
unnecessary.
(scm_make): Adapt to new generic slot order, and no more
simple-method.
(create_standard_classes): What was the GF slot "dispatch-procedure"
is now the applicable-struct slot "procedure". No more foreign class,
foreign object, or simple method. Rename <entity> and friends to
<applicable-struct> and friends. No more entity-with-setter -- though
perhaps it will come back too. Instead generic-with-setter is its own
thing.
* libguile/goops.h (SCM_CLASSF_METACLASS): "A goops class that is a
vtable" -- no need for a separate flag.
(SCM_CLASSF_FOREIGN, SCM_CLASSF_SIMPLE_METHOD)
(SCM_CLASSF_ACCESSOR_METHOD): Removed these unused flags.
(SCM_ACCESSORP): Removed.
Renumber generic slots, rename entity classes, and remove the foreign
class, foreign object, and simple method classes.
* libguile/struct.c (scm_i_struct_inherit_vtable_magic): New function,
called when making new vtables.applicable structs
(scm_i_alloc_struct): Remove 8-bit alignment check, as libGC
guarantees this for us. Handle finalizer registration here.
(scm_make_struct): Factor some things to scm_i_alloc_struct and
scm_i_struct_inherit_vtable_magic.
(scm_make_vtable_vtable): Adapt to scm_i_alloc_struct name change.
* libguile/struct.h (scm_i_alloc_struct): Change name from
scm_alloc_struct, and make internal.
* module/oop/goops.scm (oop): Don't declare #:replace <class> et al,
because <class> isn't defined in the core any more.
(accessor-method-slot-definition): Defined in Scheme now.
Remove <foreign-object> methods.
(initialize on <class>): Prep layout before inheriting magic, as in
scm_basic_make_class.
* module/oop/goops/dispatch.scm (delayed-compile)
(memoize-effective-method!): Adapt to 'procedure slot name change.
commit e29db33c14bc2cb21b7c044fcd0d61a68ad150bb
Author: Andy Wingo <address@hidden>
Date: Fri Nov 6 17:17:33 2009 +0100
%invalidate-method-cache invalidates the dispatch procedure too
* libguile/goops.c (make_dispatch_procedure, clear_method_cache):
Properly reset the dispatch procedure.
commit cfe55d3e819930e5aaaf9fd94c4495fe9f15ed4a
Author: Andy Wingo <address@hidden>
Date: Fri Nov 6 11:25:50 2009 +0100
generic dispatch protocol in scheme, not yet wired up
* module/oop/goops/dispatch.scm: Add a dispatch protocol in Scheme. The
idea is that instead of using a hardcoded C protocol, we compile
dispatch procedures at runtime. To avoid too much thrashing at bootup,
there is a simple JIT mechanism -- dispatch will be data-driven,
through the cache, for the first 5 invocations, then a dispatch
procedure will be compiled from the cache.
My initial timings indicate that interpreted dispatch takes about
100us, and that compiled dispatch takes about 60us. Compilation itself
takes about 16000us (16 ms). The compiled procedure dispatch times
will improve soon, hopefully.
commit ab455d1f1b14347e1445161eeafec919235af92e
Author: Andy Wingo <address@hidden>
Date: Fri Nov 6 10:27:19 2009 +0100
eqv? not a generic, equal? dispatches to generic only for objects
* libguile/eq.c (scm_eqv_p): Not a generic any more. Since eqv? is used
by e.g. `case', which should be able to compile into dispatch tables,
it really doesn't make sense to dispatch out to a generic.
(scm_equal_p): So it was always the case that (equal? 'foo "foo") =>
#f. But (equal? 'foo 'bar) could actually be extended by a generic.
This was a bug, if you follow the other logic of the code. Changed so
that generic functions can only extend the domain of equal? when
operating on goops objects.
* oop/goops.scm: No more eqv? generic.
* test-suite/tests/goops.test: Remove eqv? tests.
commit a9a90a8820e6f6a36d0f17cdca5f8ba0d7ca735b
Author: Andy Wingo <address@hidden>
Date: Thu Nov 5 17:35:44 2009 +0100
generic tweaks; realizing what the setter slot actually is
* libguile/goops.h (scm_si_dispatch_procedure)
(scm_si_effective_methods): Rename the new generics slots to
"effective-methods" and "dispatch-procedure".
(scm_si_generic_setter): Rename this one from "%setter" to "setter",
and it's not a cache -- it's a pointer to the setter, which is also a
generic. I didn't realize that before. It's better this way (like it
always was.)
(SCM_SET_GENERIC_DISPATCH_PROCEDURE)
(SCM_CLEAR_GENERIC_EFFECTIVE_METHODS): New helper macros.
* libguile/goops.c (clear_method_cache): Clear the new dispatch
procedure and the effective methods as well.
(create_standard_classes): Rename slots, and fix the setter slots.
commit 2aecf4cfe22962118e945a9a4b6ab52e063a7119
Author: Andy Wingo <address@hidden>
Date: Thu Nov 5 13:16:40 2009 +0100
more clarity in (oop goops dispatch)
* module/oop/goops/dispatch.scm (memoize-method!): If we don't have a
no-applicable-method, just call no-applicable-method directly.
* test-suite/tests/goops.test ("no-applicable-method"): Add some tests.
commit c40944c9ff4f22ccae7c54628bf0057d9a0032f2
Author: Andy Wingo <address@hidden>
Date: Thu Nov 5 12:54:41 2009 +0100
remove code-table slot from methods
* libguile/goops.c (scm_sys_invalidate_method_cache_x, scm_make)
(create_standard_classes): Remove code-table slot from methods. The
generic cache completely does its job, afaict.
* libguile/goops.h (scm_si_formals, scm_si_body, scm_si_make_procedure):
Renumber slots.
* module/oop/goops.scm (initialize on <method>): No more code-table
slot.
* module/oop/goops/compile.scm: Always "compile" a method, instead of
looking for a hit in an always-empty cache.
commit 6d33e90f0ccf96f5a9f6403768daf24f84481046
Author: Andy Wingo <address@hidden>
Date: Thu Nov 5 12:41:54 2009 +0100
remove used-by slot from generics
* libguile/goops.c (clear_method_cache)
(scm_sys_invalidate_method_cache_x, scm_make)
(create_standard_classes): Remove the used-by method from generics, as
it is not used at all.
* libguile/goops.h: Renumber generic slots.
* module/oop/goops/dispatch.scm (memoize-method!): No more used-by slot.
commit 0f84ac3fe6da365c9580ea2d475c4fb8fa58b1a7
Author: Andy Wingo <address@hidden>
Date: Thu Nov 5 11:32:16 2009 +0100
first step towards effective methods
* libguile/goops.c (create_standard_classes):
* libguile/goops.h *scm_si_applicable_methods, scm_si_effective_method)
(scm_si_applicable_setter_methods, scm_si_effective_setter_method):
Add space for the new form of the generic cache and effective method.
commit b6cf4d026506b8e5042671f7503d4d9e9a810d49
Author: Andy Wingo <address@hidden>
Date: Tue Nov 3 23:59:51 2009 +0100
a very big commit cleaning up structs & goops. also applicable structs.
I tried to split this one, and I know it's a bit disruptive, but this
stuff really is one big cobweb. So instead we'll pretend like these are
separate commits, by separating the changelog.
Applicable struct runtime support.
* libguile/debug.c (scm_procedure_source):
* libguile/eval.c (scm_trampoline_0, scm_trampoline_1)
(scm_trampoline_2):
* libguile/eval.i.c (CEVAL):
* libguile/goops.c (scm_class_of):
* libguile/procprop.c (scm_i_procedure_arity):
* libguile/procs.c (scm_procedure_p, scm_procedure, scm_setter): Allow
for applicable structs. Whee!
* libguile/deprecated.h (scm_vtable_index_vtable): Define as a synonym
for scm_vtable_index_self.
(scm_vtable_index_printer): Alias scm_vtable_index_instance_printer.
(scm_struct_i_free): Alias scm_vtable_index_instance_finalize.
(scm_struct_i_flags): Alias scm_vtable_index_flags.
(SCM_STRUCTF_FLAGS): Be a -1 mask, we have a whole word now.
(SCM_SET_VTABLE_DESTRUCTOR): Implement by hand.
Hidden slots.
* libguile/struct.c (scm_make_struct_layout): Add support for "hidden"
fields, writable fields that are not visible to make-struct. This
allows us to add fields to vtables and not break existing make-struct
invocations.
(scm_struct_ref, scm_struct_set_x): Always get struct length from the
vtable. Support hidden fields.
* libguile/goops.c (scm_class_hidden, scm_class_protected_hidden): New
slot classes, to correspond to the new vtable slots.
(scm_sys_prep_layout_x): Turn hidden slots into 'h'.
(build_class_class_slots): Reorder the class slots to account for
vtable fields coming out of negative-land, for name as a vtable slot,
and for hidden fields.
(create_standard_classes): Define <hidden-slot> and
<protected-hidden-slot>.
Clean up struct.h.
* libguile/struct.h: Lay things out cleaner. There are no more hidden
(negative) words. Names are nicer. The exposition is nicer. But the
basics are the same. The incompatibilities are that <vtable> has more
slots now, and that scm_alloc_struct's signature has changed. The
former is ameliorated by the "hidden" slots mentioned before, and the
latter, well, it was always a very internal thing...
(scm_t_struct_finalize): New type, a finalizer function to be run when
instances of a vtable are collected.
(scm_t_struct_free): Removed, structs' data is managed by the GC now,
and not freed by vtable functions.
* libguile/struct.c: (scm_vtable_p): Now we keep flags on
vtable-vtables, so this check is cheaper.
(scm_alloc_struct): No hidden words. Yippee.
(struct_finalizer_trampoline): Entersify.
(scm_make_struct): No need to babysit extra words, though now we have
to babysit flags. Propagate the vtable, applicable, and setter flags
appropriately.
(scm_make_vtable_vtable): Update for new simplicity.
(scm_print_struct): A better printer.
(scm_init_struct): Define <applicable-struct-vtable>, a magical vtable
like CL's funcallable-standard-class. Also define
<applicable-struct-with-setter-vtable>.
Remove foreign object implementation.
* libguile/goops.h:
* libguile/goops.c (scm_make_foreign_object, scm_make_class)
(scm_add_slot, scm_wrap_object, scm_wrap_component): Remove, these
were undocumented and unworking.
Clean up goops.h, a little.
* libguile/goops.h:
* libguile/goops.c: Also clean up.
* module/oop/goops/dispatch.scm (hashset-index): Adapt for new hashset
index.
-----------------------------------------------------------------------
Summary of changes:
libguile/debug.c | 5 +-
libguile/deprecated.h | 9 +
libguile/eq.c | 26 +-
libguile/eval.c | 6 +
libguile/eval.i.c | 126 ++-------
libguile/goops.c | 651 +++++++----------------------------------
libguile/goops.h | 199 ++++++-------
libguile/procprop.c | 9 +-
libguile/procs.c | 16 +-
libguile/struct.c | 393 +++++++++++++------------
libguile/struct.h | 153 +++++++---
libguile/vm-i-loader.c | 3 +-
libguile/vm-i-system.c | 30 +--
module/oop/goops.scm | 50 ++--
module/oop/goops/compile.scm | 30 +--
module/oop/goops/dispatch.scm | 443 ++++++++++++++--------------
test-suite/tests/goops.test | 35 ++-
17 files changed, 855 insertions(+), 1329 deletions(-)
diff --git a/libguile/debug.c b/libguile/debug.c
index a6de84a..53eb16b 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -355,7 +355,10 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1,
0, 0,
}
}
case scm_tcs_struct:
- if (!(SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC))
+ if (!SCM_STRUCT_APPLICABLE_P (proc))
+ break;
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ if (SCM_IMP (proc))
break;
goto procprop;
case scm_tc7_smob:
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 7228a84..cad1454 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -92,6 +92,15 @@ SCM_DEPRECATED const char scm_s_formals[];
: scm_i_eval_x (SCM_CAR (x), (env)))
+/* From structs.h:
+ Deprecated in Guile 1.9.5 on 2009-11-03. */
+#define scm_vtable_index_vtable scm_vtable_index_self
+#define scm_vtable_index_printer scm_vtable_index_instance_printer
+#define scm_struct_i_free scm_vtable_index_instance_finalize
+#define scm_struct_i_flags scm_vtable_index_flags
+#define SCM_STRUCTF_MASK ((scm_t_bits)-1)
+#define SCM_SET_VTABLE_DESTRUCTOR(X, D)
(SCM_STRUCT_DATA(x)[scm_struct_i_free]=(scm_t_bits)(D))
+
#define scm_substring_move_left_x scm_substring_move_x
#define scm_substring_move_right_x scm_substring_move_x
diff --git a/libguile/eq.c b/libguile/eq.c
index 2db4ac0..6cb9bc2 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -104,7 +104,7 @@ real_eqv (double x, double y)
}
#include <stdio.h>
-SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
+SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
"for characters and numbers the same value.\n"
@@ -173,10 +173,7 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
SCM_COMPLEX_IMAG (y)));
}
}
- if (SCM_UNPACK (g_scm_eqv_p))
- return scm_call_generic_2 (g_scm_eqv_p, x, y);
- else
- return SCM_BOOL_F;
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -294,13 +291,20 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?",
scm_tc7_rpsubr,
case scm_tc7_wvect:
return scm_i_vector_equal_p (x, y);
}
+ /* Check equality between structs of equal type (see cell-type test above).
*/
+ if (SCM_STRUCTP (x))
+ {
+ if (SCM_INSTANCEP (x))
+ goto generic_equal;
+ else
+ return scm_i_struct_equalp (x, y);
+ }
- /* Check equality between structs of equal type (see cell-type test above)
- that are not GOOPS instances. GOOPS instances are treated via the
- generic function. */
- if ((SCM_STRUCTP (x)) && (!SCM_INSTANCEP (x)))
- return scm_i_struct_equalp (x, y);
-
+ /* Otherwise just return false. Dispatching to the generic is the wrong thing
+ here, as we can hit this case for any two objects of the same type that we
+ think are distinct, like different symbols. */
+ return SCM_BOOL_F;
+
generic_equal:
if (SCM_UNPACK (g_scm_equal_p))
return scm_call_generic_2 (g_scm_equal_p, x, y);
diff --git a/libguile/eval.c b/libguile/eval.c
index df9e5ab..7152322 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -3269,6 +3269,8 @@ scm_trampoline_0 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_0;
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
+ trampoline = scm_call_0;
else
return NULL;
break;
@@ -3393,6 +3395,8 @@ scm_trampoline_1 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_1;
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
+ trampoline = scm_call_1;
else
return NULL;
break;
@@ -3488,6 +3492,8 @@ scm_trampoline_2 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_2;
+ else if (SCM_STRUCT_APPLICABLE_P (proc))
+ trampoline = scm_call_2;
else
return NULL;
break;
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index a28a25a..6811698 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -733,23 +733,6 @@ dispatch:
case (ISYMNUM (SCM_IM_DELAY)):
RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env)));
- /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
- code (type_dispatch) is intended to be the tail of the case
- clause for the internal macro SCM_IM_DISPATCH. Please don't
- remove it from this location without discussing it with Mikael
- <address@hidden> */
-
- /* The type dispatch code is duplicated below
- * (c.f. objects.c:scm_mcache_compute_cmethod) since that
- * cuts down execution time for type dispatch to 50%. */
- type_dispatch: /* inputs: x, arg1 */
- {
- proc = scm_mcache_compute_cmethod (x, arg1);
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
-
-
case (ISYMNUM (SCM_IM_SLOT_REF)):
x = SCM_CDR (x);
{
@@ -1026,24 +1009,14 @@ dispatch:
goto nontoplevel_begin;
}
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_GENERIC_METHOD_CACHE (proc);
- arg1 = SCM_EOL;
- goto type_dispatch;
- }
-#if 0
- else if (SCM_I_ENTITYP (proc))
- {
- arg1 = proc;
- proc = SCM_ENTITY_PROCEDURE (proc);
+ if (SCM_STRUCT_APPLICABLE_P (proc))
+ {
+ proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
- debug.info->a.proc = proc;
- debug.info->a.args = scm_list_1 (arg1);
+ debug.info->a.proc = proc;
#endif
- goto evap1;
+ goto evap0;
}
-#endif
else
goto badfun;
case scm_tc7_subr_1:
@@ -1155,29 +1128,14 @@ dispatch:
goto nontoplevel_begin;
}
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_GENERIC_METHOD_CACHE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_1 (arg1);
-#endif
- goto type_dispatch;
- }
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ if (SCM_STRUCT_APPLICABLE_P (proc))
{
- arg2 = arg1;
- arg1 = proc;
- proc = SCM_ENTITY_PROCEDURE (proc);
+ proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
debug.info->a.proc = proc;
#endif
- goto evap2;
+ goto evap1;
}
-#endif
else
goto badfun;
case scm_tc7_subr_2:
@@ -1236,35 +1194,23 @@ dispatch:
RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
#endif
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_GENERIC_METHOD_CACHE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_2 (arg1, arg2);
-#endif
- goto type_dispatch;
- }
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ if (SCM_STRUCT_APPLICABLE_P (proc))
{
operatorn:
#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_ENTITY_PROCEDURE (proc),
- scm_cons (proc, debug.info->a.args),
+ RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
+ debug.info->a.args,
SCM_EOL));
#else
- RETURN (SCM_APPLY (SCM_ENTITY_PROCEDURE (proc),
- scm_cons2 (proc, arg1,
- scm_cons (arg2,
- scm_ceval_args (x,
+ RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
+ scm_cons (arg1,
+ scm_cons (arg2,
+ scm_ceval_args (x,
env,
proc))),
SCM_EOL));
#endif
}
-#endif
else
goto badfun;
case scm_tc7_subr_0:
@@ -1464,20 +1410,8 @@ dispatch:
}
#endif /* DEVAL */
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc));
-#endif
- x = SCM_GENERIC_METHOD_CACHE (proc);
- goto type_dispatch;
- }
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ if (SCM_STRUCT_APPLICABLE_P (proc))
goto operatorn;
-#endif
else
goto badfun;
case scm_tc7_subr_2:
@@ -1772,36 +1706,26 @@ tail:
#endif
goto tail;
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ if (SCM_STRUCT_APPLICABLE_P (proc))
{
+ proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
-#else
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+ debug.vect[0].a.proc = proc;
#endif
- RETURN (scm_apply_generic (proc, args));
+ if (SCM_NIMP (proc))
+ goto tail;
+ else
+ goto badproc;
}
-#if 0
- else if (SCM_I_ENTITYP (proc))
+ else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
- /* operator */
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
- arg1 = proc;
- proc = SCM_ENTITY_PROCEDURE (proc);
-#ifdef DEVAL
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = scm_cons (arg1, args);
-#endif
- if (SCM_NIMP (proc))
- goto tail;
- else
- goto badproc;
+ RETURN (scm_apply_generic (proc, args));
}
-#endif
else
goto badproc;
default:
diff --git a/libguile/goops.c b/libguile/goops.c
index e3f403d..89047cf 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -61,11 +61,6 @@
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
-#define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod)
-#define SCM_CMETHOD_FORMALS(cmethod) SCM_CAR (SCM_CMETHOD_CODE (cmethod))
-#define SCM_CMETHOD_BODY(cmethod) SCM_CDR (SCM_CMETHOD_CODE (cmethod))
-#define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod)
-
/* Port classes */
#define SCM_IN_PCLASS_INDEX 0
#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT
@@ -78,7 +73,6 @@ static SCM var_slot_unbound = SCM_BOOL_F;
static SCM var_slot_missing = SCM_BOOL_F;
static SCM var_compute_cpl = SCM_BOOL_F;
static SCM var_no_applicable_method = SCM_BOOL_F;
-static SCM var_memoize_method_x = SCM_BOOL_F;
static SCM var_change_class = SCM_BOOL_F;
SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
@@ -144,24 +138,23 @@ SCM scm_class_integer, scm_class_real, scm_class_complex,
scm_class_fraction;
SCM scm_class_unknown;
SCM scm_class_top, scm_class_object, scm_class_class;
SCM scm_class_applicable;
-SCM scm_class_entity, scm_class_entity_with_setter;
+SCM scm_class_applicable_struct, scm_class_applicable_struct_with_setter;
SCM scm_class_generic, scm_class_generic_with_setter;
SCM scm_class_accessor;
SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
SCM scm_class_extended_accessor;
SCM scm_class_method;
-SCM scm_class_simple_method, scm_class_accessor_method;
+SCM scm_class_accessor_method;
SCM scm_class_procedure_class;
-SCM scm_class_entity_class;
+SCM scm_class_applicable_struct_class;
SCM scm_class_number, scm_class_list;
SCM scm_class_keyword;
SCM scm_class_port, scm_class_input_output_port;
SCM scm_class_input_port, scm_class_output_port;
-SCM scm_class_foreign_class, scm_class_foreign_object;
SCM scm_class_foreign_slot;
SCM scm_class_self, scm_class_protected;
-SCM scm_class_opaque, scm_class_read_only;
-SCM scm_class_protected_opaque, scm_class_protected_read_only;
+SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
+SCM scm_class_protected_hidden, scm_class_protected_opaque,
scm_class_protected_read_only;
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
@@ -294,9 +287,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
if (!scm_is_symbol (name))
name = scm_string_to_symbol (scm_nullstr);
- /* FIXME APPLICABLE structs */
class =
- scm_make_extended_class_from_symbol (name, 0);
+ scm_make_extended_class_from_symbol (name,
+
SCM_STRUCT_APPLICABLE_P (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
@@ -704,6 +697,8 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
a = 'o';
else if (SCM_SUBCLASSP (type, scm_class_read_only))
a = 'r';
+ else if (SCM_SUBCLASSP (type, scm_class_hidden))
+ a = 'h';
else
a = 'w';
}
@@ -733,7 +728,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
inconsistent:
SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
}
- SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
+ SCM_SET_VTABLE_LAYOUT (class, scm_string_to_symbol (layout));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -745,40 +740,9 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2,
0, 0,
"")
#define FUNC_NAME s_scm_sys_inherit_magic_x
{
- SCM ls = dsupers;
- long flags = 0;
SCM_VALIDATE_INSTANCE (1, class);
- while (!scm_is_null (ls))
- {
- SCM_ASSERT (scm_is_pair (ls)
- && SCM_INSTANCEP (SCM_CAR (ls)),
- dsupers,
- SCM_ARG2,
- FUNC_NAME);
- flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
- ls = SCM_CDR (ls);
- }
- flags &= SCM_CLASSF_INHERIT;
-
- if (! (flags & SCM_CLASSF_PURE_GENERIC))
- {
- long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
-#if 0
- /*
- * We could avoid calling scm_gc_malloc in the allocation code
- * (in which case the following two lines are needed). Instead
- * we make 0-slot instances non-light, so that the light case
- * can be handled without special cases.
- */
- if (n == 0)
- SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0);
-#endif
- if (n > 0 && !(flags & SCM_CLASSF_METACLASS))
- {
- flags |= SCM_STRUCTF_LIGHT; /* use light representation */
- }
- }
- SCM_SET_CLASS_FLAGS (class, flags);
+ scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class);
+ SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID);
prep_hashsets (class);
@@ -812,7 +776,7 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM
dsupers, SCM dslots)
nfields = scm_from_int (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
- SCM_SET_SLOT (z, scm_si_name, name);
+ SCM_SET_SLOT (z, scm_vtable_index_name, name);
SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
@@ -833,9 +797,6 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM
dsupers, SCM dslots)
scm_si_direct_subclasses)));
}
- /* Support for the underlying structs: */
- /* FIXME: set entity flag on z if class == entity_class ? */
- SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_GOOPS_OR_VALID);
return z;
}
@@ -843,16 +804,19 @@ SCM
scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
{
SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
- scm_sys_inherit_magic_x (z, dsupers);
scm_sys_prep_layout_x (z);
+ scm_sys_inherit_magic_x (z, dsupers);
return z;
}
/******************************************************************************/
SCM_SYMBOL (sym_layout, "layout");
-SCM_SYMBOL (sym_vcell, "vcell");
-SCM_SYMBOL (sym_vtable, "vtable");
+SCM_SYMBOL (sym_flags, "flags");
+SCM_SYMBOL (sym_self, "%self");
+SCM_SYMBOL (sym_instance_finalizer, "instance-finalizer");
+SCM_SYMBOL (sym_reserved_0, "%reserved-0");
+SCM_SYMBOL (sym_reserved_1, "%reserved-1");
SCM_SYMBOL (sym_print, "print");
SCM_SYMBOL (sym_procedure, "procedure");
SCM_SYMBOL (sym_setter, "setter");
@@ -882,12 +846,17 @@ SCM_SYMBOL (sym_environment, "environment");
static SCM
build_class_class_slots ()
{
+ /* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
+ SCM_CLASS_CLASS_LAYOUT */
return scm_list_n (
scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
- scm_list_3 (sym_vtable, k_class, scm_class_self),
+ scm_list_3 (sym_flags, k_class, scm_class_hidden),
+ scm_list_3 (sym_self, k_class, scm_class_self),
+ scm_list_3 (sym_instance_finalizer, k_class, scm_class_hidden),
scm_list_1 (sym_print),
- scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque),
- scm_list_3 (sym_setter, k_class, scm_class_protected_opaque),
+ scm_list_3 (sym_name, k_class, scm_class_protected_hidden),
+ scm_list_3 (sym_reserved_0, k_class, scm_class_hidden),
+ scm_list_3 (sym_reserved_1, k_class, scm_class_hidden),
scm_list_1 (sym_redefined),
scm_list_3 (sym_h0, k_class, scm_class_int),
scm_list_3 (sym_h1, k_class, scm_class_int),
@@ -897,7 +866,6 @@ build_class_class_slots ()
scm_list_3 (sym_h5, k_class, scm_class_int),
scm_list_3 (sym_h6, k_class, scm_class_int),
scm_list_3 (sym_h7, k_class, scm_class_int),
- scm_list_1 (sym_name),
scm_list_1 (sym_direct_supers),
scm_list_1 (sym_direct_slots),
scm_list_1 (sym_direct_subclasses),
@@ -917,9 +885,8 @@ create_basic_classes (void)
{
/* SCM slots_of_class = build_class_class_slots (); */
- /**** <scm_class_class> ****/
- SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
- + 2 * scm_vtable_offset_user);
+ /**** <class> ****/
+ SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM name = scm_from_locale_symbol ("<class>");
scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
SCM_INUM0,
@@ -927,7 +894,7 @@ create_basic_classes (void)
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
- SCM_SET_SLOT (scm_class_class, scm_si_name, name);
+ SCM_SET_SLOT (scm_class_class, scm_vtable_index_name, name);
SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be
changed */
/* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
@@ -945,7 +912,7 @@ create_basic_classes (void)
DEFVAR(name, scm_class_class);
- /**** <scm_class_top> ****/
+ /**** <top> ****/
name = scm_from_locale_symbol ("<top>");
scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
name,
@@ -954,7 +921,7 @@ create_basic_classes (void)
DEFVAR(name, scm_class_top);
- /**** <scm_class_object> ****/
+ /**** <object> ****/
name = scm_from_locale_symbol ("<object>");
scm_class_object = scm_permanent_object (scm_basic_make_class
(scm_class_class,
name,
@@ -1156,16 +1123,6 @@ SCM_DEFINE (scm_method_procedure, "method-procedure", 1,
0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_accessor_method_slot_definition,
"accessor-method-slot-definition", 1, 0, 0,
- (SCM obj),
- "Return the slot definition of the accessor @var{obj}.")
-#define FUNC_NAME s_scm_accessor_method_slot_definition
-{
- SCM_VALIDATE_ACCESSOR (1, obj);
- return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
-}
-#undef FUNC_NAME
-
/******************************************************************************
*
* S l o t a c c e s s
@@ -1516,86 +1473,42 @@ SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
static void clear_method_cache (SCM);
-static SCM
-wrap_init (SCM class, SCM *m, long n)
-{
- long i;
- scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
- SCM layout = SCM_PACK (slayout);
-
- /* Set all SCM-holding slots to unbound */
- for (i = 0; i < n; i++)
- if (scm_i_symbol_ref (layout, i*2) == 'p')
- m[i] = SCM_GOOPS_UNBOUND;
- else
- m[i] = 0;
-
- return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
- | scm_tc3_struct),
- (scm_t_bits) m, 0, 0);
-}
-
SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
(SCM class, SCM initargs),
"Create a new instance of class @var{class} and initialize it\n"
"from the arguments @var{initargs}.")
#define FUNC_NAME s_scm_sys_allocate_instance
{
- SCM *m;
+ SCM obj;
long n;
+ long i;
+ SCM layout;
SCM_VALIDATE_CLASS (1, class);
- /* Most instances */
- if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
- {
- n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
- return wrap_init (class, m, n);
- }
-
- /* Foreign objects */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
- return scm_make_foreign_object (class, initargs);
+ /* 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");
- /* FIXME applicable structs */
- /* Generic functions */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
- {
- SCM gf;
- m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
- "generic function");
- m[scm_struct_i_setter] = SCM_BOOL_F;
- m[scm_struct_i_procedure] = SCM_BOOL_F;
- gf = wrap_init (class, m, n);
- clear_method_cache (gf);
- return gf;
- }
+ layout = SCM_VTABLE_LAYOUT (class);
- /* Class objects */
- if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
+ /* Set all SCM-holding slots to unbound */
+ for (i = 0; i < n; i++)
{
- long i;
-
- /* allocate class object */
- SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
-
- SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND);
- for (i = scm_si_goops_fields; i < n; i++)
- SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
-
- /* FIXME propagate applicable struct flag */
-
- return z;
+ scm_t_wchar c = scm_i_symbol_ref (layout, i*2);
+ if (c == 'p')
+ SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND);
+ else if (c == 's')
+ SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj);
+ else
+ SCM_STRUCT_DATA (obj)[i] = 0;
}
- /* Non-light instances */
- {
- m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
- return wrap_init (class, m, n);
- }
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
+ clear_method_cache (obj);
+
+ return obj;
}
#undef FUNC_NAME
@@ -1662,10 +1575,10 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2,
0, 0,
word1 = SCM_CELL_WORD_1 (old);
SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
- SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
+ SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old);
SCM_SET_CELL_WORD_0 (new, word0);
SCM_SET_CELL_WORD_1 (new, word1);
- SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
+ SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new);
}
SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
@@ -1774,167 +1687,52 @@ static SCM list_of_no_method;
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
-/* The cache argument for scm_mcache_lookup_cmethod has one of two possible
- * formats:
- *
- * Format #1:
- * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
- * #((TYPE1 ... . CMETHOD) ...)
- * GF)
- *
- * Format #2:
- * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
- * #((TYPE1 ... CMETHOD) ...)
- * GF)
- *
- * ARGS is either a list of expressions, in which case they
- * are interpreted as the arguments of an application, or
- * a non-pair, which is interpreted as a single expression
- * yielding all arguments.
- *
- * SCM_IM_DISPATCH expressions in generic functions always
- * have ARGS = the symbol `args' or the iloc address@hidden
- *
- * We should probably not complicate this mechanism by
- * introducing "optimizations" for getters and setters or
- * primitive methods. Getters and setter will normally be
- * compiled into @slot-[ref|set!] or a procedure call.
- * They rely on the dispatch performed before executing
- * the code which contains them.
- *
- * We might want to use a more efficient representation of
- * this form in the future, perhaps after we have introduced
- * low-level support for syntax-case macros.
- */
-
-SCM
-scm_mcache_lookup_cmethod (SCM cache, SCM args)
-{
- unsigned long i, mask, n, end;
- SCM ls, methods, z = SCM_CDDR (cache);
- n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
- methods = SCM_CADR (z);
-
- if (scm_is_simple_vector (methods))
- {
- /* cache format #1: prepare for linear search */
- mask = -1;
- i = 0;
- end = SCM_SIMPLE_VECTOR_LENGTH (methods);
- }
- else
- {
- /* cache format #2: compute a hash value */
- unsigned long hashset = scm_to_ulong (methods);
- long j = n;
- z = SCM_CDDR (z);
- mask = scm_to_ulong (SCM_CAR (z));
- methods = SCM_CADR (z);
- i = 0;
- ls = args;
- if (!scm_is_null (ls))
- do
- {
- i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
- [scm_si_hashsets + hashset];
- ls = SCM_CDR (ls);
- }
- while (j-- && !scm_is_null (ls));
- i &= mask;
- end = i;
- }
-
- /* Search for match */
- do
- {
- long j = n;
- z = SCM_SIMPLE_VECTOR_REF (methods, i);
- ls = args; /* list of arguments */
- /* More arguments than specifiers => z = CMETHOD, not a pair.
- * Fewer arguments than specifiers => CAR != CLASS or `no-method'. */
- if (!scm_is_null (ls) && scm_is_pair (z))
- do
- {
- if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
- goto next_method;
- ls = SCM_CDR (ls);
- z = SCM_CDR (z);
- }
- while (j-- && !scm_is_null (ls) && scm_is_pair (z));
- if (!scm_is_pair (z))
- return z;
- next_method:
- i = (i + 1) & mask;
- } while (i != end);
- return SCM_BOOL_F;
-}
-
-SCM
-scm_mcache_compute_cmethod (SCM cache, SCM args)
-{
- SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
- if (scm_is_false (cmethod))
- /* No match - memoize */
- return scm_memoize_method (cache, args);
- return cmethod;
-}
-
SCM
scm_apply_generic (SCM gf, SCM args)
{
- SCM cmethod = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf),
args);
- if (SCM_PROGRAM_P (cmethod))
- return scm_vm_apply (scm_the_vm (), cmethod, args);
- else if (scm_is_pair (cmethod))
- return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
- SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
- args,
- SCM_CMETHOD_ENV (cmethod)));
- else
- return scm_apply (cmethod, args, SCM_EOL);
+ return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL);
}
SCM
scm_call_generic_0 (SCM gf)
{
- return scm_apply_generic (gf, SCM_EOL);
+ return scm_call_0 (SCM_STRUCT_PROCEDURE (gf));
}
SCM
scm_call_generic_1 (SCM gf, SCM a1)
{
- return scm_apply_generic (gf, scm_list_1 (a1));
+ return scm_call_1 (SCM_STRUCT_PROCEDURE (gf), a1);
}
SCM
scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
{
- return scm_apply_generic (gf, scm_list_2 (a1, a2));
+ return scm_call_2 (SCM_STRUCT_PROCEDURE (gf), a1, a2);
}
SCM
scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
{
- return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
+ return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
}
-SCM
-scm_make_method_cache (SCM gf)
+SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
+static SCM
+make_dispatch_procedure (SCM gf)
{
- return scm_list_5 (SCM_IM_DISPATCH,
- scm_sym_args,
- scm_from_int (1),
- scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
- list_of_no_method),
- gf);
+ static SCM var = SCM_BOOL_F;
+ if (var == SCM_BOOL_F)
+ var = scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
+ sym_delayed_compile);
+ return scm_call_1 (SCM_VARIABLE_REF (var), gf);
}
static void
clear_method_cache (SCM gf)
{
- SCM cache = scm_make_method_cache (gf);
- SCM_SET_GENERIC_METHOD_CACHE (gf, cache);
- SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F);
+ SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf, make_dispatch_procedure (gf));
+ SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf);
}
SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1,
0, 0,
@@ -1942,23 +1740,8 @@ SCM_DEFINE (scm_sys_invalidate_method_cache_x,
"%invalidate-method-cache!", 1, 0
"")
#define FUNC_NAME s_scm_sys_invalidate_method_cache_x
{
- SCM used_by;
SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
- used_by = SCM_SLOT (gf, scm_si_used_by);
- if (scm_is_true (used_by))
- {
- SCM methods = SCM_SLOT (gf, scm_si_methods);
- for (; scm_is_pair (used_by); used_by = SCM_CDR (used_by))
- scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
- clear_method_cache (gf);
- for (; scm_is_pair (methods); methods = SCM_CDR (methods))
- SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
- }
- {
- SCM n = SCM_SLOT (gf, scm_si_n_specialized);
- /* The sign of n is a flag indicating rest args. */
- SCM_SET_MCACHE_N_SPECIALIZED (SCM_GENERIC_METHOD_CACHE (gf), n);
- }
+ clear_method_cache (gf);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1997,6 +1780,19 @@ SCM_DEFINE (scm_enable_primitive_generic_x,
"enable-primitive-generic!", 0, 0, 1
}
#undef FUNC_NAME
+SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
+ (SCM subr, SCM generic),
+ "")
+#define FUNC_NAME s_scm_set_primitive_generic_x
+{
+ SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
+ subr, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
+ *SCM_SUBR_GENERIC (subr) = generic;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0,
0,
(SCM subr),
"")
@@ -2025,8 +1821,6 @@ static const char extension_gc_hint[] = "GOOPS extension";
static t_extension *extensions = 0;
-SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
-
void
scm_c_extend_primitive_generic (SCM extended, SCM extension)
{
@@ -2249,10 +2043,6 @@ scm_compute_applicable_methods (SCM gf, SCM args, long
len, int find_method_p)
for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR
(l))
{
fl = SPEC_OF (SCM_CAR (l));
- /* Only accept accessors which match exactly in first arg. */
- if (SCM_ACCESSORP (SCM_CAR (l))
- && (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
- continue;
for (i = 0; ; i++, fl = SCM_CDR (fl))
{
if (SCM_INSTANCEP (fl)
@@ -2308,53 +2098,6 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args)
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
SCM_VARIABLE_INIT (var_compute_applicable_methods,
"compute-applicable-methods", scm_c_define_gsubr
(s_sys_compute_applicable_methods, 2, 0, 0,
scm_sys_compute_applicable_methods));
-static void
-lock_cache_mutex (void *m)
-{
- SCM mutex = SCM_PACK ((scm_t_bits) m);
- scm_lock_mutex (mutex);
-}
-
-static void
-unlock_cache_mutex (void *m)
-{
- SCM mutex = SCM_PACK ((scm_t_bits) m);
- scm_unlock_mutex (mutex);
-}
-
-static SCM
-call_memoize_method (void *a)
-{
- SCM args = SCM_PACK ((scm_t_bits) a);
- SCM gf = SCM_CAR (args);
- SCM x = SCM_CADR (args);
- /* First check if another thread has inserted a method between
- * the cache miss and locking the mutex.
- */
- SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
- if (scm_is_true (cmethod))
- return cmethod;
-
- if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x)))
- var_memoize_method_x =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_memoize_method_x));
-
- return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR
(args), x);
-}
-
-SCM
-scm_memoize_method (SCM x, SCM args)
-{
- SCM gf = SCM_CAR (scm_last_pair (x));
- return scm_internal_dynamic_wind (
- lock_cache_mutex,
- call_memoize_method,
- unlock_cache_mutex,
- (void *) SCM_UNPACK (scm_cons2 (gf, x, args)),
- (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex)));
-}
-
/******************************************************************************
*
* A simple make (which will be redefined later in Scheme)
@@ -2393,10 +2136,9 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
if (class == scm_class_generic || class == scm_class_accessor)
{
z = scm_make_struct (class, SCM_INUM0,
- scm_list_5 (SCM_EOL,
+ scm_list_4 (SCM_BOOL_F,
+ SCM_EOL,
SCM_INUM0,
- SCM_BOOL_F,
- scm_make_mutex (),
SCM_EOL));
scm_set_procedure_property_x (z, scm_sym_name,
scm_get_keyword (k_name,
@@ -2415,7 +2157,6 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
z = scm_sys_allocate_instance (class, args);
if (class == scm_class_method
- || class == scm_class_simple_method
|| class == scm_class_accessor_method)
{
SCM_SET_SLOT (z, scm_si_generic_function,
@@ -2436,7 +2177,6 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
len - 1,
SCM_BOOL_F,
FUNC_NAME));
- SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
SCM_SET_SLOT (z, scm_si_formals,
scm_i_get_keyword (k_formals,
args,
@@ -2459,7 +2199,7 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
else
{
/* In all the others case, make a new class .... No instance here */
- SCM_SET_SLOT (z, scm_si_name,
+ SCM_SET_SLOT (z, scm_vtable_index_name,
scm_i_get_keyword (k_name,
args,
len - 1,
@@ -2597,7 +2337,6 @@ create_standard_classes (void)
SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
scm_from_locale_symbol ("specializers"),
sym_procedure,
- scm_from_locale_symbol ("code-table"),
scm_from_locale_symbol ("formals"),
scm_from_locale_symbol ("body"),
scm_from_locale_symbol ("make-procedure"),
@@ -2605,24 +2344,15 @@ create_standard_classes (void)
SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol
("slot-definition"),
k_init_keyword,
k_slot_definition));
- SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex"));
- SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- SCM_EOL,
- mutex_slot),
- SCM_EOL);
- SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"),
+ SCM gf_slots = scm_list_4 (scm_from_locale_symbol ("methods"),
scm_list_3 (scm_from_locale_symbol
("n-specialized"),
k_init_value,
SCM_INUM0),
- scm_list_3 (scm_from_locale_symbol ("used-by"),
- k_init_value,
- SCM_BOOL_F),
- scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
- k_init_thunk,
- mutex_closure),
scm_list_3 (scm_from_locale_symbol ("extended-by"),
k_init_value,
- SCM_EOL));
+ SCM_EOL),
+ scm_from_locale_symbol ("effective-methods"));
+ SCM setter_slots = scm_list_1 (sym_setter);
SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
k_init_value,
SCM_EOL));
@@ -2631,18 +2361,22 @@ create_standard_classes (void)
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_protected, "<protected-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
+ make_stdcls (&scm_class_hidden, "<hidden-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_opaque, "<opaque-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_read_only, "<read-only-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_self, "<self-slot>",
- scm_class_class,
- scm_class_read_only,
- SCM_EOL);
+ scm_class_class, scm_class_read_only, SCM_EOL);
make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
scm_class_class,
scm_list_2 (scm_class_protected, scm_class_opaque),
SCM_EOL);
+ make_stdcls (&scm_class_protected_hidden, "<protected-hidden-slot>",
+ scm_class_class,
+ scm_list_2 (scm_class_protected, scm_class_hidden),
+ SCM_EOL);
make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
scm_class_class,
scm_list_2 (scm_class_protected, scm_class_read_only),
@@ -2664,76 +2398,49 @@ create_standard_classes (void)
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
compute_getters_n_setters (slots));
- make_stdcls (&scm_class_foreign_class, "<foreign-class>",
- scm_class_class, scm_class_class,
- scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
- k_class,
- scm_class_opaque),
- scm_list_3 (scm_from_locale_symbol ("destructor"),
- k_class,
- scm_class_opaque)));
- make_stdcls (&scm_class_foreign_object, "<foreign-object>",
- scm_class_foreign_class, scm_class_object, SCM_EOL);
- SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
-
/* scm_class_generic functions classes */
make_stdcls (&scm_class_procedure_class, "<procedure-class>",
scm_class_class, scm_class_class, SCM_EOL);
- make_stdcls (&scm_class_entity_class, "<entity-class>",
+ make_stdcls (&scm_class_applicable_struct_class,
"<applicable-struct-class>",
scm_class_class, scm_class_procedure_class, SCM_EOL);
+ SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
make_stdcls (&scm_class_method, "<method>",
scm_class_class, scm_class_object, method_slots);
- make_stdcls (&scm_class_simple_method, "<simple-method>",
- scm_class_class, scm_class_method, SCM_EOL);
- SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
make_stdcls (&scm_class_accessor_method, "<accessor-method>",
- scm_class_class, scm_class_simple_method, amethod_slots);
- SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
+ scm_class_class, scm_class_method, amethod_slots);
make_stdcls (&scm_class_applicable, "<applicable>",
scm_class_class, scm_class_top, SCM_EOL);
- make_stdcls (&scm_class_entity, "<entity>",
- scm_class_entity_class,
+ make_stdcls (&scm_class_applicable_struct, "<applicable-struct>",
+ scm_class_applicable_struct_class,
scm_list_2 (scm_class_object, scm_class_applicable),
- SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_entity, SCM_STRUCTF_LIGHT);
- make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
- scm_class_entity_class, scm_class_entity, SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_entity_with_setter, SCM_STRUCTF_LIGHT);
+ scm_list_1 (sym_procedure));
make_stdcls (&scm_class_generic, "<generic>",
- scm_class_entity_class, scm_class_entity, gf_slots);
- SCM_CLEAR_CLASS_FLAGS (scm_class_generic, SCM_STRUCTF_LIGHT);
+ scm_class_applicable_struct_class, scm_class_applicable_struct,
gf_slots);
SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic, "<extended-generic>",
- scm_class_entity_class, scm_class_generic, egf_slots);
- SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic, SCM_STRUCTF_LIGHT);
+ scm_class_applicable_struct_class, scm_class_generic, egf_slots);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
- scm_class_entity_class,
- scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
- SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_generic_with_setter, SCM_STRUCTF_LIGHT);
+ scm_class_applicable_struct_class, scm_class_generic,
setter_slots);
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_accessor, "<accessor>",
- scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_accessor, SCM_STRUCTF_LIGHT);
+ scm_class_applicable_struct_class,
scm_class_generic_with_setter, SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
- scm_class_entity_class,
+ scm_class_applicable_struct_class,
scm_list_2 (scm_class_generic_with_setter,
scm_class_extended_generic),
SCM_EOL);
- SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
- scm_class_entity_class,
+ scm_class_applicable_struct_class,
scm_list_2 (scm_class_accessor,
scm_class_extended_generic_with_setter),
SCM_EOL);
fix_cpl (scm_class_extended_accessor,
scm_class_extended_generic, scm_class_generic);
- SCM_CLEAR_CLASS_FLAGS (scm_class_extended_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
@@ -2962,7 +2669,7 @@ make_struct_class (void *closure SCM_UNUSED,
SCM sym = SCM_STRUCT_TABLE_NAME (data);
if (scm_is_true (sym))
{
- int applicablep = 0; /* FIXME SCM_CLASS_FLAGS (vtable) &
SCM_CLASSF_ENTITY */
+ int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_VTABLE_FLAG_APPLICABLE;
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class_from_symbol (sym,
applicablep));
@@ -2992,149 +2699,12 @@ scm_load_goops ()
}
-SCM
-scm_make_foreign_object (SCM class, SCM initargs)
-#define FUNC_NAME s_scm_make
-{
- void * (*constructor) (SCM)
- = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor);
- if (constructor == 0)
- SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
- return scm_wrap_object (class, constructor (initargs));
-}
-#undef FUNC_NAME
-
-
-static size_t
-scm_free_foreign_object (SCM *class, SCM *data)
-{
- size_t (*destructor) (void *)
- = (size_t (*) (void *)) class[scm_si_destructor];
- return destructor (data);
-}
-
-SCM
-scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
- void * (*constructor) (SCM initargs),
- size_t (*destructor) (void *))
-{
- SCM name, class;
- name = scm_from_locale_symbol (s_name);
- if (scm_is_null (supers))
- supers = scm_list_1 (scm_class_foreign_object);
- class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
- scm_sys_inherit_magic_x (class, supers);
-
- if (destructor != 0)
- {
- SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
- SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
- }
-
- SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
- SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
-
- return class;
-}
-
SCM_SYMBOL (sym_o, "o");
SCM_SYMBOL (sym_x, "x");
SCM_KEYWORD (k_accessor, "accessor");
SCM_KEYWORD (k_getter, "getter");
-static SCM
-default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
-{
- scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
- return 0;
-}
-
-void
-scm_add_slot (SCM class, char *slot_name, SCM slot_class,
- SCM (*getter) (SCM obj),
- SCM (*setter) (SCM obj, SCM x),
- char *accessor_name)
-{
- {
- SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter);
- SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2,
- setter ? setter : default_setter);
-
- /* Dirk:FIXME:: The following two expressions make use of the fact that
- * the memoizer will accept a subr-object in the place of a function.
- * This is not guaranteed to stay this way. */
- SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- scm_list_1 (sym_o),
- scm_list_2 (get, sym_o)),
- SCM_EOL);
- SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
- scm_list_2 (sym_o, sym_x),
- scm_list_3 (set, sym_o, sym_x)),
- SCM_EOL);
-
- {
- SCM name = scm_from_locale_symbol (slot_name);
- SCM aname = scm_from_locale_symbol (accessor_name);
- SCM gf = scm_ensure_accessor (aname);
- SCM slot = scm_list_5 (name,
- k_class,
- slot_class,
- setter ? k_accessor : k_getter,
- gf);
- scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
- k_specializers,
- scm_list_1 (class),
- k_procedure,
- getm)));
- scm_add_method (scm_setter (gf),
- scm_make (scm_list_5 (scm_class_accessor_method,
- k_specializers,
- scm_list_2 (class, scm_class_top),
- k_procedure,
- setm)));
- DEFVAR (aname, gf);
-
- SCM_SET_SLOT (class, scm_si_slots,
- scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
- scm_list_1 (slot))));
- {
- SCM n = SCM_SLOT (class, scm_si_nfields);
- SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
- SCM_UNDEFINED);
- SCM_SET_SLOT (class, scm_si_getters_n_setters,
- scm_append_x (scm_list_2 (SCM_SLOT (class,
scm_si_getters_n_setters),
- scm_list_1 (gns))));
- SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1)));
- }
- }
- }
-}
-
-SCM
-scm_wrap_object (SCM class, void *data)
-{
- return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
- (scm_t_bits) data,
- 0, 0);
-}
-
-SCM scm_components;
-
-SCM
-scm_wrap_component (SCM class, SCM container, void *data)
-{
- SCM obj = scm_wrap_object (class, data);
- SCM handle = scm_hash_fn_create_handle_x (scm_components,
- obj,
- SCM_BOOL_F,
- scm_struct_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- SCM_SETCDR (handle, container);
- return obj;
-}
-
SCM
scm_ensure_accessor (SCM name)
{
@@ -3217,9 +2787,6 @@ scm_init_goops_builtins (void)
*/
scm_permanent_object (scm_module_goops);
- scm_components = scm_permanent_object (scm_make_weak_key_hash_table
- (scm_from_int (37)));
-
goops_rstate = scm_c_make_rstate ("GOOPS", 5);
#include "libguile/goops.x"
diff --git a/libguile/goops.h b/libguile/goops.h
index 153aace..382422d 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -34,36 +34,78 @@
#include "libguile/validate.h"
+/* {Class flags}
+ *
+ * These are used for efficient identification of instances of a
+ * certain class or its subclasses when traversal of the inheritance
+ * graph would be too costly.
+ */
+#define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0
+#define SCM_VTABLE_FLAG_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_1
+#define SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_2
+
+#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
+#define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class))
+#define SCM_OBJ_CLASS_FLAGS(obj) (SCM_STRUCT_VTABLE_FLAGS (obj))
+#define SCM_SET_CLASS_FLAGS(c, f) (SCM_SET_VTABLE_FLAGS (c, f))
+#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLEAR_VTABLE_FLAGS (c, f))
+
+#define SCM_CLASSF_METACLASS
(SCM_VTABLE_FLAG_GOOPS_CLASS|SCM_VTABLE_FLAG_VTABLE)
+#define SCM_CLASSF_PURE_GENERIC SCM_VTABLE_FLAG_GOOPS_PURE_GENERIC
+#define SCM_CLASSF_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_VALID
+#define SCM_CLASSF_GOOPS SCM_VTABLE_FLAG_GOOPS_CLASS
+#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
+
/*
* scm_class_class
*/
-#define SCM_CLASS_CLASS_LAYOUT
"prsrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw"
-
-#define scm_si_layout 0 /* the struct layout */
-#define scm_si_vtable 1
-#define scm_si_print 2 /* the struct print closure */
-#define scm_si_proc 3
-#define scm_si_setter 4
-
-#define scm_si_goops_fields 5
-#define scm_si_redefined 5 /* The class to which class was
redefined. */
-#define scm_si_hashsets 6
-
-#define scm_si_name 14 /* a symbol */
-#define scm_si_direct_supers 15 /* (class ...) */
-#define scm_si_direct_slots 16 /* ((name . options) ...) */
-#define scm_si_direct_subclasses 17 /* (class ...) */
-#define scm_si_direct_methods 18 /* (methods ...) */
-#define scm_si_cpl 19 /* (class ...) */
-#define scm_si_slotdef_class 20
-#define scm_si_slots 21 /* ((name . options) ...) */
-#define scm_si_name_access 22
+/* see also, SCM_VTABLE_BASE_LAYOUT, and build_class_class_slots */
+#define SCM_CLASS_CLASS_LAYOUT \
+ "pw" /* redefined */ \
+ "uw" /* h0 */ \
+ "uw" /* h1 */ \
+ "uw" /* h2 */ \
+ "uw" /* h3 */ \
+ "uw" /* h4 */ \
+ "uw" /* h5 */ \
+ "uw" /* h6 */ \
+ "uw" /* h7 */ \
+ "pw" /* direct supers */ \
+ "pw" /* direct slots */ \
+ "pw" /* direct subclasses */ \
+ "pw" /* direct methods */ \
+ "pw" /* cpl */ \
+ "pw" /* default-slot-definition-class */ \
+ "pw" /* slots */ \
+ "pw" /* getters-n-setters */ \
+ "pw" /* keyword access */ \
+ "pw" /* nfields */ \
+ "pw" /* environment */
+
+#define scm_si_redefined (scm_vtable_offset_user + 0)
+#define scm_si_h0 (scm_vtable_offset_user + 1)
+#define scm_si_hashsets scm_si_h0
+#define scm_si_h1 (scm_vtable_offset_user + 2)
+#define scm_si_h2 (scm_vtable_offset_user + 3)
+#define scm_si_h3 (scm_vtable_offset_user + 4)
+#define scm_si_h4 (scm_vtable_offset_user + 5)
+#define scm_si_h5 (scm_vtable_offset_user + 6)
+#define scm_si_h6 (scm_vtable_offset_user + 7)
+#define scm_si_h7 (scm_vtable_offset_user + 8)
+#define scm_si_direct_supers (scm_vtable_offset_user + 9) /* (class ...) */
+#define scm_si_direct_slots (scm_vtable_offset_user + 10) /* ((name .
options) ...) */
+#define scm_si_direct_subclasses (scm_vtable_offset_user + 11) /* (class ...)
*/
+#define scm_si_direct_methods (scm_vtable_offset_user + 12) /* (methods ...)
*/
+#define scm_si_cpl (scm_vtable_offset_user + 13) /* (class ...) */
+#define scm_si_slotdef_class (scm_vtable_offset_user + 14)
+#define scm_si_slots (scm_vtable_offset_user + 15) /* ((name .
options) ...) */
+#define scm_si_name_access (scm_vtable_offset_user + 16)
#define scm_si_getters_n_setters scm_si_name_access
-#define scm_si_keyword_access 23
-#define scm_si_nfields 24 /* an integer */
-#define scm_si_environment 25 /* The environment in which class is built
*/
-#define SCM_N_CLASS_SLOTS 26
+#define scm_si_keyword_access (scm_vtable_offset_user + 17)
+#define scm_si_nfields (scm_vtable_offset_user + 18) /* an integer */
+#define scm_si_environment (scm_vtable_offset_user + 19) /* The
environment in which class is built */
+#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 20)
typedef struct scm_t_method {
SCM generic_function;
@@ -73,34 +115,6 @@ typedef struct scm_t_method {
#define SCM_METHOD(obj) ((scm_t_method *) SCM_STRUCT_DATA (obj))
-/* {Class flags}
- *
- * These are used for efficient identification of instances of a
- * certain class or its subclasses when traversal of the inheritance
- * graph would be too costly.
- */
-#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class) [scm_struct_i_flags])
-#define SCM_OBJ_CLASS_FLAGS(obj) (SCM_STRUCT_VTABLE_DATA (obj)
[scm_struct_i_flags])
-#define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
-#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
-#define SCM_CLASSF_MASK SCM_STRUCTF_MASK
-
-#define SCM_CLASSF_SIMPLE_METHOD (0x004 << 20)
-#define SCM_CLASSF_ACCESSOR_METHOD (0x008 << 20)
-#define SCM_CLASSF_PURE_GENERIC SCM_STRUCTF_GOOPS_HACK
-#define SCM_CLASSF_FOREIGN (0x020 << 20)
-#define SCM_CLASSF_METACLASS (0x040 << 20)
-#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
-#define SCM_CLASSF_GOOPS (0x100 << 20)
-#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
-
-#define SCM_CLASSF_INHERIT (~(SCM_CLASSF_PURE_GENERIC \
- | SCM_CLASSF_SIMPLE_METHOD \
- | SCM_CLASSF_ACCESSOR_METHOD \
- | SCM_STRUCTF_LIGHT) \
- & SCM_CLASSF_MASK)
-
-#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_OBJ_CLASS_REDEF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)
[scm_si_redefined]))
#define SCM_INST(x) SCM_STRUCT_DATA (x)
@@ -119,12 +133,8 @@ typedef struct scm_t_method {
(SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_PURE_GENERIC))
#define SCM_VALIDATE_PUREGENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x,
PUREGENERICP, "pure generic function")
-#define SCM_ACCESSORP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) &
SCM_CLASSF_ACCESSOR_METHOD))
-#define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x,
ACCESSORP, "accessor")
-
-#define SCM_SLOT(x, i) (SCM_PACK (SCM_INST (x) [i]))
-#define SCM_SET_SLOT(x, i, v) (SCM_INST (x) [i] = SCM_UNPACK (v))
+#define SCM_SLOT(x, i) (SCM_STRUCT_SLOT_REF (x, i))
+#define SCM_SET_SLOT(x, i, v) (SCM_STRUCT_SLOT_SET (x, i, v))
#define SCM_INSTANCE_HASH(c, i) (SCM_INST (c) [scm_si_hashsets + (i)])
#define SCM_SET_HASHSET(c, i, h) (SCM_INST (c) [scm_si_hashsets + (i)] = (h))
@@ -142,30 +152,25 @@ typedef struct scm_t_method {
#define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
-#define SCM_GENERIC_METHOD_CACHE(G) (SCM_PACK (SCM_STRUCT_DATA (G)
[scm_struct_i_procedure]))
-#define SCM_SET_GENERIC_METHOD_CACHE(G,C) (SCM_STRUCT_DATA (G)
[scm_struct_i_procedure] = SCM_UNPACK (C))
-#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G)
[scm_struct_i_setter]))
-#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) [scm_struct_i_setter]
= SCM_UNPACK (C))
-#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C)
-#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X)
+#define SCM_SET_GENERIC_DISPATCH_PROCEDURE(G,C) (SCM_STRUCT_SLOT_SET (G,
scm_si_dispatch_procedure, (C)))
+#define SCM_CLEAR_GENERIC_EFFECTIVE_METHODS(G) (SCM_STRUCT_SLOT_SET (G,
scm_si_effective_methods, SCM_EOL));
-#define SCM_INITIAL_MCACHE_SIZE 1
+#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G)
[scm_si_generic_setter]))
+#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G)
[scm_si_generic_setter] = SCM_UNPACK (C))
-#define scm_si_constructor SCM_N_CLASS_SLOTS
-#define scm_si_destructor SCM_N_CLASS_SLOTS + 1
-
-#define scm_si_methods 0 /* offset of methods slot in a <generic> */
-#define scm_si_n_specialized 1
-#define scm_si_used_by 2
-#define scm_si_cache_mutex 3
+#define scm_si_dispatch_procedure scm_applicable_struct_index_procedure /* 0 */
+#define scm_si_methods 1
+#define scm_si_n_specialized 2
+#define scm_si_extended_by 3
+#define scm_si_effective_methods 4
+#define scm_si_generic_setter 5
#define scm_si_generic_function 0 /* offset of gf slot in a
<method> */
#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
#define scm_si_procedure 2 /* offset of proc. slot in a <method> */
-#define scm_si_code_table 3 /* offset of code. slot in a <method> */
-#define scm_si_formals 4 /* offset of form. slot in a <method> */
-#define scm_si_body 5 /* offset of body slot in a <method> */
-#define scm_si_make_procedure 6 /* offset of makep.slot in a <method> */
+#define scm_si_formals 3 /* offset of form. slot in a <method> */
+#define scm_si_body 4 /* offset of body slot in a <method> */
+#define scm_si_make_procedure 5 /* offset of makep.slot in a <method> */
/* C interface */
SCM_API SCM scm_class_boolean;
@@ -188,8 +193,8 @@ SCM_API SCM scm_class_top;
SCM_API SCM scm_class_object;
SCM_API SCM scm_class_class;
SCM_API SCM scm_class_applicable;
-SCM_API SCM scm_class_entity;
-SCM_API SCM scm_class_entity_with_setter;
+SCM_API SCM scm_class_applicable_struct;
+SCM_API SCM scm_class_applicable_struct_with_setter;
SCM_API SCM scm_class_generic;
SCM_API SCM scm_class_generic_with_setter;
SCM_API SCM scm_class_accessor;
@@ -197,10 +202,9 @@ SCM_API SCM scm_class_extended_generic;
SCM_API SCM scm_class_extended_generic_with_setter;
SCM_API SCM scm_class_extended_accessor;
SCM_API SCM scm_class_method;
-SCM_API SCM scm_class_simple_method;
SCM_API SCM scm_class_accessor_method;
SCM_API SCM scm_class_procedure_class;
-SCM_API SCM scm_class_entity_class;
+SCM_API SCM scm_class_applicable_struct_class;
SCM_API SCM scm_class_number;
SCM_API SCM scm_class_list;
SCM_API SCM scm_class_keyword;
@@ -208,13 +212,13 @@ SCM_API SCM scm_class_port;
SCM_API SCM scm_class_input_output_port;
SCM_API SCM scm_class_input_port;
SCM_API SCM scm_class_output_port;
-SCM_API SCM scm_class_foreign_class;
-SCM_API SCM scm_class_foreign_object;
SCM_API SCM scm_class_foreign_slot;
SCM_API SCM scm_class_self;
SCM_API SCM scm_class_protected;
+SCM_API SCM scm_class_hidden;
SCM_API SCM scm_class_opaque;
SCM_API SCM scm_class_read_only;
+SCM_API SCM scm_class_protected_hidden;
SCM_API SCM scm_class_protected_opaque;
SCM_API SCM scm_class_protected_read_only;
SCM_API SCM scm_class_scm;
@@ -232,18 +236,8 @@ SCM_API SCM scm_oldfmt (SCM);
SCM_API char *scm_c_oldfmt0 (char *);
SCM_API char *scm_c_oldfmt (char *, int n);
SCM_API void scm_load_goops (void);
-SCM_API SCM scm_make_foreign_object (SCM cls, SCM initargs);
-SCM_API SCM scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
- void * (*constructor) (SCM initargs),
- size_t (*destructor) (void *));
SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep);
SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
-SCM_API void scm_add_slot (SCM c, char *slot, SCM slot_class,
- SCM (*getter) (SCM obj),
- SCM (*setter) (SCM obj, SCM x),
- char *accessor_name);
-SCM_API SCM scm_wrap_object (SCM c, void *);
-SCM_API SCM scm_wrap_component (SCM c, SCM obj, void *);
SCM_API SCM scm_ensure_accessor (SCM name);
SCM_API void scm_add_method (SCM gf, SCM m);
SCM_API SCM scm_class_of (SCM obj);
@@ -287,7 +281,6 @@ SCM_API SCM scm_generic_function_methods (SCM obj);
SCM_API SCM scm_method_generic_function (SCM obj);
SCM_API SCM scm_method_specializers (SCM obj);
SCM_API SCM scm_method_procedure (SCM obj);
-SCM_API SCM scm_accessor_method_slot_definition (SCM obj);
SCM_API SCM scm_sys_tag_body (SCM body);
SCM_API SCM scm_sys_fast_slot_ref (SCM obj, SCM index);
SCM_API SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value);
@@ -300,10 +293,10 @@ SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name);
SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst);
SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls);
SCM_API SCM scm_sys_invalidate_class (SCM cls);
-SCM_API SCM scm_make_method_cache (SCM gf);
SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf);
SCM_API SCM scm_generic_capability_p (SCM proc);
SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
+SCM_INTERNAL SCM scm_set_primitive_generic_x (SCM subr, SCM generic);
SCM_API SCM scm_primitive_generic_generic (SCM subr);
SCM_API void scm_c_extend_primitive_generic (SCM subr, SCM extension);
SCM_API SCM stklos_version (void);
@@ -311,9 +304,6 @@ SCM_API SCM scm_make (SCM args);
SCM_API SCM scm_find_method (SCM args);
SCM_API SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs);
SCM_API void scm_change_object_class (SCM, SCM, SCM);
-SCM_API SCM scm_memoize_method (SCM x, SCM args);
-SCM_API SCM scm_mcache_lookup_cmethod (SCM cache, SCM args);
-SCM_API SCM scm_mcache_compute_cmethod (SCM cache, SCM args);
/* The following are declared in __scm.h
SCM_API SCM scm_call_generic_0 (SCM gf);
SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
@@ -326,19 +316,6 @@ SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2,
SCM a3);
SCM_INTERNAL SCM scm_init_goops_builtins (void);
SCM_INTERNAL void scm_init_goops (void);
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-#define SCM_INST_TYPE(x) SCM_OBJ_CLASS_FLAGS (x)
-#define SCM_SIMPLEMETHODP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_SIMPLE_METHOD))
-#define SCM_FASTMETHODP(x) \
- (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) \
- & (SCM_CLASSF_ACCESSOR_METHOD \
- | SCM_CLASSF_SIMPLE_METHOD)))
-
-
-#endif
-
#endif /* SCM_GOOPS_H */
/*
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 2b67bb1..c1a3789 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -126,13 +126,10 @@ scm_i_procedure_arity (SCM proc)
r = 1;
break;
}
- /* FIXME applicable structs */
- return SCM_BOOL_F;
-#if 0
- proc = SCM_ENTITY_PROCEDURE (proc);
- a -= 1;
+ else if (!SCM_STRUCT_APPLICABLE_P (proc))
+ return SCM_BOOL_F;
+ proc = SCM_STRUCT_PROCEDURE (proc);
goto loop;
-#endif
default:
return SCM_BOOL_F;
}
diff --git a/libguile/procs.c b/libguile/procs.c
index df62514..dc43755 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -97,7 +97,8 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
switch (SCM_TYP7 (obj))
{
case scm_tcs_struct:
- if (!(SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC))
+ if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
+ || SCM_STRUCT_APPLICABLE_P (obj)))
break;
case scm_tcs_closures:
case scm_tcs_subrs:
@@ -253,7 +254,7 @@ SCM_DEFINE (scm_make_procedure_with_setter,
"make-procedure-with-setter", 2, 0,
SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
(SCM proc),
"Return the procedure of @var{proc}, which must be either a\n"
- "procedure with setter, or an operator struct.")
+ "procedure with setter, or an applicable struct.")
#define FUNC_NAME s_scm_procedure
{
SCM_VALIDATE_NIM (1, proc);
@@ -261,7 +262,7 @@ SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
return SCM_PROCEDURE (proc);
else if (SCM_STRUCTP (proc))
{
- SCM_ASSERT (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC,
+ SCM_ASSERT (SCM_PUREGENERICP (proc) || SCM_STRUCT_APPLICABLE_P (proc),
proc, SCM_ARG1, FUNC_NAME);
return proc;
}
@@ -280,10 +281,11 @@ scm_setter (SCM proc)
return SCM_SETTER (proc);
else if (SCM_STRUCTP (proc))
{
- SCM setter;
- SCM_GASSERT1 (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC,
- g_setter, proc, SCM_ARG1, s_setter);
- setter = SCM_GENERIC_SETTER (proc);
+ SCM setter = SCM_BOOL_F;
+ if (SCM_PUREGENERICP (proc))
+ setter = SCM_GENERIC_SETTER (proc);
+ else if (SCM_STRUCT_SETTER_P (proc))
+ setter = SCM_STRUCT_SETTER (proc);
if (SCM_NIMP (setter))
return setter;
/* fall through */
diff --git a/libguile/struct.c b/libguile/struct.c
index f202d66..9fd73a6 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -45,8 +45,13 @@
+/* A needlessly obscure test. */
+#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
+
static SCM required_vtable_fields = SCM_BOOL_F;
-SCM scm_struct_table;
+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_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
@@ -57,9 +62,14 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1,
0, 0,
"type, the second a field protection. Allowed types are 'p' for\n"
"GC-protected Scheme data, 'u' for unprotected binary data, and 's'
for\n"
"a field that points to the structure itself. Allowed
protections\n"
- "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for
opaque\n"
- "fields. The last field protection specification may be
capitalized to\n"
- "indicate that the field is a tail-array.")
+ "are 'w' for mutable fields, 'h' for hidden fields, 'r' for
read-only\n"
+ "fields, and 'o' for opaque fields.\n\n"
+ "Hidden fields are writable, but they will not consume an
initializer arg\n"
+ "passed to @code{make-struct}. They are useful to add slots to a
struct\n"
+ "in a way that preserves backward-compatibility with existing
calls to\n"
+ "@code{make-struct}, especially for derived vtables.\n\n"
+ "The last field protection specification may be capitalized to
indicate\n"
+ "that the field is a tail-array.")
#define FUNC_NAME s_scm_make_struct_layout
{
SCM new_sym;
@@ -96,6 +106,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1,
0, 0,
switch (c = scm_i_string_ref (fields, x + 1))
{
case 'w':
+ case 'h':
if (scm_i_string_ref (fields, x) == 's')
SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
case 'r':
@@ -135,15 +146,73 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout",
1, 0, 0,
+void
+scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
+#define FUNC_NAME "%inherit-vtable-magic"
+{
+ /* Verily, what is the deal here, you ask? Basically, we need to know a
couple
+ of properties of structures at runtime. For example, "is this structure a
+ vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
+ Both of these questions also imply a certain layout of the structure. So
+ instead of checking the layout at runtime, what we do is pre-verify the
+ layout -- so that at runtime we can just check the applicable flag and
+ dispatch directly to the Scheme procedure in slot 0.
+ */
+ SCM olayout;
+
+ /* verify that obj is a valid vtable */
+ if (scm_is_false (scm_symbol_p (SCM_VTABLE_LAYOUT (obj))))
+ scm_misc_error (FUNC_NAME, "invalid layout for new vtable",
+ scm_list_1 (SCM_VTABLE_LAYOUT (obj)));
+
+ /* if obj's vtable is compatible with the required vtable (class) layout, it
+ is a metaclass */
+ olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
+ if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields),
+ scm_string_length (olayout)))
+ && scm_is_true (scm_string_eq (olayout, required_vtable_fields,
+ scm_from_size_t (0),
+ scm_string_length
(required_vtable_fields),
+ scm_from_size_t (0),
+ scm_string_length
(required_vtable_fields))))
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+
+ /* finally if obj is an applicable class, verify that its vtable is
+ compatible with the required applicable layout */
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
+ {
+ if (scm_is_false (scm_string_eq (olayout,
required_applicable_with_setter_fields,
+ scm_from_size_t (0),
+ scm_from_size_t (4),
+ scm_from_size_t (0),
+ scm_from_size_t (4))))
+ scm_misc_error (FUNC_NAME, "invalid applicable-with-setter struct
layout",
+ scm_list_1 (olayout));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE |
SCM_VTABLE_FLAG_SETTER);
+ }
+ else if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE))
+ {
+ if (scm_is_false (scm_string_eq (olayout, required_applicable_fields,
+ scm_from_size_t (0),
+ scm_from_size_t (2),
+ scm_from_size_t (0),
+ scm_from_size_t (2))))
+ scm_misc_error (FUNC_NAME, "invalid applicable struct layout",
+ scm_list_1 (olayout));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
+ }
+}
+#undef FUNC_NAME
static void
-scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM
inits)
+scm_struct_init (SCM handle, SCM layout, int tail_elts, SCM inits)
{
scm_t_wchar prot = 0;
int n_fields = scm_i_symbol_length (layout) / 2;
int tailp = 0;
int i;
+ scm_t_bits *mem = SCM_STRUCT_DATA (handle);
i = -2;
while (n_fields)
@@ -236,36 +305,23 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0,
0,
"Return @code{#t} iff @var{x} is a vtable structure.")
#define FUNC_NAME s_scm_struct_vtable_p
{
- SCM layout;
- scm_t_bits * mem;
- SCM tmp;
- size_t len;
-
- if (!SCM_STRUCTP (x))
- return SCM_BOOL_F;
-
- layout = SCM_STRUCT_LAYOUT (x);
+ return scm_from_bool
+ (SCM_STRUCTP (x)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE));
+}
+#undef FUNC_NAME
- if (scm_i_symbol_length (layout)
- < scm_i_string_length (required_vtable_fields))
- return SCM_BOOL_F;
- len = scm_i_string_length (required_vtable_fields);
- tmp = scm_string_eq (scm_symbol_to_string (layout),
- required_vtable_fields,
- scm_from_size_t (0),
- scm_from_size_t (len),
- scm_from_size_t (0),
- scm_from_size_t (len));
- if (scm_is_false (tmp))
- return SCM_BOOL_F;
-
- mem = SCM_STRUCT_DATA (x);
+/* Finalization: invoke the finalizer of the struct pointed to by PTR. */
+static void
+struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
+{
+ SCM obj = PTR2SCM (ptr);
+ scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
- return scm_from_bool (scm_is_symbol (SCM_PACK
(mem[scm_vtable_index_layout])));
+ if (finalize)
+ finalize (obj);
}
-#undef FUNC_NAME
-
/* All struct data must be allocated at an address whose bottom three
bits are zero. This is because the tag for a struct lives in the
@@ -274,88 +330,38 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0,
0,
address of that data doesn't end in three zeros, tagging it will
destroy the pointer.
- This function allocates a block of memory, and returns a pointer at
- least scm_struct_n_extra_words words into the block. Furthermore,
- it guarantees that that pointer's least three significant bits are
- all zero.
-
- The argument n_words should be the number of words that should
- appear after the returned address. (That is, it shouldn't include
- scm_struct_n_extra_words.)
-
- This function initializes the following fields of the struct:
-
- scm_struct_i_ptr --- the actual start of the block of memory; the
- address you should pass to 'free' to dispose of the block.
- This field allows us to both guarantee that the returned
- address is divisible by eight, and allow the GC to free the
- block.
-
- scm_struct_i_n_words --- the number of words allocated to the
- block, including the extra fields. This is used by the GC.
-
- Ugh. */
-
-
-scm_t_bits *
-scm_alloc_struct (int n_words, int n_extra, const char *what)
-{
- int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7;
- void * block = scm_gc_malloc (size, what);
-
- /* Adjust the pointer to hide the extra words. */
- scm_t_bits * p = (scm_t_bits *) block + n_extra;
+ I suppose we should make it clear here that, the data must be 8-byte
aligned,
+ *within* the struct, and the struct itself should be 8-byte aligned. In
+ practice we ensure this because the data starts two words into a struct.
- /* Adjust it even further so it's aligned on an eight-byte boundary. */
- p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7);
-
- /* Initialize a few fields as described above. */
- p[scm_struct_i_free] = (scm_t_bits) 0;
- p[scm_struct_i_ptr] = (scm_t_bits) block;
- p[scm_struct_i_n_words] = n_words;
- p[scm_struct_i_flags] = 0;
-
- /* Since `SCM' objects will record either P or P + SCM_TC3_STRUCT, we need
- to register them as valid displacements. Fortunately, only a handful of
- N_EXTRA values are used in core Guile. */
- GC_REGISTER_DISPLACEMENT ((char *)p - (char *)block);
- GC_REGISTER_DISPLACEMENT ((char *)p - (char *)block + scm_tc3_struct);
-
- return p;
-}
-
-
-/* Finalization. */
-
-
-/* Invoke the finalizer of the struct pointed to by PTR. */
-static void
-struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
+ This function allocates an 8-byte aligned block of memory, whose first word
+ 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 obj = PTR2SCM (ptr);
-
- /* XXX - use less explicit code. */
- scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct;
- scm_t_bits *vtable_data = (scm_t_bits *) word0;
- scm_t_bits *data = SCM_STRUCT_DATA (obj);
- scm_t_struct_free free_struct_data
- = ((scm_t_struct_free) vtable_data[scm_struct_i_free]);
-
- SCM_SET_CELL_TYPE (obj, scm_tc3_struct);
-
-#if 0
- /* A sanity check. However, this check can fail if the free function
- changed between the `make-struct' time and now. */
- if (free_struct_data != (scm_t_struct_free)unused_data)
- abort ();
-#endif
+ scm_t_bits ret;
+ ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2),
"struct");
+ SCM_SET_CELL_WORD_0 (SCM_PACK (ret), (scm_t_bits)vtable_data |
scm_tc3_struct);
+ SCM_SET_CELL_WORD_1 (SCM_PACK (ret),
+ (scm_t_bits)SCM_CELL_OBJECT_LOC (SCM_PACK (ret), 2));
+
+ /* vtable_data can be null when making a vtable vtable */
+ if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
+ {
+ /* Register a finalizer for the newly created instance. */
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+ GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret,
+ struct_finalizer_trampoline,
+ NULL,
+ &prev_finalizer,
+ &prev_finalizer_data);
+ }
- if (free_struct_data)
- free_struct_data (vtable_data, data);
+ return SCM_PACK (ret);
}
-
-
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
@@ -368,30 +374,23 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
"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"
+ "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"
- "Structs are currently the basic representation for record-like
data\n"
- "structures in Guile. The plan is to eventually replace them with
a\n"
- "new representation which will at the same time be easier to use
and\n"
- "more powerful.\n\n"
"For more information, see the documentation for
@code{make-vtable-vtable}.")
#define FUNC_NAME s_scm_make_struct
{
SCM layout;
size_t basic_size;
size_t tail_elts;
- scm_t_bits *data, *c_vtable;
- SCM handle;
+ SCM obj;
SCM_VALIDATE_VTABLE (1, vtable);
SCM_VALIDATE_REST_ARGUMENT (init);
- c_vtable = SCM_STRUCT_DATA (vtable);
-
- layout = SCM_PACK (c_vtable [scm_vtable_index_layout]);
+ layout = SCM_VTABLE_LAYOUT (vtable);
basic_size = scm_i_symbol_length (layout) / 2;
tail_elts = scm_to_size_t (tail_array_size);
@@ -414,47 +413,18 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
goto bad_tail;
}
- /* In guile 1.8.5 and earlier, everything below was covered by a
- CRITICAL_SECTION lock. This can lead to deadlocks in garbage
- collection, since other threads might be holding the heap_mutex, while
- sleeping on the CRITICAL_SECTION lock. There does not seem to be any
- need for a lock on the section below, as it does not access or update
- any globals, so the critical section has been removed. */
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
+ "struct");
- if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_GOOPS_HACK)
- {
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_entity_n_extra_words,
- "entity struct");
- data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
- data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
- }
- else
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_n_extra_words,
- "struct");
- handle = scm_double_cell ((((scm_t_bits) c_vtable)
- + scm_tc3_struct),
- (scm_t_bits) data, 0, 0);
-
- if (c_vtable[scm_struct_i_free])
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- scm_t_struct_free free_struct =
- (scm_t_struct_free)c_vtable[scm_struct_i_free];
+ scm_struct_init (obj, layout, tail_elts, init);
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (handle),
- struct_finalizer_trampoline,
- free_struct,
- &prev_finalizer,
- &prev_finalizer_data);
- }
-
- scm_struct_init (handle, layout, data, tail_elts, 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. */
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
+ && scm_is_true (SCM_VTABLE_LAYOUT (obj)))
+ scm_i_struct_inherit_vtable_magic (vtable, obj);
- return handle;
+ return obj;
}
#undef FUNC_NAME
@@ -512,8 +482,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
SCM layout;
size_t basic_size;
size_t tail_elts;
- scm_t_bits *data;
- SCM handle;
+ SCM obj;
SCM_VALIDATE_STRING (1, user_fields);
SCM_VALIDATE_REST_ARGUMENT (init);
@@ -524,15 +493,13 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
basic_size = scm_i_symbol_length (layout) / 2;
tail_elts = scm_to_size_t (tail_array_size);
SCM_CRITICAL_SECTION_START;
- data = scm_alloc_struct (basic_size + tail_elts,
- scm_struct_n_extra_words,
- "struct");
- handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct,
- (scm_t_bits) data, 0, 0);
- data [scm_vtable_index_layout] = SCM_UNPACK (layout);
- scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
+ obj = scm_i_alloc_struct (NULL, basic_size + tail_elts, "struct");
+ /* magic magic magic */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) |
scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
- return handle;
+ scm_struct_init (obj, layout, tail_elts, scm_cons (layout, init));
+ SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
+ return obj;
}
#undef FUNC_NAME
@@ -611,8 +578,7 @@ scm_i_struct_equalp (SCM s1, SCM s2)
SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
(SCM handle, SCM pos),
- "@deffnx {Scheme Procedure} struct-set! struct n value\n"
- "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
+ "Access the @var{n}th field of @var{struct}.\n\n"
"If the field is of type 'p', then it can be set to an arbitrary
value.\n\n"
"If the field is of type 'u', then it can only be set to a
non-negative\n"
"integer value small enough to fit in one machine word.")
@@ -634,11 +600,9 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
p = scm_to_size_t (pos);
layout_len = scm_i_symbol_length (layout);
- if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
- /* no extra words */
- n_fields = layout_len / 2;
- else
- n_fields = data[scm_struct_i_n_words];
+ n_fields = layout_len / 2;
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
SCM_ASSERT_RANGE(1, pos, p < n_fields);
@@ -647,7 +611,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
scm_t_wchar ref;
field_type = scm_i_symbol_ref (layout, p * 2);
ref = scm_i_symbol_ref (layout, p * 2 + 1);
- if ((ref != 'r') && (ref != 'w'))
+ if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
{
if ((ref == 'R') || (ref == 'W'))
field_type = 'u';
@@ -713,11 +677,9 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
p = scm_to_size_t (pos);
layout_len = scm_i_symbol_length (layout);
- if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
- /* no extra words */
- n_fields = layout_len / 2;
- else
- n_fields = data[scm_struct_i_n_words];
+ n_fields = layout_len / 2;
+ if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
+ n_fields += data[n_fields - 1];
SCM_ASSERT_RANGE (1, pos, p < n_fields);
@@ -726,7 +688,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
char set_x;
field_type = scm_i_symbol_ref (layout, p * 2);
set_x = scm_i_symbol_ref (layout, p * 2 + 1);
- if (set_x != 'w')
+ if (set_x != 'w' && set_x != 'h')
SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
}
else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
@@ -854,13 +816,39 @@ scm_print_struct (SCM exp, SCM port, scm_print_state
*pstate)
SCM name = scm_struct_vtable_name (vtable);
scm_puts ("#<", port);
if (scm_is_true (name))
- scm_display (name, port);
+ {
+ scm_display (name, port);
+ scm_putc (' ', port);
+ }
else
- scm_puts ("struct", port);
- scm_putc (' ', port);
- scm_uintprint (SCM_UNPACK (vtable), 16, port);
- scm_putc (':', port);
+ {
+ if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE))
+ scm_puts ("vtable:", port);
+ else
+ scm_puts ("struct:", port);
+ scm_uintprint (SCM_UNPACK (vtable), 16, port);
+ scm_putc (' ', port);
+ scm_write (SCM_VTABLE_LAYOUT (vtable), port);
+ scm_putc (' ', port);
+ }
scm_uintprint (SCM_UNPACK (exp), 16, port);
+ /* hackety hack */
+ if (SCM_STRUCT_APPLICABLE_P (exp))
+ {
+ if (scm_is_true (SCM_STRUCT_PROCEDURE (exp)))
+ {
+ scm_puts (" proc: ", port);
+ if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp))))
+ scm_write (SCM_STRUCT_PROCEDURE (exp), port);
+ else
+ scm_puts ("(not a procedure?)", port);
+ }
+ if (SCM_STRUCT_SETTER_P (exp))
+ {
+ scm_puts (" setter: ", port);
+ scm_write (SCM_STRUCT_SETTER (exp), port);
+ }
+ }
scm_putc ('>', port);
}
}
@@ -874,19 +862,38 @@ scm_struct_prehistory ()
void
scm_init_struct ()
{
- scm_struct_table
- = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
- required_vtable_fields = scm_from_locale_string ("prsrpw");
- scm_permanent_object (required_vtable_fields);
+ 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
*/
+
+ scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
+ required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
+ 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_permanent_object
- (scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL));
+ 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_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_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);
+ scm_c_define ("<applicable-struct-with-setter-vtable>",
scm_applicable_struct_with_setter_vtable_vtable);
scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
- scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable));
scm_c_define ("vtable-index-printer",
- scm_from_int (scm_vtable_index_printer));
+ scm_from_int (scm_vtable_index_instance_printer));
scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user));
#include "libguile/struct.x"
}
diff --git a/libguile/struct.h b/libguile/struct.h
index 8634659..9372cec 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -28,48 +28,112 @@
-/* Number of words with negative index */
-#define scm_struct_n_extra_words 4
-#define scm_struct_entity_n_extra_words 6
-
-/* These are how the initial words of a vtable are allocated. */
-#define scm_struct_i_setter -6 /* Setter */
-#define scm_struct_i_procedure -5 /* Optional procedure slot */
-#define scm_struct_i_free -4 /* Destructor */
-#define scm_struct_i_ptr -3 /* Start of block (see alloc_struct) */
-#define scm_struct_i_n_words -2 /* How many words allocated to this struct?
*/
-#define scm_struct_i_flags -1 /* Upper 12 bits used as flags */
-
-/* These indices must correspond to required_vtable_fields in
- struct.c. */
-#define scm_vtable_index_layout 0 /* A symbol describing the physical
arrangement of this type. */
-#define scm_vtable_index_vtable 1 /* A pointer to the handle for this vtable.
*/
-#define scm_vtable_index_printer 2 /* A printer for this struct type. */
-#define scm_vtable_offset_user 3 /* Where do user fields start? */
-
-typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
-
-#define SCM_STRUCTF_MASK (0xFFF << 20)
-#define SCM_STRUCTF_GOOPS_HACK (0x010 << 20) /* FIXME -- PURE_GENERIC */
-#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
- (no hidden words) */
+/* The relationship between a struct and its vtable is a bit complicated,
+ because we want structs to be used as GOOPS' native representation -- which
+ in turn means we need support for changing the "class" (vtable) of an
+ "instance" (struct). This necessitates some indirection and trickery.
+
+ I would like to write this all up here, but for now:
+
+ http://wingolog.org/pub/goops-class-redefinition-3.png
+ */
+
+/* All vtables have the following fields. */
+#define SCM_VTABLE_BASE_LAYOUT \
+ "pr" /* layout */ \
+ "uh" /* flags */ \
+ "sr" /* self */ \
+ "uh" /* finalizer */ \
+ "pw" /* printer */ \
+ "ph" /* name (hidden from make-struct for back-compat reasons) */ \
+ "uh" /* reserved */ \
+ "uh" /* reserved */
+
+#define scm_vtable_index_layout 0 /* A symbol describing the
physical arrangement of this type. */
+#define scm_vtable_index_flags 1 /* Class flags */
+#define scm_vtable_index_self 2 /* A pointer to the vtable itself
*/
+#define scm_vtable_index_instance_finalize 3 /* Finalizer for instances of
this struct type. */
+#define scm_vtable_index_instance_printer 4 /* A printer for this struct
type. */
+#define scm_vtable_index_name 5 /* Name of this vtable. */
+#define scm_vtable_index_reserved_6 6
+#define scm_vtable_index_reserved_7 7
+#define scm_vtable_offset_user 8 /* Where do user fields start in
the vtable? */
+
+/* All applicable structs have the following fields. */
+#define SCM_APPLICABLE_BASE_LAYOUT \
+ "pw" /* procedure */
+#define SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT \
+ "pw" /* procedure */ \
+ "pw" /* setter */
+#define scm_applicable_struct_index_procedure 0 /* The procedure of an
applicable
+ struct. Only valid if the
+ struct's vtable has the
+ applicable flag set. */
+#define scm_applicable_struct_index_setter 1 /* The setter of an applicable
+ struct. Only valid if the
+ struct's vtable has the
+ setter flag set. */
+
+#define SCM_VTABLE_FLAG_VTABLE (1L << 0) /* instances of this vtable are
themselves vtables? */
+#define SCM_VTABLE_FLAG_APPLICABLE_VTABLE (1L << 1) /* instances of this
vtable are applicable vtables? */
+#define SCM_VTABLE_FLAG_APPLICABLE (1L << 2) /* instances of this vtable are
applicable? */
+#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 3) /* instances of this vtable
are applicable-with-setter vtables? */
+#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_GOOPS_0 (1L << 8)
+#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 9)
+#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 10)
+#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 11)
+#define SCM_VTABLE_FLAG_GOOPS_4 (1L << 12)
+#define SCM_VTABLE_FLAG_GOOPS_5 (1L << 13)
+#define SCM_VTABLE_FLAG_GOOPS_6 (1L << 14)
+#define SCM_VTABLE_FLAG_GOOPS_7 (1L << 15)
+#define SCM_VTABLE_USER_FLAG_SHIFT 16
+
+typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_STRUCTP(X) (!SCM_IMP(X) && (SCM_TYP3(X) ==
scm_tc3_struct))
-#define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X))
-#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) -
scm_tc3_struct))
-
-#define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X)
[scm_vtable_index_layout]))
-#define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X)
[scm_vtable_index_layout] = SCM_UNPACK (v))
-
-#define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X)
[scm_vtable_index_vtable]))
-#define SCM_STRUCT_VTABLE_FLAGS(X) \
- (SCM_STRUCT_VTABLE_DATA (X) [scm_struct_i_flags])
-#define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X)
[scm_vtable_index_printer]))
-#define SCM_SET_STRUCT_PRINTER(x, v)\
- (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = SCM_UNPACK (v))
-#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X)
[scm_struct_i_free] = (scm_t_bits) (D))
-/* Efficiency is important in the following macro, since it's used in GC */
-#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
+#define SCM_STRUCT_SLOTS(X) ((SCM*)SCM_CELL_WORD_1 ((X)))
+#define SCM_STRUCT_SLOT_REF(X,I) (SCM_STRUCT_SLOTS (X)[(I)])
+#define SCM_STRUCT_SLOT_SET(X,I,V) SCM_STRUCT_SLOTS (X)[(I)]=(V)
+#define SCM_STRUCT_DATA(X) ((scm_t_bits*)SCM_CELL_WORD_1 (X))
+#define SCM_STRUCT_DATA_REF(X,I) (SCM_STRUCT_DATA (X)[(I)])
+#define SCM_STRUCT_DATA_SET(X,I,V) SCM_STRUCT_DATA (X)[(I)]=(V)
+
+/* The SCM_VTABLE_* macros assume that you're passing them a struct which is a
+ valid vtable. */
+#define SCM_VTABLE_LAYOUT(X) (SCM_STRUCT_SLOT_REF ((X),
scm_vtable_index_layout))
+#define SCM_SET_VTABLE_LAYOUT(X,L) (SCM_STRUCT_SLOT_SET ((X),
scm_vtable_index_layout, L))
+#define SCM_VTABLE_FLAGS(X) (SCM_STRUCT_DATA_REF (X,
scm_vtable_index_flags))
+#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_PRINTER(X) (SCM_STRUCT_SLOT_REF (X,
scm_vtable_index_instance_printer))
+#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))
+
+/* Structs hold a pointer to their vtable's data, not the vtable itself. To get
+ the vtable we have to do an indirection through the self slot. */
+#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits*)(SCM_CELL_WORD_0 (X) -
scm_tc3_struct))
+#define SCM_STRUCT_VTABLE_SLOTS(X) ((SCM*)(SCM_CELL_WORD_0 (X) -
scm_tc3_struct))
+#define SCM_STRUCT_VTABLE(X)
(SCM_STRUCT_VTABLE_SLOTS(X)[scm_vtable_index_self])
+/* But often we just need to access the vtable's data; we can do that without
+ the data->self->data indirection. */
+#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_SLOTS
(X)[scm_vtable_index_layout])
+#define SCM_STRUCT_PRINTER(X) (SCM_STRUCT_VTABLE_SLOTS
(X)[scm_vtable_index_instance_printer])
+#define SCM_STRUCT_FINALIZER(X)
((scm_t_struct_finalize)SCM_STRUCT_VTABLE_DATA
(X)[scm_vtable_index_instance_finalize])
+#define SCM_STRUCT_VTABLE_FLAGS(X) (SCM_STRUCT_VTABLE_DATA
(X)[scm_vtable_index_flags])
+#define SCM_STRUCT_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_VTABLE_DATA
(X)[scm_vtable_index_flags]&(F))
+
+#define SCM_STRUCT_APPLICABLE_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X),
SCM_VTABLE_FLAG_APPLICABLE))
+#define SCM_STRUCT_SETTER_P(X) (SCM_STRUCT_VTABLE_FLAG_IS_SET
((X), SCM_VTABLE_FLAG_SETTER))
+#define SCM_STRUCT_PROCEDURE(X) (SCM_STRUCT_SLOT_REF (X,
scm_applicable_struct_index_procedure))
+#define SCM_SET_STRUCT_PROCEDURE(X,P) (SCM_STRUCT_SLOT_SET (X,
scm_applicable_struct_index_procedure, P))
+#define SCM_STRUCT_SETTER(X) (SCM_STRUCT_SLOT_REF (X,
scm_applicable_struct_index_setter))
+#define SCM_SET_STRUCT_SETTER(X,P) (SCM_STRUCT_SLOT_SET (X,
scm_applicable_struct_index_setter, P))
#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
@@ -79,25 +143,26 @@ SCM_API SCM scm_struct_table;
-SCM_API scm_t_bits * scm_alloc_struct (int n_words, int n_extra,
- const char *what);
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_make_vtable (SCM fields, SCM printer);
SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM
init);
-SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
SCM_API SCM scm_struct_vtable_tag (SCM handle);
-SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_struct_prehistory (void);
+
+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 void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
SCM_INTERNAL void scm_init_struct (void);
#endif /* SCM_STRUCT_H */
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index e242ef9..ef53cdd 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -107,7 +107,8 @@ VM_DEFINE_LOADER (90, load_wide_string, "load-wide-string")
FETCH_LENGTH (len);
if (SCM_UNLIKELY (len % 4))
- { finish_args = scm_list_1 (scm_from_size_t (len));
+ {
+ finish_args = scm_list_1 (scm_from_size_t (len));
goto vm_error_bad_wide_string_length;
}
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index df8424c..1f376ab 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -761,15 +761,9 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
APPLY_HOOK ();
NEXT;
}
- if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
{
- SCM args = SCM_EOL;
- int n = nargs;
- SCM* walk = sp;
- SYNC_REGISTER ();
- while (n--)
- args = scm_cons (*walk--, args);
- *walk = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (x), args);
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_call;
}
/*
@@ -845,15 +839,9 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1,
1)
APPLY_HOOK ();
NEXT;
}
- if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
{
- SCM args = SCM_EOL;
- int n = nargs;
- SCM* walk = sp;
- SYNC_REGISTER ();
- while (n--)
- args = scm_cons (*walk--, args);
- *walk = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (x), args);
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_goto_args;
}
@@ -937,15 +925,9 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
APPLY_HOOK ();
NEXT;
}
- if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
+ if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x))
{
- SCM args = SCM_EOL;
- int n = nargs;
- SCM* walk = sp;
- SYNC_REGISTER ();
- while (n--)
- args = scm_cons (*walk--, args);
- *walk = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (x), args);
+ sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_mv_call;
}
/*
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index a9e26b5..c8a183b 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -73,7 +73,6 @@
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword)
- :replace (<class> <entity-class> <entity>)
:no-backtrace)
(define *goops-module* (current-module))
@@ -705,6 +704,10 @@
(define (slot-init-function class slot-name)
(cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+(define (accessor-method-slot-definition obj)
+ "Return the slot definition of the accessor @var{obj}."
+ (slot-ref obj 'slot-definition))
+
;;;
;;; {Standard methods used by the C runtime}
@@ -713,8 +716,15 @@
;;; Methods to compare objects
;;;
-(define-method (eqv? x y) #f)
-(define-method (equal? x y) (eqv? x y))
+;; Have to do this in a strange order because equal? is used in the
+;; add-method! implementation; we need to make sure that when the
+;; primitive is extended, that the generic has a method. =
+(define g-equal? (make-generic 'equal?))
+;; When this generic gets called, we will have already checked eq? and
+;; eqv? -- the purpose of this generic is to extend equality. So by
+;; default, there is no extension, thus the #f return.
+(add-method! g-equal? (method (x y) #f))
+(set-primitive-generic! equal? g-equal?)
;;;
;;; methods to display/write an object
@@ -746,17 +756,6 @@
(display #\> file))
(next-method))))
-(define-method (write (o <foreign-object>) file)
- (let ((class (class-of o)))
- (if (slot-bound? class 'name)
- (begin
- (display "#<foreign-object " file)
- (display (class-name class) file)
- (display #\space file)
- (display-address o file)
- (display #\> file))
- (next-method))))
-
(define-method (write (class <class>) file)
(let ((meta (class-of class)))
(if (and (slot-bound? class 'name)
@@ -1169,6 +1168,7 @@
;;; compute-getters-n-setters
;;;
+;; FIXME!!!
(define (make-thunk thunk)
(lambda () (thunk)))
@@ -1468,11 +1468,10 @@
;; Support for the underlying structs:
- ;; Inherit class flags (invisible on scheme level) from supers
- (%inherit-magic! class supers)
-
;; Set the layout slot
- (%prep-layout! class)))
+ (%prep-layout! class)
+ ;; Inherit class flags (invisible on scheme level) from supers
+ (%inherit-magic! class supers)))
(define (initialize-object-procedure object initargs)
(let ((proc (get-keyword #:procedure initargs #f)))
@@ -1485,13 +1484,9 @@
(set-object-procedure! object
(lambda args (apply proc args)))))))
-(define-method (initialize (entity <entity>) initargs)
+(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)
- (initialize-object-procedure entity initargs))
-
-(define-method (initialize (ews <entity-with-setter>) initargs)
- (next-method)
- (%set-object-setter! ews (get-keyword #:setter initargs #f)))
+ (initialize-object-procedure applicable-struct initargs))
(define-method (initialize (generic <generic>) initargs)
(let ((previous-definition (get-keyword #:default initargs #f))
@@ -1505,6 +1500,10 @@
(set-procedure-property! generic 'name name))
))
+(define-method (initialize (gws <generic-with-setter>) initargs)
+ (next-method)
+ (%set-object-setter! gws (get-keyword #:setter initargs #f)))
+
(define-method (initialize (eg <extended-generic>) initargs)
(next-method)
(slot-set! eg 'extends (get-keyword #:extends initargs '())))
@@ -1517,14 +1516,11 @@
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
(slot-set! method 'procedure
(get-keyword #:procedure initargs #f))
- (slot-set! method 'code-table '())
(slot-set! method 'formals (get-keyword #:formals initargs '()))
(slot-set! method 'body (get-keyword #:body initargs '()))
(slot-set! method 'make-procedure (get-keyword #:make-procedure initargs
#f)))
-(define-method (initialize (obj <foreign-object>) initargs))
-
;;;
;;; {Change-class}
;;;
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm
index 5db406c..db1a160 100644
--- a/module/oop/goops/compile.scm
+++ b/module/oop/goops/compile.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 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
@@ -29,32 +29,6 @@
)
;;;
-;;; Method entries
-;;;
-
-(define code-table-lookup
- (letrec ((check-entry (lambda (entry types)
- (cond
- ((not (pair? entry)) (and (null? types) entry))
- ((null? types) #f)
- (else
- (and (eq? (car entry) (car types))
- (check-entry (cdr entry) (cdr types))))))))
- (lambda (code-table types)
- (cond ((null? code-table) #f)
- ((check-entry (car code-table) types))
- (else (code-table-lookup (cdr code-table) types))))))
-
-(define (compute-cmethod methods types)
- (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
- (let* ((method (car methods))
- (cmethod (compile-method methods types))
- (entry (append types cmethod)))
- (slot-set! method 'code-table
- (cons entry (slot-ref method 'code-table)))
- cmethod)))
-
-;;;
;;; Compiling next methods into method bodies
;;;
@@ -70,7 +44,7 @@
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
-(define (compile-method methods types)
+(define (compute-cmethod methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure
(make-procedure
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index 6a450c1..e433b86 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -22,247 +22,248 @@
(eval-when (compile) (resolve-module '(oop goops)))
(define-module (oop goops dispatch)
- :use-module (oop goops)
- :use-module (oop goops util)
- :use-module (oop goops compile)
- :export (memoize-method!)
- :no-backtrace
- )
+ #:use-module (oop goops)
+ #:use-module (oop goops util)
+ #:use-module (oop goops compile)
+ #:export (memoize-method!)
+ #:no-backtrace)
-;;;
-;;; This file implements method memoization. It will finally be
-;;; implemented on C level in order to obtain fast generic function
-;;; application also during the first pass through the code.
-;;;
-
-;;;
-;;; Constants
-;;;
-
-(define hashsets 8)
-(define hashset-index 6)
-
-(define hash-threshold 3)
-(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
-
-(define initial-hash-size-1 (- initial-hash-size 1))
-
-(define the-list-of-no-method '(no-method))
-
-;;;
-;;; Method cache
-;;;
-
-;; (address@hidden args N-SPECIALIZED #((TYPE1 ... . CMETHOD) ...) GF)
-;; (address@hidden args N-SPECIALIZED HASHSET MASK
-;; #((TYPE1 ... . CMETHOD) ...)
-;; GF)
-
-;;; Representation
-
-;; non-hashed form
-
-(define method-cache-entries cadddr)
-
-(define (set-method-cache-entries! mcache entries)
- (set-car! (cdddr mcache) entries))
-
-(define (method-cache-n-methods exp)
- (n-cache-methods (method-cache-entries exp)))
-
-(define (method-cache-methods exp)
- (cache-methods (method-cache-entries exp)))
-
-;; hashed form
-(define (set-hashed-method-cache-hashset! exp hashset)
- (set-car! (cdddr exp) hashset))
+(define *dispatch-module* (current-module))
-(define (set-hashed-method-cache-mask! exp mask)
- (set-car! (cddddr exp) mask))
-
-(define (hashed-method-cache-entries exp)
- (list-ref exp 5))
-
-(define (set-hashed-method-cache-entries! exp entries)
- (set-car! (list-cdr-ref exp 5) entries))
-
-;; either form
-
-(define (method-cache-generic-function exp)
- (list-ref exp (if (method-cache-hashed? exp) 6 4)))
-
-;;; Predicates
-
-(define (method-cache-hashed? x)
- (integer? (cadddr x)))
-
-(define max-non-hashed-index (- hash-threshold 2))
-
-(define (passed-hash-threshold? exp)
- (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
- (struct? (car (vector-ref (method-cache-entries exp)
- max-non-hashed-index)))))
-
-;;; Converting a method cache to hashed form
-
-(define (method-cache->hashed! exp)
- (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
- exp)
-
-;;;
-;;; Cache entries
;;;
-
-(define (n-cache-methods entries)
- (do ((i (- (vector-length entries) 1) (- i 1)))
- ((or (< i 0) (struct? (car (vector-ref entries i))))
- (+ i 1))))
-
-(define (cache-methods entries)
- (do ((i (- (vector-length entries) 1) (- i 1))
- (methods '() (let ((entry (vector-ref entries i)))
- (if (or (not (pair? entry)) (struct? (car entry)))
- (cons entry methods)
- methods))))
- ((< i 0) methods)))
-
+;;; Generic functions have an applicable-methods cache associated with
+;;; them. Every distinct set of types that is dispatched through a
+;;; generic adds an entry to the cache. This cache gets compiled out to
+;;; a dispatch procedure. In steady-state, this dispatch procedure is
+;;; never recompiled; but during warm-up there is some churn, both to
+;;; the cache and to the dispatch procedure.
;;;
-;;; Method insertion
+;;; So what is the deal if warm-up happens in a multithreaded context?
+;;; There is indeed a window between missing the cache for a certain set
+;;; of arguments, and then updating the cache with the newly computed
+;;; applicable methods. One of the updaters is liable to lose their new
+;;; entry.
;;;
-
-(define (method-cache-insert! exp entry)
- (let* ((entries (method-cache-entries exp))
- (n (n-cache-methods entries)))
- (if (>= n (vector-length entries))
- ;; grow cache
- (let ((new-entries (make-vector (* 2 (vector-length entries))
- the-list-of-no-method)))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (vector-set! new-entries i (vector-ref entries i)))
- (vector-set! new-entries n entry)
- (set-method-cache-entries! exp new-entries))
- (vector-set! entries n entry))))
-
-(define (hashed-method-cache-insert! exp entry)
- (let* ((cache (hashed-method-cache-entries exp))
- (size (vector-length cache)))
- (let* ((entries (cons entry (cache-methods cache)))
- (size (if (<= (length entries) size)
- size
- ;; larger size required
- (let ((new-size (* 2 size)))
- (set-hashed-method-cache-mask! exp (- new-size 1))
- new-size)))
- (min-misses size)
- (best #f))
- (do ((hashset 0 (+ 1 hashset)))
- ((= hashset hashsets))
- (let* ((test-cache (make-vector size the-list-of-no-method))
- (misses (cache-try-hash! min-misses hashset test-cache entries)))
- (cond ((zero? misses)
- (set! min-misses 0)
- (set! best hashset)
- (set! cache test-cache)
- (set! hashset (- hashsets 1)))
- ((< misses min-misses)
- (set! min-misses misses)
- (set! best hashset)
- (set! cache test-cache)))))
- (set-hashed-method-cache-hashset! exp best)
- (set-hashed-method-cache-entries! exp cache))))
-
+;;; This is actually OK though, because a subsequent cache miss for the
+;;; race loser will just cause memoization to try again. The cache will
+;;; eventually be consistent. We're not mutating the old part of the
+;;; cache, just consing on the new entry.
;;;
-;;; Caching
+;;; It doesn't even matter if the dispatch procedure and the cache are
+;;; inconsistent -- most likely the type-set that lost the dispatch
+;;; procedure race will simply re-trigger a memoization, but since the
+;;; winner isn't in the effective-methods cache, it will likely also
+;;; re-trigger a memoization, and the cache will finally be consistent.
+;;; As you can see there is a possibility for ping-pong effects, but
+;;; it's unlikely given the shortness of the window between slot-set!
+;;; invocations. We could add a mutex, but it is strictly unnecessary,
+;;; and would add runtime cost and complexity.
;;;
-(define (cache-hashval hashset entry)
- (let ((hashset-index (+ hashset-index hashset)))
- (do ((sum 0)
- (classes entry (cdr classes)))
- ((not (and (pair? classes) (struct? (car classes))))
- sum)
- (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
+(define (emit-linear-dispatch gf-sym nargs methods free rest?)
+ (define (gen-syms n stem)
+ (let lp ((n (1- n)) (syms '()))
+ (if (< n 0)
+ syms
+ (lp (1- n) (cons (gensym stem) syms)))))
+ (let* ((args (gen-syms nargs "a"))
+ (types (gen-syms nargs "t")))
+ (let lp ((methods methods)
+ (free free)
+ (exp `(cache-miss ,gf-sym
+ ,(if rest?
+ `(cons* ,@args rest)
+ `(list ,@args)))))
+ (cond
+ ((null? methods)
+ (values `(,(if rest? `(,@args . rest) args)
+ (let ,(map (lambda (t a)
+ `(,t (class-of ,a)))
+ types args)
+ ,exp))
+ free))
+ (else
+ ;; jeez
+ (let preddy ((free free)
+ (types types)
+ (specs (vector-ref (car methods) 1))
+ (checks '()))
+ (if (null? types)
+ (let ((m-sym (gensym "p")))
+ (lp (cdr methods)
+ (acons (vector-ref (car methods) 3)
+ m-sym
+ free)
+ `(if (and . ,checks)
+ ,(if rest?
+ `(apply ,m-sym ,@args rest)
+ `(,m-sym . ,args))
+ ,exp)))
+ (let ((var (assq-ref free (car specs))))
+ (if var
+ (preddy free
+ (cdr types)
+ (cdr specs)
+ (cons `(eq? ,(car types) ,var)
+ checks))
+ (let ((var (gensym "c")))
+ (preddy (acons (car specs) var free)
+ (cdr types)
+ (cdr specs)
+ (cons `(eq? ,(car types) ,var)
+ checks))))))))))))
+
+(define (compute-dispatch-procedure gf cache)
+ (define (scan)
+ (let lp ((ls cache) (nreq -1) (nrest -1))
+ (cond
+ ((null? ls)
+ (collate (make-vector (1+ nreq) '())
+ (make-vector (1+ nrest) '())))
+ ((vector-ref (car ls) 2) ; rest
+ (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
+ (else ; req
+ (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
+ (define (collate req rest)
+ (let lp ((ls cache))
+ (cond
+ ((null? ls)
+ (emit req rest))
+ ((vector-ref (car ls) 2) ; rest
+ (let ((n (vector-ref (car ls) 0)))
+ (vector-set! rest n (cons (car ls) (vector-ref rest n)))
+ (lp (cdr ls))))
+ (else ; req
+ (let ((n (vector-ref (car ls) 0)))
+ (vector-set! req n (cons (car ls) (vector-ref req n)))
+ (lp (cdr ls)))))))
+ (define (emit req rest)
+ (let ((gf-sym (gensym "g")))
+ (define (emit-rest n clauses free)
+ (if (< n (vector-length rest))
+ (let ((methods (vector-ref rest n)))
+ (cond
+ ((null? methods)
+ (emit-rest (1+ n) clauses free))
+ ;; FIXME: hash dispatch
+ (else
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #t))
+ (lambda (clause free)
+ (emit-rest (1+ n) (cons clause clauses) free))))))
+ (emit-req (1- (vector-length req)) clauses free)))
+ (define (emit-req n clauses free)
+ (if (< n 0)
+ (comp `(lambda ,(map cdr free)
+ (case-lambda ,@clauses))
+ (map car free))
+ (let ((methods (vector-ref req n)))
+ (cond
+ ((null? methods)
+ (emit-req (1- n) clauses free))
+ ;; FIXME: hash dispatch
+ (else
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #f))
+ (lambda (clause free)
+ (emit-req (1- n) (cons clause clauses) free))))))))
+
+ (emit-rest 0
+ (if (or (zero? (vector-length rest))
+ (null? (vector-ref rest 0)))
+ (list `(args (cache-miss ,gf-sym args)))
+ '())
+ (acons gf gf-sym '()))))
+ (define (comp exp vals)
+ (let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*)))
+ (apply p vals)))
+
+ ;; kick it.
+ (scan))
+
+;; o/~ ten, nine, eight
+;; sometimes that's just how it goes
+;; three, two, one
+;;
+;; get out before it blows o/~
+;;
+(define timer-init 30)
+(define (delayed-compile gf)
+ (let ((timer timer-init))
+ (lambda args
+ (set! timer (1- timer))
+ (cond
+ ((zero? timer)
+ (let ((dispatch (compute-dispatch-procedure
+ gf (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'procedure dispatch)
+ (apply dispatch args)))
+ (else
+ ;; interestingly, this catches recursive compilation attempts as
+ ;; well; in that case, timer is negative
+ (cache-dispatch gf args))))))
+
+(define (cache-dispatch gf args)
+ (define (map-until n f ls)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
+ (define (equal? x y) ; can't use the stock equal? because it's a generic...
+ (cond ((pair? x) (and (pair? y)
+ (eq? (car x) (car y))
+ (equal? (cdr x) (cdr y))))
+ ((null? x) (null? y))
+ (else #f)))
+ (if (slot-ref gf 'n-specialized)
+ (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
+ (let lp ((cache (slot-ref gf 'effective-methods)))
+ (cond ((null? cache)
+ (cache-miss gf args))
+ ((equal? (vector-ref (car cache) 1) types)
+ (apply (vector-ref (car cache) 3) args))
+ (else (lp (cdr cache))))))
+ (cache-miss gf args)))
+
+(define (cache-miss gf args)
+ (apply (memoize-method! gf args) args))
+
+(define (memoize-effective-method! gf args applicable)
+ (define (first-n ls n)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (car ls) (first-n (cdr ls) (- n 1)))))
+ (define (parse n ls)
+ (cond ((null? ls)
+ (memoize n #f (map class-of args)))
+ ((= n (slot-ref gf 'n-specialized))
+ (memoize n #t (map class-of (first-n args n))))
+ (else
+ (parse (1+ n) (cdr ls)))))
+ (define (memoize len rest? types)
+ (let* ((cmethod (compute-cmethod applicable types))
+ (cache (cons (vector len types rest? cmethod)
+ (slot-ref gf 'effective-methods))))
+ (slot-set! gf 'effective-methods cache)
+ (slot-set! gf 'procedure (delayed-compile gf))
+ cmethod))
+ (parse 0 args))
-(define (cache-try-hash! min-misses hashset cache entries)
- (let ((mask (- (vector-length cache) 1)))
- (let outer ((in entries) (max-misses 0))
- (if (null? in)
- max-misses
- (let inner ((i (logand mask (cache-hashval hashset (car in))))
- (misses 0))
- (cond
- ((and (pair? (vector-ref cache i))
- (eq? (car (vector-ref cache i)) 'no-method))
- (vector-set! cache i (car in))
- (outer (cdr in) (if (> misses max-misses) misses max-misses)))
- (else
- (let ((misses (+ 1 misses)))
- (if (>= misses min-misses)
- misses ;; this is a return, yo.
- (inner (logand mask (+ i 1)) misses))))))))))
;;;
;;; Memoization
;;;
-;; Backward compatibility
-(define (lookup-create-cmethod gf args)
- (no-applicable-method (car args) (cadr args)))
-
-(define (memoize-method! gf args exp)
- (if (not (slot-ref gf 'used-by))
- (slot-set! gf 'used-by '()))
+(define (memoize-method! gf args)
(let ((applicable ((if (eq? gf compute-applicable-methods)
%compute-applicable-methods
compute-applicable-methods)
gf args)))
(cond (applicable
- ;; *fixme* dispatch.scm needs rewriting Since the current
- ;; code mutates the method cache, we have to work on a
- ;; copy. Otherwise we might disturb another thread
- ;; currently dispatching on the cache. (No need to copy
- ;; the vector.)
- (let* ((new (list-copy exp))
- (res
- (cond ((method-cache-hashed? new)
- (method-cache-install! hashed-method-cache-insert!
- new args applicable))
- ((passed-hash-threshold? new)
- (method-cache-install! hashed-method-cache-insert!
- (method-cache->hashed! new)
- args
- applicable))
- (else
- (method-cache-install! method-cache-insert!
- new args applicable)))))
- (set-cdr! (cdr exp) (cddr new))
- res))
- ((null? args)
- (lookup-create-cmethod no-applicable-method (list gf '())))
+ (memoize-effective-method! gf args applicable))
(else
- ;; Mutate arglist to fit no-applicable-method
- (set-cdr! args (list (cons (car args) (cdr args))))
- (set-car! args gf)
- (lookup-create-cmethod no-applicable-method args)))))
+ (no-applicable-method gf args)))))
(set-procedure-property! memoize-method! 'system-procedure #t)
-
-(define method-cache-install!
- (letrec ((first-n
- (lambda (ls n)
- (if (or (zero? n) (null? ls))
- '()
- (cons (car ls) (first-n (cdr ls) (- n 1)))))))
- (lambda (insert! exp args applicable)
- (let* ((specializers (method-specializers (car applicable)))
- (n-specializers
- (if (list? specializers)
- (length specializers)
- (+ 1 (slot-ref (method-cache-generic-function exp)
- 'n-specialized)))))
- (let* ((types (map class-of (first-n args n-specializers)))
- (cmethod (compute-cmethod applicable types)))
- (insert! exp (append types cmethod)) ; entry = types + cmethod
- cmethod))))) ; cmethod
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index c7a03d6..8a06ad9 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -20,6 +20,9 @@
#:use-module (test-suite lib)
#:autoload (srfi srfi-1) (unfold))
+(define exception:no-applicable-method
+ '(goops-error . "^No applicable method"))
+
(pass-if "GOOPS loads"
(false-if-exception
(begin (resolve-module '(oop goops))
@@ -405,18 +408,6 @@
(define o4 (make <c> #:x '(4) #:y '(3)))
(not (eqv? o1 o2)))
(current-module)))
- (pass-if "eqv?"
- (eval '(begin
- (define-method (eqv? (a <c>) (b <c>))
- (equal? (x a) (x b)))
- (eqv? o1 o2))
- (current-module)))
- (pass-if "not eqv?"
- (eval '(not (eqv? o2 o3))
- (current-module)))
- (pass-if "transfer eqv? => equal?"
- (eval '(equal? o1 o2)
- (current-module)))
(pass-if "equal?"
(eval '(begin
(define-method (equal? (a <c>) (b <c>))
@@ -499,3 +490,23 @@
(= (x (o2 o)) 3)
(= (y (o2 o)) 5)))
(current-module))))
+
+(with-test-prefix "no-applicable-method"
+ (pass-if-exception "calling generic, no methods"
+ exception:no-applicable-method
+ (eval '(begin
+ (define-class <qux> ())
+ (define-generic quxy)
+ (quxy 1))
+ (current-module)))
+ (pass-if "calling generic, one method, applicable"
+ (eval '(begin
+ (define-method (quxy (q <qux>))
+ #t)
+ (define q (make <qux>))
+ (quxy q))
+ (current-module)))
+ (pass-if-exception "calling generic, one method, not applicable"
+ exception:no-applicable-method
+ (eval '(quxy 1)
+ (current-module))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-5-41-g2858dea,
Andy Wingo <=