mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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.
This commit is contained in:
Andy Wingo
parent
c2c4e28198
commit
9d019f9be0
3 changed files with 41 additions and 99 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
(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)))
|
||||
;; 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))))
|
||||
;; 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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue