[Guile-commits] 47/88: Rewrite %initialize-object in Scheme

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 4a28ef1086a1fa6c890f7306ca81161cdd817119
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 11 00:17:22 2015 +0100

    Rewrite %initialize-object in Scheme
    
    * libguile/goops.h:
    * libguile/goops.c (scm_sys_initialize_object): Remove C interface.
      This function was only really useful as part of a GOOPS initialize
      method but was not exported from the goops module.
    
    * module/oop/goops.scm (get-keyword, %initialize-object): Implement in
      Scheme.
---
 libguile/goops.c     |   68 --------------------------------------------------
 libguile/goops.h     |    1 -
 module/oop/goops.scm |   48 +++++++++++++++++++++++++++++++++++
 3 files changed, 48 insertions(+), 69 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index d722e0d..ce07686 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -332,74 +332,6 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
 SCM_KEYWORD (k_init_keyword, "init-keyword");
 
 
-SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
-           (SCM obj, SCM initargs),
-           "Initialize the object @var{obj} with the given arguments\n"
-           "@var{initargs}.")
-#define FUNC_NAME s_scm_sys_initialize_object
-{
-  SCM tmp, get_n_set, slots;
-  SCM class       = SCM_CLASS_OF (obj);
-  long n_initargs;
-
-  SCM_VALIDATE_INSTANCE (1, obj);
-  n_initargs = scm_ilength (initargs);
-  SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
-
-  get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
-  slots     = SCM_SLOT (class, scm_si_slots);
-
-  /* See for each slot how it must be initialized */
-  for (;
-       !scm_is_null (slots);
-       get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
-    {
-      SCM slot_name  = SCM_CAR (slots);
-      SCM slot_value = SCM_GOOPS_UNBOUND;
-
-      if (!scm_is_null (SCM_CDR (slot_name)))
-       {
-         /* This slot admits (perhaps) to be initialized at creation time */
-         long n = scm_ilength (SCM_CDR (slot_name));
-         if (n & 1) /* odd or -1 */
-           SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
-                           scm_list_1 (slot_name));
-         tmp   = scm_i_get_keyword (k_init_keyword,
-                                    SCM_CDR (slot_name),
-                                    n,
-                                    SCM_PACK (0),
-                                    FUNC_NAME);
-         slot_name = SCM_CAR (slot_name);
-         if (SCM_UNPACK (tmp))
-           {
-             /* an initarg was provided for this slot */
-             if (!scm_is_keyword (tmp))
-               SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
-                               scm_list_1 (tmp));
-             slot_value = scm_i_get_keyword (tmp,
-                                             initargs,
-                                             n_initargs,
-                                             SCM_GOOPS_UNBOUND,
-                                             FUNC_NAME);
-           }
-       }
-
-      if (!SCM_GOOPS_UNBOUNDP (slot_value))
-       /* set slot to provided value */
-       scm_slot_set_x (obj, slot_name, slot_value);
-      else
-       {
-         /* set slot to its :init-form if it exists */
-         tmp = SCM_CADAR (get_n_set);
-         if (scm_is_true (tmp))
-            scm_slot_set_x (obj, slot_name, scm_call_0 (tmp));
-       }
-    }
-
-  return obj;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0,
            (SCM class, SCM layout),
            "")
diff --git a/libguile/goops.h b/libguile/goops.h
index 4550baa..f2655a8 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -136,7 +136,6 @@ SCM_INTERNAL void scm_i_inherit_applicable (SCM c);
 SCM_INTERNAL SCM scm_i_get_keyword (SCM key, SCM l, long len,
                                    SCM default_value, const char *subr);
 SCM_API SCM scm_get_keyword (SCM key, SCM l, SCM default_value);
-SCM_API SCM scm_sys_initialize_object (SCM obj, SCM initargs);
 SCM_API SCM scm_sys_inherit_magic_x (SCM c, SCM dsupers);
 SCM_API SCM scm_instance_p (SCM obj);
 SCM_API int scm_is_generic (SCM x);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index dcc9a45..ed60d4c 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -599,6 +599,22 @@
 (define (invalidate-method-cache! gf)
   (%invalidate-method-cache! gf))
 
+(define* (get-keyword key l #:optional default)
+  "Determine an associated value for the keyword @var{key} from the list
address@hidden  The list @var{l} has to consist of an even number of elements,
+where, starting with the first, every second element is a keyword,
+followed by its associated value.  If @var{l} does not hold a value for
address@hidden, the value @var{default} is returned."
+  (unless (keyword? key)
+    (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f))
+  (let lp ((l l))
+    (match l
+      (() default)
+      ((kw arg . l)
+       (unless (keyword? kw)
+         (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
+       (if (eq? kw key) arg (lp l))))))
+
 ;; A simple make which will be redefined later.  This version handles
 ;; only creation of gf, methods and classes (no instances).
 ;;
@@ -2333,6 +2349,38 @@
 ;;; {Initialize}
 ;;;
 
+(define *unbound* (make-unbound))
+
+;; FIXME: This could be much more efficient.
+(define (%initialize-object obj initargs)
+  "Initialize the object @var{obj} with the given arguments
+var{initargs}."
+  (unless (instance? obj)
+    (scm-error 'wrong-type-arg #f "Not an object: ~S"
+               (list obj) #f))
+  (unless (even? (length initargs))
+    (scm-error 'wrong-type-arg #f "Initargs has odd length: ~S"
+               (list initargs) #f))
+  (let ((class (class-of obj)))
+    (define (get-initarg kw)
+      (if kw
+          (get-keyword kw initargs *unbound*)
+          *unbound*))
+    (let lp ((get-n-set (struct-ref class class-index-getters-n-setters))
+             (slots (struct-ref class class-index-slots)))
+      (match slots
+        (() obj)
+        (((name . options) . slots)
+         (match get-n-set
+           (((_ init-thunk . _) . get-n-set)
+            (let ((initarg (get-initarg (get-keyword #:init-keyword options))))
+              (cond
+               ((not (unbound? initarg))
+                (slot-set! obj name initarg))
+               (init-thunk
+                (slot-set! obj name (init-thunk)))))
+            (lp get-n-set slots))))))))
+
 (define-method (initialize (object <object>) initargs)
   (%initialize-object object initargs))