From 07452c83aee3a3ce0caa4cb61673351ed7007bea Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 11 Jan 2015 19:11:41 +0100 Subject: [PATCH] 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 05bc06e15..f8c8a8474 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 8992c2b9f..f7233cb4d 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 3a930e66e..435367854 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 ) (eq? class )) @@ -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 ) (eq? class )) (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 )) - (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 )) - (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 ) initargs) - (%allocate-instance class initargs)) + (%allocate-instance class)) (define-method (make-instance (class ) . initargs) (let ((instance (allocate-instance class initargs))) -- 2.20.1