[Guile-commits] 36/87: <class> accessors implemented in Scheme

[Andy Wingo]

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

commit 3bb2f0865b24948eba692d9224b0b153166ec501
Author: Andy Wingo <address@hidden>
Date:   Fri Jan 9 21:01:03 2015 +0100

    <class> accessors implemented in Scheme
    
    * libguile/goops.c (scm_class_p): New internal helper, exported to
      goops.scm.
      (scm_class_name, scm_class_direct_supers, scm_class_direct_slots):
      (scm_class_direct_subclasses, scm_class_direct_methods):
      (scm_class_precedence_list, scm_class_slots): Dispatch to Scheme.
      (scm_sys_goops_early_init): Capture <class> accessors.
    
    * module/oop/goops.scm (define-class-accessor): New helper.
      (class-name, class-direct-supers, class-direct-slots):
      (class-direct-subclasses, class-direct-methods)
      (class-precedence-list, class-slots): Define in Scheme.
      (compute-std-cpl, compute-cpl): Move lower.
---
 libguile/goops.c     |  104 ++++++++++++++++--------------------
 module/oop/goops.scm |  145 ++++++++++++++++++++++++++++++--------------------
 2 files changed, 135 insertions(+), 114 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 6e3d71d..b37c5aa 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -69,6 +69,13 @@ static SCM var_slot_unbound = SCM_BOOL_F;
 static SCM var_slot_missing = SCM_BOOL_F;
 static SCM var_change_class = SCM_BOOL_F;
 static SCM var_make = 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;
+static SCM var_class_direct_subclasses = SCM_BOOL_F;
+static SCM var_class_direct_methods = SCM_BOOL_F;
+static SCM var_class_precedence_list = SCM_BOOL_F;
+static SCM var_class_slots = SCM_BOOL_F;
 
 SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
 SCM_SYMBOL (sym_slot_missing, "slot-missing");
@@ -163,6 +170,7 @@ SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT];
 
 static SCM scm_make_unbound (void);
 static SCM scm_unbound_p (SCM obj);
+static SCM scm_class_p (SCM obj);
 static SCM scm_sys_bless_applicable_struct_vtables_x (SCM applicable,
                                                       SCM setter);
 static SCM scm_sys_bless_pure_generic_vtable_x (SCM vtable);
