-;;; installed-scm-file
-
-;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.
+;;;; goops.scm -- The Guile Object-Oriented Programming System
+;;;;
+;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; This library is free software; you can redistribute it and/or
method-specializers method-formals
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
- make find-method get-keyword)
- #:no-backtrace)
+ make find-method get-keyword))
;;;
;;; class-index-flags. `vtable-flag-vtable' indicates that instances of
;;; a vtable are themselves vtables, and `vtable-flag-validated'
;;; indicates that the struct's layout has been validated. goops.c
-;;; defines a couple of additional flags: one to indicate that a vtable
-;;; is actually a class, and one to indicate that the class is "valid",
-;;; meaning that it hasn't been redefined.
+;;; defines a few additional flags: one to indicate that a vtable is
+;;; actually a class, one to indicate that the class is "valid" (meaning
+;;; that it hasn't been redefined), and one to indicate that instances
+;;; of a class are slot definition objects (<slot> instances).
;;;
(define vtable-flag-goops-metaclass
(logior vtable-flag-vtable vtable-flag-goops-class))
(define-inlinable (class? obj)
(class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
+(define-inlinable (slot? obj)
+ (and (struct? obj)
+ (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
+
(define-inlinable (instance? obj)
(class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
;;; more of the protocol. Again, the CPL and class hierarchy slots
;;; remain uninitialized.
;;;
-
(define* (get-keyword key l #:optional default)
"Determine an associated value for the keyword @var{key} from the list
@var{l}. The list @var{l} has to consist of an even number of elements,
(struct-set! <slot> class-index-redefined #f)
<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)
- docstring
- (let ((val obj))
- (unless (slot? val)
+;;; Access to slot objects is performance-sensitive for slot-ref, so in
+;;; addition to the type-checking accessors that we export, we also
+;;; define some internal inlined helpers that just do an unchecked
+;;; struct-ref in cases where we know the object must be a slot, as
+;;; when accessing class-slots.
+;;;
+(define-syntax-rule (define-slot-accessor name docstring %name field)
+ (begin
+ (define-syntax-rule (%name obj)
+ (struct-ref obj field))
+ (define (name obj)
+ docstring
+ (unless (slot? obj)
(scm-error 'wrong-type-arg #f "Not a slot: ~S"
- (list val) #f))
- (struct-ref val field))))
+ (list obj) #f))
+ (%name obj))))
(define-slot-accessor slot-definition-name
"Return the name of @var{obj}."
- slot-index-name)
+ %slot-definition-name slot-index-name)
(define-slot-accessor slot-definition-allocation
"Return the allocation of the slot @var{obj}."
- slot-index-allocation)
+ %slot-definition-allocation slot-index-allocation)
(define-slot-accessor slot-definition-init-keyword
"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
"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
"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
"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
"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
"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
"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
"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
"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!
"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
"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
"Return the number fields used by the slot @var{obj}, or @code{#f}."
- slot-index-size)
-
-(define (class-slot-definition class slot-name)
- (let lp ((slots (class-slots class)))
- (match slots
- (() #f)
- ((slot . slots)
- (if (eq? (struct-ref slot slot-index-name) slot-name)
- slot
- (lp slots))))))
+ %slot-definition-size slot-index-size)
;; Boot definition.
(define (direct-slot-definition-class class initargs)
(init-slot slot-index-init-value #:init-value *unbound*)
(struct-set! slot slot-index-init-thunk
(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)
#f
(lambda () val)))))
(define (build-slots-list dslots cpl)
(define (slot-memq slot slots)
- (let ((name (slot-definition-name slot)))
+ (let ((name (%slot-definition-name slot)))
(let lp ((slots slots))
(match slots
(() #f)
((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)
(when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
(scm-error 'misc-error #f
(match slots
(() res)
((slot . slots)
- (let ((name (slot-definition-name slot)))
+ (let ((name (%slot-definition-name slot)))
(if (memq name seen)
(lp slots res seen)
(lp slots (cons slot res) (cons name seen))))))))
(define (slot-protection-and-kind slot)
(define (subclass? class parent)
(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>))
(values (cond
((subclass? type <self-slot>) #\s)
(error "bad layout for class"))))
layout)
((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))
(lambda (protection kind)
- (let init ((n n) (size (slot-definition-size slot)))
+ (let init ((n n) (size (%slot-definition-size slot)))
(cond
((zero? size) (lp n slots))
(else
;;;
;;; Slot access.
-;;;
-(define (get-slot-value-using-name class obj slot-name)
- (cond
- ((class-slot-definition class slot-name)
- => (lambda (slot)
- (cond
- ((slot-definition-slot-ref slot)
- => (lambda (slot-ref) (slot-ref obj)))
- (else
- (struct-ref obj (slot-definition-index slot))))))
- (else (slot-missing class obj slot-name))))
-
-(define (set-slot-value-using-name! class obj slot-name value)
- (cond
- ((class-slot-definition class slot-name)
- => (lambda (slot)
- (cond
- ((slot-definition-slot-set! slot)
- => (lambda (slot-set!) (slot-set! obj value)))
- (else
- (struct-set! obj (slot-definition-index slot) value)))))
- (else (slot-missing class obj slot-name))))
-
-(define (test-slot-existence class obj slot-name)
- (and (class-slot-definition class slot-name)
- #t))
-
;;;
;;; Before we go on, some notes about class redefinition. In GOOPS,
;;; classes can be redefined. Redefinition of a class marks the class
;;; here though as the { class, object data } pair needs to be accessed
;;; atomically, not the { class, object } pair.
;;;
+(define-inlinable (%class-slot-definition class slot-name kt kf)
+ (let lp ((slots (struct-ref class class-index-slots)))
+ (match slots
+ ((slot . slots)
+ (if (eq? (%slot-definition-name slot) slot-name)
+ (kt slot)
+ (lp slots)))
+ (_ (kf)))))
+
+(define (class-slot-definition class slot-name)
+ (unless (class? class)
+ (scm-error 'wrong-type-arg #f "Not a class: ~S" (list class) #f))
+ (%class-slot-definition class slot-name
+ (lambda (slot) slot)
+ (lambda () #f)))
(define (slot-ref obj slot-name)
"Return the value from @var{obj}'s slot with the nam var{slot_name}."
- (unless (symbol? slot-name)
- (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
- (list slot-name) #f))
- (let* ((class (class-of obj))
- (val (get-slot-value-using-name class obj slot-name)))
- (if (unbound? val)
- (slot-unbound class obj slot-name)
- val)))
+ (let ((class (class-of obj)))
+ (define (slot-value slot)
+ (cond
+ ((%slot-definition-slot-ref slot)
+ => (lambda (slot-ref) (slot-ref obj)))
+ (else
+ (struct-ref obj (%slot-definition-index slot)))))
+ (define (have-slot slot)
+ (let ((val (slot-value slot)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let ((val (slot-missing class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (%class-slot-definition class slot-name have-slot no-slot)))
(define (slot-set! obj slot-name value)
"Set the slot named @var{slot_name} of @var{obj} to @var{value}."
- (unless (symbol? slot-name)
- (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
- (list slot-name) #f))
- (set-slot-value-using-name! (class-of obj) obj slot-name value))
+ (let ((class (class-of obj)))
+ (define (have-slot slot)
+ (cond
+ ((%slot-definition-slot-set! slot)
+ => (lambda (slot-set!) (slot-set! obj value)))
+ (else
+ (struct-set! obj (%slot-definition-index slot) value))))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (slot-missing class obj slot-name value))
+
+ (%class-slot-definition class slot-name have-slot no-slot)))
(define (slot-bound? obj slot-name)
"Return the value from @var{obj}'s slot with the nam var{slot_name}."
- (unless (symbol? slot-name)
- (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
- (list slot-name) #f))
- (not (unbound? (get-slot-value-using-name (class-of obj) obj slot-name))))
+ (let ((class (class-of obj)))
+ (define (slot-value slot)
+ (cond
+ ((%slot-definition-slot-ref slot)
+ => (lambda (slot-ref) (slot-ref obj)))
+ (else
+ (struct-ref obj (%slot-definition-index slot)))))
+ (define (have-slot slot)
+ (not (unbound? (slot-value slot))))
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ (let ((val (slot-missing class obj slot-name)))
+ (if (unbound? val)
+ (slot-unbound class obj slot-name)
+ val)))
+ (%class-slot-definition class slot-name have-slot no-slot)))
(define (slot-exists? obj slot-name)
"Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
- (unless (symbol? slot-name)
- (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
- (list slot-name) #f))
- (test-slot-existence (class-of obj) obj slot-name))
+ (define (have-slot slot) #t)
+ (define (no-slot)
+ (unless (symbol? slot-name)
+ (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+ (list slot-name) #f))
+ #f)
+ (%class-slot-definition (class-of obj) slot-name have-slot no-slot))
(begin-deprecated
(define (check-slot-args class obj slot-name)
(match slot-spec
(((? symbol? name) . args) name)
;; 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*))
(supers (if (not (or-map (lambda (class)
;;; Slots
;;;
(define (slot-init-function class slot-name)
- (slot-definition-init-thunk (or (class-slot-definition class slot-name)
- (error "slot not found" slot-name))))
+ (%slot-definition-init-thunk (or (class-slot-definition class slot-name)
+ (error "slot not found" slot-name))))
(define (accessor-method-slot-definition obj)
"Return the slot definition of the accessor @var{obj}."
(display "#<" file)
(display (class-name class) file)
(display #\space file)
- (display (slot-definition-name slot) file)
+ (display (%slot-definition-name slot) file)
(display #\space file)
(display-address slot file)
(display #\> file))
(define (class-slot-ref 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))
- (let ((x ((slot-definition-slot-ref slot) #f)))
+ (let ((x ((%slot-definition-slot-ref slot) #f)))
(if (unbound? x)
(slot-unbound class slot-name)
x))))
(define (class-slot-set! class slot-name value)
(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-definition-slot-set! slot) #f value)))
+ ((%slot-definition-slot-set! slot) #f value)))
(define-method (slot-unbound (c <class>) (o <object>) s)
(goops-error "Slot `~S' is unbound in object ~S" s o))
(define (compute-slot-accessors class slots)
(for-each
(lambda (slot)
- (let ((getter (slot-definition-getter slot))
- (setter (slot-definition-setter slot))
+ (let ((getter (%slot-definition-getter slot))
+ (setter (%slot-definition-setter slot))
(accessor-setter setter)
- (accessor (slot-definition-accessor slot)))
+ (accessor (%slot-definition-accessor slot)))
(when getter
(add-method! getter (compute-getter-method class slot)))
(when setter
(define (%initialize-object obj initargs)
"Initialize the object @var{obj} with the given arguments
var{initargs}."
+ (define (valid-initargs? initargs)
+ (match initargs
+ (() #t)
+ (((? keyword?) _ . initargs) (valid-initargs? initargs))
+ (_ #f)))
(unless (instance? obj)
(scm-error 'wrong-type-arg #f "Not an object: ~S"
(list obj) #f))
- (unless (even? (length initargs))
- (scm-error 'wrong-type-arg #f "Initargs has odd length: ~S"
+ (unless (valid-initargs? initargs)
+ (scm-error 'wrong-type-arg #f "Invalid initargs: ~S"
(list initargs) #f))
(let ((class (class-of obj)))
(define (get-initarg kw)
(if kw
- (get-keyword kw initargs *unbound*)
+ ;; Inlined get-keyword to avoid checking initargs for validity
+ ;; each time.
+ (let lp ((initargs initargs))
+ (match initargs
+ ((kw* val . initargs)
+ (if (eq? kw* kw)
+ val
+ (lp initargs)))
+ (_ *unbound*)))
*unbound*))
(let lp ((slots (struct-ref class class-index-slots)))
(match slots
(() obj)
((slot . slots)
- (let ((initarg (get-initarg (slot-definition-init-keyword slot))))
+ (define (initialize-slot! value)
+ (cond
+ ((%slot-definition-slot-set! slot)
+ => (lambda (slot-set!) (slot-set! obj value)))
+ (else
+ (struct-set! obj (%slot-definition-index slot) value))))
+ (let ((initarg (get-initarg (%slot-definition-init-keyword slot))))
(cond
((not (unbound? initarg))
- (slot-set! obj (slot-definition-name slot) initarg))
- ((slot-definition-init-thunk slot)
+ (initialize-slot! initarg))
+ ((%slot-definition-init-thunk slot)
=> (lambda (init-thunk)
(unless (memq (slot-definition-allocation slot)
'(#:class #:each-subclass))
- (slot-set! obj (slot-definition-name slot) (init-thunk)))))))
+ (initialize-slot! (init-thunk)))))))
(lp slots))))))
(define-method (initialize (object <object>) initargs)
(define-method (initialize (slot <slot>) initargs)
(next-method)
(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
(unless (thunk? init-thunk)
(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 (make-direct-slot-definition dslot)
(for-each
(lambda (slot)
(if (and (slot-exists? old-instance slot)
- (eq? (slot-definition-allocation
+ (eq? (%slot-definition-allocation
(class-slot-definition old-class slot))
#:instance)
(slot-bound? old-instance slot))
HCoop / bpt / guile.git / blobdiff