[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 08/88: compute-cpl implementation only in Scheme
From: |
Andy Wingo |
Subject: |
[Guile-commits] 08/88: compute-cpl implementation only in Scheme |
Date: |
Fri, 23 Jan 2015 15:25:21 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 9167e0b88d3829a6b54d4b4faa6197b3675bb38e
Author: Andy Wingo <address@hidden>
Date: Wed Dec 24 09:37:14 2014 -0500
compute-cpl implementation only in Scheme
* 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.
---
libguile/goops.c | 156 ++++++++++-----------------------------
module/oop/goops.scm | 202 +++++++++++++++----------------------------------
2 files changed, 102 insertions(+), 256 deletions(-)
diff --git a/libguile/goops.c b/libguile/goops.c
index c62ea7c..f76f745 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -338,63 +338,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
/******************************************************************************
*
- * 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 ();
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index ebc47eb..654ee86 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -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 <address@hidden>.
-;;
-
-(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)
- [Guile-commits] branch master updated (4247d8e -> 4bde3f0), Andy Wingo, 2015/01/23
- [Guile-commits] 01/88: Fix the assembler for unexpected source properties, Andy Wingo, 2015/01/23
- [Guile-commits] 02/88: Mark two coverage tests as XFAIL, Andy Wingo, 2015/01/23
- [Guile-commits] 03/88: %compute-applicable-methods in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 07/88: More useless goops.c code removal, Andy Wingo, 2015/01/23
- [Guile-commits] 05/88: Rewrite %method-more-specific? to be in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 06/88: Remove unused macros in goops.c, Andy Wingo, 2015/01/23
- [Guile-commits] 04/88: Deprecate C interfaces scm_compute_applicable_methods, scm_find_method, Andy Wingo, 2015/01/23
- [Guile-commits] 09/88: %init-goops-builtins is an extension, not a global, Andy Wingo, 2015/01/23
- [Guile-commits] 10/88: Preparation for more GOOPS refactorings, Andy Wingo, 2015/01/23
- [Guile-commits] 08/88: compute-cpl implementation only in Scheme,
Andy Wingo <=
- [Guile-commits] 14/88: Deprecate scm_basic_make_class, Andy Wingo, 2015/01/23
- [Guile-commits] 16/88: define-generic, define-extended-generic are hygienic syntax, Andy Wingo, 2015/01/23
- [Guile-commits] 12/88: Remove declarations without definitions, Andy Wingo, 2015/01/23
- [Guile-commits] 17/88: Remove unused *goops-module* definition., Andy Wingo, 2015/01/23
- [Guile-commits] 20/88: Deprecate scm_no_applicable_method C export, Andy Wingo, 2015/01/23
- [Guile-commits] 23/88: Remove unused `default-slot-definition-class' <class> slot, Andy Wingo, 2015/01/23
- [Guile-commits] 24/88: Remove unused CPP defines naming <method> slots, Andy Wingo, 2015/01/23
- [Guile-commits] 15/88: `class' is a hygienic macro, Andy Wingo, 2015/01/23
- [Guile-commits] 22/88: Remove useless scm_s_slot_set_x export, Andy Wingo, 2015/01/23
- [Guile-commits] 11/88: Remove unused %fast-slot-ref / %fast-slot-set! from GOOPS, Andy Wingo, 2015/01/23