mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

Inline internal slot accessors

Browse source 
* module/oop/goops.scm (define-slot-accessor): Also define internal
  accessors without the type check for when we know that the object is a
  slot.  Adapt struct-ref users to use these variants.
This commit is contained in:
Andy Wingo 2015-01-19 12:20:50 +01:00
parent c4974c5799
commit 2a3ef7c44b
1 changed files with 55 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

108
module/oop/goops.scm
View file

@ -430,57 +430,59 @@ followed by its associated value. If @var{l} does not hold a value for
(and (struct? obj) (and (struct? obj)
(class-has-flags? (struct-vtable obj) vtable-flag-goops-slot))) (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
(define-syntax-rule (define-slot-accessor name docstring field) (define-syntax-rule (define-slot-accessor name docstring %name field)
(define (name obj) (begin
docstring (define-syntax-rule (%name obj)
(let ((val obj)) (struct-ref obj field))
(unless (slot? val) (define (name obj)
docstring
(unless (slot? obj)
(scm-error 'wrong-type-arg #f "Not a slot: ~S" (scm-error 'wrong-type-arg #f "Not a slot: ~S"
(list val) #f)) (list obj) #f))
(struct-ref val field)))) (%name obj))))
(define-slot-accessor slot-definition-name (define-slot-accessor slot-definition-name
"Return the name of @var{obj}." "Return the name of @var{obj}."
slot-index-name) %slot-definition-name slot-index-name)
(define-slot-accessor slot-definition-allocation (define-slot-accessor slot-definition-allocation
"Return the allocation of the slot @var{obj}." "Return the allocation of the slot @var{obj}."
slot-index-allocation) %slot-definition-allocation slot-index-allocation)
(define-slot-accessor slot-definition-init-keyword (define-slot-accessor slot-definition-init-keyword
"Return the init keyword of the slot @var{obj}, or @code{#f}." "Return the init keyword of the slot @var{obj}, or @code{#f}."
slot-index-init-keyword) %slot-definition-init-keyword slot-index-init-keyword)
(define-slot-accessor slot-definition-init-form (define-slot-accessor slot-definition-init-form
"Return the init form of the slot @var{obj}, or the unbound value" "Return the init form of the slot @var{obj}, or the unbound value"
slot-index-init-form) %slot-definition-init-form slot-index-init-form)
(define-slot-accessor slot-definition-init-value (define-slot-accessor slot-definition-init-value
"Return the init value of the slot @var{obj}, or the unbound value." "Return the init value of the slot @var{obj}, or the unbound value."
slot-index-init-value) %slot-definition-init-value slot-index-init-value)
(define-slot-accessor slot-definition-init-thunk (define-slot-accessor slot-definition-init-thunk
"Return the init thunk of the slot @var{obj}, or @code{#f}." "Return the init thunk of the slot @var{obj}, or @code{#f}."
slot-index-init-thunk) %slot-definition-init-thunk slot-index-init-thunk)
(define-slot-accessor slot-definition-options (define-slot-accessor slot-definition-options
"Return the initargs given when creating the slot @var{obj}." "Return the initargs given when creating the slot @var{obj}."
slot-index-options) %slot-definition-options slot-index-options)
(define-slot-accessor slot-definition-getter (define-slot-accessor slot-definition-getter
"Return the getter of the slot @var{obj}, or @code{#f}." "Return the getter of the slot @var{obj}, or @code{#f}."
slot-index-getter) %slot-definition-getter slot-index-getter)
(define-slot-accessor slot-definition-setter (define-slot-accessor slot-definition-setter
"Return the setter of the slot @var{obj}, or @code{#f}." "Return the setter of the slot @var{obj}, or @code{#f}."
slot-index-setter) %slot-definition-setter slot-index-setter)
(define-slot-accessor slot-definition-accessor (define-slot-accessor slot-definition-accessor
"Return the accessor of the slot @var{obj}, or @code{#f}." "Return the accessor of the slot @var{obj}, or @code{#f}."
slot-index-accessor) %slot-definition-accessor slot-index-accessor)
(define-slot-accessor slot-definition-slot-ref (define-slot-accessor slot-definition-slot-ref
"Return the slot-ref procedure of the slot @var{obj}, or @code{#f}." "Return the slot-ref procedure of the slot @var{obj}, or @code{#f}."
slot-index-slot-ref) %slot-definition-slot-ref slot-index-slot-ref)
(define-slot-accessor slot-definition-slot-set! (define-slot-accessor slot-definition-slot-set!
"Return the slot-set! procedure of the slot @var{obj}, or @code{#f}." "Return the slot-set! procedure of the slot @var{obj}, or @code{#f}."
slot-index-slot-set!) %slot-definition-slot-set! slot-index-slot-set!)
(define-slot-accessor slot-definition-index (define-slot-accessor slot-definition-index
"Return the allocated struct offset of the slot @var{obj}, or @code{#f}." "Return the allocated struct offset of the slot @var{obj}, or @code{#f}."
slot-index-index) %slot-definition-index slot-index-index)
(define-slot-accessor slot-definition-size (define-slot-accessor slot-definition-size
"Return the number fields used by the slot @var{obj}, or @code{#f}." "Return the number fields used by the slot @var{obj}, or @code{#f}."
slot-index-size) %slot-definition-size slot-index-size)
;; Boot definition. ;; Boot definition.
(define (direct-slot-definition-class class initargs) (define (direct-slot-definition-class class initargs)
@ -498,7 +500,7 @@ followed by its associated value. If @var{l} does not hold a value for
(init-slot slot-index-init-value #:init-value *unbound*) (init-slot slot-index-init-value #:init-value *unbound*)
(struct-set! slot slot-index-init-thunk (struct-set! slot slot-index-init-thunk
(or (get-keyword #:init-thunk initargs #f) (or (get-keyword #:init-thunk initargs #f)
(let ((val (struct-ref slot slot-index-init-value))) (let ((val (%slot-definition-init-value slot)))
(if (unbound? val) (if (unbound? val)
#f #f
(lambda () val))))) (lambda () val)))))
@ -619,12 +621,12 @@ followed by its associated value. If @var{l} does not hold a value for
(define (build-slots-list dslots cpl) (define (build-slots-list dslots cpl)
(define (slot-memq slot slots) (define (slot-memq slot slots)
(let ((name (slot-definition-name slot))) (let ((name (%slot-definition-name slot)))
(let lp ((slots slots)) (let lp ((slots slots))
(match slots (match slots
(() #f) (() #f)
((slot . slots) ((slot . slots)
(or (eq? (slot-definition-name slot) name) (lp slots))))))) (or (eq? (%slot-definition-name slot) name) (lp slots)))))))
(define (check-cpl slots static-slots) (define (check-cpl slots static-slots)
(when (or-map (lambda (slot) (slot-memq slot slots)) static-slots) (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
(scm-error 'misc-error #f (scm-error 'misc-error #f
@ -635,7 +637,7 @@ followed by its associated value. If @var{l} does not hold a value for
(match slots (match slots
(() res) (() res)
((slot . slots) ((slot . slots)
(let ((name (slot-definition-name slot))) (let ((name (%slot-definition-name slot)))
(if (memq name seen) (if (memq name seen)
(lp slots res seen) (lp slots res seen)
(lp slots (cons slot res) (cons name seen)))))))) (lp slots (cons slot res) (cons name seen))))))))
@ -705,7 +707,7 @@ slots as we go."
(define (slot-protection-and-kind slot) (define (slot-protection-and-kind slot)
(define (subclass? class parent) (define (subclass? class parent)
(memq parent (class-precedence-list class))) (memq parent (class-precedence-list class)))
(let ((type (kw-arg-ref (struct-ref slot slot-index-options) #:class))) (let ((type (kw-arg-ref (%slot-definition-options slot) #:class)))
(if (and type (subclass? type <foreign-slot>)) (if (and type (subclass? type <foreign-slot>))
(values (cond (values (cond
((subclass? type <self-slot>) #\s) ((subclass? type <self-slot>) #\s)
@ -728,10 +730,10 @@ slots as we go."
(error "bad layout for class")))) (error "bad layout for class"))))
layout) layout)
((slot . slots) ((slot . slots)
(unless (= n (slot-definition-index slot)) (error "bad allocation")) (unless (= n (%slot-definition-index slot)) (error "bad allocation"))
(call-with-values (lambda () (slot-protection-and-kind slot)) (call-with-values (lambda () (slot-protection-and-kind slot))
(lambda (protection kind) (lambda (protection kind)
(let init ((n n) (size (slot-definition-size slot))) (let init ((n n) (size (%slot-definition-size slot)))
(cond (cond
((zero? size) (lp n slots)) ((zero? size) (lp n slots))
(else (else
@ -1057,7 +1059,7 @@ function."
(let lp ((slots (struct-ref class class-index-slots))) (let lp ((slots (struct-ref class class-index-slots)))
(match slots (match slots
((slot . slots) ((slot . slots)
(if (eq? (struct-ref slot slot-index-name) slot-name) (if (eq? (%slot-definition-name slot) slot-name)
(kt slot) (kt slot)
(lp slots))) (lp slots)))
(_ (kf))))) (_ (kf)))))
@ -1074,10 +1076,10 @@ function."
(let ((class (class-of obj))) (let ((class (class-of obj)))
(define (slot-value slot) (define (slot-value slot)
(cond (cond
((struct-ref slot slot-index-slot-ref) ((%slot-definition-slot-ref slot)
=> (lambda (slot-ref) (slot-ref obj))) => (lambda (slot-ref) (slot-ref obj)))
(else (else
(struct-ref obj (struct-ref slot slot-index-index))))) (struct-ref obj (%slot-definition-index slot)))))
(define (have-slot slot) (define (have-slot slot)
(let ((val (slot-value slot))) (let ((val (slot-value slot)))
(if (unbound? val) (if (unbound? val)
@ -1098,10 +1100,10 @@ function."
(let ((class (class-of obj))) (let ((class (class-of obj)))
(define (have-slot slot) (define (have-slot slot)
(cond (cond
((slot-definition-slot-set! slot) ((%slot-definition-slot-set! slot)
=> (lambda (slot-set!) (slot-set! obj value))) => (lambda (slot-set!) (slot-set! obj value)))
(else (else
(struct-set! obj (slot-definition-index slot) value)))) (struct-set! obj (%slot-definition-index slot) value))))
(define (no-slot) (define (no-slot)
(unless (symbol? slot-name) (unless (symbol? slot-name)
(scm-error 'wrong-type-arg #f "Not a symbol: ~S" (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
@ -1115,10 +1117,10 @@ function."
(let ((class (class-of obj))) (let ((class (class-of obj)))
(define (slot-value slot) (define (slot-value slot)
(cond (cond
((struct-ref slot slot-index-slot-ref) ((%slot-definition-slot-ref slot)
=> (lambda (slot-ref) (slot-ref obj))) => (lambda (slot-ref) (slot-ref obj)))
(else (else
(struct-ref obj (struct-ref slot slot-index-index))))) (struct-ref obj (%slot-definition-index slot)))))
(define (have-slot slot) (define (have-slot slot)
(not (unbound? (slot-value slot)))) (not (unbound? (slot-value slot))))
(define (no-slot) (define (no-slot)
@ -1550,7 +1552,7 @@ function."
(match slot-spec (match slot-spec
(((? symbol? name) . args) name) (((? symbol? name) . args) name)
;; We can get here when redefining classes. ;; We can get here when redefining classes.
((? slot? slot) (slot-definition-name slot)))) ((? slot? slot) (%slot-definition-name slot))))
(let* ((name (get-keyword #:name options *unbound*)) (let* ((name (get-keyword #:name options *unbound*))
(supers (if (not (or-map (lambda (class) (supers (if (not (or-map (lambda (class)
@ -2180,8 +2182,8 @@ function."
;;; Slots ;;; Slots
;;; ;;;
(define (slot-init-function class slot-name) (define (slot-init-function class slot-name)
(slot-definition-init-thunk (or (class-slot-definition class slot-name) (%slot-definition-init-thunk (or (class-slot-definition class slot-name)
(error "slot not found" slot-name)))) (error "slot not found" slot-name))))
(define (accessor-method-slot-definition obj) (define (accessor-method-slot-definition obj)
"Return the slot definition of the accessor @var{obj}." "Return the slot definition of the accessor @var{obj}."
@ -2243,7 +2245,7 @@ function."
(display "#<" file) (display "#<" file)
(display (class-name class) file) (display (class-name class) file)
(display #\space file) (display #\space file)
(display (slot-definition-name slot) file) (display (%slot-definition-name slot) file)
(display #\space file) (display #\space file)
(display-address slot file) (display-address slot file)
(display #\> file)) (display #\> file))
@ -2391,18 +2393,18 @@ function."
(define (class-slot-ref class slot-name) (define (class-slot-ref class slot-name)
(let ((slot (class-slot-definition class slot-name))) (let ((slot (class-slot-definition class slot-name)))
(unless (memq (slot-definition-allocation slot) '(#:class #:each-subclass)) (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))
(slot-missing class slot-name)) (slot-missing class slot-name))
(let ((x ((slot-definition-slot-ref slot) #f))) (let ((x ((%slot-definition-slot-ref slot) #f)))
(if (unbound? x) (if (unbound? x)
(slot-unbound class slot-name) (slot-unbound class slot-name)
x)))) x))))
(define (class-slot-set! class slot-name value) (define (class-slot-set! class slot-name value)
(let ((slot (class-slot-definition class slot-name))) (let ((slot (class-slot-definition class slot-name)))
(unless (memq (slot-definition-allocation slot) '(#:class #:each-subclass)) (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))
(slot-missing class slot-name)) (slot-missing class slot-name))
((slot-definition-slot-set! slot) #f value))) ((%slot-definition-slot-set! slot) #f value)))
(define-method (slot-unbound (c <class>) (o <object>) s) (define-method (slot-unbound (c <class>) (o <object>) s)
(goops-error "Slot `~S' is unbound in object ~S" s o)) (goops-error "Slot `~S' is unbound in object ~S" s o))
@ -2581,10 +2583,10 @@ function."
(define (compute-slot-accessors class slots) (define (compute-slot-accessors class slots)
(for-each (for-each
(lambda (slot) (lambda (slot)
(let ((getter (slot-definition-getter slot)) (let ((getter (%slot-definition-getter slot))
(setter (slot-definition-setter slot)) (setter (%slot-definition-setter slot))
(accessor-setter setter) (accessor-setter setter)
(accessor (slot-definition-accessor slot))) (accessor (%slot-definition-accessor slot)))
(when getter (when getter
(add-method! getter (compute-getter-method class slot))) (add-method! getter (compute-getter-method class slot)))
(when setter (when setter
@ -2749,15 +2751,15 @@ var{initargs}."
(match slots (match slots
(() obj) (() obj)
((slot . slots) ((slot . slots)
(let ((initarg (get-initarg (slot-definition-init-keyword slot)))) (let ((initarg (get-initarg (%slot-definition-init-keyword slot))))
(cond (cond
((not (unbound? initarg)) ((not (unbound? initarg))
(slot-set! obj (slot-definition-name slot) initarg)) (slot-set! obj (%slot-definition-name slot) initarg))
((slot-definition-init-thunk slot) ((%slot-definition-init-thunk slot)
=> (lambda (init-thunk) => (lambda (init-thunk)
(unless (memq (slot-definition-allocation slot) (unless (memq (slot-definition-allocation slot)
'(#:class #:each-subclass)) '(#:class #:each-subclass))
(slot-set! obj (slot-definition-name slot) (init-thunk))))))) (slot-set! obj (%slot-definition-name slot) (init-thunk)))))))
(lp slots)))))) (lp slots))))))
(define-method (initialize (object <object>) initargs) (define-method (initialize (object <object>) initargs)
@ -2766,11 +2768,11 @@ var{initargs}."
(define-method (initialize (slot <slot>) initargs) (define-method (initialize (slot <slot>) initargs)
(next-method) (next-method)
(struct-set! slot slot-index-options initargs) (struct-set! slot slot-index-options initargs)
(let ((init-thunk (struct-ref slot slot-index-init-thunk))) (let ((init-thunk (%slot-definition-init-thunk slot)))
(when init-thunk (when init-thunk
(unless (thunk? init-thunk) (unless (thunk? init-thunk)
(goops-error "Bad init-thunk for slot `~S': ~S" (goops-error "Bad init-thunk for slot `~S': ~S"
(slot-definition-name slot) init-thunk))))) (%slot-definition-name slot) init-thunk)))))
(define-method (initialize (class <class>) initargs) (define-method (initialize (class <class>) initargs)
(define (make-direct-slot-definition dslot) (define (make-direct-slot-definition dslot)
@ -2871,7 +2873,7 @@ var{initargs}."
(for-each (for-each
(lambda (slot) (lambda (slot)
(if (and (slot-exists? old-instance slot) (if (and (slot-exists? old-instance slot)
(eq? (slot-definition-allocation (eq? (%slot-definition-allocation
(class-slot-definition old-class slot)) (class-slot-definition old-class slot))
#:instance) #:instance)
(slot-bound? old-instance slot)) (slot-bound? old-instance slot))