#f)
  (options)
  (getter #:init-keyword #:getter #:init-value #f)
  (setter #:init-keyword #:setter #:init-value #f)
  (accessor #:init-keyword #:accessor #:init-value #f)
  ;; These last don't have #:init-keyword because they are meant to be
  ;; set by `allocate-slots', not in compute-effective-slot-definition.
  (slot-ref/raw #:init-value #f)
  (slot-ref #:init-value #f)
  (slot-set! #:init-value #f)
  (index #:init-value #f)
  (size #:init-value #f))

;;;
;;; Statically define variables for slot offsets: `class-index-layout'
;;; will be 0, `class-index-flags' will be 1, and so on, and the same
;;; for `slot-index-name' and such for <slot>.
;;;
(let-syntax ((define-slot-indexer
               (syntax-rules ()
                 ((_ define-index prefix)
                  (define-syntax define-index
                    (lambda (x)
                      (define (id-append ctx a b)
                        (datum->syntax ctx (symbol-append (syntax->datum a)
                                                          (syntax->datum b))))
                      (define (tail-length tail)
                        (syntax-case tail ()
                          ((begin) 0)
                          ((visit head tail) (1+ (tail-length #'tail)))))
                      (syntax-case x ()
                        ((_ (name . _) tail)
                         #`(begin
                             (define-syntax #,(id-append #'name #'prefix #'name)
                               (identifier-syntax #,(tail-length #'tail)))
                             tail)))))))))
  (define-slot-indexer define-class-index class-index-)
  (define-slot-indexer define-slot-index slot-index-)
  (fold-class-slots macro-fold-left define-class-index (begin))
  (fold-slot-slots macro-fold-left define-slot-index (begin)))

;;;
;;; Structs that are vtables have a "flags" slot, which corresponds to
;;; 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 few additional flags: one to indicate that a vtable is
;;; actually a class, one to indicate that instances of a class are slot
;;; definition objects (<slot> instances), one to indicate that this
;;; class has "static slot allocation" (meaning that its slots must
;;; always be allocated to the same indices in all subclasses), and two
;;; more flags used for redefinable classes (more below).
;;;
(define vtable-flag-goops-metaclass
  (logior vtable-flag-vtable vtable-flag-goops-class))

(define-inlinable (class-add-flags! class flags)
  (struct-set!/unboxed
   class
   class-index-flags
   (logior flags (struct-ref/unboxed class class-index-flags))))

(define-inlinable (class-clear-flags! class flags)
  (struct-set!/unboxed
   class
   class-index-flags
   (logand (lognot flags) (struct-ref/unboxed class class-index-flags))))

(define-inlinable (class-has-flags? class flags)
  (eqv? flags
        (logand (struct-ref/unboxed class class-index-flags) flags)))

(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)
  (and (struct? obj)
       (class-has-flags? (struct-vtable obj) vtable-flag-goops-class)))

(define (class-has-statically-allocated-slots? class)
  (class-has-flags? class vtable-flag-goops-static-slot-allocation))

(define (class-has-indirect-instances? class)
  (class-has-flags? class vtable-flag-goops-indirect))

(define (indirect-slots-need-migration? slots)
  (class-has-flags? (struct-vtable slots) vtable-flag-goops-needs-migration))

;;;
;;; Now that we know the slots that must be present in classes, and
;;; their offsets, we can create the root of the class hierarchy.
;;;
;;; Note that the `direct-supers', `direct-slots', `cpl', and `slots'
;;; fields will be updated later, once we can create slot definition
;;; objects and once we have definitions for <top> and <object>.
;;;
(define <class>
  (let-syntax ((cons-layout
                ;; A simple way to compute class layout for the concrete
                ;; types used in <class>.
                (syntax-rules (<protected-read-only-slot>
                               <hidden-slot>
                               <protected-hidden-slot>)
                  ((_ (name) tail)
                   (string-append "pw" tail))
                  ((_ (name #:class <protected-read-only-slot>) tail)
                   (string-append "pw" tail))
                  ((_ (name #:class <hidden-slot>) tail)
                   (string-append "uh" tail))
                  ((_ (name #:class <protected-hidden-slot>) tail)
                   (string-append "ph" tail)))))
    (let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
           (nfields (/ (string-length layout) 2))
           (<class> (%make-vtable-vtable layout)))
      (class-add-flags! <class> vtable-flag-goops-class)
      (struct-set! <class> class-index-name '<class>)
      (struct-set!/unboxed <class> class-index-nfields nfields)
      (struct-set! <class> class-index-direct-supers '())
      (struct-set! <class> class-index-direct-slots '())
      (struct-set! <class> class-index-direct-subclasses '())
      (struct-set! <class> class-index-direct-methods '())
      (struct-set! <class> class-index-cpl '())
      (struct-set! <class> class-index-slots '())
      <class>)))

;;;
;;; Accessors to fields of <class>.
;;;
(define-syntax-rule (define-class-accessor name docstring field)
  (define (name obj)
    docstring
    (let ((val obj))
      (unless (class? val)
        (scm-error 'wrong-type-arg #f "Not a class: ~S"
                   (list val) #f))
      (struct-ref val field))))

(define-class-accessor class-name
  "Return the class name of @var{obj}."
  class-index-name)
(define-class-accessor class-direct-supers
  "Return the direct superclasses of the class @var{obj}."
  class-index-direct-supers)
(define-class-accessor class-direct-slots
  "Return the direct slots of the class @var{obj}."
  class-index-direct-slots)
(define-class-accessor class-direct-subclasses
  "Return the direct subclasses of the class @var{obj}."
  class-index-direct-subclasses)
(define-class-accessor class-direct-methods
  "Return the direct methods of the class @var{obj}."
  class-index-direct-methods)
(define-class-accessor class-precedence-list
  "Return the class precedence list of the class @var{obj}."
  class-index-cpl)
(define-class-accessor class-slots
  "Return the slot list of the class @var{obj}."
  class-index-slots)

(define (class-subclasses c)
  "Compute a list of all subclasses of @var{c}, direct and indirect."
  (define (all-subclasses c)
    (cons c (append-map all-subclasses
                        (class-direct-subclasses c))))
  (delete-duplicates (cdr (all-subclasses c)) eq?))

(define (class-methods c)
  "Compute a list of all methods that specialize on @var{c} or
subclasses of @var{c}."
  (delete-duplicates (append-map class-direct-methods
                                 (cons c (class-subclasses c)))
                     eq?))

(define (is-a? obj class)
  "Return @code{#t} if @var{obj} is an instance of @var{class}, or
@code{#f} otherwise."
  (and (memq class (class-precedence-list (class-of obj))) #t))