diff options
| -rw-r--r-- | libguile/goops.c | 68 | ||||
| -rw-r--r-- | libguile/goops.h | 1 | ||||
| -rw-r--r-- | module/oop/goops.scm | 48 |
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)) |