summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-27 20:50:40 +0100
committerAndy Wingo <wingo@pobox.com>2009-12-01 21:00:25 +0100
commit9d019f9be0a1a7d3aaa507c9996cd5097da53875 (patch)
tree1213b717cf840d383cdd2ab84ac91dfa3395b52e
parentc2c4e281988bf1c5261fde3a74566dc49d8eecf7 (diff)
downloadguile-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.c60
-rw-r--r--libguile/goops.h8
-rw-r--r--module/oop/goops.scm76
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)