diff options
| -rw-r--r-- | libguile/goops.c | 2 | ||||
| -rw-r--r-- | libguile/goops.h | 1 | ||||
| -rw-r--r-- | module/oop/goops.scm | 51 |
3 files changed, 35 insertions, 19 deletions
diff --git a/libguile/goops.c b/libguile/goops.c index 398a5d263..d5c743559 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1053,6 +1053,8 @@ scm_init_goops_builtins (void *unused) scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS)); scm_c_define ("vtable-flag-goops-valid", scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID)); + scm_c_define ("vtable-flag-goops-slot", + scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT)); } void diff --git a/libguile/goops.h b/libguile/goops.h index 3dd3f3e45..daa2a9e1a 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -42,6 +42,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_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 d6d281731..fd1b9ff9d 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -413,6 +413,7 @@ followed by its associated value. If @var{l} does not hold a value for (nfields (/ (string-length layout) 2)) (<slot> (make-struct/no-tail <class> (make-struct-layout layout)))) (class-add-flags! <slot> (logior vtable-flag-goops-class + vtable-flag-goops-slot vtable-flag-goops-valid)) (struct-set! <slot> class-index-name '<slot>) (struct-set! <slot> class-index-nfields nfields) @@ -425,8 +426,9 @@ followed by its associated value. If @var{l} does not hold a value for (struct-set! <slot> class-index-redefined #f) <slot>))) -(define (slot? obj) - (is-a? obj <slot>)) +(define-inlinable (slot? obj) + (and (struct? obj) + (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot))) (define-syntax-rule (define-slot-accessor name docstring field) (define (name obj) @@ -632,10 +634,10 @@ followed by its associated value. If @var{l} does not hold a value for (() #f) ((slot . slots) (or (eq? (slot-definition-name slot) name) (lp slots))))))) - (define (check-cpl slots class-slots ) - (when (or-map (lambda (slot) (slot-memq slot slots)) class-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 <class> inherited field cannot be redefined" + "a predefined static inherited field cannot be redefined" '() '()))) (define (remove-duplicate-slots slots) (let lp ((slots (reverse slots)) (res '()) (seen '())) @@ -646,26 +648,31 @@ followed by its associated value. If @var{l} does not hold a value for (if (memq name seen) (lp slots res seen) (lp slots (cons slot res) (cons name seen)))))))) - ;; FIXME: the thing we do for <class> ensures static slot allocation. - ;; do the same thing for <slot>. - (let* ((class-slots (and (memq <class> cpl) - (struct-ref <class> class-index-slots)))) - (when class-slots - (check-cpl dslots class-slots)) - (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '())) + ;; 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)))) + (when static-slots + (check-cpl dslots static-slots)) + (let lp ((cpl (cdr cpl)) (res dslots) (static-slots '())) (match cpl - (() (remove-duplicate-slots (append class-slots res))) + (() (remove-duplicate-slots (append static-slots res))) ((head . cpl) (let ((new-slots (struct-ref head class-index-direct-slots))) (cond - ((not class-slots) - (lp cpl (append new-slots res) class-slots)) - ((eq? head <class>) - ;; Move class slots to the head of the list. + ((not static-slots) + (lp cpl (append new-slots res) static-slots)) + ((or (eq? head <class>) (eq? head <slot>)) + ;; Move static slots to the head of the list. (lp cpl res new-slots)) (else - (check-cpl new-slots class-slots) - (lp cpl (append new-slots res) class-slots))))))))) + (check-cpl new-slots static-slots) + (lp cpl (append new-slots res) static-slots))))))))) ;; Boot definition. (define (compute-get-n-set class slot) @@ -769,6 +776,8 @@ slots as we go." (struct-set! z class-index-redefined #f) (let ((cpl (compute-cpl z))) (struct-set! z class-index-cpl cpl) + (when (memq <slot> cpl) + (class-add-flags! z vtable-flag-goops-slot)) (let* ((dslots (map make-direct-slot-definition dslots)) (slots (allocate-slots z (build-slots-list dslots cpl)))) (struct-set! z class-index-direct-slots dslots) @@ -2769,6 +2778,10 @@ var{initargs}." (struct-set! class class-index-slots (allocate-slots class (compute-slots class))) + ;; This is a hack. + (when (memq <slot> (struct-ref class class-index-cpl)) + (class-add-flags! class vtable-flag-goops-slot)) + ;; Build getters - setters - accessors (compute-slot-accessors class (struct-ref class class-index-slots)) |