[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/08: Reimplement %allocate-instance in Scheme
From: |
Andy Wingo |
Subject: |
[Guile-commits] 03/08: Reimplement %allocate-instance in Scheme |
Date: |
Sun, 11 Jan 2015 21:23:59 +0000 |
wingo pushed a commit to branch wip-goops-refactor
in repository guile.
commit a1d2225200219818270fe275beb94633429b4caf
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 99f7ca2..cf7f564 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);
@@ -521,45 +522,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 f7640af..d4f8af0 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -649,6 +649,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>))
@@ -661,7 +666,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
@@ -2019,9 +2024,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))))
@@ -2029,9 +2034,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
@@ -2524,7 +2529,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)))
- [Guile-commits] branch wip-goops-refactor updated (951cce9 -> b623b66), Andy Wingo, 2015/01/11
- [Guile-commits] 01/08: Move <class> initialization to Scheme, Andy Wingo, 2015/01/11
- [Guile-commits] 05/08: goops.c no longer knows about <class> slot allocation, Andy Wingo, 2015/01/11
- [Guile-commits] 06/08: Remove special cases for <keyword>, Andy Wingo, 2015/01/11
- [Guile-commits] 04/08: Reimplement inherit-applicable! in Scheme, Andy Wingo, 2015/01/11
- [Guile-commits] 07/08: Incorporate %inherit-magic! into %init-layout!, Andy Wingo, 2015/01/11
- [Guile-commits] 08/08: Cosmetic goops refactors., Andy Wingo, 2015/01/11
- [Guile-commits] 03/08: Reimplement %allocate-instance in Scheme,
Andy Wingo <=
- [Guile-commits] 02/08: Re-use the vtable "size" field for GOOPS nfields, Andy Wingo, 2015/01/11