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.

3 files changed, 48 insertions, 69 deletions

diff --git a/libguile/goops.c b/libguile/goops.c
index d722e0dde..ce07686a2 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 4550baab8..f2655a81a 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 dcc9a45cd..ed60d4cc5 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
+@var{l}.  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
+@var{key}, 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))