;;; -*-Mode: Scheme; coding: iso-8859-1 -*-
;;;
;;; Part of the RIPOFF object system.
;;; Originally part of Tiny-CLOS,
;;; Heavily hacked by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
;;; as part of Swindle, then hacked and ported Common Larceny by jrm.

;;> This module is the core object system.  It is a heavily hacked
;;> version of the original Tiny-CLOS code from Xerox, but it has been
;;> fitted to Larceny, optimized and extended.  See the source file
;;> for a lot of details about how the CLOS magic is created.

;;; Original copyright:
;;; ***************************************************************************
;;; Copyright (c) 1992 Xerox Corporation.  All Rights Reserved.
;;;
;;; Use, reproduction, and preparation of derivative works are permitted.  Any
;;; copy of this software or of any derivative work must include the above
;;; copyright notice of Xerox Corporation, this paragraph and the one after it.
;;; Any distribution of this software or derivative works must comply with all
;;; applicable United States export control laws.
;;; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS ALL
;;; WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE, AND
;;; NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY LIABILITY FOR
;;; DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS EXPRESSLY DISCLAIMED,
;;; WHETHER ARISING IN CONTRACT, TORT (INCLUDING NEGLIGENCE) OR STRICT
;;; LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED OF THE POSSIBILITY OF SUCH
;;; DAMAGES.
;;; ***************************************************************************

($$trace "generic")

;;; Syntax copied here for mzscheme bootstrapping.
;;; This should go away once we are self hosting.

;;; Shamelessly abuse the macro system to get performance.
(define-syntax %set-instance/procedure!
  (syntax-rules ()
    ((%set-instance/procedure! instance proc) (procedure-set! instance 3 proc))))

(define-syntax %instance/class
  (syntax-rules ()
    ((%instance/class instance) (procedure-ref instance 4))))

(define-syntax %instance/slots
  (syntax-rules ()
    ((%instance/slots instance) (procedure-ref instance 5))))

(define-syntax %instance/ref
  (syntax-rules ()
    ((%instance/ref instance offset)
     (vector-ref (%instance/slots instance) offset))))

(define-syntax %instance/serial-number
  (syntax-rules ()
    ((%instance/serial-number instance)
     (%instance/ref instance 0))))

(define-syntax %instance/set!
  (syntax-rules ()
    ((%instance/set! instance offset value)
     (vector-set! (%instance/slots instance) offset value))))

(define-syntax %instance/update!
  (syntax-rules ()
    ((%instance/set! instance offset proc)
     (let ((slots (%instance/slots instance))
           (index offset))
       (vector-set! slots index (proc (vector-ref slots index)))))))

(define-syntax %instance-overhead
  (syntax-rules ()
    ((%instance-overhead) 1)))

(define-syntax lookup-slot-info
  (syntax-rules ()
    ((lookup-slot-info class slot-name selector)
     (selector (or (assq slot-name
                         ;; no need to ground slot-ref any more! -- see below
                         ;; (if (eq? class <class>)
                         ;;   ;;* This grounds out the slot-ref tower
                         ;;   getters-n-setters-for-class
                         ;;   (%class-getters-n-setters class))
                         (%class-getters-n-setters class))
                   (error "slot-ref: no slot `~e' in ~e" slot-name class))))))

;;; End of syntax for mzscheme

