mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Reimplement inherit-applicable! in Scheme

Browse source 
* libguile/goops.c: Move captured keywords and symbols up to the top.
  (scm_i_inherit_applicable): Dispatch to Scheme.
  (scm_sys_goops_early_init): Capture inherit-applicable!.

* module/oop/goops.scm (inherit-applicable!): Scheme implementation.
This commit is contained in:
Andy Wingo 2015-01-11 20:49:16 +01:00
parent 07452c83ae
commit f37bece4e4
2 changed files with 33 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

43
libguile/goops.c
View file

@ -67,11 +67,16 @@
References to ordinary procedures is by reference (by variable),
though, as in the rest of Guile. */
SCM_KEYWORD (k_name, "name");
SCM_KEYWORD (k_setter, "setter");
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
static int goops_loaded_p = 0;
static SCM var_make_standard_class = SCM_BOOL_F;
static SCM var_change_class = SCM_BOOL_F;
static SCM var_make = SCM_BOOL_F;
static SCM var_inherit_applicable = SCM_BOOL_F;
static SCM var_class_name = SCM_BOOL_F;
static SCM var_class_direct_supers = SCM_BOOL_F;
static SCM var_class_direct_slots = SCM_BOOL_F;
@ -700,9 +705,6 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
*
******************************************************************************/
SCM_KEYWORD (k_name, "name");
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
(SCM proc),
"")
@ -866,36 +868,7 @@ scm_make_extended_class (char const *type_name, int applicablep)
void
scm_i_inherit_applicable (SCM c)
{
if (!SCM_SUBCLASSP (c, class_applicable))
{
SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
SCM cpl = SCM_SLOT (c, scm_si_cpl);
/* patch class_applicable into direct-supers */
SCM top = scm_c_memq (class_top, dsupers);
if (scm_is_false (top))
dsupers = scm_append (scm_list_2 (dsupers,
scm_list_1 (class_applicable)));
else
{
SCM_SETCAR (top, class_applicable);
SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
}
SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
/* patch class_applicable into cpl */
top = scm_c_memq (class_top, cpl);
if (scm_is_false (top))
abort ();
else
{
SCM_SETCAR (top, class_applicable);
SCM_SETCDR (top, scm_cons (class_top, SCM_CDR (top)));
}
/* add class to direct-subclasses of class_applicable */
SCM_SET_SLOT (class_applicable,
scm_si_direct_subclasses,
scm_cons (c, SCM_SLOT (class_applicable,
scm_si_direct_subclasses)));
}
scm_call_1 (scm_variable_ref (var_inherit_applicable), c);
}
static void
@ -1040,9 +1013,6 @@ scm_load_goops ()
scm_c_resolve_module ("oop goops");
}
SCM_KEYWORD (k_setter, "setter");
SCM
scm_ensure_accessor (SCM name)
{
@ -1088,6 +1058,7 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
{
var_make_standard_class = scm_c_lookup ("make-standard-class");
var_make = scm_c_lookup ("make");
var_inherit_applicable = scm_c_lookup ("inherit-applicable!");
var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");

26
module/oop/goops.scm
View file

@ -620,6 +620,32 @@
(define-standard-class <output-port> (<port>))
(define-standard-class <input-output-port> (<input-port> <output-port>))
(define (inherit-applicable! class)
"An internal routine to redefine a SMOB class that was added after
GOOPS was loaded, and on which scm_set_smob_apply installed an apply
function."
;; Why not use class-redefinition? We would, except that loading the
;; compiler to compile effective methods can happen while GOOPS has
;; only been partially loaded, and loading the compiler might cause
;; SMOB types to be defined that need this facility. Instead we make
;; a very specific hack, not a general solution. Probably the right
;; solution is to avoid using the compiler, but that is another kettle
;; of fish.
(unless (memq <applicable> (class-precedence-list class))
(unless (null? (class-slots class))
(error "SMOB object has slots?"))
(for-each
(lambda (super)
(let ((subclasses (struct-ref super class-index-direct-subclasses)))
(struct-set! super class-index-direct-subclasses
(delq class subclasses))))
(struct-ref class class-index-direct-supers))
(struct-set! class class-index-direct-supers (list <applicable>))
(struct-set! class class-index-cpl (compute-cpl class))
(let ((subclasses (struct-ref <applicable> class-index-direct-subclasses)))
(struct-set! <applicable> class-index-direct-subclasses
(cons class subclasses)))))
(define (%invalidate-method-cache! gf)
(slot-set! gf 'procedure (delayed-compile gf))
(slot-set! gf 'effective-methods '()))