+(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,
+where, starting with the first, every second element is a keyword,
+followed by its associated value. If @var{l} does not hold a value for
+@var{key}, the value @var{default} is returned."
+ (unless (keyword? key)
+ (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f))
+ (let lp ((l l))
+ (match l
+ (() default)
+ ((kw arg . l)
+ (unless (keyword? kw)
+ (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
+ (if (eq? kw key) arg (lp l))))))
+
+(define *unbound* (list 'unbound))
+
+(define-inlinable (unbound? x)
+ (eq? x *unbound*))
+
+(define (%allocate-instance class)
+ (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
+ (%clear-fields! obj *unbound*)
+ obj))
+
+(define <slot>
+ (let-syntax ((cons-layout
+ ;; All slots are "pw" in <slot>.
+ (syntax-rules ()
+ ((_ _ tail) (string-append "pw" tail)))))
+ (let* ((layout (fold-slot-slots macro-fold-right cons-layout ""))
+ (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)
+ (struct-set! <slot> class-index-direct-supers '())
+ (struct-set! <slot> class-index-direct-slots '())
+ (struct-set! <slot> class-index-direct-subclasses '())
+ (struct-set! <slot> class-index-direct-methods '())
+ (struct-set! <slot> class-index-cpl (list <slot>))
+ (struct-set! <slot> class-index-slots '())
+ (struct-set! <slot> class-index-redefined #f)
+ <slot>)))
+
+;;; 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 obj) #f))
+ (%name obj))))
+
+(define-slot-accessor slot-definition-name
+ "Return the name of @var{obj}."
+ %slot-definition-name slot-index-name)
+(define-slot-accessor slot-definition-allocation
+ "Return the allocation of the slot @var{obj}."
+ %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-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-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-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-definition-init-thunk slot-index-init-thunk)
+(define-slot-accessor slot-definition-options
+ "Return the initargs given when creating the slot @var{obj}."
+ %slot-definition-options slot-index-options)
+(define-slot-accessor slot-definition-getter
+ "Return the getter of the slot @var{obj}, or @code{#f}."
+ %slot-definition-getter slot-index-getter)
+(define-slot-accessor slot-definition-setter
+ "Return the setter of the slot @var{obj}, or @code{#f}."
+ %slot-definition-setter slot-index-setter)
+(define-slot-accessor slot-definition-accessor
+ "Return the accessor of the slot @var{obj}, or @code{#f}."
+ %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-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-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-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-definition-size slot-index-size)
+
+;; Boot definition.
+(define (direct-slot-definition-class class initargs)
+ (get-keyword #:class initargs <slot>))
+
+;; Boot definition.
+(define (make-slot class initargs)
+ (let ((slot (make-struct/no-tail class)))
+ (define-syntax-rule (init-slot offset kw default)
+ (struct-set! slot offset (get-keyword kw initargs default)))
+ (init-slot slot-index-name #:name #f)
+ (init-slot slot-index-allocation #:allocation #:instance)
+ (init-slot slot-index-init-keyword #:init-keyword #f)
+ (init-slot slot-index-init-form #:init-form *unbound*)
+ (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 (%slot-definition-init-value slot)))
+ (if (unbound? val)
+ #f
+ (lambda () val)))))
+ (struct-set! slot slot-index-options initargs)
+ (init-slot slot-index-getter #:getter #f)
+ (init-slot slot-index-setter #:setter #f)
+ (init-slot slot-index-accessor #:accessor #f)
+ (init-slot slot-index-slot-ref #:slot-ref #f)
+ (init-slot slot-index-slot-set! #:slot-set! #f)
+ (init-slot slot-index-index #:index #f)
+ (init-slot slot-index-size #:size #f)
+ slot))
+
+;; Boot definition.
+(define (make class . args)
+ (unless (memq <slot> (class-precedence-list class))
+ (error "Unsupported class: ~S" class))
+ (make-slot class args))
+
+;; Boot definition.
+(define (compute-direct-slot-definition class initargs)
+ (apply make (direct-slot-definition-class class initargs) initargs))
+
+(define (compute-direct-slot-definition-initargs class slot-spec)
+ (match slot-spec
+ ((? symbol? name) (list #:name name))
+ (((? symbol? name) . initargs)
+ (cons* #:name name
+ ;; If there is an #:init-form, the `class' macro will have
+ ;; already added an #:init-thunk. Still, if there isn't an
+ ;; #:init-thunk already but we do have an #:init-value,
+ ;; synthesize an #:init-thunk initarg. This will ensure
+ ;; that the #:init-thunk gets passed on to the effective
+ ;; slot definition too.
+ (if (get-keyword #:init-thunk initargs)
+ initargs
+ (let ((value (get-keyword #:init-value initargs *unbound*)))
+ (if (unbound? value)
+ initargs
+ (cons* #:init-thunk (lambda () value) initargs))))))))
+
+(let ()
+ (define-syntax cons-slot
+ (syntax-rules ()
+ ((_ (name #:class class) tail)
+ ;; Special case to avoid referencing specialized <slot> kinds,
+ ;; which are not defined yet.
+ (cons (list 'name) tail))
+ ((_ (name . initargs) tail)
+ (cons (list 'name . initargs) tail))))
+ (define-syntax-rule (initialize-direct-slots! class fold-slots)
+ (let ((specs (fold-slots macro-fold-right cons-slot '())))
+ (define (make-direct-slot-definition spec)
+ (let ((initargs (compute-direct-slot-definition-initargs class spec)))
+ (compute-direct-slot-definition class initargs)))
+ (struct-set! class class-index-direct-slots
+ (map make-direct-slot-definition specs))))
+
+ (initialize-direct-slots! <class> fold-class-slots)
+ (initialize-direct-slots! <slot> fold-slot-slots))
+
+
+\f
+