"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/unboxed 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))
      (struct-set! <slot> class-index-name '<slot>)
      (struct-set!/unboxed <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 '())
      <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/raw
  "Return the raw slot-ref procedure of the slot @var{obj}."
   %slot-definition-slot-ref/raw slot-index-slot-ref/raw)
(define-slot-accessor slot-definition-slot-ref
  "Return the slot-ref procedure of the slot @var{obj}."
   %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}."
   %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)
    (struct-set! slot slot-index-slot-ref/raw #f)
    (struct-set! slot slot-index-slot-ref #f)
    (struct-set! slot slot-index-slot-set! #f)
    (struct-set! slot slot-index-index #f)
    (struct-set! slot slot-index-size #f)
    slot))

;; Boot definition.
(define (make class . args)
  (unless (memq <slot> (class-precedence-list class))
    (error (format #f "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))