@@ -496,6 +504,15 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_class_p, "class?", 1, 0, 0,
+           (SCM obj),
+           "Return @code{#t} if @var{obj} is a class.")
+#define FUNC_NAME s_scm_class_p
+{
+  return scm_from_bool (SCM_CLASSP (obj));
+}
+#undef FUNC_NAME
+
 int
 scm_is_generic (SCM x)
 {
@@ -515,85 +532,51 @@ scm_is_method (SCM x)
  
******************************************************************************/
 
 SCM_SYMBOL (sym_procedure, "procedure");
-SCM_SYMBOL (sym_direct_supers, "direct-supers");
-SCM_SYMBOL (sym_direct_slots, "direct-slots");
-SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
-SCM_SYMBOL (sym_direct_methods, "direct-methods");
-SCM_SYMBOL (sym_cpl, "cpl");
-SCM_SYMBOL (sym_slots, "slots");
-
-SCM_DEFINE (scm_class_name, "class-name",  1, 0, 0,
-           (SCM obj),
-           "Return the class name of @var{obj}.")
-#define FUNC_NAME s_scm_class_name
+
+SCM
+scm_class_name (SCM obj)
 {
-  SCM_VALIDATE_CLASS (1, obj);
-  return scm_slot_ref (obj, scm_sym_name);
+  return scm_call_1 (scm_variable_ref (var_class_name), obj);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
-           (SCM obj),
-           "Return the direct superclasses of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_direct_supers
+SCM
+scm_class_direct_supers (SCM obj)
 {
-  SCM_VALIDATE_CLASS (1, obj);
-  return scm_slot_ref (obj, sym_direct_supers);
+  return scm_call_1 (scm_variable_ref (var_class_direct_supers), obj);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
-           (SCM obj),
-           "Return the direct slots of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_direct_slots
+SCM
+scm_class_direct_slots (SCM obj)
 {
-  SCM_VALIDATE_CLASS (1, obj);
-  return scm_slot_ref (obj, sym_direct_slots);
+  return scm_call_1 (scm_variable_ref (var_class_direct_slots), obj);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
-           (SCM obj),
-           "Return the direct subclasses of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_direct_subclasses
+SCM
+scm_class_direct_subclasses (SCM obj)
 {
-  SCM_VALIDATE_CLASS (1, obj);
-  return scm_slot_ref(obj, sym_direct_subclasses);
+  return scm_call_1 (scm_variable_ref (var_class_direct_subclasses), obj);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
-           (SCM obj),
-           "Return the direct methods of the class @var{obj}")
-#define FUNC_NAME s_scm_class_direct_methods
+SCM
+scm_class_direct_methods (SCM obj)
 {
-  SCM_VALIDATE_CLASS (1, obj);
-  return scm_slot_ref (obj, sym_direct_methods);
+  return scm_call_1 (scm_variable_ref (var_class_direct_methods), obj);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
-           (SCM obj),
-           "Return the class precedence list of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_precedence_list
+SCM
+scm_class_precedence_list (SCM obj)
 {
-  SCM_VALIDATE_CLASS (1, obj);
-  return scm_slot_ref (obj, sym_cpl);
+  return scm_call_1 (scm_variable_ref (var_class_precedence_list), obj);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
-           (SCM obj),
-           "Return the slot list of the class @var{obj}.")
-#define FUNC_NAME s_scm_class_slots
+SCM
+scm_class_slots (SCM obj)
 {
-  SCM_VALIDATE_CLASS (1, obj);
-  return scm_slot_ref (obj, sym_slots);
+  return scm_call_1 (scm_variable_ref (var_class_slots), obj);
 }
-#undef FUNC_NAME
 
 SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
-           (SCM obj),
+            (SCM obj),
            "Return the name of the generic function @var{obj}.")
 #define FUNC_NAME s_scm_generic_function_name
 {
@@ -1598,6 +1581,13 @@ 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_class_name = scm_c_lookup ("class-name");
+  var_class_direct_supers = scm_c_lookup ("class-direct-supers");
+  var_class_direct_slots = scm_c_lookup ("class-direct-slots");
+  var_class_direct_subclasses = scm_c_lookup ("class-direct-subclasses");
+  var_class_direct_methods = scm_c_lookup ("class-direct-methods");
+  var_class_precedence_list = scm_c_lookup ("class-precedence-list");
+  var_class_slots = scm_c_lookup ("class-slots");
 
   class_class = scm_variable_ref (scm_c_lookup ("<class>"));
   class_top = scm_variable_ref (scm_c_lookup ("<top>"));
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 77c387d..b1da1ff 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -150,63 +150,6 @@
   (use-modules ((language tree-il primitives) :select 
(add-interesting-primitive!)))
   (add-interesting-primitive! 'class-of))
 
-;;; The standard class precedence list computation algorithm
-;;;
-;;; Correct behaviour:
-;;;
-;;; (define-class food ())
-;;; (define-class fruit (food))
-;;; (define-class spice (food))
-;;; (define-class apple (fruit))
-;;; (define-class cinnamon (spice))
-;;; (define-class pie (apple cinnamon))
-;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
-;;;
-;;; (define-class d ())
-;;; (define-class e ())
-;;; (define-class f ())
-;;; (define-class b (d e))
-;;; (define-class c (e f))
-;;; (define-class a (b c))
-;;; => cpl (a) = a b d c e f object top
-;;;
-
-(define (compute-std-cpl c get-direct-supers)
-  (define (only-non-null lst)
-    (filter (lambda (l) (not (null? l))) lst))
-
-  (define (merge-lists reversed-partial-result inputs)
-    (cond
-     ((every null? inputs)
-      (reverse! reversed-partial-result))
-     (else
-      (let* ((candidate (lambda (c)
-                          (and (not (any (lambda (l)
-                                           (memq c (cdr l)))
-                                         inputs))
-                               c)))
-             (candidate-car (lambda (l)
-                              (and (not (null? l))
-                                   (candidate (car l)))))
-             (next (any candidate-car inputs)))
-        (if (not next)
-            (goops-error "merge-lists: Inconsistent precedence graph"))
-        (let ((remove-next (lambda (l)
-                             (if (eq? (car l) next)
-                                 (cdr l)
-                                 l))))
-          (merge-lists (cons next reversed-partial-result)
-                       (only-non-null (map remove-next inputs))))))))
-  (let ((c-direct-supers (get-direct-supers c)))
-    (merge-lists (list c)
-                 (only-non-null (append (map class-precedence-list
-                                             c-direct-supers)
-                                        (list c-direct-supers))))))
-
-;; Bootstrap version.
-(define (compute-cpl class)
-  (compute-std-cpl class class-direct-supers))
-
 (define-syntax macro-fold-left
   (syntax-rules ()
     ((_ folder seed ()) seed)
@@ -264,6 +207,94 @@
                        tail))))))
   (fold-<class>-slots macro-fold-left define-class-index (begin)))
 
+(define-syntax-rule (define-class-accessor name docstring field)
+  (define (name obj)
+    docstring
+    (let ((val obj))
+      (unless (class? val)
+        (scm-error 'wrong-type-arg #f "Not a class: ~S"
+                   (list val) #f))
+      (struct-ref val field))))
+
+(define-class-accessor class-name
+  "Return the class name of @var{obj}."
+  class-index-name)
+(define-class-accessor class-direct-supers
+  "Return the direct superclasses of the class @var{obj}."
+  class-index-direct-supers)
+(define-class-accessor class-direct-slots
+  "Return the direct slots of the class @var{obj}."
+  class-index-direct-slots)
+(define-class-accessor class-direct-subclasses
+  "Return the direct subclasses of the class @var{obj}."
+  class-index-direct-subclasses)
+(define-class-accessor class-direct-methods
+  "Return the direct methods of the class @var{obj}."
+  class-index-direct-methods)
+(define-class-accessor class-precedence-list
+  "Return the class precedence list of the class @var{obj}."
+  class-index-cpl)
+(define-class-accessor class-slots
+  "Return the slot list of the class @var{obj}."
+  class-index-slots)
+
+;;; The standard class precedence list computation algorithm
+;;;
+;;; Correct behaviour:
+;;;
+;;; (define-class food ())
+;;; (define-class fruit (food))
+;;; (define-class spice (food))
+;;; (define-class apple (fruit))
+;;; (define-class cinnamon (spice))
+;;; (define-class pie (apple cinnamon))
+;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
+;;;
+;;; (define-class d ())
+;;; (define-class e ())
+;;; (define-class f ())
+;;; (define-class b (d e))
+;;; (define-class c (e f))
+;;; (define-class a (b c))
+;;; => cpl (a) = a b d c e f object top
+;;;
+
+(define (compute-std-cpl c get-direct-supers)
+  (define (only-non-null lst)
+    (filter (lambda (l) (not (null? l))) lst))
+
+  (define (merge-lists reversed-partial-result inputs)
+    (cond
+     ((every null? inputs)
+      (reverse! reversed-partial-result))
+     (else
+      (let* ((candidate (lambda (c)
+                          (and (not (any (lambda (l)
+                                           (memq c (cdr l)))
+                                         inputs))
+                               c)))
+             (candidate-car (lambda (l)
+                              (and (not (null? l))
+                                   (candidate (car l)))))
+             (next (any candidate-car inputs)))
+        (if (not next)
+            (goops-error "merge-lists: Inconsistent precedence graph"))
+        (let ((remove-next (lambda (l)
+                             (if (eq? (car l) next)
+                                 (cdr l)
+                                 l))))
+          (merge-lists (cons next reversed-partial-result)
+                       (only-non-null (map remove-next inputs))))))))
+  (let ((c-direct-supers (get-direct-supers c)))
+    (merge-lists (list c)
+                 (only-non-null (append (map class-precedence-list
+                                             c-direct-supers)
+                                        (list c-direct-supers))))))
+
+;; Bootstrap version.
+(define (compute-cpl class)
+  (compute-std-cpl class class-direct-supers))
+
 (define (build-slots-list dslots cpl)
   (define (check-cpl slots class-slots)
     (when (or-map (lambda (slot-def) (assq (car slot-def) slots))