mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

compute-cpl implementation only in Scheme

Browse source 
* libguile/goops.c (build_class_class_slots, create_basic_classes):
  Instead of creating <class> with uninitialized `direct-slots',
  `slots', and `getters-n-setters' fields and initializing them later,
  create <class> with a "boot" version of unspecialized slots and later
  replace the fields with specialized slot classes.  This allows
  slot-ref to work during early boot, which is necessary to move
  compute-cpl to Scheme.
  (create_standard_classes): Finish initializing <class> here.
  (map, filter_cpl, compute_cpl): Remove the boot-time compute-cpl in C
  and its helpers.
  (scm_basic_basic_make_class): Call compute-cpl in Scheme.
  (fix_cpl): Remove; since we use the correct compute-cpl from the
  beginning, there's no need to correct for the deficiencies of the C
  implementation any more.
  (build_slots_list): Adapt to build_class_class_slots change.

* module/oop/goops.scm (compute-std-cpl, compute-cpl): Move these up to
  the top, so they can be called by the boot process.
  (compute-clos-cpl, top-sort, std-tie-breaker, build-transitive-closure)
  (build-constraints): Remove unused private code.
This commit is contained in:
Andy Wingo 2014-12-24 09:37:14 -05:00
parent d1500d3a3b
commit 9167e0b88d
2 changed files with 102 additions and 256 deletions
Download patch file Download diff file Expand all files Collapse all files

156
libguile/goops.c
View file