;;>   Determines if something is a singleton specification (which is any
;;>   list with a head containing the symbol `singleton').
(define-syntax %singleton?
  (syntax-rules ()
    ((%singleton? object)
     (and (pair? object)
          (eq? (car object) 'singleton)))))

(define-syntax %nullable?
  (syntax-rules ()
    ((%nullable? object)
     (and (pair? object)
          (eq? (car object) 'nullable)))))

;;; ---------------------------------------------------------------------------
;;; Customization variables

;;>> *default-method-class*
;;>> *default-generic-class*
;;>> *default-class-class*
;;>> *default-entityclass-class*
;;>   These parameters specify default classes for the many constructor
;;>   macros in `clos'.
(define *default-method-class*      (make-parameter "*default-method-class*" <method> class?))
(define *default-generic-class*     (make-parameter "*default-generic-class*" <generic> class?))
(define *default-class-class*       (make-parameter "*default-class-class*" <class> class?))
(define *default-entityclass-class* (make-parameter "*default-entityclass-class*" <entity-class> class?))

;;>> *make-safely*
;;>   Setting this parameter to #t will make Ripoff perform sanity checks
;;>   on given initargs for creating an object.  This will make things
;;>   easier for debugging, but also slower.  Defaults to `#f'.  Note that
;;>   the sanity checks are done in `initialize-instance'.
(define *make-safely* (make-parameter "*make-safely*" #t boolean?))

;;; Miscellaneous helper functions

(define (arglist->arity arglist)
  (define (loop count tail)
    (cond ((pair? tail) (loop (+ count 1) (cdr tail)))
          ((null? tail) count)
          (else (make-arity-at-least count))))
  (loop 0 arglist))

(define (make-generic name arity . additional)
  (apply make (*default-generic-class*)
         :name name
         :arity (cond ((or (and (integer? arity)
                                (exact? arity))
                           (arity-at-least? arity))
                       arity)
                      ((or (null? arity)
                           (pair? arity)
                           (symbol? arity))
                       (arglist->arity arity))
                      (else (error "MAKE-GENERIC: arity specifier must be an integer, arity, or list.")))
         additional))

;; Uses an existing generic to determine the arity of the new method.
(define (extend-generic generic . args)
  (add-method generic
    (apply make (*default-method-class*)
           :arity (generic-arity generic)
           args)))

;;; A object that simply behaves like an aggregate will want
;;; to use these functions.

(define (generic-getter name) (make-generic name '(instance)))

(define (generic-setter name) (make-generic name '(instance new-value)))

(define (generic-updater name) (make-generic name '(instance update-procedure)))

;;; This looks *much* harder than it is.  The idea is simple.  Each
;;; direct superclass has a linearization list.  We look at the heads
;;; of each of these lists.  If we find a head element that *isn't* in
;;; the tail of a different list, we use it (and pop it from all the
;;; lists that might also have that head element).  Iterate until done.

;;; NOTE:  THIS IS THE `C3' LINEARIZATION ALGORITHM
;;; IT IS DIFFERENT FROM CLOS AND SWINDLE
(define (compute-class-linearization class)

  (define (select-candidate lists)
    (let search-loop ((scan lists))
      (cond ((pair? scan)
             (let ((list (car scan))
                   (more (cdr scan)))
               (cond ((pair? list)
                      (let ((candidate (car list)))
                        (let validate-loop ((l lists))
                          (cond ((pair? l)
                                 (let ((v (car l)))
                                   (cond ((pair? v) (if (memq candidate (cdr v))
                                                        (search-loop more)
                                                        (validate-loop (cdr l))))
                                         ((null? v) (validate-loop (cdr l)))
                                         (else (error "Improper list.")))))
                                ((null? l) candidate)
                                (else (error "Improper list."))))))
                     ((null? list) (search-loop more))
                     (else (error "Improper list")))))
            ((null? scan) (error "Inconsistent class linearization."))
            (else (error "Improper list.")))))

  (define (merge-lists remaining result)
    (if (every? null? remaining)
        (reverse! result)
        (let ((candidate (select-candidate remaining)))
          (merge-lists
           (map (lambda (list)
                  (cond ((pair? list) (if (eq? candidate (car list))
                                          (cdr list)
                                          list))
                        ((null? list) list)
                        (else (error "Improper list"))))
                remaining)
           (cons candidate result)))))

  (let ((direct-superclasses (%class-direct-supers class)))
    (merge-lists
     (map %class-cpl direct-superclasses)
     (list class))))

;;>>... Generics in the instance initialization protocol
;;> The following generic functions are used as part of the protocol of
;;> instantiating an instance, and some are used specifically to instantiate
;;> class objects.

;;; The instance structure protocol.
;;>> (allocate-instance class initargs)
;;>   This generic function is called to allocate an instance of a class.
;;>   It is applied on the class object, and is expected to return the new
;;>   instance object of that class.
(define allocate-instance (make-generic 'allocate-instance '(class initargs)))

;;>> (initialize-instance instance initargs)
;;>   This generic is called to initialize an instance.  It is applied on
;;>   the newly allocated object and the given initargs, and is not expected
;;>   to return any meaningful value -- only do some side effects on the
;;>   instance to initialize it.  When overriding this for a some class, it
;;>   is not a good idea to skip `call-next-method' since it is responsible
;;>   for initializing slot values.
(define initialize-instance (make-generic 'initialize-instance '(instance initargs)))

;;>> (compute-getter-and-setter class slot allocator)
;;>   This generic is used to get a getter and setter functions for a given
;;>   slot.  It is passed the class object, the slot information (a list of
;;>   a slot name and options), and an allocator function.  The allocator is
;;>   a function that gets an initializer function and returns an index
;;>   position for the new slot.  The return value should be a list of two
;;>   elements -- a getter and a setter functions.
(define compute-getter-and-setter (make-generic 'compute-getter-and-setter '(class slot allocator)))

;;; The class initialization protocol.
;;>> (compute-cpl class)
;;>   This generic is used to get the class-precedence-list for a class
;;>   object.  The standard <class> object uses the `compute-std-cpl' (see
;;>   in the code) which flattens the class ancestors using a topological
;;>   sort that resolve ambiguities left-to-right.
(define compute-cpl                   (make-generic 'compute-cpl '(class)))

;;>> (compute-slots class)
;;>   This generic is used to compute all slot information for a given
;;>   class, after its precedence list has been computed.  The standard
;;>   <class> collects information from all preceding classes.
(define compute-slots                 (make-generic 'compute-slots '(class)))

;;>> (compute-default-initargs class)
;;>   This generic is used to compute the default initargs for a given
;;>   class.
(define compute-default-initargs      (make-generic 'compute-default-initargs '(class)))

;;>> (compute-apply-method method)
;;>   This generic is used to compute the procedure that will get executed
;;>   when a method is applied directly.
(define compute-apply-method          (make-generic 'compute-apply-method '(method)))

;;>> ((compute-apply-generic generic) args ...)
;;>   This generic is used to compute the object (a closure) that is
;;>   actually applied to execute the generic call.  The standard version
;;>   uses `compute-method' and `compute-apply-methods' below, and caches
;;>   the result.
(define compute-apply-generic         (make-generic 'compute-apply-generic '(generic)))

;;>> (compute-methods generic args)
;;>   Computes the methods that should be applied for this generic
;;>   invocation with args.  The standard code filters applicable methods
;;>   and sorts them according to their specificness.  The return value is
;;>   expected to depend only on the types of the arguments (and values if
;;>   there are singleton specializers).
(define compute-methods               (make-generic 'compute-methods '(generic arguments)))

;;>> (compute-methods-by-class generic argument-types)
;;>   Computes the methods that should be applied for this generic
;;>   invocation with args of argument-types.  The standard code filters applicable methods
;;>   and sorts them according to their specificness.  The return value is
;;>   expected to depend only on the types of the arguments.  If there
;;>   are singleton specializers, an error is raised.
(define compute-methods-by-class      (make-generic 'compute-methods-by-class '(generic argument-types)))

;;>> ((compute-method-more-specific? generic) mthd1 mthd2 args)
;;>   Get a generic and return a function that gets two methods and a list
;;>   of arguments and decide which of the two methods is more specific.
;;>   This decision should only be based on the argument types, or values
;;>   only in case of singletons.
(define compute-method-more-specific? (make-generic 'compute-method-more-specific? '(generic)))

;;>> ((compute-method-more-specific? generic) mthd1 mthd2 arg-classes)
;;>   Get a generic and return a function that gets two methods and a list
;;>   of argument classes and decide which of the two methods is more specific.
;;>   This decision should only be based on the argument types.  An
;;>   error is raised if either method is specialized on a singleton.
(define compute-method-more-specific-by-class? (make-generic 'compute-method-more-specific-by-class? '(generic)))

;;>> ((compute-apply-methods generic methods) args ...)
;;>   Gets a generic and returns a function that gets the given arguments
;;>   for this call.  This function which it returns is the combination of
;;>   all given methods.  The standard one arranges them by default using
;;>   the `call-next-method' argument argument that methods have.  Ripoff
;;>   extends this with qualified methods and applies `before', `after', and
;;>   `around' methods in a similar way to CLOS: first the `around' methods
;;>   are applied (and they usually call their `call-next-method' to
;;>   continue but can return a different value), then all the `before'
;;>   methods are applied (with no `call-next-method'), then all `primary'
;;>   methods as usual (remembering the return value), and finally the
;;>   `after' methods (similar to the `before', but in reverse specificness
;;>   order).  If the generic has a `combination' slot value, then it is a
;;>   procedure that is used to combine the primary methods, but the
;;>   auxiliary ones are still applied in the same way.  This is unlike CLOS
;;>   where the standard combinations run only `around' methods, and there
;;>   is generally more control with method combinations, but in Ripoff
;;>   `compute-apply-methods' should be overridden for this.  See
;;>   `make-generic-combination' for details about method combinations.
(define compute-apply-methods         (make-generic 'compute-apply-methods '(generic methods)))

(define generic-invocation-generics
  (list compute-apply-generic
        compute-methods
        compute-methods-by-class
        compute-method-more-specific?
        compute-method-more-specific-by-class?
        compute-apply-methods))

;;; This is used to signal whenever all method caches are to be reset - so when
;;; a method is added to generic-invocation-generics, this is set to some value
;;; which is not eq? to the current one.
(define *generic-app-cache-tag* #t)


;;>> (add-method generic method)
;;>   This generic function is called to add a method to a generic function
;;>   object.  This is another change from the original Tiny CLOS where it
;;>   was a normal function.
(define (add-method generic method)
  ;; add singleton specializer value (if any) to the corresponding hash table
  ;; in singletons-list.
  (define (add-to-singletons-list specs tables)
    (if (pair? specs)
        (begin
          (if (%singleton? (car specs))
              (begin
                (if (not (car tables))
                    (set-car! tables (make-hash-table 'weak)))
                (hash-table-put! (car tables) (singleton-value (car specs)) #t)))
          (add-to-singletons-list (cdr specs) (cdr tables)))))

  (define (n-falses n)
    (let loop ((n n) (r '()))
      (if (zero? n) r (loop (- n 1) (cons #f r)))))

  (let ((tables    (%generic-singletons-list generic))
        (specs     (%method-specializers method))
        (qualifier (%method-qualifier method)))
    ;; make sure that tables always contain enough hash tables (or #f's)
    (cond ((eq? tables *unbound-slot-value*)
           (set! tables (n-falses (length specs)))
           (%set-generic-singletons-list! generic tables))
          ((shorter? tables specs)
           (set! tables (append!
                         tables
                         (n-falses (- (length specs) (length tables)))))
           (%set-generic-singletons-list! generic tables)))
    (add-to-singletons-list specs tables)
    (if (memq generic generic-invocation-generics)
        ;; reset all caches by changing the value of *generic-app-cache-tag*
        (set! *generic-app-cache-tag* (list #f))
        ;; reset this generic app-cache
        (%set-generic-app-cache! generic *unbound-slot-value*))
    (%update-generic-methods!
     generic
     (lambda (existing-methods)
       (cons method
           ;; When adding a method, we remove the previous definition
           ;; by filtering out methods with the same specializers and
           ;; qualifiers.
           (filter (lambda (existing)
                     (not (same-method-signature? method existing)))
                   existing-methods))))
    (%set-instance/procedure! generic (compute-apply-generic generic))))

;;; Adding a method calls COMPUTE-APPLY-GENERIC, the result of which calls the
;;; other generics in the generic invocation protocol.  Two, related, problems
;;; come up.  A chicken and egg problem and a infinite regress problem.
;;; In order to add our first method to COMPUTE-APPLY-GENERIC, we need
;;; something sitting there, so it can be called.  The first definition below
;;; does that.
;;; Then, the second definition solves both the infinite regress and the not
;;; having enough of the protocol around to build itself problem the same way:
;;; it special cases invocation of generics in the invocation protocol.

;;; BOOTSTRAP STEP
(%set-instance/procedure! compute-apply-generic
                          (lambda (instance arglist)
                            (let ((generic (car arglist)))
                              ((%method-procedure (car (%generic-methods generic))) '() generic))))

(extend-generic compute-apply-generic
  :specializers (list <generic>)
  :procedure ((lambda ()

                ;; This function converts the list of arguments to a list of keys to look
                ;; for in the cache - use the argument's class except when there is a
                ;; corresponding singleton with the same value at the same position.
                (define (get-keys args tables)
                  (let loop ((args args) (tables tables) (ks '()))
                    (if (and (pair? tables)
                             (pair? args))
                        (loop (cdr args) (cdr tables)
                              (cons (let ((this-table (car tables))
                                          (this-arg   (car args)))
                                      (if (and this-table
                                               (hash-table-get this-table this-arg false))
                                          this-arg
                                          (%instance/serial-number (class-of this-arg))))
                                    ks))
                        (reverse! ks))))

                (define (method:compute-apply-generic call-next-method ignored)
;      #| The code below is the original, then comes the optimized version below
;      ;; see the definition of the <generic> class above.
;      (lambda args
;        (if (and (memq generic generic-invocation-generics)    ;* Ground case
;                 (memq (car args) generic-invocation-generics))
;          (apply (%method-procedure (last (%generic-methods generic))) #f args)
;          ((compute-apply-methods generic)
;           (compute-methods generic args) . args)))
;      |#

                  ;; This is the main function that brings the correct value from the
                  ;; cache, or generates one and store it if there is no entry, or the
                  ;; cache was reset.  Finally, it is applied to the arguments as usual.
                  ;; NOTE: This code is delicate! Handle with extreme care!
                  (lambda (generic args)
                    (let ((app-cache (%generic-app-cache generic))
                          (arity     (%generic-arity generic))
                          (keys      (get-keys args (%generic-singletons-list generic)))
                          (ground?   (and ;* Ground case
                                      (memq generic generic-invocation-generics)
                                      (pair? args)
                                      (memq (car args) generic-invocation-generics))))
                      ;; This function creates the cached closure -- the assumption is that
                      ;; `keys' contain a specification that will identify all calls that
                      ;; will have this exact same list.
                      (define (compute-callable)
                        (let ((c (if ground?
                                     (let ((m (%method-procedure
                                               (last (%generic-methods generic)))))
                                       (lambda args (apply m #f args)))
                                     (compute-apply-methods
                                      generic (compute-methods generic args)))))
                          (hash-table-put! (cdr app-cache) keys c)
                          c))
                      (if (cond ((not arity) #f)
                                ((and (integer? arity) (exact? arity)) (not (length=? args arity)))
                                (else (length<? args (arity-at-least-value arity))))
                          (let ((least (and (arity-at-least? arity)
                                            (arity-at-least-value arity))))
                            (error "APPLY:  wrong number of arguments to generic function " (%generic-name generic))))
                      (if (or (eq? app-cache *unbound-slot-value*)
                              (not (eq? (car app-cache) *generic-app-cache-tag*)))
                          (begin
                            (set! app-cache (cons *generic-app-cache-tag*
                                                  (make-hash-table 'weak 'equal)))
                            (%set-generic-app-cache! generic app-cache)))
                      (apply (hash-table-get (cdr app-cache) keys compute-callable) args))))

                method:compute-apply-generic)))

(extend-generic compute-methods
  :specializers (list <generic>)
  :procedure ((lambda ()
                (define (sort-predicate compare arguments)
                  (lambda (left-method right-method)
                    (compare left-method right-method arguments)))

                (define (method:compute-methods call-next-method generic args)
                  (sort (filter
                         (lambda (m)
                           (instances-of? args (%method-specializers m)))
                         (%generic-methods generic))
                        (sort-predicate (compute-method-more-specific? generic) args)))

                method:compute-methods)))

(extend-generic compute-methods-by-class
  :specializers (list <generic>)
  :procedure ((lambda ()
                (define (sort-predicate compare arguments)
                  (lambda (left-method right-method)
                    (compare left-method right-method arguments)))

                (define (method:compute-methods-by-class call-next-method generic arg-classes)
                  (sort (filter
                         (lambda (m)
                           (subclasses-of? arg-classes (%method-specializers m)))
                         (%generic-methods generic))
                        (sort-predicate (compute-method-more-specific-by-class? generic) arg-classes)))

                method:compute-methods-by-class)))

;;>> (specializer? x)
;;>   Determines whether `x' is a class, a singleton, or a struct-type.
(define (specializer? x)
  (or (class? x)
      (%nullable? x)
      (%singleton? x)
      (struct-type? x)
      (record-type-descriptor? x)))

(define-syntax %struct->class
  (syntax-rules ()
    ((%struct->class c) (cond ((record-type-descriptor? c) (record-type->class c))
                              ((struct-type? c) (struct-type->class c))
                              (else c)))))

;;>> (more-specific? class1 class2 x)
;;>   Is `class1' more specific than `class2' for the given value?
(define (more-specific? c1 c2 arg)
  (cond ((%singleton? c1) (eq? (singleton-value c1) arg))
        ((%singleton? c2) (not (eq? (singleton-value c2) arg)))
        (else (let ((cc1 (memq (%struct->class c1) (%class-cpl (class-of arg)))))
                (and cc1 (memq (%struct->class c2) (cdr cc1)))))))

;; Is class1 more specific than class2 for an argument of the given type?
;; Signals an error if either c1 or c2 are singletons.
(define (more-specific-by-class? c1 c2 arg-class)
  (cond ((%singleton? c1) (error "more-specific-by-class?:  singleton specializer" c1))
        ((%singleton? c2) (error "more-specific-by-class?:  singleton specializer" c2))
        (else (let ((cc1 (memq (%struct->class c1) (%class-cpl arg-class))))
                (and cc1 (memq (%struct->class c2) (cdr cc1)))))))

(define (make-compute-method-more-specific specificity-checker)
  (define (method:compute-method-more-specific? call-next-method generic)
    (lambda (left right args)
      (let loop ((specls-left (%method-specializers left))
                 (specls-right (%method-specializers right))
                 (args    args))
        (cond ((and (null? specls-left) (null? specls-right))
               (if (eq? (%method-qualifier left) (%method-qualifier right))
                   (error "COMPUTE-METHOD-MORE-SPECIFIC?:  two methods are equally specific in " generic)
                   #f))
              ;; some methods in this file have fewer specializers than
              ;; others for things like args -- so remove this, leave the
              ;; args check but treat the missing as if it's <top>
              ;; ((or (null? specls-left) (null? specls-right))
              ;;  (error 'generic
              ;;         "two methods have different number of ~
              ;;          specializers in ~e" generic))
              ((null? args)             ; shouldn't happen
               (error "COMPUTE-METHOD-MORE-SPECIFIC?: fewer arguments than specializers for " generic))
              ((null? specls-left)      ; see above -> treat this like <top>
               (if (eq? <top> (car specls-right))
                   (loop specls-left (cdr specls-right) (cdr args))
                   #f))
              ((null? specls-right)     ; see above -> treat this like <top>
               (if (eq? <top> (car specls-left))
                   (loop (cdr specls-left) specls-right (cdr args))
                   #t))
              (else (let ((c1 (car specls-left))
                          (c2 (car specls-right)))
                      (cond ((eq? c1 c2)
                             (loop (cdr specls-left) (cdr specls-right) (cdr args)))
                            ((%nullable? c1) (if (%nullable? c2)
                                                 (if (null? (car args))
                                                     (loop (cdr specls-left) (cdr specls-right) (cdr args))
                                                     (specificity-checker (nullable-value c1)
                                                                          (nullable-value c2)
                                                                          (car args)))
                                                 (if (null? (car args))
                                                     #t
                                                     (specificity-checker (nullable-value c1)
                                                                          c2
                                                                          (car args)))))

                            ((%nullable? c2) (if (null? (car args))
                                                 #f
                                                 (specificity-checker c1
                                                                      (nullable-value c2)
                                                                      (car args))))
                            (else
                             (specificity-checker c1 c2 (car args))))))))))
  method:compute-method-more-specific?)

(extend-generic compute-method-more-specific?
  :specializers (list <generic>)
  :procedure (make-compute-method-more-specific more-specific?))

(extend-generic compute-method-more-specific-by-class?
  :specializers (list <generic>)
  :procedure (make-compute-method-more-specific more-specific-by-class?))

(extend-generic compute-apply-methods
  :specializers (list <generic>)
  :procedure ((lambda ()
                (define (method:compute-apply-methods call-next-method generic methods)
                  (let ((primaries '()) (arounds '()) (befores '()) (afters '())
                        (combination (%generic-combination generic)))
                    ;; *** Trick: this (and in <method> above) is the only code that is
                    ;; supposed to ever apply a method procedure.  So, the closure that
                    ;; will invoke `no-next-method' is named `*no-next-method' so it is
                    ;; identifiable.  The only way to break this would be to call the
                    ;; method-procedure directly on an object with such a name.

                    (define one-step
                      (if combination
                          (combination generic)
                          (lambda (tail args)
                            (lambda newargs
                              ;; tail is never null: (null? (cdr tail)) below, and the fact
                              ;; that this function is applied on the primaries which are
                              ;; never null
                              (let ((args (if (null? newargs) args newargs)))
                                (apply (cdar tail)
                                       (if (null? (cdr tail))
                                           ((lambda ()
                                              (define (*no-next-method* . args)
                                                (apply no-next-method generic (caar tail) args))
                                              *no-next-method*))
                                           (one-step (cdr tail) args))
                                       args))))))

                    (define (apply-before/after-method args)
                      (lambda (method)
                        (apply (cdr method)
                               ((lambda ()
                                  (define (*no-next-method* . args)
                                    (apply no-next-method generic (car method) args))
                                  *no-next-method*))
                               args)))

                    (define (call-before-primary-after args)
                      (lambda newargs
                        ;; could supply newargs below, but change before calling befores
                        (let ((args (if (null? newargs) args newargs)))
                          (for-each (apply-before/after-method args) befores)
                          (let ((result ((one-step primaries args))))
                            (for-each (apply-before/after-method args) afters)
                            result))))

                    (define (one-around-step tail args)
                      (if (null? tail)
                          (call-before-primary-after args)
                          (lambda newargs
                            (let ((args (if (null? newargs) args newargs)))
                              (apply (cdar tail) (one-around-step (cdr tail) args) args)))))

                    ;; first sort by qualifier and pull out method-procedures
                    (let loop ((ms methods))
                      (cond ((pair? ms)
                             (let* ((cms (car ms))
                                    (q (%method-qualifier cms)))
                               (cond ((eq? q :primary)
                                      (set! primaries (cons (cons cms (%method-procedure cms)) primaries)))
                                     ((eq? q :around)
                                      (set! arounds (cons (cons cms (%method-procedure cms)) arounds)))
                                     ((eq? q :before)
                                      (set! befores (cons (cons cms (%method-procedure cms)) befores)))
                                     ((eq? q :after)
                                      (set! afters (cons (cons cms (%method-procedure cms)) afters)))
                                     (else (error "COMPUTE-APPLY-METHODS:  a method ~e has an unexpected qualifier "
                                                  (car methods) (%method-qualifier (car methods)))))
                               (loop (cdr ms))))
                            ((null? ms)
                             (set! primaries (reverse! primaries))
                             (set! arounds   (reverse! arounds))
                             (set! befores   (reverse! befores)))
                            ;; no reverse! for afters)
                            (else (error "COMPUTE-APPLY-METHODS:  bad list?"))))

                    (cond ((null? primaries)
                           (lambda args (apply no-applicable-method generic args)))
                          ;; optimize common case of only primaries
                          ((and (null? befores) (null? afters) (null? arounds))
                           ;; args is initialized to () since if it is a generic of no
                           ;; arguments then it will always stay so, otherwise, the first
                           ;; call will have the real arguments anyway
                           (one-step primaries '()))
                          (else (one-around-step arounds '())))))
                method:compute-apply-methods)))

;;>> (((make-generic-combination keys...) generic) tail args)
;;>   This function can be used to construct simple method combinations that
;;>   can be used with the `combination' slot of generic functions.  The
;;>   combination itself is a function that gets a generic and returns a
;;>   function that gets a list of method/procedure pairs (for optimization
;;>   the method-procedures are pre taken) and the arguments and performs
;;>   the call -- but this is only interesting if there's any need to
;;>   implement a method combination directly, otherwise, the
;;>   `make-generic-combination' interface should allow enough freedom.
;;>   Note that when a method combination is used, `around', `before', and
;;>   `after' are called around the primary call as usual, but the primaries
;;>   are never called with a valid `call-next-method' argument.
;;>
;;   NOTE NOTE NOTE
;;   The args are no longer keyword args but are required args.
;;>   The keyword arguments that can be taken determine the behavior of this
;;>   combination.  Overall, it is roughly like a customizable version of a
;;>   fold operation on the method calls.
;;>   * init
;;>     - The initial value for this computation.  Defaults to null.
;;>   * combine
;;>     - A function to be called on a method call result and the old value,
;;>       and produces a new value.  The default is `cons', which with an
;;>       initial null value will collect the results into a reversed list.
;;>   * process-methods
;;>     - A function that can be called on the initial list of
;;>       method/procedure pairs to change it -- for example, it can be
;;>       reversed to apply the methods from the least specific to the most
;;>       specific.  No default.
;;>   * process-result
;;>     - A function that can be called on the final resulting value to
;;>       produce the actual return value.  For example, it can reverse back
;;>       a list of accumulated values.  No default.
;;>   * control
;;>     - If this parameter is specified, then the `'combine' argument is
;;>       ignored.  The value given to `'control' should be a function of
;;>       four arguments:
;;>       1. a `loop' function that should be called on some new value and
;;>          some new tail;
;;>       2. a `val' argument that gets the current accumulated value;
;;>       3. a `this' thunk that can be called to apply the current method
;;>          and return its result;
;;>       4. a `tail' value that holds the rest of the method/procedure list
;;>          which can be sent to `loop'.
;;>       It should be clear now, that a `'control' argument can have a lot
;;>       of control on the computation, it can abort, change arbitrary
;;>       values and skip calling methods.  Note that if it won't call
;;>       `loop' with an empty list, then a `'process-result' function will
;;>       not be used as well.  See the pre-defined combinations in the
;;>       source code to see examples of using this function.
(define (make-generic-combination init process-methods process-result control)
  (lambda (generic)
    (lambda (tail dummy-args)
      (let ((tail (process-methods tail)))
        (lambda args
          (let loop ((res init) (tail tail))
            ;; see *no-next-method* trick above
            (let ((*no-next-method*
                   (lambda args (apply no-next-method generic (caar tail) args))))
              (cond ((pair? tail) (control loop res
                                           (lambda () (apply (cdar tail) *no-next-method* args))
                                           (cdr tail)))
                    ((null? tail) (process-result res))
                    (else (error "MAKE-GENERIC-COMBINATION:  Bad method list?"))))))))))

(define (generic-combination-cons loop val this tail)
  (loop (cons (this) val) tail))

(define (generic-combination-control combine)
  (lambda (loop val this tail)
    (loop (combine (this) val) tail)))

;;>> generic-+-combination
;;>> generic-list-combination
;;>> generic-min-combination
;;>> generic-max-combination
;;>> generic-append-combination
;;>> generic-append!-combination
;;>> generic-begin-combination
;;>> generic-and-combination
;;>> generic-or-combination
;;>   These are all functions that can be used as a `combination' value for
;;>   a generic function.  They work in the same way as the standard method
;;>   combinations of CL.  Most of them do the obvious thing based on some
;;>   function to combine the result.  The `begin' combination simply
;;>   executes all methods one by one and returns the last value, the `and'
;;>   and `or' combinations will call them one by one until a false or true
;;>   result is returned.  The source of these can be used as templates for
;;>   defining more combinations.
(define generic-+-combination
  (make-generic-combination   0 identity identity (generic-combination-control +)))
(define generic-list-combination
  (make-generic-combination '() identity reverse! generic-combination-cons))
(define generic-min-combination
  (make-generic-combination '() identity (lambda (r) (apply min r)) generic-combination-cons))
(define generic-max-combination
  (make-generic-combination '() identity (lambda (r) (apply max r)) generic-combination-cons))
(define generic-append-combination
  (make-generic-combination '() identity (lambda (r) (apply append (reverse! r))) generic-combination-cons))
(define generic-append!-combination
  (make-generic-combination '() identity (lambda (r) (apply append! (reverse! r))) generic-combination-cons))
(define generic-begin-combination
  (make-generic-combination #f identity identity (generic-combination-control (lambda (x y) x))))
(define generic-and-combination
  (make-generic-combination #t identity identity (lambda (loop val this tail)
                                                   (and val
                                                        (let ((it (this)))
                                                          (and it
                                                               (loop it tail)))))))
(define generic-or-combination
  (make-generic-combination #f identity identity (lambda (loop val this tail)
                                                   (or (this) (loop #f tail)))))

;;; Install the class initializers for the standard classes.
(extend-generic initialize-instance
  :procedure ((lambda ()
                (define (method:initialize-instance call-next-method object initargs)
                  (error "INITIALIZE-INSTANCE: can't initialize an instance of "
                         (%class-name (class-of object))))
                method:initialize-instance)))

(extend-generic initialize-instance
  :specializers (list <object>)
  :procedure ((lambda ()
                (define (method:initialize-instance call-next-method object initargs)
                  (let ((class (class-of object)))
                    (for-each (lambda (init) (apply init initargs))
                              (%class-initializers class))
                    (foldl (lambda (initializer index)
                             (%instance/set! object index (apply initializer initargs))
                             (+ index 1))
                           (%instance-overhead)
                           (%class-field-initializers class))))
                method:initialize-instance)))

(define (getter-method class slot-name)
  (if (not (subclass? class <object>))
      (error "getter-method: class must derive from <object> " class))

  (let ((fast-slot-reader (let ((slot (assq slot-name (%class-getters-n-setters class))))
                            (if (not slot)
                                (slot-missing class #f slot-name 'getter-method)
                                (cadr slot)))))

    (define (fast-slot-ref instance)
      (let ((value (fast-slot-reader instance)))
        (if (eq? value *unbound-slot-value*)
            (slot-unbound class instance slot-name)
            value)))

    (define (method:slot-reader call-next-method instance)
      (if (eq? (%instance/class instance) class)
          (fast-slot-ref instance)
          (slot-ref instance slot-name)))

    (make <method>
      :arity 1
      :specializers (list class)
      :procedure method:slot-reader)))

(define (setter-method class slot-name)
  (if (not (subclass? class <object>))
      (error "setter-method: class must derive from <object> " class))

  (let ((fast-slot-writer (let ((slot (assq slot-name (%class-getters-n-setters class))))
                            (if (not slot)
                                (slot-missing class #f slot-name 'writer-method)
                                (caddr slot)))))

    (define (method:slot-writer call-next-method instance new-value)
      (if (eq? (%instance/class instance) class)
          (fast-slot-writer instance new-value)
          (slot-set! instance slot-name new-value)))

    (make <method>
      :arity 2
      :specializers (list class)
      :procedure method:slot-writer)))

(define (updater-method class slot-name)
  (if (not (subclass? class <object>))
      (error "updater-method: class must derive from <object> " class))

  (let ((fast-slot-updater (let ((slot (assq slot-name (%class-getters-n-setters class))))
                             (if (not slot)
                                 (slot-missing class #f slot-name 'updater-method)
                                 (cadddr slot)))))

    (define (method:slot-updater call-next-method instance procedure)
      (if (eq? (%instance/class instance) class)
          (fast-slot-updater instance procedure)
          (slot-update! instance slot-name procedure)))

    (make <method>
      :arity 2
      :specializers (list class <function>)
      :procedure method:slot-updater)))

(define (initialize-generic-accessors class)
  (for-each
   (lambda (slot)
     (let ((slot-name (car slot))
           (readers (getargs (cdr slot) :reader))
           (writers (getargs (cdr slot) :writer))
           (updaters (getargs (cdr slot) :updater)))

       (if (pair? readers)
           (let ((method (getter-method class slot-name)))
             (for-each
              (lambda (reader)
                (cond ((not (generic? reader))
                       (error "slot :reader is not bound to a generic function " reader))
                      ((not (= (%generic-arity reader) 1))
                       (error "slot :reader is not bound to a generic function of the correct arity "
                              reader))
                      (else
                       (add-method reader method))))
              readers)))

       (if (pair? writers)
           (let ((method (setter-method class slot-name)))
             (for-each
              (lambda (writer)
                (cond ((not (generic? writer))
                       (error "slot :writer is not bound to a generic function " writer))
                      ((not (= (%generic-arity writer) 2))
                       (error "slot :writer is not bound to a generic function of the correct arity "
                              writer))
                      (else
                       (add-method writer method))))
              writers)))

       (if (pair? updaters)
           (let ((method (updater-method class slot-name)))
             (for-each
              (lambda (updater)
                (cond ((not (generic? updater))
                       (error "slot :updater is not bound to a generic function " updater))
                      ((not (= (%generic-arity updater) 2))
                       (error "slot :updater is not bound to a generic function of the correct arity "
                              updater))
                      (else
                       (add-method updater method))))
              updaters)))))
   (%class-direct-slots class)))

(extend-generic initialize-instance
  :specializers (list <class>)
  :procedure ((lambda ()
                (define (method:initialize-instance call-next-method class initargs)
                  (call-next-method)
                  ;; No checking on this.
                  (%set-class-direct-default-initargs!
                   class
                   (getarg initargs :direct-default-initargs #f))
                  (%set-class-direct-supers!
                   class
                   (let ((default (*default-object-class*))
                         (supers (getarg initargs :direct-supers #f)))
                     ;; check valid supers, and always have an object class
                     (cond
                      ((not default) supers) ; check disabled
                      ((or (not supers) (null? supers)) (list default))
                      ((not (list? supers)) (error "INITIALIZE-INSTANCE bad superclasses " supers))
                      (else (let ((c (find-if
                                      (lambda (c)
                                        (not (and (class? c) (subclass? c default))))
                                      supers)))
                              (if c
                                  (error "INITIALIZE-INSTANCE:  cannot inherit from a ~a, ~e"
                                         (if (class? c) "non-object class" "non-class") c)
                                  supers))))))
                  (%set-class-direct-slots!
                   class
                   (let ((autoinitargs (getarg initargs :autoinitargs #f)))
                     (map (lambda (s)
                            (if (pair? s)
                                (if (or (not autoinitargs)
                                        (getarg (cdr s) :initarg #f)
                                        (not (symbol? (car s))))
                                    s
                                    (list* (car s) :initarg (string->symbol
                                                             (string-append ":"
                                                                            (symbol->string (car s))))
                                           (cdr s)))
                                (list s)))
                          (getarg initargs :direct-slots '()))))
                  (%set-class-cpl!   class (compute-cpl   class))
                  (%set-class-slots! class (compute-slots class))
                  (%set-class-default-initargs! class (compute-default-initargs class))
                  (%set-class-name!  class (getarg initargs :name '*-anonymous-*))
                  (let* ((nfields (%instance-overhead))
                         (field-initializers '())
                         ;; allocator: give me an initializer function, get a slot number
                         (allocator (lambda (init)
                                      (let ((f nfields))
                                        (set! nfields (+ nfields 1))
                                        (set! field-initializers
                                              (cons init field-initializers))
                                        f)))
                         (getters-n-setters (map (lambda (slot)
                                                   (cons (car slot)
                                                         (compute-getter-and-setter
                                                          class slot allocator)))
                                                 (%class-slots class))))
                    (%set-class-nfields! class (- nfields (%instance-overhead)))
                    (%set-class-field-initializers! class (reverse! field-initializers))
                    (%set-class-getters-n-setters! class getters-n-setters))
                  (%set-class-initializers!
                   class (reverse
                          (append-map
                           (lambda (c)
                             (if (class? c) (%class-initializers c) '()))
                           (cdr (%class-cpl class)))))
                  (%set-class-direct-additional-initargs!
                   class (getarg initargs :direct-additional-initargs '()))
                  (%set-class-effective-valid-initargs! ; for sanity checks
                   class (append
                          (append-map %class-direct-additional-initargs (%class-cpl class))
                          (append-map
                           (lambda (slot) (getargs (cdr slot) :initarg))
                           (%class-slots class))))

                  ;; Install the reader and writer methods.
                  (initialize-generic-accessors class))
                method:initialize-instance)))

(extend-generic initialize-instance
  :specializers (list <generic>)
  :procedure ((lambda ()
                (define (method:initialize-instance call-next-method generic initargs)
                  (call-next-method)
                  (%set-generic-methods!     generic '())
                  ;; Should these be necessary?!
                  (let ((arity (getarg initargs :arity #f)))
                    (if arity
                        (%set-generic-arity!       generic arity)
                        (error "Required initarg :arity omitted when constructing a generic function.")))
                  (%set-generic-name!        generic (getarg initargs
                                                             :name '*-anonymous-generic-*))
                  (%set-generic-combination! generic (getarg initargs :combination #f))
                  (%set-instance/procedure!  generic
                                             (lambda (generic args)
                                               (error "APPLY:  generic function has no methods "
                                                      (%generic-name generic) generic args)))
                  ;; Add user-supplied initial method set if present.
                  (for-each (lambda (method)
                              (add-method generic method))
                            (getargs initargs :method)))
                method:initialize-instance)))

(extend-generic initialize-instance
  :specializers (list <method>)
  :procedure ((lambda ()
                (define (method:initialize-instance call-next-method method initargs)
                  (call-next-method)
                  (%set-method-specializers! method (trim-method-specializers (%method-specializers method)))
                  (%set-instance/procedure!  method (compute-apply-method method)))
                method:initialize-instance)))

(extend-generic allocate-instance
  :specializers (list <class>)
  :procedure ((lambda ()
                (define (method:allocate-instance call-next-method class initargs)
                  (%make-instance class (allocate-instance-state-vector
                                         (length (%class-field-initializers class))
                                         *unbound-slot-value*)))
                method:allocate-instance)))

(extend-generic allocate-instance
  :specializers (list <entity-class>)
  :procedure ((lambda ()
                (define (method:allocate-instance call-next-method class initargs)
                  (%make-entity class
                                uninitialized-entity-procedure
                                (allocate-instance-state-vector (length (%class-field-initializers class))
                                                                *unbound-slot-value*)))
                method:allocate-instance)))

(extend-generic compute-cpl
  :specializers (list <class>)
  :procedure ((lambda ()
                (define (method:compute-cpl call-next-method class)
                  (compute-class-linearization class))
                method:compute-cpl)))

(extend-generic compute-slots
  :specializers (list <class>)
  :procedure ((lambda ()

                (define (method:compute-slots call-next-method class)
                  (let ((all-slots   (map %class-direct-slots (%class-cpl class))))

                    (let collect1 ((to-process (apply append all-slots))
                                   (final-slots '()))
                      (cond ((pair? to-process)
                             (let* ((name   (caar to-process))
                                    (others '())
                                    (remaining-to-process
                                     (filter (lambda (o)
                                               (if (eq? (car o) name)
                                                   (begin (set! others (cons (cdr o) others)) #f)
                                                   #t))
                                             to-process)))
                               (collect1 remaining-to-process
                                         (cons (cons name (apply append (reverse! others)))
                                               final-slots))))
                            ((null? to-process)

                             ;; Sort the slots by order of appearance in cpl, makes them stay in the
                             ;; same index, allowing optimizations for single-inheritance
                             (let collect2 ((to-process (apply append (reverse! all-slots)))
                                            (result '()))
                               (cond ((pair? to-process) (collect2 (cdr to-process)
                                                                   (if (assq (caar to-process) result)
                                                                       result
                                                                       (cons (assq (caar to-process) final-slots)
                                                                             result))))
                                     ((null? to-process) (reverse! result))
                                     (else (error "COMPUTE-SLOTS:  bad list")))))

                            (else (error "COMPUTE-SLOTS:  bad list"))))))

                method:compute-slots)))

(extend-generic compute-default-initargs
  :specializers (list <class>)
  :procedure ((lambda ()
                (define (method:compute-default-initargs call-next-method class)
                  (reverse!
                   ;; Remove the duplicates from the less specific classes
                   (foldl
                    (lambda (initarg initlist)
                      (if (memp (lambda (already-seen)
                                  (eq? (car initarg) (car already-seen)))
                                initlist)
                          initlist
                          (cons initarg initlist)))
                    '()
                    ;; Collect them into a list (if they aren't #F)
                    (foldr (lambda (initargs all-initargs)
                             (if initargs
                                 (append initargs all-initargs)
                                 all-initargs))
                           '()
                           ;; Get all the initargs
                           (map %class-direct-default-initargs (%class-cpl class))))))
                method:compute-default-initargs)))

(extend-generic compute-getter-and-setter
  :specializers (list <class>)
  :procedure ((lambda ()
                (define (method:compute-getter-and-setter call-next-method class slot allocator)
                  (let ((initargs    (getargs (cdr slot) :initarg))
                        (initializer (getarg (cdr slot) :initializer #f))
                        (initvalue   (getarg (cdr slot) :initvalue *unbound-slot-value*))
                        (type        (getarg (cdr slot) :type #f))
                        (allocation  (getarg (cdr slot) :allocation :instance))
                        (lock        (getarg (cdr slot) :lock #f))
                        (nothing     (cons #f #f)))

                    (cond ((and type
                                (not (specializer? type)))
                           (error "MAKE:  bad type specifier " (car slot) type))

                          ((eq? allocation :instance)
                           (let* ((type-predicate (class-predicate (or type <top>)))

                                  (f (allocator
                                      (lambda args
                                        (let* ((result (getarg* args initargs nothing))
                                               (result1 (if (eq? result nothing)
                                                            (if (not initializer)
                                                                initvalue
                                                                (apply initializer args))
                                                            result)))
                                          (if (and (not (eq? result1 *unbound-slot-value*))
                                                   (not (type-predicate result1)))
                                              (error "INITIALIZE-INSTANCE:  bad initial value " (car slot) class result type)
                                              result1)))))

                                  ;; NOTE:
                                  ;;  These internal procedures are the `real' getter and setter
                                  ;;  functions of slots in an object.
                                  (g-s (list (lambda (o) (%instance/ref o f))
                                             (if (and type (not (eq? type <top>)))
                                                 (lambda (o n)
                                                   (if (type-predicate n)
                                                       (%instance/set! o f n)
                                                       (error "SLOT-SET!:  wrong type "
                                                              (%class-name class)
                                                              " "
                                                              (car slot)
                                                              " expected "
                                                              type
                                                              " got "
                                                              n)))
                                                 (lambda (o n) (%instance/set! o f n)))
                                             (if (and type (not (eq? type <top>)))
                                                 (lambda (o p)
                                                   (%instance/update! o f
                                                                      (lambda (old-value)
                                                                        (let ((new-value (p old-value)))
                                                                          (if (type-predicate new-value)
                                                                              new-value
                                                                              (error "SLOT-UPDATE!:  wrong type " (car slot) (%class-name class)))))))
                                                 (lambda (o p) (%instance/update! o f p))))))
                             (if lock
                                 (make-setter-locked! g-s lock
                                                      (lambda ()
                                                        (error "SLOT-SET!:  locked slot "
                                                               (car slot) (%class-name class)))))
                             g-s))

                          ((eq? allocation :class)
                           (if (not (null? initargs))
                               (let ((setter #f))
                                 (%update-class-initializers!
                                  class
                                  (lambda (existing)
                                    (cons (lambda args
                                            (let ((result (getarg* args initargs nothing)))
                                              ;; cache the setter
                                              (if (not setter)
                                                  (set! setter
                                                        (caddr (assq (car slot)
                                                                     (%class-getters-n-setters
                                                                      class)))))
                                              (if (not (eq? result nothing))
                                                  (setter #f result))))
                                          existing)))))

                           (if (and (assq (car slot) (%class-direct-slots class))
                                    (getarg (cdr (assq (car slot)
                                                       (%class-direct-slots class)))
                                            :allocation #f))
                               ;; the slot was declared as 'class here
                               (let* ((type-predicate (class-predicate (or type <top>)))
                                      (cell (if (not initializer)
                                                initvalue
                                                (initializer))) ; default value - no arguments
                                      (g+s (list (lambda (o) cell)
                                                 (lambda (o n)
                                                   (if (and type (not (type-predicate n)))
                                                       (error "SLOT-SET!:  wrong type for shared slot ")
                                                       (begin (set! cell n) n)))
                                                 (lambda (o p)
                                                   (let ((n (p cell)))
                                                     (if (and type (not (type-predicate n)))
                                                         (error "SLOT-UPDATE!:  wrong type for shared slot ")
                                                         (begin (set! cell n) n)))))))
                                 (if lock
                                     (make-setter-locked! (car slot) g+s lock
                                                          (lambda ()
                                                            (error "SLOT-SET!:  locked shared slot "
                                                                   (car slot) (%class-name class) (car slot)))))
                                 g+s)
                               ;; the slot was inherited as 'class - fetch its getters/setters
                               (let loop ((cpl (cdr (%class-cpl class))))
                                 (let ((probe (assq (car slot) (%class-getters-n-setters (car cpl)))))
                                   (if probe
                                       (cdr probe)
                                       (loop (cdr cpl)))))))

                          (else (error "MAKE:  allocation must be 'class or 'instance " (car slot) allocation)))))

                method:compute-getter-and-setter)))

;;; Use the previous function when populating this generic.
(extend-generic compute-apply-method
  :specializers (list <method>)
  :procedure method:compute-apply-method)

;;; BOOTSTRAP STEP  fixup the initalizers for <method> so subclassing methods works
(let* ((class <method>)
       (nfields (%instance-overhead))
       (field-initializers '())
       ;; allocator: give me an initializer function, get a slot number
       (allocator (lambda (init)
                    (let ((f nfields))
                      (set! nfields (+ nfields 1))
                      (set! field-initializers
                            (cons init field-initializers))
                      f)))
       (getters-n-setters (map (lambda (slot)
                                 (cons (car slot)
                                       (compute-getter-and-setter
                                        class slot allocator)))
                               (%class-slots class))))
  (%set-class-field-initializers! class (reverse! field-initializers))
  (%set-class-getters-n-setters! class getters-n-setters))

(extend-generic no-next-method
  :specializers (list <generic> <method>)
  :procedure (lambda (call-next-method generic method . args)
               (error "APPLY:  no applicable next method to call " (%method-qualifier method)
                      (%generic-name generic) generic)))

(extend-generic no-next-method
  :specializers (list (singleton #f) <method>)
  :procedure (lambda (call-next-method generic method . args)
               (error "APPLY:  no applicable next method when calling a method directly "
                      (%method-name method) method)))

(extend-generic no-applicable-method
  :specializers (list <generic>)
  :procedure (lambda (call-next-method generic . args)
               (error "APPLY:  no applicable primary methods for argument types ~e "
                      (%generic-name generic) (map class-of args) generic)))

(define (extend-initargs given-initargs class-initargs)
  (let ((extended
         (foldl (lambda (initarg initlist)
                  (let ((key (car initarg)))
                    (if (getarg given-initargs key #f)
                        initlist
                        (cons key (cons ((caddr initarg)) initlist)))))
                '() class-initargs)))
    (if (null? extended)
        given-initargs
        (append given-initargs extended))))

;;; BOOTSTRAP STEP
;;; Turn MAKE into a generic function.

(let ((g (make-generic 'make '(class . initargs))))
  (extend-generic g
    :specializers (list <class>)
    :procedure ((lambda ()
                  (define (method:make call-next-method class . given-initargs)
                    (let* ((initargs (extend-initargs given-initargs (class-default-initargs class)))
                           (instance (allocate-instance class initargs)))
                      (if (*make-safely*) (check-initargs class initargs))
                      (initialize-instance instance initargs)
                      instance))
                  method:make)))
  (set! make g))

;; The clean concept behind this is due to Joe Marshall.

;;>> (rec-make (name class arg ...) ...)
;;>   This is similar to:
;;>
;;>     (letrec ((name (make class arg ...)) ...)
;;>       (values name ...))
;;>
;;>   except that the names are first bound to allocated instances with no
;;>   initargs, and then they are initialized with all these bindings.  This
;;>   is useful for situations where creating some instances needs other
;;>   instances as values.  One sample usage is the way `defclass' makes the
;;>   class binding available for slot specifications like `'type'.  Note
;;>   that this is a special form, which invokes `allocate-instance' and
;;>   `initialize-instance' directly, so specializing `make' on some input will not
;;>   change the way `rec-make' works.

(define (rec-allocate-instance class given-initargs)
  (allocate-instance class (extend-initargs given-initargs (class-default-initargs class))))

(define (rec-initialize instance given-initargs)
  (initialize-instance instance (extend-initargs given-initargs (class-default-initargs (class-of instance)))))

;;; ---------------------------------------------------------------------------
;;; BOOTSTRAP STEP
;;; Turn `add-method' into a generic function

(let ((old-add-method add-method))
  (set! add-method (make-generic 'add-method '(generic method)))
  (old-add-method
   add-method
   (make <method>
     :arity 2
     :specializers (list <generic> <method>)
     :procedure
     ((lambda ()

        (define (compute-method-name specs generic-name)
          (define (spec-string spec)
            (cond ((%singleton? spec) (let ((string-output-port (string-io/open-output-string)))
                                        (write (singleton-value spec) string-output-port)
                                        (string-io/get-output-string string-output-port)))
                  ((%nullable? spec) (let ((string-output-port (string-io/open-output-string)))
                                        (write (nullable-value spec) string-output-port)
                                        (string-io/get-output-string string-output-port)))
                  ((class? spec)     (symbol->string
                                       (%class-name (%struct->class spec))))
                  (else               "???")))

          (string->symbol
           (apply string-append
                  (symbol->string generic-name) ":"
                  (if (null? specs)
                      '("()")
                      (cons (spec-string (car specs))
                            (map (lambda (c) (string-append "," (spec-string c)))
                                 (cdr specs)))))))

        (define (method:add-method call-next-method generic method)
          ;; Ensure that the arity is compatible.
          (let ((method-arity  (%method-arity method))
                (generic-arity (%generic-arity generic)))
            ;; If the method arity was not specified, set it to the generic arity.
            (if (eq? method-arity *unbound-slot-value*)
                (%set-method-arity! method generic-arity))
            (cond
                  ;; note: equal? works on arity-at-least structs
                  ((or (eq? method-arity *unbound-slot-value*)
                       (equal? generic-arity method-arity)) #t)
                  ;; Ok if generic guarantees at least as much as method wants.
                  ((and (arity-at-least? method-arity)
                        (>= (if (arity-at-least? generic-arity)
                                (arity-at-least-value generic-arity)
                                generic-arity)
                            (arity-at-least-value method-arity))) #t)
                  (else
                   (error "ADD-METHOD: wrong arity for `~e', expects ~a; given a method with ~a "
                          (%generic-name generic)
                          (if (and (integer? generic-arity) (exact? generic-arity))
                              generic-arity
                              (format "at-least-~a"
                                      (arity-at-least-value generic-arity)))
                          (if (and (integer? method-arity) (exact? method-arity))
                              method-arity
                              (format "at-least-~a"
                                      (arity-at-least-value method-arity)))))))

          ;; set a name for the method if none (when attached to a generic)
          (let ((n (%method-name method)))
            (if (not (and n (not (eq? n '*-anonymous-method-*))))
                (%set-method-name!
                 method
                 (let* ((psym (procedure-name (%method-procedure method)))
                        (pstr (and psym (symbol->string psym))))
                   (if (or (not pstr)
                           ;; (regexp-match #rx":[0-9]*:[0-9]*$" pstr)
                           )
                       (compute-method-name (%method-specializers method)
                                            (%generic-name generic))
                       psym)))))

          ;; Add the method
          (old-add-method generic method))

        method:add-method)))))

;;; BOOTSTRAP STEP
;;; Turn slot-unbound and slot-missing into generic-functions
(set! slot-missing (make-generic 'slot-missing '(class instance slot-name operation . new-value)))
(extend-generic slot-missing
  :procedure (lambda (call-next-method class instance slot-name operation . new-value)
               (error (string-append "slot-missing: '"(symbol->string slot-name)
                                     "' is not a slot in ") class)))

(set! slot-unbound (make-generic 'slot-unbound '(class instance slot-name)))
(extend-generic slot-unbound
  :procedure (lambda (call-next-method class instance slot-name)
               (error (string-append "slot-unbound: '"(symbol->string slot-name)
                                     "' is not bound in ") instance)))

;;; BOOTSTRAP STEP
;;; Optimized frequently used accessors:
;;; This is possible because of the ordering of the slots in compute-slots,
;;; works only for single-inheritance.  Note that there is no type checking -
;;; it is unsafe (hence the percent sign), but makes things around 5-6 times faster!

;;; These are for optimizations.
(let ((%slot-getter (lambda (class slot-name) (lookup-slot-info class slot-name cadr)))
      (%slot-setter (lambda (class slot-name) (lookup-slot-info class slot-name caddr)))
      (%slot-updater (lambda (class slot-name) (lookup-slot-info class slot-name cadddr))))

  (set! %class-cpl                 (%slot-getter <class>   'cpl))
  (set! %class-default-initargs    (%slot-getter <class>   'default-initargs))
  (set! %class-direct-default-initargs (%slot-getter <class> 'direct-default-initargs))
  (set! %class-direct-slots        (%slot-getter <class>   'direct-slots))
  (set! %class-direct-supers       (%slot-getter <class>   'direct-supers))
  (set! %class-field-initializers  (%slot-getter <class>   'field-initializers))
  (set! %class-getters-n-setters   (%slot-getter <class>   'getters-n-setters))
  (set! %class-initializers        (%slot-getter <class>   'initializers))
  (set! %class-name                (%slot-getter <class>   'name))
  (set! %class-nfields             (%slot-getter <class>   'nfields))
  (set! %class-slots               (%slot-getter <class>   'slots))
  (set! %class-direct-additional-initargs    (%slot-getter <class> 'direct-additional-initargs))
  (set! %class-effective-valid-initargs      (%slot-getter <class> 'effective-valid-initargs))

  (set! %set-class-cpl!            (%slot-setter <class>   'cpl))
  (set! %set-class-default-initargs! (%slot-setter <class> 'default-initargs))
  (set! %set-class-direct-default-initargs! (%slot-setter <class> 'direct-default-initargs))
  (set! %set-class-direct-slots!   (%slot-setter <class>   'direct-slots))
  (set! %set-class-direct-supers!  (%slot-setter <class>   'direct-supers))
  (set! %set-class-field-initializers!(%slot-setter <class> 'field-initializers))
  (set! %set-class-getters-n-setters! (%slot-setter <class> 'getters-n-setters))
  (set! %set-class-initializers!   (%slot-setter <class>   'initializers))
  (set! %set-class-name!           (%slot-setter <class>   'name))
  (set! %set-class-nfields!        (%slot-setter <class>   'nfields))
  (set! %set-class-slots!          (%slot-setter <class>   'slots))
  (set! %set-class-direct-additional-initargs! (%slot-setter <class> 'direct-additional-initargs))
  (set! %set-class-effective-valid-initargs! (%slot-setter <class>   'effective-valid-initargs))

  (set! %update-class-initializers! (%slot-updater <class> 'initializers))
  (set! %update-class-effective-valid-initargs! (%slot-updater <class> 'effective-valid-initargs)))

(let ((%slot-getter (lambda (class slot-name)
                      (let ((fast (lookup-slot-info class slot-name cadr)))
                        (lambda (instance)
                          (if (eq? (%instance/class instance) class)
                              (fast instance)
                              ((lookup-slot-info (class-of instance) slot-name cadr) instance))))))

      (%slot-setter (lambda (class slot-name)
                      (let ((fast (lookup-slot-info class slot-name caddr)))
                        (lambda (instance new-value)
                          (if (eq? (%instance/class instance) class)
                              (fast instance new-value)
                              ((lookup-slot-info (class-of instance) slot-name caddr) instance new-value))))))

      (%slot-updater (lambda (class slot-name)
                       (let ((fast (lookup-slot-info class slot-name cadddr)))
                         (lambda (instance proc)
                           (if (eq? (%instance/class instance) class)
                               (fast instance proc)
                               ((lookup-slot-info (class-of instance) slot-name cadddr) instance proc)))))))

  (set! %generic-arity             (%slot-getter <generic> 'arity))
  (set! %generic-combination       (%slot-getter <generic> 'combination))
  (set! %generic-methods           (%slot-getter <generic> 'methods))
  (set! %generic-name              (%slot-getter <generic> 'name))

  (set! %method-arity              (%slot-getter <method>  'arity))
  (set! %method-name               (%slot-getter <method>  'name))
  (set! %method-procedure          (%slot-getter <method>  'procedure))
  (set! %method-qualifier          (%slot-getter <method>  'qualifier))
  (set! %method-specializers       (%slot-getter <method>  'specializers))

  (set! %set-generic-arity!        (%slot-setter <generic> 'arity))
  (set! %set-generic-combination!  (%slot-setter <generic> 'combination))
  (set! %set-generic-methods!      (%slot-setter <generic> 'methods))
  (set! %set-generic-name!         (%slot-setter <generic> 'name))

  (set! %update-generic-methods!   (%slot-updater <generic> 'methods))

  (set! %set-method-arity!         (%slot-setter <method>  'arity))
  (set! %set-method-name!          (%slot-setter <method>  'name))
  (set! %set-method-procedure!     (%slot-setter <method>  'procedure))
  (set! %set-method-qualifier!     (%slot-setter <method>  'qualifier))
  (set! %set-method-specializers!  (let ((setter (%slot-setter <method>  'specializers)))
                                     (lambda (instance new-value)
                                       (setter instance (trim-method-specializers new-value)))))

  ;; Optimize these internal ones as well.
  (set! %generic-app-cache            (%slot-getter <generic> 'app-cache))
  (set! %generic-singletons-list      (%slot-getter <generic> 'singletons-list))
  (set! %set-generic-app-cache!       (%slot-setter <generic> 'app-cache))
  (set! %set-generic-singletons-list! (%slot-setter <generic> 'singletons-list)))

;;; Create the class hierarchy for builtin objects.

;;>   These classes represent built-in objects.  See the class hierarchy
;;>   below for a complete description of the relations between these
;;>   classes.

;;>> <builtin>
;;>   The superclass of all built-in classes.
(define <builtin>
  (parameterize ((*default-object-class* #f))
    (make <primitive-class>
      :direct-supers (list <top>)
      :name          '<builtin>)))

(define builtin?  (class-predicate <builtin>))

(define-syntax defprimclass
  (syntax-rules ()
    ((defprimclass primclass) (defprimclass primclass <builtin>))
    ((defprimclass primclass supers ...)
     (define primclass
       (parameterize ((*default-object-class* #f))
         ;; Quote these keywords.
         (make <primitive-class>
           ':name          'primclass
           ':direct-supers (list supers ...)))))))

;;; Concrete base types
(defprimclass <boolean>)
(defprimclass <bytevector-like>)
(defprimclass <char>)
(defprimclass <end-of-file>)
(defprimclass <vector-like>)
(defprimclass <void>)

;;; Abstract base types
(defprimclass <number>)
(defprimclass <sequence>)
(defprimclass <unknown-primitive>)

;; Larceny has a vector-like object that claims to be a `structure'.
;; It may be untagged, so you can't get much info about it.
(defprimclass <primitive-structure> <vector-like>)

(defprimclass <namespace> <primitive-structure>)
(defprimclass <record> <primitive-structure>)

;;;>> <struct>
;;;>> <opaque-struct>
;;;>   These are also classes for built-in objects, but they are classes for
;;;>   MzScheme structs -- which can be used like Ripoff classes since they
;;;>   will get converted to appropriate Ripoff subclasses of `<struct>'.
;(define <struct>
;  (make <primitive-class>
;    ':direct-supers (list <primitive-structure>)
;    ':name '<struct>))

;;;>   `<opaque-struct>' is a class of structs that are hidden -- see the
;;;>   documentation for `struct-info' and the `skipped?' result.  Note that
;;;>   structs can be used as long as they can be inspected -- otherwise, we
;;;>   can't even know that they are structs with `struct?' (this means that
;;;>   <opaque-struct> can only appear in the cpl of a struct class that
;;;>   inherits from a struct which is not under the current inspector).
;(define <opaque-struct>
;  (make <primitive-class>
;    ':direct-supers (list <struct>)
;    ':name '<opaque-struct>))


;(defprimclass <immutable>)

;(defprimclass <box>)
;(defprimclass <weak-box> <box>)

;(defprimclass <compiled-expression>)
;(defprimclass <custodian>)
;(defprimclass <exn>)
;(defprimclass <break-exn> <exn>)
;(defprimclass <non-break-exn> <exn>)

;(defprimclass <foreign-object>)
;(defprimclass <foreign-array>   <foreign-object>)
;(defprimclass <foreign-boolean> <foreign-object>)
;(defprimclass <foreign-enum>    <foreign-object>)
;(defprimclass <foreign-int32>   <foreign-object>)
;(defprimclass <foreign-null>    <foreign-object>)
;(defprimclass <foreign-string>  <foreign-object>)

;(defprimclass <inspector>)

(defprimclass <exact> <number>)
(defprimclass <inexact> <number>)
(defprimclass <complex> <number>)
(defprimclass <real> <complex>)
(defprimclass <rational> <real>)
(defprimclass <integer> <rational>)
(defprimclass <exact-complex> <complex> <exact>)
(defprimclass <inexact-complex> <complex> <inexact>)
(defprimclass <exact-real> <real> <exact-complex>)
(defprimclass <inexact-real> <real> <inexact-complex>)
(defprimclass <exact-rational> <rational> <exact-real>)
(defprimclass <inexact-rational> <rational> <inexact-real>)
(defprimclass <exact-integer> <integer> <exact-rational>)
(defprimclass <inexact-integer> <integer> <inexact-rational>)

(defprimclass <bytevector> <bytevector-like>)

(defprimclass <bignum> <exact-integer> <bytevector-like>)
(defprimclass <fixnum> <exact-integer>)
(defprimclass <flonum> <inexact-real> <bytevector-like>)
(defprimclass <ratnum> <exact-rational> <vector-like>)
(defprimclass <rectnum> <exact-complex> <vector-like>)

;(defprimclass <parameter>)

(defprimclass <port> <vector-like>)
(defprimclass <input-port> <port>)
(defprimclass <output-port> <port>)
;(defprimclass <stream-port> <port>)
;(defprimclass <input-stream-port> <input-port> <stream-port>)
;(defprimclass <output-stream-port> <output-port> <stream-port>)

;(defprimclass <promise>)
;(defprimclass <pseudo-random-generator>)
;(defprimclass <regexp>)
;(defprimclass <security-guard>)
;(defprimclass <semaphore>)

;; It is expensive to run down a list every time you want to
;; pass one to a generic function, so we don't distinguish
;; proper from improper lists.
;(defprimclass <improper-list> <sequence>)
(defprimclass <pair> <sequence>)
;(defprimclass <immutable-pair> <pair> <immutable>)
(defprimclass <list> <sequence>)
(defprimclass <nonempty-list> <pair> <list>)
;(defprimclass <immutable-nonempty-list> <nonempty-list> <immutable>)
(defprimclass <null> <list>)

(defprimclass <string> <sequence> <bytevector-like>)
;(defprimclass <immutable-string> <string> <immutable>)
(defprimclass <vector> <sequence> <vector-like>)

(defprimclass <code-object> <vector>)
(defprimclass <assignment> <code-object>)
(defprimclass <begin> <code-object>)
(defprimclass <call> <code-object>)
(defprimclass <conditional> <code-object>)
(defprimclass <constant> <code-object>)
(defprimclass <lambda> <code-object>)
(defprimclass <variable> <code-object>)

(defprimclass <hash-table> <vector>)

(defprimclass <struct-type>)
;(defprimclass <subprocess>)
;(defprimclass <syntax>)
;(defprimclass <identifier-syntax> <syntax>)
(defprimclass <symbol> <vector-like>)
(defprimclass <interned-symbol> <symbol>)
(defprimclass <uninterned-symbol> <symbol>)
;(defprimclass <tcp-listener>)
;(defprimclass <thread>)

;(defprimclass <will-executor>)

(define <procedure>
  (parameterize ((*default-object-class* #f))
    (make <procedure-class>
      :name          '<procedure>
      :direct-supers (list <builtin> <function>))))

(define <interpreted-expression>
  (parameterize ((*default-object-class* #f))
    (make <procedure-class>
      :name          '<interpreted-expression>
      :direct-supers (list <procedure>))))

(define <interpreted-primitive>
  (parameterize ((*default-object-class* #f))
    (make <procedure-class>
      :name          '<interpreted-primitive>
      :direct-supers (list <procedure>))))

(define <interpreted-procedure>
  (parameterize ((*default-object-class* #f))
    (make <procedure-class>
      :name          '<interpreted-procedure>
      :direct-supers (list <procedure>))))

;; BOOTSTRAP STEP
;; Disable allocation of primitive classes.
(extend-generic allocate-instance
  :specializers (list <primitive-class>)
  :procedure ((lambda ()
                (define (method:allocate-instance call-next-method class initargs)
                  (error "ALLOCATE-INSTANCE: can't instantiate a primitive class ~e "
                         class))
                method:allocate-instance)))

;;; BOOTSTRAP STEP
;;; replace class-of with something more intelligent

(set! class-of
      (lambda (object)
        (cond ((procedure? object) (cond ((instance? object) (%instance/class object))
                                         ((interpreted-expression? object) <interpreted-expression>)
                                         ((interpreted-primitive? object) <interpreted-primitive>)
                                         ((interpreted-procedure? object) <interpreted-procedure>)
                                         (else <procedure>)))

              ((vector-like? object)
               (cond ((ratnum? object) <ratnum>)
                     ((rectnum? object) <rectnum>)
                     ((symbol? object) (if (uninterned-symbol? object)
                                           <uninterned-symbol>
                                           <interned-symbol>))
                     ((port? object) (cond ((input-port? object) <input-port>)
                                           ((output-port? object) <output-port>)
                                           (else <port>)))
                     ((structure? object) (cond ((environment? object) <namespace>)
                                        ;((struct? object) (struct-type->class object))
                                                ((record? object)
                                                 (record-type->class (record-type-descriptor object)))
                                                (else <primitive-structure>)))
                     ((vector? object)
                      (cond ((= (vector-length object) 0) <vector>)
                            ((hashtable? object) <hash-table>)
                            ((code-object? object)
                             (cond ((assignment? object) <assignment>)
                                   ((begin? object) <begin>)
                                   ((call? object) <call>)
                                   ((conditional? object) <conditional>)
                                   ((constant? object) <constant>)
                                   ((lambda? object) <lambda>)
                                   ((variable? object) <variable>)
                                   (else <code-object>)))
                            (else <vector>)))
                     (else <vector-like>)))

              ((bytevector-like? object)
               (cond ((bignum? object) <bignum>)
                     ((bytevector? object) <bytevector>)
                     ((flonum? object) <flonum>)
                     ((string? object) <string>)
                     (else <bytevector-like>)))

              ((boolean? object) <boolean>)
              ((char? object)   <char>)
              ((eof-object? object) <end-of-file>)
              ((fixnum? object) <fixnum>)
              ((null? object) <null>)
              ((pair? object) <nonempty-list>)
              ((eq? object (void)) <void>)
              (else <unknown-primitive>))))

;;; Miscellany

(define (make-class name . args)
  (apply make (getarg args :metaclass (*default-class-class*))
         :name name
         args))

(define (make-method . args)
  (apply make (*default-method-class*) args))

;; A handy thing to use for the :initializer of a slot.
(define (require-initarg initarg)
  (let ((message (string-append "Required initarg "
                                (symbol->string initarg)
                                " omitted. ")))
    (lambda supplied
      (error message supplied))))

;;; Print methods for objects, classes and instances.
;;; Moved to gprint.sch
