[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/08: Reimplement inherit-applicable! in Scheme
From: |
Andy Wingo |
Subject: |
[Guile-commits] 04/08: Reimplement inherit-applicable! in Scheme |
Date: |
Sun, 11 Jan 2015 21:23:59 +0000 |
wingo pushed a commit to branch wip-goops-refactor
in repository guile.
commit e1c9341f21d44d8f7bdaed815b23d11091616914
Author: Andy Wingo <address@hidden>
Date: Sun Jan 11 20:49:16 2015 +0100
Reimplement inherit-applicable! in Scheme
* libguile/goops.c: Move captured keywords and symbols up to the top.
(scm_i_inherit_applicable): Dispatch to Scheme.
(scm_sys_goops_early_init): Capture inherit-applicable!.
* module/oop/goops.scm (inherit-applicable!): Scheme implementation.
---
libguile/goops.c | 43 +++++++------------------------------------
module/oop/goops.scm | 26 ++++++++++++++++++++++++++
2 files changed, 33 insertions(+), 36 deletions(-)
diff --git a/libguile/goops.c b/libguile/goops.c
index cf7f564..278d22a 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -67,11 +67,16 @@
References to ordinary procedures is by reference (by variable),
though, as in the rest of Guile. */
+SCM_KEYWORD (k_name, "name");
+SCM_KEYWORD (k_setter, "setter");
+SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+
static int goops_loaded_p = 0;
static SCM var_make_standard_class = SCM_BOOL_F;
static SCM var_change_class = SCM_BOOL_F;
static SCM var_make = SCM_BOOL_F;
+static SCM var_inherit_applicable = SCM_BOOL_F;
static SCM var_class_name = SCM_BOOL_F;
static SCM var_class_direct_supers = SCM_BOOL_F;
static SCM var_class_direct_slots = SCM_BOOL_F;
@@ -698,9 +703,6 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED,
SCM new_class)
*
******************************************************************************/
-SCM_KEYWORD (k_name, "name");
-SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
-
SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
(SCM proc),
"")
@@ -864,36 +866,7 @@ scm_make_extended_class (char const *type_name, int
applicablep)
void
scm_i_inherit_applicable (SCM c)
{
- if (!SCM_SUBCLASSP (c, class_applicable))
- {
- SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
- SCM cpl = SCM_SLOT (c, scm_si_cpl);
- /* patch class_applicable into direct-supers */
- SCM top = scm_c_memq (class_top, dsupers);
- if (scm_is_false (top))
- dsupers = scm_append (scm_list_2 (dsupers,
- scm_list_1 (class_applicable)));
- else
- {
- SCM_SETCAR (top, class_applicable);
- SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
- }
- SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
- /* patch class_applicable into cpl */
- top = scm_c_memq (class_top, cpl);
- if (scm_is_false (top))
- abort ();
- else
- {
- SCM_SETCAR (top, class_applicable);
- SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
- }
- /* add class to direct-subclasses of class_applicable */
- SCM_SET_SLOT (class_applicable,
- scm_si_direct_subclasses,
- scm_cons (c, SCM_SLOT (class_applicable,
- scm_si_direct_subclasses)));
- }
+ scm_call_1 (scm_variable_ref (var_inherit_applicable), c);
}
static void
@@ -1040,9 +1013,6 @@ scm_load_goops ()
scm_c_resolve_module ("oop goops");
}
-
-SCM_KEYWORD (k_setter, "setter");
-
SCM
scm_ensure_accessor (SCM name)
{
@@ -1088,6 +1058,7 @@ SCM_DEFINE (scm_sys_goops_early_init,
"%goops-early-init", 0, 0, 0,
{
var_make_standard_class = scm_c_lookup ("make-standard-class");
var_make = scm_c_lookup ("make");
+ var_inherit_applicable = scm_c_lookup ("inherit-applicable!");
var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index d4f8af0..ef57f7a 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -619,6 +619,32 @@
(define-standard-class <output-port> (<port>))
(define-standard-class <input-output-port> (<input-port> <output-port>))
+(define (inherit-applicable! class)
+ "An internal routine to redefine a SMOB class that was added after
+GOOPS was loaded, and on which scm_set_smob_apply installed an apply
+function."
+ ;; Why not use class-redefinition? We would, except that loading the
+ ;; compiler to compile effective methods can happen while GOOPS has
+ ;; only been partially loaded, and loading the compiler might cause
+ ;; SMOB types to be defined that need this facility. Instead we make
+ ;; a very specific hack, not a general solution. Probably the right
+ ;; solution is to avoid using the compiler, but that is another kettle
+ ;; of fish.
+ (unless (memq <applicable> (class-precedence-list class))
+ (unless (null? (class-slots class))
+ (error "SMOB object has slots?"))
+ (for-each
+ (lambda (super)
+ (let ((subclasses (struct-ref super class-index-direct-subclasses)))
+ (struct-set! super class-index-direct-subclasses
+ (delq class subclasses))))
+ (struct-ref class class-index-direct-supers))
+ (struct-set! class class-index-direct-supers (list <applicable>))
+ (struct-set! class class-index-cpl (compute-cpl class))
+ (let ((subclasses (struct-ref <applicable> class-index-direct-subclasses)))
+ (struct-set! <applicable> class-index-direct-subclasses
+ (cons class subclasses)))))
+
(define (%invalidate-method-cache! gf)
(slot-set! gf 'procedure (delayed-compile gf))
(slot-set! gf 'effective-methods '()))
- [Guile-commits] branch wip-goops-refactor updated (951cce9 -> b623b66), Andy Wingo, 2015/01/11
- [Guile-commits] 01/08: Move <class> initialization to Scheme, Andy Wingo, 2015/01/11
- [Guile-commits] 05/08: goops.c no longer knows about <class> slot allocation, Andy Wingo, 2015/01/11
- [Guile-commits] 06/08: Remove special cases for <keyword>, Andy Wingo, 2015/01/11
- [Guile-commits] 04/08: Reimplement inherit-applicable! in Scheme,
Andy Wingo <=
- [Guile-commits] 07/08: Incorporate %inherit-magic! into %init-layout!, Andy Wingo, 2015/01/11
- [Guile-commits] 08/08: Cosmetic goops refactors., Andy Wingo, 2015/01/11
- [Guile-commits] 03/08: Reimplement %allocate-instance in Scheme, Andy Wingo, 2015/01/11
- [Guile-commits] 02/08: Re-use the vtable "size" field for GOOPS nfields, Andy Wingo, 2015/01/11