lass <applicable-struct-class>
  procedure)
(define-standard-class <applicable-struct-with-setter> (<applicable-struct>)
  #:metaclass <applicable-struct-with-setter-class>
  setter)
(define-standard-class <generic> (<applicable-struct>)
  #:metaclass <applicable-struct-class>
  methods
  (n-specialized #:init-value 0)
  (extended-by #:init-value ())
  effective-methods)
(define-standard-class <extended-generic> (<generic>)
  #:metaclass <applicable-struct-class>
  (extends #:init-value ()))
(define-standard-class <generic-with-setter> (<generic>
                                              <applicable-struct-with-setter>)
  #:metaclass <applicable-struct-with-setter-class>)
(define-standard-class <accessor> (<generic-with-setter>)
  #:metaclass <applicable-struct-with-setter-class>)
(define-standard-class <extended-generic-with-setter> (<extended-generic>
                                                       <generic-with-setter>)
  #:metaclass <applicable-struct-with-setter-class>)
(define-standard-class <extended-accessor> (<accessor>
                                            <extended-generic-with-setter>)
  #:metaclass <applicable-struct-with-setter-class>)

(define-standard-class <method> (<object>)
  generic-function
  specializers
  procedure
  formals
  body
  make-procedure)
(define-standard-class <accessor-method> (<method>)
  (slot-definition #:init-keyword #:slot-definition))

(define-standard-class <boolean> (<top>))
(define-standard-class <char> (<top>))
(define-standard-class <list> (<top>))
;; Not all pairs are lists, but there is code out there that relies on
;; (is-a? '(1 2 3) <list>) to work.  Terrible.  How to fix?
(define-standard-class <pair> (<list>))
(define-standard-class <null> (<list>))
(define-standard-class <string> (<top>))
(define-standard-class <symbol> (<top>))
(define-standard-class <vector> (<top>))
(define-standard-class <foreign> (<top>))
(define-standard-class <hashtable> (<top>))
(define-standard-class <fluid> (<top>))
(define-standard-class <dynamic-state> (<top>))
(define-standard-class <frame> (<top>))
(define-standard-class <vm-continuation> (<top>))
(define-standard-class <bytevector> (<top>))
(define-standard-class <uvec> (<bytevector>))
(define-standard-class <array> (<top>))
(define-standard-class <bitvector> (<top>))
(define-standard-class <number> (<top>))
(define-standard-class <complex> (<number>))
(define-standard-class <real> (<complex>))
(define-standard-class <integer> (<real>))
(define-standard-class <fraction> (<real>))
(define-standard-class <keyword> (<top>))
(define-standard-class <syntax> (<top>))
(define-standard-class <atomic-box> (<top>))
(define-standard-class <unknown> (<top>))
(define-standard-class <procedure> (<applicable>)
  #:metaclass <procedure-class>)
(define-standard-class <primitive-generic> (<procedure>)
  #:metaclass <procedure-class>)
(define-standard-class <port> (<top>))
(define-standard-class <input-port> (<port>))
(define-standard-class <output-port> (<port>))
(define-standard-class <input-output-port> (<input-port> <output-port>))

(define (inherit-applicable! class)
  "An internal routine to redefine a SMOB class that was added after
GOOPS was loaded, and on which scm_set_smob_apply installed an apply
function."
  ;; Why not use class-redefinition?  We would, except that loading the
  ;; compiler to compile effective methods can happen while GOOPS has
  ;; only been partially loaded, and loading the compiler might cause
  ;; SMOB types to be defined that need this facility.  Instead we make
  ;; a very specific hack, not a general solution.  Probably the right
  ;; solution is to avoid using the compiler, but that is another kettle
  ;; of fish.
  (unless (memq <applicable> (class-precedence-list class))
    (unless (null? (class-slots class))
      (error "SMOB object has slots?"))
    (for-each
     (lambda (super)
       (let ((subclasses (struct-ref super class-index-direct-subclasses)))
         (struct-set! super class-index-direct-subclasses
                      (delq class subclasses))))
     (struct-ref class class-index-direct-supers))
    (struct-set! class class-index-direct-supers (list <applicable>))
    (struct-set! class class-index-cpl (compute-cpl class))
    (let ((subclasses (struct-ref <applicable> class-index-direct-subclasses)))
      (struct-set! <applicable> class-index-direct-subclasses
                   (cons class subclasses)))))


