match l
      (() #f)
      ((head . tail)
       (if (memq head tail)
           head
           (find-duplicate tail)))))
  (define (slot-spec->name slot-spec)
    (match slot-spec
      (((? symbol? name) . args) name)
      ;; We can get here when redefining classes.
      ((? slot? slot) (%slot-definition-name slot))))

  (let* ((name (get-keyword #:name options *unbound*))
         (supers (if (not (or-map (lambda (class)
                                    (memq <object>
                                          (class-precedence-list class)))
                                  supers))
                     (append supers (list <object>))
                     supers))
         (metaclass (or (get-keyword #:metaclass options #f)
                        (ensure-metaclass supers))))

    ;; Verify that all direct slots are different and that we don't inherit
    ;; several time from the same class
    (let ((tmp1 (find-duplicate supers))
          (tmp2 (find-duplicate (map slot-spec->name slots))))
      (if tmp1
          (goops-error "make-class: super class ~S is duplicate in class ~S"
                       tmp1 name))
      (if tmp2
          (goops-error "make-class: slot ~S is duplicate in class ~S"
                       tmp2 name)))

    ;; Everything seems correct, build the class
    (apply make metaclass
           #:dsupers supers
           #:slots slots
           #:name name
           options)))

;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;;   OPTION ::= KEYWORD VALUE
;;;
(define-syntax class
  (lambda (x)
    (define (parse-options options)
      (syntax-case options ()
        (() #'())
        ((kw arg . options) (keyword? (syntax->datum #'kw))
         (with-syntax ((options (parse-options #'options)))
           (syntax-case #'kw ()
             (#:init-form
              #'(kw 'arg #:init-thunk (lambda () arg) . options))
             (_
              #'(kw arg . options)))))))
    (define (check-valid-kwargs args)
      (syntax-case args ()
        (() #'())
        ((kw arg . args) (keyword? (syntax->datum #'kw))
         #`(kw arg . #,(check-valid-kwargs #'args)))))
    (define (parse-slots-and-kwargs args)
      (syntax-case args ()
        (()
         #'(() ()))
        ((kw . _) (keyword? (syntax->datum #'kw))
         #`(() #,(check-valid-kwargs args)))
        (((name option ...) args ...)
         (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))
                       ((option ...) (parse-options #'(option ...))))
           #'(((list 'name option ...) . slots) kwargs)))
        ((name args ...) (symbol? (syntax->datum #'name))
         (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...))))
           #'(('(name) . slots) kwargs)))))
    (syntax-case x ()
      ((class (super ...) arg ...)
       (with-syntax ((((slot-def ...) (option ...))
                      (parse-slots-and-kwargs #'(arg ...))))
         #'(make-class (list super ...)
                       (list slot-def ...)
                       option ...))))))

(define-syntax define-class-pre-definition
  (lambda (x)
    (syntax-case x ()
      ((_ (k arg rest ...) out ...)
       (keyword? (syntax->datum #'k))
       (case (syntax->datum #'k)
         ((#:getter #:setter)
          #'(define-class-pre-definition (rest ...)
              out ...
              (when (or (not (defined? 'arg))
                        (not (is-a? arg <generic>)))
                (toplevel-define!
                 'arg
                 (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
         ((#:accessor)
          #'(define-class-pre-definition (rest ...)
              out ...
              (when (or (not (defined? 'arg))
                        (not (is-a? arg <accessor>)))
                (toplevel-define!
                 'arg
                 (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
         (else
          #'(define-class-pre-definition (rest ...) out ...))))
      ((_ () out ...)
       #'(begin out ...)))))

;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
;; which represent accessors exist before `make-class' tries to add
;; methods to them.
(define-syntax define-class-pre-definitions
  (lambda (x)
    (syntax-case x ()
      ((_ () out ...)
       #'(begin out ...))
      ((_ (slot rest ...) out ...)
       (keyword? (syntax->datum #'slot))
       #'(begin out ...))
      ((_ (slot rest ...) out ...)
       (identifier? #'slot)
       #'(define-class-pre-definitions (rest ...)
         out ...))
      ((_ ((slotname slotopt ...) rest ...) out ...)
       #'(define-class-pre-definitions (rest ...)
         out ... (define-class-pre-definition (slotopt ...)))))))

(define-syntax-rule (define-class name supers slot ...)
  (begin
    (define-class-pre-definitions (slot ...))
    (let ((cls (class supers slot ... #:name 'name)))
      (toplevel-define!
       'name
       (if (defined? 'name)
           (class-redefinition name cls)
           cls)))))

(define-syntax-rule (standard-define-class arg ...)
  (define-class arg ...))

;;;
;;; {Generic functions and accessors}
;;;

;; Apparently the desired semantics are that we extend previous
;; procedural definitions, but that if `name' was already a generic, we
;; overwrite its definition.
(define-syntax define-generic
  (lambda (x)
    (syntax-case x ()
      ((define-generic name) (symbol? (syntax->datum #'name))
       #'(define name
           (if (and (defined? 'name) (is-a? name <generic>))
               (make <generic> #:name 'name)
               (ensure-generic (if (defined? 'name) name #f) 'name)))))))

(define-syntax define-extended-generic
  (lambda (x)
    (syntax-case x ()
      ((define-extended-generic name val) (symbol? (syntax->datum #'name))
       #'(define name (make-extended-generic val 'name))))))

(define-syntax define-extended-generics
  (lambda (x)
    (define (id-append ctx a b)
      (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
    (syntax-case x ()
      ((define-extended-generic (name ...) #:prefix (prefix ...))
       (and (and-map symbol? (syntax->datum #'(name ...)))
            (and-map symbol? (syntax->datum #'(prefix ...))))
       (with-syntax ((((val ...)) (map (lambda (name)
                                         (map (lambda (prefix)
                                                (id-append name prefix name))
                                              #'(prefix ...)))
                                       #'(name ...))))
         #'(begin
             (define-extended-generic name (list val ...))
             ...))))))

(define* (make-generic #:optional name)
  (make <generic> #:name name))

(define* (make-extended-generic gfs #:optional name)
  (let* ((gfs (if (list? gfs) gfs (list gfs)))
         (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
    (let ((ans (if gws?
                   (let* ((sname (and name (make-setter-name name)))
                          (setters
                           (append-map (lambda (gf)
                                         (if (is-a? gf <generic-with-setter>)
                                             (list (ensure-generic (setter gf)
                                                                   sname))
                                             '()))
                                       gfs))
                          (es (make <extended-generic-with-setter>
                                #:name name
                                #:extends gfs
                                #:setter (make <extended-generic>
                                           #:name sname
                                           #:extends setters))))
                     (extended-by! setters (setter es))
                     es)
                   (make <extended-generic>
                     #:name name
                     #:extends gfs))))
      (extended-by! gfs ans)
      ans)))

(define (extended-by! gfs eg)
  (for-each (lambda (gf)
              (slot-set! gf 'extended-by
                         (cons eg (slot-ref gf 'extended-by))))
            gfs)
  (invalidate-method-cache! eg))

(define (not-extended-by! gfs eg)
  (for-each (lambda (gf)
              (slot-set! gf 'extended-by
                         (delq! eg (slot-ref gf 'extended-by))))
            gfs)
  (invalidate-method-cache! eg))

(define* (ensure-generic old-definition #:optional name)
  (cond ((is-a? old-definition <generic>) old-definition)
        ((procedure-with-setter? old-definition)
         (make <generic-with-setter>
           #:name name
           #:default (procedure old-definition)
           #:setter (setter old-definition)))
        ((procedure? old-definition)
         (if (generic-capability? old-definition) old-definition
             (make <generic> #:name name #:default old-definition)))
        (else (make <generic> #:name name))))

;; same semantics as <generic>
(define-syntax-rule (define-accessor name)
  (define name
    (cond ((not (defined? 'name))  (ensure-accessor #f 'name))
          ((is-a? name <accessor>) (make <accessor> #:name 'name))
          (else                    (ensure-accessor name 'name)))))

(define (make-setter-name name)
  (string->symbol (string-append "setter:" (symbol->string name))))

(define* (make-accessor #:optional name)
  (make <accessor>
    #:name name
    #:setter (make <generic>
               #:name (and name (make-setter-name name)))))

(define* (ensure-accessor proc #:optional name)
  (cond ((and (is-a? proc <accessor>)
              (is-a? (setter proc) <generic>))
         proc)
        ((is-a? proc <generic-with-setter>)
         (upgrade-accessor proc (setter proc)))
        ((is-a? proc <generic>)
         (upgrade-accessor proc (make-generic name)))
        ((procedure-with-setter? proc)
         (make <accessor>
           #:name name
           #:default (procedure proc)
           #:setter (ensure-generic (setter proc) name)))
        ((procedure? proc)
         (ensure-accessor (if (generic-capability? proc)
                              (make <generic> #:name name #:default proc)
                              (ensure-generic proc name))
                          name))
        (else
         (make-accessor name))))

(define (upgrade-accessor generic setter)
  (let ((methods (slot-ref generic 'methods))
        (gws (make (if (is-a? generic <extended-generic>)
                       <extended-generic-with-setter>
                       <accessor>)
                   #:name (generic-function-name generic)
                   #:extended-by (slot-ref generic 'extended-by)
                   #:setter setter)))
    (when (is-a? generic <extended-generic>)
      (let ((gfs (slot-ref generic 'extends)))
        (not-extended-by! gfs generic)
        (slot-set! gws 'extends gfs)
        (extended-by! gfs gws)))
    ;; Steal old methods
    (for-each (lambda (method)
                (slot-set! method 'generic-function gws))
              methods)
    (slot-set! gws 'methods methods)
    (invalidate-method-cache! gws)
    gws))

;;;
;;; {Methods}
;;;

;; Note: `a' and `b' can have unequal lengths (i.e. one can be one
;; element longer than the other when we have a dotted parameter
;; list). For instance, with the call
;;
;;   (M 1)
;;
;; with
;;
;;   (define-method M (a . l) ....)
;;   (define-method M (a) ....)
;;
;; we consider that the second method is more specific.
;;
;; Precondition: `a' and `b' are methods and are applicable to `types'.
(define (%method-more-specific? a b types)
  (let lp ((a-specializers (method-specializers a))
           (b-specializers (method-specializers b))
           (types types))
    (cond
     ;; (a) less specific than (a b ...) or (a . b)
     ((null? a-specializers) #t)
     ;; (a b ...) or (a . b) less specific than (a)
     ((null? b-specializers) #f)
     ;; (a . b) less specific than (a b ...)
     ((not (pair? a-specializers)) #f)
     ;; (a b ...) more specific than (a . b)
     ((not (pair? b-specializers)) #t)
     (else
      (let ((a-specializer (car a-specializers))
            (b-specializer (car b-specializers))
            (a-specializers (cdr a-specializers))
            (b-specializers (cdr b-specializers))
            (type (car types))
            (types (cdr types)))
        (if (eq? a-specializer b-specializer)
            (lp a-specializers b-specializers types)
            (let lp ((cpl (class-precedence-list type)))
              (let ((elt (car cpl)))
                (cond
                 ((eq? a-specializer elt) #t)
                 ((eq? b-specializer elt) #f)
                 (else (lp (cdr cpl))))))))))))

(define (%sort-applicable-methods methods types)
  (sort methods (lambda (a b) (%method-more-specific? a b types))))

(define (generic-function-methods obj)
  "Return the methods of the generic function @var{obj}."
  (define (fold-upward method-lists gf)
    (cond
     ((is-a? gf <extended-generic>)
      (let lp ((method-lists method-lists) (gfs (slot-ref gf 'extends)))
        (match gfs
          (() method-lists)
          ((gf . gfs)
           (lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf)
               gfs)))))
     (else method-lists)))
  (define (fold-downward method-lists gf)
    (let lp ((method-lists (cons (slot-ref gf 'methods) method-lists))
             (gfs (slot-ref gf 'extended-by)))
      (match gfs
        (() method-lists)
        ((gf . gfs)
         (lp (fold-downward method-lists gf) gfs)))))
  (unless (is-a? obj <generic>)
    (scm-error 'wrong-type-arg #f "Not a generic: ~S"
               (list obj) #f))
  (concatenate (fold-downward (fold-upward '() obj) obj)))

(define (%compute-applicable-methods gf args)
  (define (method-applicable? m types)
    (let ((specs (method-specializers m)))
      (cond
       ((and (is-a? m <accessor-method>)
             (or (null? specs) (null? types)
                 (not (eq? (car specs) (car types)))))
        ;; Slot accessor methods are added to each subclass with the
        ;; slot.  They only apply to that specific concrete class, which
        ;; appears as the first argument.
        #f)
       (else
        (let lp ((specs specs) (types types))
          (cond
           ((null? specs) (null? types))
           ((not (pair? specs)) #t)
           ((null? types) #f)
           (else
            (and (memq (car specs) (class-precedence-list (car types)))
                 (lp (cdr specs) (cdr types))))))))))
  (let ((n (length args))
        (types (map class-of args)))
    (let lp ((methods (generic-function-methods gf))
             (applicable '()))
      (if (null? methods)
          (and (not (null? applicable))
               (%sort-applicable-methods applicable types))
          (let ((m (car methods)))
            (lp (cdr methods)
                (if (method-applicable? m types)
                    (cons m applicable)
                    applicable)))))))

(define compute-applicable-methods %compute-applicable-methods)

(define (toplevel-define! name val)
  (module-define! (current-module) name val))

(define-syntax define-method
  (syntax-rules (setter)
    ((_ ((setter name) . args) body ...)
     (begin
       (when (or (not (defined? 'name))
                 (not (is-a? name <accessor>)))
         (toplevel-define! 'name
                           (ensure-accessor
                            (if (defined? 'name) name #f) 'name)))
       (add-method! (setter name) (method args body ...))))
    ((_ (name . args) body ...)
     (begin
       ;; FIXME: this code is how it always was, but it's quite cracky:
       ;; it will only define the generic function if it was undefined
       ;; before (ok), or *was defined to #f*. The latter is crack. But
       ;; there are bootstrap issues about fixing this -- change it to
       ;; (is-a? name <generic>) and see.
       (when (or (not (defined? 'name))
                 (not name))
         (toplevel-define! 'name (make <generic> #:name 'name)))
       (add-method! name (method args body ...))))))

(define-syntax method
  (lambda (x)
    (define (parse-args args)
      (let lp ((ls args) (formals '()) (specializers '()))
        (syntax-case ls ()
          (((f s) . rest)
           (and (identifier? #'f) (identifier? #'s))
           (lp #'rest
               (cons #'f formals)
               (cons #'s specializers)))
          ((f . rest)
           (identifier? #'f)
           (lp #'rest
               (cons #'f formals)
               (cons #'<top> specializers)))
          (()
           (list (reverse formals)
                 (reverse (cons #''() specializers))))
          (tail
           (identifier? #'tail)
           (list (append (reverse formals) #'tail)
                 (reverse (cons #'<top> specializers)))))))

    (define (find-free-id exp referent)
      (syntax-case exp ()
        ((x . y)
         (or (find-free-id #'x referent)
             (find-free-id #'y referent)))
        (x
         (identifier? #'x)
         (let ((id (datum->syntax #'x referent)))
           (and (free-identifier=? #'x id) id)))
        (_ #f)))

    (define (compute-procedure formals body)
      (syntax-case body ()
        ((body0 ...)
         (with-syntax ((formals formals))
           #'(lambda formals body0 ...)))))

    (define (->proper args)
      (let lp ((ls args) (out '()))
        (syntax-case ls ()
          ((x . xs)        (lp #'xs (cons #'x out)))
          (()              (reverse out))
          (tail            (reverse (cons #'tail out))))))

    (define (compute-make-procedure formals body next-method)
      (syntax-case body ()
        ((body ...)
         (with-syntax ((next-method next-method))
           (syntax-case formals ()
             ((formal ...)
              #'(lambda (real-next-method)
                  (lambda (formal ...)
                    (let ((next-method (lambda args
                                         (if (null? args)
                                             (real-next-method formal ...)
                                             (apply real-next-method args)))))
                      body ...))))
             (formals
              (with-syntax (((formal ...) (->proper #'formals)))
                #'(lambda (real-next-method)
                    (lambda formals
                      (let ((next-method (lambda args
                                           (if (null? args)
                                               (apply real-next-method formal ...)
                                               (apply real-next-method args)))))
                        body ...))))))))))

    (define (compute-procedures formals body)
      ;; So, our use of this is broken, because it operates on the
      ;; pre-expansion source code. It's equivalent to just searching
      ;; for referent in the datums. Ah well.
      (let ((id (find-free-id body 'next-method)))
        (if id
            ;; return a make-procedure
            (values #'#f
                    (compute-make-procedure formals body id))
            (values (compute-procedure formals body)
                    #'#f))))

    (syntax-case x ()
      ((_ args) #'(method args (if #f #f)))
      ((_ args body0 body1 ...)
       (with-syntax (((formals (specializer ...)) (parse-args #'args)))
         (call-with-values
             (lambda ()
               (compute-procedures #'formals #'(body0 body1 ...)))
           (lambda (procedure make-procedure)
             (with-syntax ((procedure procedure)
                           (make-procedure make-procedure))
               #'(make <method>
                   #:specializers (cons* specializer ...)
                   #:formals 'formals
                   #:body '(body0 body1 ...)
                   #:make-procedure make-procedure
                   #:procedure procedure)))))))))

;;;
;;; {Utilities}
;;;
;;; These are useful when dealing with method specializers, which might
;;; have a rest argument.
;;;

(define (map* fn . l) 		; A map which accepts dotted lists (arg lists
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (cons (apply fn      (map car l))
			  (apply map* fn (map cdr l))))
   (else            (apply fn l))))

(define (for-each* fn . l) 	; A for-each which accepts dotted lists (arg lists
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
   (else            (apply fn l))))

(define (length* ls)
  (do ((n 0 (+ 1 n))
       (ls ls (cdr ls)))
      ((not (pair? ls)) n)))

;;;
;;; {add-method!}
;;;

(define (add-method-in-classes! m)
  ;; Add method in all the classes which appears in its specializers list
  (for-each* (lambda (x)
               (let ((dm (class-direct-methods x)))
                 (unless (memq m dm)
                   (struct-set! x class-index-direct-methods (cons m dm)))))
             (method-specializers m)))

(define (remove-method-in-classes! m)
  ;; Remove method in all the classes which appears in its specializers list
  (for-each* (lambda (x)
               (struct-set! x
                            class-index-direct-methods
                            (delv! m (class-direct-methods x))))
             (method-specializers m)))

(define (compute-new-list-of-methods gf new)
  (let ((new-spec (method-specializers new))
        (methods  (slot-ref gf 'methods)))
    (let loop ((l methods))
      (if (null? l)
          (cons new methods)
          (if (equal? (method-specializers (car l)) new-spec)
              (begin
                ;; This spec. list already exists. Remove old method from dependents
                (remove-method-in-classes! (car l))
                (set-car! l new)
                methods)
              (loop (cdr l)))))))

(define (method-n-specializers m)
  (length* (slot-ref m 'specializers)))

(define (calculate-n-specialized gf)
  (fold (lambda (m n) (max n (method-n-specializers m)))
        0
        (generic-function-methods gf)))

(define (invalidate-method-cache! gf)
  (slot-set! gf 'n-specialized (calculate-n-specialized gf))
  (%invalidate-method-cache! gf)
  (for-each (lambda (gf) (invalidate-method-cache! gf))
            (slot-ref gf 'extended-by)))

(define internal-add-method!
  (method ((gf <generic>) (m <method>))
    (slot-set! m  'generic-function gf)
    (slot-set! gf 'methods (compute-new-list-of-methods gf m))
    (invalidate-method-cache! gf)
    (add-method-in-classes! m)
    *unspecified*))

(define-generic add-method!)

((method-procedure internal-add-method!) add-method! internal-add-method!)

(define-method (add-method! (proc <procedure>) (m <method>))
  (if (generic-capability? proc)
      (begin
        (enable-primitive-generic! proc)
        (add-method! proc m))
      (next-method)))

(define-method (add-method! (pg <primitive-generic>) (m <method>))
  (add-method! (primitive-generic-generic pg) m))

(define-method (add-method! obj (m <method>))
  (goops-error "~S is not a valid generic function" obj))

;;;
;;; {Access to meta objects}
;;;

;;;
;;; Methods
;;;
(define-method (method-source (m <method>))
  (let* ((spec (map* class-name (slot-ref m 'specializers)))
         (src (procedure-source (slot-ref m 'procedure))))
    (and src
         (let ((args (cadr src))
               (body (cddr src)))
           (cons 'method
                 (cons (map* list args spec)
                       body))))))

(define-method (method-formals (m <method>))
  (slot-ref m 'formals))

;;;
;;; Slots
;;;
(define (slot-init-function class slot-name)
  (%slot-definition-init-thunk (or (class-slot-definition class slot-name)
                                   (error "slot not found" slot-name))))

(define (accessor-method-slot-definition obj)
  "Return the slot definition of the accessor @var{obj}."
  (slot-ref obj 'slot-definition))


;;;
;;; {Standard methods used by the C runtime}
;;;

;;; Methods to compare objects
;;;

;; Have to do this in a strange order because equal? is used in the
;; add-method! implementation; we need to make sure that when the
;; primitive is extended, that the generic has a method. =
(define g-equal? (make-generic 'equal?))
;; When this generic gets called, we will have already checked eq? and
;; eqv? -- the purpose of this generic is to extend equality. So by
;; default, there is no extension, thus the #f return.
(add-method! g-equal? (method (x y) #f))
(set-primitive-generic! equal? g-equal?)

;;;
;;; methods to display/write an object
;;;

;     Code for writing objects must test that the slots they use are
;     bound. Otherwise a slot-unbound method will be called and will
;     conduct to an infinite loop.

;; Write
(define (display-address o file)
  (display (number->string (object-address o) 16) file))

(define-method (write o file)
  (display "#<instance " file)
  (display-address o file)
  (display #\> file))

(define write-object (primitive-generic-generic write))

(define-method (write (o <object>) file)
  (let ((class (class-of o)))
    (if (slot-bound? class 'name)
        (begin
          (display "#<" file)
          (display (class-name class) file)
          (display #\space file)
          (display-address o file)
          (display #\> file))
        (next-method))))

(define-method (write (slot <slot>) file)
  (let ((class (class-of slot)))
    (if (and (slot-bound? class 'name)
             (slot-bound? slot 'name))
        (begin
          (display "#<" file)
          (display (class-name class) file)
          (display #\space file)
          (display (%slot-definition-name slot) file)
          (display #\space file)
          (display-address slot file)
          (display #\> file))
        (next-method))))

(define-method (write (class <class>) file)
  (let ((meta (class-of class)))
    (if (and (slot-bound? class 'name)
             (slot-bound? meta 'name))
        (begin
          (display "#<" file)
          (display (class-name meta) file)
          (display #\space file)
          (display (class-name class) file)
          (display #\space file)
          (display-address class file)
          (display #\> file))
        (next-method))))

(define-method (write (gf <generic>) file)
  (let ((meta (class-of gf)))
    (if (and (slot-bound? meta 'name)
             (slot-bound? gf 'methods))
        (begin
          (display "#<" file)
          (display (class-name meta) file)
          (let ((name (generic-function-name gf)))
            (if name
                (begin
                  (display #\space file)
                  (display name file))))
          (display " (" file)
          (display (length (generic-function-methods gf)) file)
          (display ")>" file))
        (next-method))))

(define-method (write (o <method>) file)
  (let ((meta (class-of o)))
    (if (and (slot-bound? meta 'name)
             (slot-bound? o 'specializers))
        (begin
          (display "#<" file)
          (display (class-name meta) file)
          (display #\space file)
          (display (map* (lambda (spec)
                           (if (slot-bound? spec 'name)
                               (slot-ref spec 'name)
                               spec))
                         (method-specializers o))
                   file)
          (display #\space file)
          (display-address o file)
          (display #\> file))
        (next-method))))

;; Display (do the same thing as write by default)
(define-method (display o file)
  (write-object o file))

;;;
;;; Handling of duplicate bindings in the module system
;;;

(define (find-subclass super name)
  (let lp ((classes (class-direct-subclasses super)))
    (cond
     ((null? classes)
      (error "class not found" name))
     ((and (slot-bound? (car classes) 'name)
           (eq? (class-name (car classes)) name))
      (car classes))
     (else
      (lp (cdr classes))))))

;; A record type.
(define <module> (find-subclass <top> '<module>))

(define-method (merge-generics (module <module>)
                               (name <symbol>)
                               (int1 <module>)
                               (val1 <top>)
                               (int2 <module>)
                               (val2 <top>)
                               (var <top>)
                               (val <top>))
  #f)

(define-method (merge-generics (module <module>)
                               (name <symbol>)
                               (int1 <module>)
                               (val1 <generic>)
                               (int2 <module>)
                               (val2 <generic>)
                               (var <top>)
                               (val <boolean>))
  (and (not (eq? val1 val2))
       (make-variable (make-extended-generic (list val2 val1) name))))

(define-method (merge-generics (module <module>)
                               (name <symbol>)
                               (int1 <module>)
                               (val1 <generic>)
                               (int2 <module>)
                               (val2 <generic>)
                               (var <top>)
                               (gf <extended-generic>))
  (and (not (memq val2 (slot-ref gf 'extends)))
       (begin
         (slot-set! gf
                    'extends
                    (cons val2 (delq! val2 (slot-ref gf 'extends))))
         (slot-set! val2
                    'extended-by
                    (cons gf (delq! gf (slot-ref val2 'extended-by))))
         (invalidate-method-cache! gf)
         var)))

(module-define! duplicate-handlers 'merge-generics merge-generics)

(define-method (merge-accessors (module <module>)
                                (name <symbol>)
                                (int1 <module>)
                                (val1 <top>)
                                (int2 <module>)
                                (val2 <top>)
                                (var <top>)
                                (val <top>))
  #f)

(define-method (merge-accessors (module <module>)
                                (name <symbol>)
                                (int1 <module>)
                                (val1 <accessor>)
                                (int2 <module>)
                                (val2 <accessor>)
                                (var <top>)
                                (val <top>))
  (merge-generics module name int1 val1 int2 val2 var val))

(module-define! duplicate-handlers 'merge-accessors merge-accessors)

;;;
;;; slot access
;;;

(define (class-slot-ref class slot-name)
  (let ((slot (class-slot-definition class slot-name)))
    (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))
      (slot-missing class slot-name))
    (let ((x ((%slot-definition-slot-ref/raw slot) #f)))
      (if (unbound? x)
          (slot-unbound class slot-name)
          x))))

(define (class-slot-set! class slot-name value)
  (let ((slot (class-slot-definition class slot-name)))
    (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))
      (slot-missing class slot-name))
    ((%slot-definition-slot-set! slot) #f value)))

(define-method (slot-unbound (c <class>) (o <object>) s)
  (goops-error "Slot `~S' is unbound in object ~S" s o))

(define-method (slot-unbound (c <class>) s)
  (goops-error "Slot `~S' is unbound in class ~S" s c))

(define-method (slot-unbound (o <object>))
  (goops-error "Unbound slot in object ~S" o))

(define-method (slot-missing (c <class>) (o <object>) s)
  (goops-error "No slot with name `~S' in object ~S" s o))

(define-method (slot-missing (c <class>) s)
  (goops-error "No class slot with name `~S' in class ~S" s c))


(define-method (slot-missing (c <class>) (o <object>) s value)
  (slot-missing c o s))

;;; Methods for the possible error we can encounter when calling a gf

(define-method (no-next-method (gf <generic>) args)
  (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))

(define-method (no-applicable-method (gf <generic>) args)
  (goops-error "No applicable method for ~S in call ~S"
               gf (cons (generic-function-name gf) args)))

(define-method (no-method (gf <generic>) args)
  (goops-error "No method defined for ~S"  gf))

;;;
;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
;;;

(define-method (shallow-clone (self <object>))
  (let* ((class (class-of self))
         (clone (%allocate-instance class))
         (slots (map slot-definition-name (class-slots class))))
    (for-each (lambda (slot)
                (when (slot-bound? self slot)
                  (slot-set! clone slot (slot-ref self slot))))
              slots)
    clone))

(define-method (deep-clone  (self <object>))
  (let* ((class (class-of self))
         (clone (%allocate-instance class))
         (slots (map slot-definition-name (class-slots class))))
    (for-each (lambda (slot)
                (when (slot-bound? self slot)
                  (slot-set! clone slot
                             (let ((value (slot-ref self slot)))
                               (if (instance? value)
                                   (deep-clone value)
                                   value)))))
              slots)
    clone))

;;;
;;; {Utilities for INITIALIZE methods}
;;;

;;; compute-slot-accessors
;;;
(define (compute-slot-accessors class slots)
  (for-each
   (lambda (slot)
     (let ((getter (%slot-definition-getter slot))
           (setter (%slot-definition-setter slot))
           (accessor-setter setter)
           (accessor (%slot-definition-accessor slot)))
       (when getter
         (add-method! getter (compute-getter-method class slot)))
       (when setter
         (add-method! setter (compute-setter-method class slot)))
       (when accessor
         (add-method! accessor (compute-getter-method class slot))
         (add-method! (accessor-setter accessor)
                      (compute-setter-method class slot)))))
   slots))

(define-method (compute-getter-method (class <class>) slot)
  (make <accessor-method>
    #:specializers (list class)
    #:procedure (slot-definition-slot-ref slot)
    #:slot-definition slot))

(define-method (compute-setter-method (class <class>) slot)
  (make <accessor-method>
    #:specializers (list class <top>)
    #:procedure (slot-definition-slot-set! slot)
    #:slot-definition slot))

(define (make-generic-bound-check-getter proc)
  (lambda (o)
    (let ((val (proc o)))
      (if (unbound? val)
          (slot-unbound o)
          val))))

;;; compute-cpl
;;;

;; Replace the bootstrap compute-cpl with this definition.
(define compute-cpl
  (make <generic> #:name 'compute-cpl))

(define-method (compute-cpl (class <class>))
  (compute-std-cpl class class-direct-supers))

;;; compute-get-n-set
;;;
(define compute-get-n-set
  (make <generic> #:name 'compute-get-n-set))

(define-method (compute-get-n-set (class <class>) s)
  (define (class-slot-init-value)
    (let ((thunk (slot-definition-init-thunk s)))
      (if thunk
          (thunk)
          (slot-definition-init-value s))))

  (define (make-closure-variable class value)
    (list (lambda (o) value)
          (lambda (o v) (set! value v))))

  (case (slot-definition-allocation s)
    ((#:instance) ;; Instance slot
     ;; get-n-set is just its offset
     (let ((already-allocated (struct-ref/unboxed class class-index-nfields)))
       (struct-set!/unboxed class class-index-nfields (+ already-allocated 1))
       already-allocated))

    ((#:class) ;; Class slot
     ;; Class-slots accessors are implemented as 2 closures around
     ;; a Scheme variable. As instance slots, class slots must be
     ;; unbound at init time.
     (let ((name (slot-definition-name s)))
       (if (memq name (map slot-definition-name (class-direct-slots class)))
           ;; This slot is direct; create a new shared variable
           (make-closure-variable class (class-slot-init-value))
           ;; Slot is inherited. Find its definition in superclass
           (let lp ((cpl (cdr (class-precedence-list class))))
             (match cpl
               ((super . cpl)
                (let ((s (class-slot-definition super name)))
                  (if s
                      (list (slot-definition-slot-ref s)
                            (slot-definition-slot-set! s))
                      ;; Multiple inheritance means that we might have
                      ;; to look deeper in the CPL.
                      (lp cpl)))))))))

    ((#:each-subclass) ;; slot shared by instances of direct subclass.
     ;; (Thomas Buerger, April 1998)
     (make-closure-variable class (class-slot-init-value)))

    ((#:virtual) ;; No allocation
     ;; slot-ref and slot-set! function must be given by the user
     (let ((get (get-keyword #:slot-ref  (slot-definition-options s) #f))
           (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
       (unless (and get set)
         (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S" s))
       (list get set)))
    (else    (next-method))))

(define-method (compute-get-n-set (o <object>) s)
  (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))

(define-method (compute-slots (class <class>))
  (build-slots-list (class-direct-slots class)
                    (class-precedence-list class)))

;;;
;;; {Initialize}
;;;

;; FIXME: This could be much more efficient.
(define (%initialize-object obj initargs)
  "Initialize the object @var{obj} with the given arguments
var{initargs}."
  (define (valid-initargs? initargs)
    (match initargs
      (() #t)
      (((? keyword?) _ . initargs) (valid-initargs? initargs))
      (_ #f)))
  (unless (instance? obj)
    (scm-error 'wrong-type-arg #f "Not an object: ~S"
               (list obj) #f))
  (unless (valid-initargs? initargs)
    (scm-error 'wrong-type-arg #f "Invalid initargs: ~S"
               (list initargs) #f))
  (let ((class (class-of obj)))
    (define (get-initarg kw)
      (if kw
          ;; Inlined get-keyword to avoid checking initargs for validity
          ;; each time.
          (let lp ((initargs initargs))
            (match initargs
              ((kw* val . initargs)
               (if (eq? kw* kw)
                   val
                   (lp initargs)))
              (_ *unbound*)))
          *unbound*))
    (let lp ((slots (struct-ref class class-index-slots)))
      (match slots
        (() obj)
        ((slot . slots)
         (define (initialize-slot! value)
           ((%slot-definition-slot-set! slot) obj value))
         (let ((initarg (get-initarg (%slot-definition-init-keyword slot))))
           (cond
            ((not (unbound? initarg))
             (initialize-slot! initarg))
            ((%slot-definition-init-thunk slot)
             => (lambda (init-thunk)
                  (unless (memq (slot-definition-allocation slot)
                                '(#:class #:each-subclass))
                    (initialize-slot! (init-thunk)))))))
         (lp slots))))))

(define-method (initialize (object <object>) initargs)
  (%initialize-object object initargs))

(define-method (initialize (slot <slot>) initargs)
  (next-method)
  (struct-set! slot slot-index-options initargs)
  (let ((init-thunk (%slot-definition-init-thunk slot)))
    (when init-thunk
      (unless (thunk? init-thunk)
        (goops-error "Bad init-thunk for slot `~S': ~S"
                     (%slot-definition-name slot) init-thunk)))))

(define-method (initialize (class <class>) initargs)
  (define (make-direct-slot-definition dslot)
    (let ((initargs (compute-direct-slot-definition-initargs class dslot)))
      (compute-direct-slot-definition class initargs)))

  (next-method)
  (class-add-flags! class vtable-flag-goops-class)
  (struct-set! class class-index-name (get-keyword #:name initargs '???))
  (struct-set!/unboxed class class-index-nfields 0)
  (struct-set! class class-index-direct-supers
               (get-keyword #:dsupers initargs '()))
  (struct-set! class class-index-direct-subclasses '())
  (struct-set! class class-index-direct-methods '())
  (struct-set! class class-index-cpl (compute-cpl class))
  (when (get-keyword #:static-slot-allocation? initargs #f)
    (match (filter class-has-statically-allocated-slots?
                   (class-precedence-list class))
      (()
       (class-add-flags! class vtable-flag-goops-static-slot-allocation))
      (classes
       (error "Class has superclasses with static slot allocation" classes))))
  (struct-set! class class-index-direct-slots
               (map (lambda (slot)
                      (if (slot? slot)
                          slot
                          (make-direct-slot-definition slot)))
                    (get-keyword #:slots initargs '())))
  (struct-set! class class-index-slots
               (allocate-slots class (compute-slots class)))

  ;; This is a hack.
  (when (memq <slot> (struct-ref class class-index-cpl))
    (class-add-flags! class vtable-flag-goops-slot))

  ;; Build getters - setters - accessors
  (compute-slot-accessors class (struct-ref class class-index-slots))

  ;; Update the "direct-subclasses" of each inherited classes
  (for-each (lambda (x)
              (let ((dsubs (struct-ref x class-index-direct-subclasses)))
                (struct-set! x class-index-direct-subclasses
                             (cons class dsubs))))
            (struct-ref class class-index-direct-supers))

  ;; Compute struct layout of instances, set the `layout' slot, and
  ;; update class flags.
  (%prep-layout! class))

(define (initialize-object-procedure object initargs)
  (let ((proc (get-keyword #:procedure initargs #f)))
    (cond ((not proc))
          ((pair? proc)
           (apply slot-set! object 'procedure proc))
          (else
           (slot-set! object 'procedure proc)))))

(define-method (initialize (applicable-struct <applicable-struct>) initargs)
  (next-method)
  (initialize-object-procedure applicable-struct initargs))

(define-method (initialize (applicable-struct <applicable-struct-with-setter>)
                           initargs)
  (next-method)
  (slot-set! applicable-struct 'setter (get-keyword #:setter initargs #f)))

(define-method (initialize (generic <generic>) initargs)
  (let ((previous-definition (get-keyword #:default initargs #f))
        (name (get-keyword #:name initargs #f)))
    (next-method)
    (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
                                    (list (method args
                                            (apply previous-definition args)))
                                    '()))
    (if name
        (set-procedure-property! generic 'name name))
    (invalidate-method-cache! generic)))

(define-method (initialize (eg <extended-generic>) initargs)
  (next-method)
  (slot-set! eg 'extends (get-keyword #:extends initargs '())))

(define dummy-procedure (lambda args *unspecified*))

(define-method (initialize (method <method>) initargs)
  (next-method)
  (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
  (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
  (slot-set! method 'procedure
             (get-keyword #:procedure initargs #f))
  (slot-set! method 'formals (get-keyword #:formals initargs '()))
  (slot-set! method 'body (get-keyword #:body initargs '()))
  (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))


;;;
;;; {make}
;;;
;;; A new definition which overwrites the previous one which was built-in
;;;

(define-method (allocate-instance (class <class>) initargs)
  (%allocate-instance class))

(define-method (make-instance (class <class>) . initargs)
  (let ((instance (allocate-instance class initargs)))
    (initialize instance initargs)
    instance))

(define make make-instance)

;;;
;;; {apply-generic}
;;;
;;; Protocol for calling generic functions, intended to be used when
;;; applying subclasses of <generic> and <generic-with-setter>.  The
;;; code below is similar to the first MOP described in AMOP.
;;;
;;; Note that standard generic functions dispatch only on the classes of
;;; the arguments, and the result of such dispatch can be memoized.  The
;;; `dispatch-generic-function-application-from-cache' routine
;;; implements this.  `apply-generic' isn't called currently; the
;;; generic function MOP was never fully implemented in GOOPS.  However
;;; now that GOOPS is implemented entirely in Scheme (2015) it's much
;;; easier to complete this work.  Contributions gladly accepted!
;;; Please read the AMOP first though :)
;;;
;;; The protocol is:
;;;
;;; 	+ apply-generic (gf args)
;;;		+ compute-applicable-methods (gf args ...)
;;;			+ sort-applicable-methods (gf methods args)
;;;		+ apply-methods (gf methods args)
;;;
;;; apply-methods calls make-next-method to build the "continuation" of
;;; a method.  Applying a next-method will call apply-next-method which
;;; in turn will call apply again to call effectively the following
;;; method.  (This paragraph is out of date but is kept so that maybe it
;;; illuminates some future hack.)
;;;

(define-method (apply-generic (gf <generic>) args)
  (when (null? (slot-ref gf 'methods))
    (no-method gf args))
  (let ((methods (compute-applicable-methods gf args)))
    (if methods
        (apply-methods gf (sort-applicable-methods gf methods args) args)
        (no-applicable-method gf args))))

;; compute-applicable-methods is bound to %compute-applicable-methods.
(define compute-applicable-methods
  (let ((gf (make <generic> #:name 'compute-applicable-methods)))
    (add-method! gf (method ((gf <generic>) args)
                      (%compute-applicable-methods gf args)))
    gf))

(define-method (sort-applicable-methods (gf <generic>) methods args)
  (%sort-applicable-methods methods (map class-of args)))

(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
  (%method-more-specific? m1 m2 targs))

(define compute-effective-method
  (let ((gf (make <generic> #:name 'compute-effective-method)))
    (add-method! gf (method ((gf <generic>) methods typev)
                      (%compute-effective-method gf methods typev)))
    gf))

(define compute-specialized-effective-method
  (let ((gf (make <generic> #:name 'compute-specialized-effective-method)))
    (add-method!
     gf
     (method ((gf <generic>) (method <method>) typev next)
       (%compute-specialized-effective-method gf method typev next)))
    gf))

(define-method (compute-specialized-effective-method (gf <generic>)
                                                     (m <accessor-method>)
                                                     typev
                                                     next)
  (let ((name (slot-definition-name (accessor-method-slot-definition m))))
    (match typev
      (#(class)
       (slot-definition-slot-ref (class-slot-definition class name)))
      (#(class _)
       (slot-definition-slot-set! (class-slot-definition class name)))
      (_
       (next-method)))))

(define-method (apply-method (gf <generic>) methods build-next args)
  (apply (method-procedure (car methods))
         (build-next (cdr methods) args)
         args))

(define-method (apply-methods (gf <generic>) (l <list>) args)
  (letrec ((next (lambda (procs args)
                   (lambda new-args
                     (let ((a (if (null? new-args) args new-args)))
                       (if (null? procs)
                           (no-next-method gf a)
                           (apply-method gf procs next a)))))))
    (apply-method gf l next args)))

;; We don't want the following procedure to turn up in backtraces:
(for-each (lambda (proc)
            (set-procedure-property! proc 'system-procedure #t))
          (list slot-unbound
                slot-missing
                no-next-method
                no-applicable-method
                no-method
                ))

