[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 77/87: Use a vtable bit to mark <slot> instances
From: |
Andy Wingo |
Subject: |
[Guile-commits] 77/87: Use a vtable bit to mark <slot> instances |
Date: |
Thu, 22 Jan 2015 17:30:25 +0000 |
wingo pushed a commit to branch wip-goops-refactor
in repository guile.
commit 7c362277e20100d9b85934a3a49a182aa93d2eb9
Author: Andy Wingo <address@hidden>
Date: Sun Jan 18 21:01:31 2015 +0100
Use a vtable bit to mark <slot> 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>, slot?, make-standard-class, initialize):
Arrange for <slot> classes to have the vtable-flag-goops.slot.
(build-slots-list): Ensure that <slot> 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 cb493e2..82749a8 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1049,6 +1049,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 3dd3f3e..daa2a9e 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 9509124..8619b65 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)
@@ -2768,6 +2777,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))
- [Guile-commits] 65/87: when and unless for one-armed ifs in goops.scm, (continued)
- [Guile-commits] 65/87: when and unless for one-armed ifs in goops.scm, Andy Wingo, 2015/01/22
- [Guile-commits] 72/87: change-object-class refactor, Andy Wingo, 2015/01/22
- [Guile-commits] 74/87: The GOOPS "unbound" value is a unique pair, Andy Wingo, 2015/01/22
- [Guile-commits] 71/87: slot-ref, slot-set! et al bypass "using-class" variants, Andy Wingo, 2015/01/22
- [Guile-commits] 73/87: GOOPS: Deprecate "using-class" procs like slot-ref-using-class, Andy Wingo, 2015/01/22
- [Guile-commits] 80/87: Optimize %initialize-object, Andy Wingo, 2015/01/22
- [Guile-commits] 75/87: Beginnings of <slot> slot definition class, Andy Wingo, 2015/01/22
- [Guile-commits] 81/87: Minor GOOPS cleanups, Andy Wingo, 2015/01/22
- [Guile-commits] 79/87: Inline internal slot accessors, Andy Wingo, 2015/01/22
- [Guile-commits] 84/87: GOOPS cosmetics, Andy Wingo, 2015/01/22
- [Guile-commits] 77/87: Use a vtable bit to mark <slot> instances,
Andy Wingo <=
- [Guile-commits] 87/87: tmp, Andy Wingo, 2015/01/22
- [Guile-commits] 78/87: Inline helpers into slot-ref, slot-set!, etc, Andy Wingo, 2015/01/22
- [Guile-commits] 83/87: Update (oop goops save) for <slot> objects, Andy Wingo, 2015/01/22
- [Guile-commits] 82/87: Fix foreign objects for removal of getters-n-setters, Andy Wingo, 2015/01/22
- [Guile-commits] 85/87: Fast generic function dispatch without calling `compile' at runtime, Andy Wingo, 2015/01/22
- [Guile-commits] 76/87: Introduce <slot> objects in GOOPS, Andy Wingo, 2015/01/22
- [Guile-commits] 86/87: Simplify GOOPS effective method cache format, Andy Wingo, 2015/01/22