[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Add #:static-slot-allocation?
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/02: Add #:static-slot-allocation? |
|
Date: |
Fri, 06 Feb 2015 12:29:47 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 26350edcac94ae51737b5394f74b84592d43af76
Author: Andy Wingo <address@hidden>
Date: Fri Feb 6 13:25:17 2015 +0100
Add #:static-slot-allocation?
* libguile/goops.h (SCM_VTABLE_FLAG_GOOPS_STATIC): Reserve the fourth
GOOPS flag to indicate that a class has static slot allocation.
* libguile/goops.c (scm_init_goops_builtins): Define
vtable-flag-goops-static for goops.scm.
* module/oop/goops.scm (class-has-statically-allocated-slots?): New
helper.
(build-slots-list): Instead of the ad-hoc checks for <class> or
<slot>, use the new helper.
(initialize): Accept #:static-slot-allocation? keyword.
* module/system/foreign-object.scm (make-foreign-object-type): Declare
foreign object classes as having static slot allocation.
* test-suite/tests/goops.test ("static slot allocation"): Add tests.
---
libguile/goops.c | 2 +
libguile/goops.h | 1 +
module/oop/goops.scm | 45 +++++++++++++++++++++++++++-----------
module/system/foreign-object.scm | 2 +
test-suite/tests/goops.test | 23 +++++++++++++++++++
5 files changed, 60 insertions(+), 13 deletions(-)
diff --git a/libguile/goops.c b/libguile/goops.c
index d5c7435..1f7ec90 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1055,6 +1055,8 @@ scm_init_goops_builtins (void *unused)
scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID));
scm_c_define ("vtable-flag-goops-slot",
scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT));
+ scm_c_define ("vtable-flag-goops-static",
+ scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC));
}
void
diff --git a/libguile/goops.h b/libguile/goops.h
index daa2a9e..cc743a6 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -43,6 +43,7 @@
#define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0
#define SCM_VTABLE_FLAG_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_1
#define SCM_VTABLE_FLAG_GOOPS_SLOT SCM_VTABLE_FLAG_GOOPS_2
+#define SCM_VTABLE_FLAG_GOOPS_STATIC SCM_VTABLE_FLAG_GOOPS_3
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
#define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index b79b79f..5a5d469 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -277,6 +277,9 @@
(define-inlinable (instance? obj)
(class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
+(define (class-has-statically-allocated-slots? class)
+ (class-has-flags? class vtable-flag-goops-static))
+
;;;
;;; Now that we know the slots that must be present in classes, and
;;; their offsets, we can create the root of the class hierarchy.
@@ -638,10 +641,14 @@ followed by its associated value. If @var{l} does not
hold a value for
((slot . slots)
(or (eq? (%slot-definition-name slot) name) (lp slots)))))))
(define (check-cpl slots static-slots)
- (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
- (scm-error 'misc-error #f
- "a predefined static inherited field cannot be redefined"
- '() '())))
+ (match static-slots
+ (() #t)
+ ((static-slot . static-slots)
+ (when (slot-memq static-slot slots)
+ (scm-error 'misc-error #f
+ "statically allocated inherited field cannot be redefined:
~a"
+ (list (%slot-definition-name static-slot)) '()))
+ (check-cpl slots static-slots))))
(define (remove-duplicate-slots slots)
(let lp ((slots (reverse slots)) (res '()) (seen '()))
(match slots
@@ -653,13 +660,13 @@ followed by its associated value. If @var{l} does not
hold a value for
(lp slots (cons slot res) (cons name seen))))))))
;; For subclases of <class> and <slot>, we need to ensure that the
;; <class> or <slot> slots come first.
- (let* ((static-slots (cond
- ((memq <class> cpl)
- (when (memq <slot> cpl) (error "invalid class"))
- (struct-ref <class> class-index-slots))
- ((memq <slot> cpl)
- (struct-ref <slot> class-index-slots))
- (else #f))))
+ (let ((static-slots
+ (match (filter class-has-statically-allocated-slots? (cdr cpl))
+ (() #f)
+ ((class) (struct-ref class class-index-direct-slots))
+ (classes
+ (error "can't subtype multiple classes with static slot allocation"
+ classes)))))
(when static-slots
(check-cpl dslots static-slots))
(let lp ((cpl (cdr cpl)) (res dslots) (static-slots '()))
@@ -670,7 +677,7 @@ followed by its associated value. If @var{l} does not hold
a value for
(cond
((not static-slots)
(lp cpl (append new-slots res) static-slots))
- ((or (eq? head <class>) (eq? head <slot>))
+ ((class-has-statically-allocated-slots? head)
;; Move static slots to the head of the list.
(lp cpl res new-slots))
(else
@@ -912,7 +919,12 @@ slots as we go."
(initialize-direct-slots! <class> fold-class-slots)
(initialize-slots! <class>)
- (initialize-slots! <slot>))
+ (initialize-slots! <slot>)
+
+ ;; Now that we're all done with that, mark <class> and <slot> as
+ ;; static.
+ (class-add-flags! <class> vtable-flag-goops-static)
+ (class-add-flags! <slot> vtable-flag-goops-static))
@@ -2834,6 +2846,13 @@ var{initargs}."
(struct-set! class class-index-direct-methods '())
(struct-set! class class-index-redefined #f)
(struct-set! class class-index-cpl (compute-cpl class))
+ (when (get-keyword #:static-slot-allocation? initargs #f)
+ (match (filter class-has-statically-allocated-slots?
+ (class-precedence-list class))
+ (()
+ (class-add-flags! class vtable-flag-goops-static))
+ (classes
+ (error "Class has superclasses with static slot allocation" classes))))
(struct-set! class class-index-direct-slots
(map (lambda (slot)
(if (slot? slot)
diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm
index f7bfc94..a8022b9 100644
--- a/module/system/foreign-object.scm
+++ b/module/system/foreign-object.scm
@@ -63,8 +63,10 @@
(if finalizer
(make-class '() dslots #:name name
#:finalizer finalizer
+ #:static-slot-allocation? #t
#:metaclass <foreign-class-with-finalizer>)
(make-class '() dslots #:name name
+ #:static-slot-allocation? #t
#:metaclass <foreign-class>))))
(define-syntax define-foreign-object-type
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 5b26cb8..087b6a9 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -657,3 +657,26 @@
(pass-if-equal "b accessor on ba" 'b (b-accessor ba))
(pass-if-equal "b accessor on cab" 'b (b-accessor cab))
(pass-if-equal "b accessor on cba" 'b (b-accessor cba))))
+
+(with-test-prefix "static slot allocation"
+ (let* ((<a> (class () (a) #:name '<a> #:static-slot-allocation? #t))
+ (<b> (class () (b) #:name '<b> #:static-slot-allocation? #t))
+ (<c> (class () (c) #:name '<c>))
+ (<ac> (class (<a> <c>) #:name '<ac>))
+ (<ca> (class (<c> <a>) #:name '<ca>)))
+ (pass-if-equal "slots of <ac>" '(a c)
+ (map slot-definition-name (class-slots <ac>)))
+ (pass-if-equal "slots of <ca>" '(a c)
+ (map slot-definition-name (class-slots <ca>)))
+ (pass-if-exception "can't make <ab>"
+ '(misc-error . "static slot")
+ (class (<a> <b>) #:name '<ab>))
+ ;; It should be possible to create subclasses of static classes
+ ;; whose slots are statically allocated, as long as there is no
+ ;; diamond inheritance among static superclasses, but for now we
+ ;; don't support it at all.
+ (pass-if-exception "static subclass"
+ '(misc-error . "static slot")
+ (class (<a>) (slot) #:name '<static-sub> #:static-slot-allocation? #t))
+ (pass-if-equal "non-static subclass" '(a d)
+ (map slot-definition-name (class-slots (class (<a>) (d) #:name
'<ad>))))))