[Guile-commits] 26/61: Reimplement %allocate-instance in Scheme

[Andy Wingo]

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

commit c9d5e3580a7bfcaa58154822d7db77ccade65df6
Author: Andy Wingo <address@hidden>
Date:   Sun Jan 11 19:11:41 2015 +0100

    Reimplement %allocate-instance in Scheme
    
    * libguile/goops.c (scm_sys_clear_fields_x): New function.
      (scm_sys_allocate_instance): Remove.  It was available to C but not to
      Scheme and it's really internal.
    * libguile/goops.h: Remove scm_sys_allocate_instance.
    
    * module/oop/goops.scm (%allocate-instance): Implement in Scheme, using
      allocate-struct and %clear-fields!.
      (make, shallow-clone, deep-clone, allocate-instance): Adapt to
      %allocate-instance not taking an initargs argument.
---
 libguile/goops.c     |   46 ++++++++++++++--------------------------------
 libguile/goops.h     |    1 -
 module/oop/goops.scm |   21 +++++++++++++--------
 3 files changed, 27 insertions(+), 41 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index 05bc06e..f8c8a84 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -153,6 +153,7 @@ static SCM scm_sys_bless_applicable_struct_vtables_x (SCM 
applicable,
                                                       SCM setter);
 static SCM scm_sys_make_root_class (SCM layout);
 static SCM scm_sys_init_layout_x (SCM class, SCM layout);
+static SCM scm_sys_clear_fields_x (SCM obj);
 static SCM scm_sys_goops_early_init (void);
 static SCM scm_sys_goops_loaded (void);
 
@@ -523,45 +524,26 @@ scm_slot_exists_p (SCM obj, SCM slot_name)
   return scm_call_2 (scm_variable_ref (var_slot_exists_p), obj, slot_name);
 }
 
-
-/******************************************************************************
- *
- * %allocate-instance (the low level instance allocation primitive)
- *
- 
******************************************************************************/
-
-SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
-           (SCM class, SCM initargs),
-           "Create a new instance of class @var{class} and initialize it\n"
-           "from the arguments @var{initargs}.")
-#define FUNC_NAME s_scm_sys_allocate_instance
+SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 1, 0, 0,
+           (SCM obj),
+            "")
+#define FUNC_NAME s_scm_sys_clear_fields_x
 {
-  SCM obj;
   scm_t_signed_bits n, i;
-  SCM layout;
+  SCM vtable, layout;
 
-  SCM_VALIDATE_CLASS (1, class);
-
-  /* FIXME: duplicates some of scm_make_struct. */
+  SCM_VALIDATE_STRUCT (1, obj);
+  vtable = SCM_STRUCT_VTABLE (obj);
 
-  n = SCM_STRUCT_DATA_REF (class, scm_vtable_index_size);
-  obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n);
+  n = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
+  layout = SCM_VTABLE_LAYOUT (vtable);
 
-  layout = SCM_VTABLE_LAYOUT (class);
-
-  /* Set all SCM-holding slots to unbound */
+  /* Set all SCM-holding slots to the GOOPS unbound value.  */
   for (i = 0; i < n; i++)
-    {
-      scm_t_wchar c = scm_i_symbol_ref (layout, i*2);
-      if (c == 'p')
-        SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (SCM_GOOPS_UNBOUND);
-      else if (c == 's')
-        SCM_STRUCT_DATA (obj)[i] = SCM_UNPACK (obj);
-      else
-        SCM_STRUCT_DATA (obj)[i] = 0;
-    }
+    if (scm_i_symbol_ref (layout, i*2) == 'p')
+      SCM_STRUCT_SLOT_SET (obj, i, SCM_GOOPS_UNBOUND);
 
-  return obj;
+  return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
 
diff --git a/libguile/goops.h b/libguile/goops.h
index 8992c2b..f7233cb 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -126,7 +126,6 @@ SCM_INTERNAL SCM scm_make_standard_class (SCM meta, SCM 
name, SCM dsupers,
                                           SCM dslots);
 
 /* Primitives exported */
-SCM_API SCM scm_sys_allocate_instance (SCM c, SCM initargs);
 SCM_API SCM scm_slot_ref (SCM obj, SCM slot_name);
 SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value);
 
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 3a930e6..4353678 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -650,6 +650,11 @@ followed by its associated value.  If @var{l} does not 
hold a value for
 ;; Since this code will disappear when Goops will be fully booted,
 ;; no precaution is taken to be efficient.
 ;;
+(define (%allocate-instance class)
+  (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
+    (%clear-fields! obj)
+    obj))
+
 (define (make class . args)
   (cond
    ((or (eq? class <generic>) (eq? class <accessor>))
@@ -662,7 +667,7 @@ followed by its associated value.  If @var{l} does not hold 
a value for
             (slot-set! z 'setter setter))))
       z))
    (else
-    (let ((z (%allocate-instance class args)))
+    (let ((z (%allocate-instance class)))
       (cond
        ((or (eq? class <method>) (eq? class <accessor-method>))
         (for-each (match-lambda
@@ -2026,9 +2031,9 @@ followed by its associated value.  If @var{l} does not 
hold a value for
 ;;;
 
 (define-method (shallow-clone (self <object>))
-  (let ((clone (%allocate-instance (class-of self) '()))
-        (slots (map slot-definition-name
-                    (class-slots (class-of self)))))
+  (let* ((class (class-of self))
+         (clone (%allocate-instance class))
+         (slots (map slot-definition-name (class-slots class))))
     (for-each (lambda (slot)
                 (if (slot-bound? self slot)
                     (slot-set! clone slot (slot-ref self slot))))
@@ -2036,9 +2041,9 @@ followed by its associated value.  If @var{l} does not 
hold a value for
     clone))
 
 (define-method (deep-clone  (self <object>))
-  (let ((clone (%allocate-instance (class-of self) '()))
-        (slots (map slot-definition-name
-                    (class-slots (class-of self)))))
+  (let* ((class (class-of self))
+         (clone (%allocate-instance class))
+         (slots (map slot-definition-name (class-slots class))))
     (for-each (lambda (slot)
                 (if (slot-bound? self slot)
                     (slot-set! clone slot
@@ -2544,7 +2549,7 @@ var{initargs}."
 ;;;
 
 (define-method (allocate-instance (class <class>) initargs)
-  (%allocate-instance class initargs))
+  (%allocate-instance class))
 
 (define-method (make-instance (class <class>) . initargs)
   (let ((instance (allocate-instance class initargs)))