@ -336,63 +336,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
}
#undef FUNC_NAME
/******************************************************************************
*
* Compute-cpl
*
* This version doesn't fully handle multiple-inheritance. It serves
* only for booting classes and will be overloaded in Scheme
*
******************************************************************************/
static SCM
map (SCM (*proc) (SCM), SCM ls)
{
if (scm_is_null (ls))
return ls;
else
{
SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
SCM h = res;
ls = SCM_CDR (ls);
while (scm_is_pair (ls))
{
SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
h = SCM_CDR (h);
ls = SCM_CDR (ls);
}
return res;
}
}
static SCM
filter_cpl (SCM ls)
{
SCM res = SCM_EOL;
while (scm_is_pair (ls))
{
SCM el = SCM_CAR (ls);
if (scm_is_false (scm_c_memq (el, res)))
res = scm_cons (el, res);
ls = SCM_CDR (ls);
}
return res;
}
static SCM
compute_cpl (SCM class)
{
if (goops_loaded_p)
return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class);
else
{
SCM supers = SCM_SLOT (class, scm_si_direct_supers);
SCM ls = scm_append (scm_acons (class, supers,
map (compute_cpl, supers)));
return scm_reverse_x (filter_cpl (ls), SCM_EOL);
}
}
/******************************************************************************
*
* compute-slots
@ -428,8 +371,8 @@ check_cpl (SCM slots, SCM bslots)
"field cannot be redefined", SCM_EOL);
}
static SCM
build_class_class_slots (void);
enum build_class_class_slots_mode { BOOT_SLOTS, FINAL_SLOTS };
static SCM build_class_class_slots (enum build_class_class_slots_mode mode);
static SCM
build_slots_list (SCM dslots, SCM cpl)
@ -443,7 +386,7 @@ build_slots_list (SCM dslots, SCM cpl)
if (classp)
{
bslots = build_class_class_slots ();
bslots = build_class_class_slots (FINAL_SLOTS);
check_cpl (res, bslots);
}
else
@ -841,7 +784,7 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
/* Initialize its slots */
SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
cpl = compute_cpl (z);
cpl = scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), z);
slots = build_slots_list (maplist (dslots), cpl);
nfields = scm_from_int (scm_ilength (slots));
g_n_s = compute_getters_n_setters (slots);
@ -909,29 +852,37 @@ SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
SCM_SYMBOL (sym_nfields, "nfields");
static int specialized_slots_initialized = 0;
static SCM
build_class_class_slots (void)
build_class_class_slots (enum build_class_class_slots_mode mode)
{
#define SPECIALIZED_SLOT(name, class) \
(mode == BOOT_SLOTS ? scm_list_1 (name) : scm_list_3 (name, k_class, class))
if (mode == FINAL_SLOTS && !specialized_slots_initialized)
abort ();
/* has to be kept in sync with SCM_VTABLE_BASE_LAYOUT and
SCM_CLASS_CLASS_LAYOUT */
return scm_list_n (
scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
scm_list_3 (sym_flags, k_class, scm_class_hidden),
scm_list_3 (sym_self, k_class, scm_class_self),
scm_list_3 (sym_instance_finalizer, k_class, scm_class_hidden),
SPECIALIZED_SLOT (sym_layout, scm_class_protected_read_only),
SPECIALIZED_SLOT (sym_flags, scm_class_hidden),
SPECIALIZED_SLOT (sym_self, scm_class_self),
SPECIALIZED_SLOT (sym_instance_finalizer, scm_class_hidden),
scm_list_1 (sym_print),
scm_list_3 (sym_name, k_class, scm_class_protected_hidden),
scm_list_3 (sym_reserved_0, k_class, scm_class_hidden),
scm_list_3 (sym_reserved_1, k_class, scm_class_hidden),
SPECIALIZED_SLOT (sym_name, scm_class_protected_hidden),
SPECIALIZED_SLOT (sym_reserved_0, scm_class_hidden),
SPECIALIZED_SLOT (sym_reserved_1, scm_class_hidden),
scm_list_1 (sym_redefined),
scm_list_3 (sym_h0, k_class, scm_class_int),
scm_list_3 (sym_h1, k_class, scm_class_int),
scm_list_3 (sym_h2, k_class, scm_class_int),
scm_list_3 (sym_h3, k_class, scm_class_int),
scm_list_3 (sym_h4, k_class, scm_class_int),
scm_list_3 (sym_h5, k_class, scm_class_int),
scm_list_3 (sym_h6, k_class, scm_class_int),
scm_list_3 (sym_h7, k_class, scm_class_int),
SPECIALIZED_SLOT (sym_h0, scm_class_int),
SPECIALIZED_SLOT (sym_h1, scm_class_int),
SPECIALIZED_SLOT (sym_h2, scm_class_int),
SPECIALIZED_SLOT (sym_h3, scm_class_int),
SPECIALIZED_SLOT (sym_h4, scm_class_int),
SPECIALIZED_SLOT (sym_h5, scm_class_int),
SPECIALIZED_SLOT (sym_h6, scm_class_int),
SPECIALIZED_SLOT (sym_h7, scm_class_int),
scm_list_1 (sym_direct_supers),
scm_list_1 (sym_direct_slots),
scm_list_1 (sym_direct_subclasses),
@ -947,7 +898,7 @@ build_class_class_slots (void)
static void
create_basic_classes (void)
{
/* SCM slots_of_class = build_class_class_slots (); */
SCM slots_of_class = build_class_class_slots (BOOT_SLOTS);
/**** <class> ****/
SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
@ -958,14 +909,14 @@ create_basic_classes (void)
SCM_SET_SLOT (scm_class_class, scm_vtable_index_name, name);
SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
/* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); /* will be changed */
SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */
/* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); /* will be changed */
SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
/* 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_getters_n_setters,
compute_getters_n_setters (slots_of_class)); /* will be changed */
SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
prep_hashsets (scm_class_class);
@ -2045,33 +1996,6 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1,
*
******************************************************************************/
/* Munge the CPL of C in place such that BEFORE appears before AFTER,
assuming that currently the reverse is true. Recalculate slots and
associated getters-n-setters. */
static void
fix_cpl (SCM c, SCM before, SCM after)
{
SCM cpl = SCM_SLOT (c, scm_si_cpl);
SCM ls = scm_c_memq (after, cpl);
SCM tail;
if (scm_is_false (ls))
/* if this condition occurs, fix_cpl should not be applied this way */
abort ();
tail = scm_delq1_x (before, SCM_CDR (ls));
SCM_SETCAR (ls, before);
SCM_SETCDR (ls, scm_cons (after, tail));
{
SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
SCM slots = build_slots_list (maplist (dslots), cpl);
SCM g_n_s = compute_getters_n_setters (slots);
SCM_SET_SLOT (c, scm_si_slots, slots);
SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
}
}
static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
{
@ -2146,9 +2070,11 @@ create_standard_classes (void)
make_stdcls (&scm_class_double, "<double-slot>",
scm_class_class, scm_class_foreign_slot, SCM_EOL);
/* Continue initialization of class <class> */
specialized_slots_initialized = 1;
slots = build_class_class_slots ();
/* Finish initialization of class <class> */
slots = build_class_class_slots (FINAL_SLOTS);
SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
@ -2195,9 +2121,6 @@ create_standard_classes (void)
scm_list_2 (scm_class_accessor,
scm_class_extended_generic_with_setter),
SCM_EOL);
/* <extended-generic> is misplaced. */
fix_cpl (scm_class_extended_accessor,
scm_class_extended_generic, scm_class_generic_with_setter);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
@ -2505,8 +2428,6 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
scm_module_variable (scm_module_goops, sym_slot_unbound);
var_slot_missing =
scm_module_variable (scm_module_goops, sym_slot_missing);
var_compute_cpl =
scm_module_variable (scm_module_goops, sym_compute_cpl);
var_no_applicable_method =
scm_module_variable (scm_module_goops, sym_no_applicable_method);
var_change_class =
@ -2527,6 +2448,9 @@ scm_init_goops_builtins (void)
#include "libguile/goops.x"
var_compute_cpl =
scm_module_variable (scm_module_goops, sym_compute_cpl);
hell = scm_calloc (hell_size * sizeof (*hell));
hell_mutex = scm_make_mutex ();

202
module/oop/goops.scm
View file

@ -135,6 +135,64 @@
(define *goops-module* (current-module))
(eval-when (compile load eval)
;;; The standard class precedence list computation algorithm
;;;
;;; Correct behaviour:
;;;
;;; (define-class food ())
;;; (define-class fruit (food))
;;; (define-class spice (food))
;;; (define-class apple (fruit))
;;; (define-class cinnamon (spice))
;;; (define-class pie (apple cinnamon))
;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
;;;
;;; (define-class d ())
;;; (define-class e ())
;;; (define-class f ())
;;; (define-class b (d e))
;;; (define-class c (e f))
;;; (define-class a (b c))
;;; => cpl (a) = a b d c e f object top
;;;
(define (compute-std-cpl c get-direct-supers)
(define (only-non-null lst)
(filter (lambda (l) (not (null? l))) lst))
(define (merge-lists reversed-partial-result inputs)
(cond
((every null? inputs)
(reverse! reversed-partial-result))
(else
(let* ((candidate (lambda (c)
(and (not (any (lambda (l)
(memq c (cdr l)))
inputs))
c)))
(candidate-car (lambda (l)
(and (not (null? l))
(candidate (car l)))))
(next (any candidate-car inputs)))
(if (not next)
(goops-error "merge-lists: Inconsistent precedence graph"))
(let ((remove-next (lambda (l)
(if (eq? (car l) next)
(cdr l)
l))))
(merge-lists (cons next reversed-partial-result)
(only-non-null (map remove-next inputs))))))))
(let ((c-direct-supers (get-direct-supers c)))
(merge-lists (list c)
(only-non-null (append (map class-precedence-list
c-direct-supers)
(list c-direct-supers))))))
;; Bootstrap version.
(define (compute-cpl class)
(compute-std-cpl class class-direct-supers)))
;; XXX FIXME: figure out why the 'eval-when's in this file must use
;; 'compile' and must avoid 'expand', but only in 2.2, and only when
;; compiling something that imports goops, e.g. (ice-9 occam-channel),
@ -1358,150 +1416,14 @@
;;; compute-cpl
;;;
;;; Correct behaviour:
;;;
;;; (define-class food ())
;;; (define-class fruit (food))
;;; (define-class spice (food))
;;; (define-class apple (fruit))
;;; (define-class cinnamon (spice))
;;; (define-class pie (apple cinnamon))
;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
;;;
;;; (define-class d ())
;;; (define-class e ())
;;; (define-class f ())
;;; (define-class b (d e))
;;; (define-class c (e f))
;;; (define-class a (b c))
;;; => cpl (a) = a b d c e f object top
;;;
;; Replace the bootstrap compute-cpl with this definition.
(define compute-cpl
(make <generic> #:name 'compute-cpl))
(define-method (compute-cpl (class <class>))
(compute-std-cpl class class-direct-supers))
;; Support
(define (only-non-null lst)
(filter (lambda (l) (not (null? l))) lst))
(define (compute-std-cpl c get-direct-supers)
(let ((c-direct-supers (get-direct-supers c)))
(merge-lists (list c)
(only-non-null (append (map class-precedence-list
c-direct-supers)
(list c-direct-supers))))))
(define (merge-lists reversed-partial-result inputs)
(cond
((every null? inputs)
(reverse! reversed-partial-result))
(else
(let* ((candidate (lambda (c)
(and (not (any (lambda (l)
(memq c (cdr l)))
inputs))
c)))
(candidate-car (lambda (l)
(and (not (null? l))
(candidate (car l)))))
(next (any candidate-car inputs)))
(if (not next)
(goops-error "merge-lists: Inconsistent precedence graph"))
(let ((remove-next (lambda (l)
(if (eq? (car l) next)
(cdr l)
l))))
(merge-lists (cons next reversed-partial-result)
(only-non-null (map remove-next inputs))))))))
;; Modified from TinyClos:
;;
;; A simple topological sort.
;;
;; It's in this file so that both TinyClos and Objects can use it.
;;
;; This is a fairly modified version of code I originally got from Anurag
;; Mendhekar <anurag@moose.cs.indiana.edu>.
;;
(define (compute-clos-cpl c get-direct-supers)
(top-sort ((build-transitive-closure get-direct-supers) c)
((build-constraints get-direct-supers) c)
(std-tie-breaker get-direct-supers)))
(define (top-sort elements constraints tie-breaker)
(let loop ((elements elements)
(constraints constraints)
(result '()))
(if (null? elements)
result
(let ((can-go-in-now
(filter
(lambda (x)
(every (lambda (constraint)
(or (not (eq? (cadr constraint) x))
(memq (car constraint) result)))
constraints))
elements)))
(if (null? can-go-in-now)
(goops-error "top-sort: Invalid constraints")
(let ((choice (if (null? (cdr can-go-in-now))
(car can-go-in-now)
(tie-breaker result
can-go-in-now))))
(loop
(filter (lambda (x) (not (eq? x choice)))
elements)
constraints
(append result (list choice)))))))))
(define (std-tie-breaker get-supers)
(lambda (partial-cpl min-elts)
(let loop ((pcpl (reverse partial-cpl)))
(let ((current-elt (car pcpl)))
(let ((ds-of-ce (get-supers current-elt)))
(let ((common (filter (lambda (x)
(memq x ds-of-ce))
min-elts)))
(if (null? common)
(if (null? (cdr pcpl))
(goops-error "std-tie-breaker: Nothing valid")
(loop (cdr pcpl)))
(car common))))))))
(define (build-transitive-closure get-follow-ons)
(lambda (x)
(let track ((result '())
(pending (list x)))
(if (null? pending)
result
(let ((next (car pending)))
(if (memq next result)
(track result (cdr pending))
(track (cons next result)
(append (get-follow-ons next)
(cdr pending)))))))))
(define (build-constraints get-follow-ons)
(lambda (x)
(let loop ((elements ((build-transitive-closure get-follow-ons) x))
(this-one '())
(result '()))
(if (or (null? this-one) (null? (cdr this-one)))
(if (null? elements)
result
(loop (cdr elements)
(cons (car elements)
(get-follow-ons (car elements)))
result))
(loop elements
(cdr this-one)
(cons (list (car this-one) (cadr this-one))
result))))))
;;; compute-get-n-set
;;;
(define-method (compute-get-n-set (class <class>) s)