From e437c50b88bc540b09763df52331c096f6ec8533 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 18 Jan 2015 21:01:31 +0100 Subject: [PATCH] Use a vtable bit to mark instances * libguile/goops.h (SCM_VTABLE_FLAG_GOOPS_SLOT): Allocate another vtable flag to indicate that instances of this vtable are slots. * libguile/goops.c (scm_init_goops_builtins): Export vtable-flag-goops-slot to Scheme. * module/oop/goops.scm (, slot?, make-standard-class, initialize): Arrange for classes to have the vtable-flag-goops.slot. (build-slots-list): Ensure that slots are statically laid out. --- libguile/goops.c | 2 ++ libguile/goops.h | 1 + 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)) ( (make-struct/no-tail (make-struct-layout layout)))) (class-add-flags! (logior vtable-flag-goops-class + vtable-flag-goops-slot vtable-flag-goops-valid)) (struct-set! class-index-name ') (struct-set! class-index-nfields nfields) @@ -425,8 +426,9 @@ followed by its associated value. If @var{l} does not hold a value for (struct-set! class-index-redefined #f) ))) -(define (slot? obj) - (is-a? obj )) +(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 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 ensures static slot allocation. - ;; do the same thing for . - (let* ((class-slots (and (memq cpl) - (struct-ref class-index-slots)))) - (when class-slots - (check-cpl dslots class-slots)) - (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '())) + ;; For subclases of and , we need to ensure that the + ;; or slots come first. + (let* ((static-slots (cond + ((memq cpl) + (when (memq cpl) (error "invalid class")) + (struct-ref class-index-slots)) + ((memq cpl) + (struct-ref 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 ) - ;; Move class slots to the head of the list. + ((not static-slots) + (lp cpl (append new-slots res) static-slots)) + ((or (eq? head ) (eq? head )) + ;; 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 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 (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)) -- 2.20.1