diff options
author | Andy Wingo <wingo@pobox.com> | 2009-11-27 20:50:40 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-12-01 21:00:25 +0100 |
commit | 9d019f9be0a1a7d3aaa507c9996cd5097da53875 (patch) | |
tree | 1213b717cf840d383cdd2ab84ac91dfa3395b52e | |
parent | c2c4e281988bf1c5261fde3a74566dc49d8eecf7 (diff) | |
download | guile-9d019f9be0a1a7d3aaa507c9996cd5097da53875.tar.gz |
remove class-environment slot, goops grubs less in the evaluator
* libguile/goops.h (scm_sys_tag_body): Remove declaration of undefined
function.
(SCM_CLASS_CLASS_LAYOUT, scm_si_environment, SCM_N_CLASS_SLOTS)
(scm_class_environment) Remove class environment slot and getter.
* libguile/goops.c (compute_getters_n_setters): Use scm_primitive_eval
to produce the init thunk, instead of scm_i_eval_x; though really we
should be doing this in Scheme.
(scm_basic_basic_make_class, build_class_class_slots)
(create_basic_classes, scm_class_environment): Remove class
environment slot.
(get_slot_value, set_slot_value): Use scm_call_1 instead of evaluator
tricks.
* module/oop/goops.scm: Remove class-environment export, and
environments throughout the file.
-rw-r--r-- | libguile/goops.c | 60 | ||||
-rw-r--r-- | libguile/goops.h | 8 | ||||
-rw-r--r-- | module/oop/goops.scm | 76 |
3 files changed, 43 insertions, 101 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 89047cf46..dcb1b7d12 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -465,11 +465,10 @@ compute_getters_n_setters (SCM slots) init = scm_get_keyword (k_init_value, options, 0); if (init) { - init = scm_i_eval_x (scm_list_3 (scm_sym_lambda, - SCM_EOL, - scm_list_2 (scm_sym_quote, - init)), - SCM_EOL); + init = scm_primitive_eval (scm_list_3 (scm_sym_lambda, + SCM_EOL, + scm_list_2 (scm_sym_quote, + init))); } else init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F); @@ -785,8 +784,6 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) SCM_SET_SLOT (z, scm_si_nfields, nfields); SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s); SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F); - SCM_SET_SLOT (z, scm_si_environment, - scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); /* Add this class in the direct-subclasses slot of dsupers */ { @@ -840,7 +837,6 @@ SCM_SYMBOL (sym_slots, "slots"); SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters"); SCM_SYMBOL (sym_keyword_access, "keyword-access"); SCM_SYMBOL (sym_nfields, "nfields"); -SCM_SYMBOL (sym_environment, "environment"); static SCM @@ -876,7 +872,6 @@ build_class_class_slots () scm_list_1 (sym_getters_n_setters), scm_list_1 (sym_keyword_access), scm_list_1 (sym_nfields), - scm_list_1 (sym_environment), SCM_UNDEFINED); } @@ -905,8 +900,6 @@ create_basic_classes (void) /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters, compute_getters_n_setters (slots_of_class)); */ SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F); - SCM_SET_SLOT (scm_class_class, scm_si_environment, - scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE)); prep_hashsets (scm_class_class); @@ -1024,17 +1017,6 @@ SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0, - (SCM obj), - "Return the environment of the class @var{obj}.") -#define FUNC_NAME s_scm_class_environment -{ - SCM_VALIDATE_CLASS (1, obj); - return scm_slot_ref(obj, sym_environment); -} -#undef FUNC_NAME - - SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0, (SCM obj), "Return the name of the generic function @var{obj}.") @@ -1245,20 +1227,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef) access bits for us. */ return scm_struct_ref (obj, access); else - { - /* We must evaluate (apply (car access) (list obj)) - * where (car access) is known to be a closure of arity 1 */ - register SCM code, env; - - code = SCM_CAR (access); - if (!SCM_CLOSUREP (code)) - return scm_call_1 (code, obj); - env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), - scm_list_1 (obj), - SCM_ENV (code)); - /* Evaluate the closure body */ - return scm_eval_body (SCM_CLOSURE_BODY (code), env); - } + return scm_call_1 (SCM_CAR (access), obj); } #undef FUNC_NAME @@ -1288,23 +1257,8 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value) /* obey permissions bits via going through struct-set! */ scm_struct_set_x (obj, access, value); else - { - /* We must evaluate (apply (cadr l) (list obj value)) - * where (cadr l) is known to be a closure of arity 2 */ - register SCM code, env; - - code = SCM_CADR (access); - if (!SCM_CLOSUREP (code)) - scm_call_2 (code, obj, value); - else - { - env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), - scm_list_2 (obj, value), - SCM_ENV (code)); - /* Evaluate the closure body */ - scm_eval_body (SCM_CLOSURE_BODY (code), env); - } - } + /* ((cadr l) obj value) */ + scm_call_2 (SCM_CADR (access), obj, value); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/goops.h b/libguile/goops.h index 382422d5f..914ab3c70 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -80,8 +80,7 @@ "pw" /* slots */ \ "pw" /* getters-n-setters */ \ "pw" /* keyword access */ \ - "pw" /* nfields */ \ - "pw" /* environment */ + "pw" /* nfields */ #define scm_si_redefined (scm_vtable_offset_user + 0) #define scm_si_h0 (scm_vtable_offset_user + 1) @@ -104,8 +103,7 @@ #define scm_si_getters_n_setters scm_si_name_access #define scm_si_keyword_access (scm_vtable_offset_user + 17) #define scm_si_nfields (scm_vtable_offset_user + 18) /* an integer */ -#define scm_si_environment (scm_vtable_offset_user + 19) /* The environment in which class is built */ -#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 20) +#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 19) typedef struct scm_t_method { SCM generic_function; @@ -275,13 +273,11 @@ SCM_API SCM scm_class_direct_subclasses (SCM obj); SCM_API SCM scm_class_direct_methods (SCM obj); SCM_API SCM scm_class_precedence_list (SCM obj); SCM_API SCM scm_class_slots (SCM obj); -SCM_API SCM scm_class_environment (SCM obj); SCM_API SCM scm_generic_function_name (SCM obj); SCM_API SCM scm_generic_function_methods (SCM obj); SCM_API SCM scm_method_generic_function (SCM obj); SCM_API SCM scm_method_specializers (SCM obj); SCM_API SCM scm_method_procedure (SCM obj); -SCM_API SCM scm_sys_tag_body (SCM body); SCM_API SCM scm_sys_fast_slot_ref (SCM obj, SCM index); SCM_API SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value); SCM_API SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name); diff --git a/module/oop/goops.scm b/module/oop/goops.scm index c8a183bcf..87afae994 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -66,7 +66,7 @@ slot-exists-using-class? slot-ref slot-set! slot-bound? class-name class-direct-supers class-direct-subclasses class-direct-methods class-direct-slots class-precedence-list - class-slots class-environment + class-slots generic-function-name generic-function-methods method-generic-function method-specializers method-formals @@ -129,7 +129,7 @@ (set! table-of-metas (cons (cons meta-supers new) table-of-metas)) new)))))) -(define (ensure-metaclass supers env) +(define (ensure-metaclass supers) (if (null? supers) <class> (let* ((all-metas (map (lambda (x) (class-of x)) supers)) @@ -175,36 +175,33 @@ (mapper f k a))) (define (make-class supers slots . options) - (let ((env (or (get-keyword #:environment options #f) - (top-level-env)))) - (let* ((name (get-keyword #:name options (make-unbound))) - (supers (if (not (or-map (lambda (class) - (memq <object> - (class-precedence-list class))) - supers)) - (append supers (list <object>)) - supers)) - (metaclass (or (get-keyword #:metaclass options #f) - (ensure-metaclass supers env)))) - - ;; Verify that all direct slots are different and that we don't inherit - ;; several time from the same class - (let ((tmp1 (find-duplicate supers)) - (tmp2 (find-duplicate (map slot-definition-name slots)))) - (if tmp1 - (goops-error "make-class: super class ~S is duplicate in class ~S" - tmp1 name)) - (if tmp2 - (goops-error "make-class: slot ~S is duplicate in class ~S" - tmp2 name))) - - ;; Everything seems correct, build the class - (apply make metaclass - #:dsupers supers - #:slots slots - #:name name - #:environment env - options)))) + (let* ((name (get-keyword #:name options (make-unbound))) + (supers (if (not (or-map (lambda (class) + (memq <object> + (class-precedence-list class))) + supers)) + (append supers (list <object>)) + supers)) + (metaclass (or (get-keyword #:metaclass options #f) + (ensure-metaclass supers)))) + + ;; Verify that all direct slots are different and that we don't inherit + ;; several time from the same class + (let ((tmp1 (find-duplicate supers)) + (tmp2 (find-duplicate (map slot-definition-name slots)))) + (if tmp1 + (goops-error "make-class: super class ~S is duplicate in class ~S" + tmp1 name)) + (if tmp2 + (goops-error "make-class: slot ~S is duplicate in class ~S" + tmp2 name))) + + ;; Everything seems correct, build the class + (apply make metaclass + #:dsupers supers + #:slots slots + #:name name + options))) ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) ;;; @@ -1066,7 +1063,6 @@ (make-class (class-direct-supers c) (class-direct-slots c) #:name (class-name c) - #:environment (slot-ref c 'environment) #:metaclass (class-of c)))) ;;; @@ -1075,7 +1071,7 @@ ;;; compute-slot-accessors ;;; -(define (compute-slot-accessors class slots env) +(define (compute-slot-accessors class slots) (for-each (lambda (s g-n-s) (let ((getter-function (slot-definition-getter s)) @@ -1172,7 +1168,7 @@ (define (make-thunk thunk) (lambda () (thunk))) -(define (compute-getters-n-setters class slots env) +(define (compute-getters-n-setters class slots) (define (compute-slot-init-function name s) (or (let ((thunk (slot-definition-init-thunk s))) @@ -1439,9 +1435,7 @@ (define-method (initialize (class <class>) initargs) (next-method) (let ((dslots (get-keyword #:slots initargs '())) - (supers (get-keyword #:dsupers initargs '())) - (env (get-keyword #:environment initargs (top-level-env)))) - + (supers (get-keyword #:dsupers initargs '()))) (slot-set! class 'name (get-keyword #:name initargs '???)) (slot-set! class 'direct-supers supers) (slot-set! class 'direct-slots dslots) @@ -1449,15 +1443,13 @@ (slot-set! class 'direct-methods '()) (slot-set! class 'cpl (compute-cpl class)) (slot-set! class 'redefined #f) - (slot-set! class 'environment env) (let ((slots (compute-slots class))) (slot-set! class 'slots slots) (slot-set! class 'nfields 0) (slot-set! class 'getters-n-setters (compute-getters-n-setters class - slots - env)) + slots)) ;; Build getters - setters - accessors - (compute-slot-accessors class slots env)) + (compute-slot-accessors class slots)) ;; Update the "direct-subclasses" of each inherited classes (for-each (lambda (x) |