diff options
author | Andy Wingo <wingo@pobox.com> | 2015-02-06 13:25:17 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-02-06 13:25:17 +0100 |
commit | 26350edcac94ae51737b5394f74b84592d43af76 (patch) | |
tree | ff474bbc6920cf98478441894a37f849e5c814fe /module/oop | |
parent | 05d0cdf18eb70f69239af5f299cb74f77c21f8d9 (diff) | |
download | guile-26350edcac94ae51737b5394f74b84592d43af76.tar.gz |
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.
Diffstat (limited to 'module/oop')
-rw-r--r-- | module/oop/goops.scm | 45 |
1 files changed, 32 insertions, 13 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm index b79b79f37..5a5d469eb 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) |