guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 50/87: Reimplement inherit-applicable! in Scheme


From: Andy Wingo
Subject: [Guile-commits] 50/87: Reimplement inherit-applicable! in Scheme
Date: Thu, 22 Jan 2015 17:29:59 +0000

wingo pushed a commit to branch wip-goops-refactor
in repository guile.

commit 26962b0e75c317975763c37b8eeef186c1b9948e
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 014216e..6e946a1 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;
@@ -700,9 +705,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),
            "")
@@ -866,36 +868,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 70d96b5..9c82c29 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -620,6 +620,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 '()))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]