[bpt/guile.git] / module / oop / goops.scm

;;; installed-scm-file

;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
\f

;;;;
;;;; This file was based upon stklos.stk from the STk distribution
;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
;;;;

(define-module (oop goops)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (system base target)
  #:use-module ((language tree-il primitives)
                :select (add-interesting-primitive!))
  #:export-syntax (define-class class standard-define-class
                    define-generic define-accessor define-method
                    define-extended-generic define-extended-generics
                    method)
  #:export ( ;; The root of everything.
            <top>
            <class> <object>

            ;; Slot types.
            <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
            <read-only-slot> <self-slot> <protected-opaque-slot>
            <protected-hidden-slot> <protected-read-only-slot>
            <scm-slot> <int-slot> <float-slot> <double-slot>

            ;; Methods are implementations of generic functions.
            <method> <accessor-method>

            ;; Applicable objects, either procedures or applicable structs.
            <procedure-class> <applicable>
            <procedure> <primitive-generic>

            ;; Applicable structs.
            <applicable-struct-class> <applicable-struct-with-setter-class>
            <applicable-struct> <applicable-struct-with-setter>
            <generic> <extended-generic>
            <generic-with-setter> <extended-generic-with-setter>
            <accessor> <extended-accessor>

            ;; Types with their own allocated typecodes.
            <boolean> <char> <list> <pair> <null> <string> <symbol>
            <vector> <bytevector> <uvec> <foreign> <hashtable>
            <fluid> <dynamic-state> <frame> <vm> <vm-continuation>
            <keyword>

            ;; Numbers.
            <number> <complex> <real> <integer> <fraction>

            ;; Unknown.
            <unknown>

            ;; Particular SMOB data types.  All SMOB types have
            ;; corresponding classes, which may be obtained via class-of,
            ;; once you have an instance.  Perhaps FIXME to provide a
            ;; smob-type-name->class procedure.
            <arbiter> <promise> <thread> <mutex> <condition-variable>
            <regexp> <hook> <bitvector> <random-state> <async>
            <directory> <array> <character-set>
            <dynamic-object> <guardian> <macro>

            ;; Modules.
            <module>

            ;; Ports.
            <port> <input-port> <output-port> <input-output-port>

            ;; Like SMOB types, all port types have their own classes,
            ;; which can be accessed via `class-of' once you have an
            ;; instance.  Here we export bindings just for file ports.
            <file-port>
            <file-input-port> <file-output-port> <file-input-output-port>

            is-a? class-of
            ensure-metaclass ensure-metaclass-with-supers
            make-class
            make-generic ensure-generic
            make-extended-generic
            make-accessor ensure-accessor
            add-method!
            class-slot-ref class-slot-set! slot-unbound slot-missing
            slot-definition-name  slot-definition-options
            slot-definition-allocation

            slot-definition-getter slot-definition-setter
            slot-definition-accessor
            slot-definition-init-value slot-definition-init-form
            slot-definition-init-thunk slot-definition-init-keyword
            slot-init-function class-slot-definition
            method-source
            compute-cpl compute-std-cpl compute-get-n-set compute-slots
            compute-getter-method compute-setter-method
            allocate-instance initialize make-instance make
            no-next-method  no-applicable-method no-method
            change-class update-instance-for-different-class
            shallow-clone deep-clone
            class-redefinition
            apply-generic apply-method apply-methods
            compute-applicable-methods %compute-applicable-methods
            method-more-specific? sort-applicable-methods
            class-subclasses class-methods
            goops-error
            min-fixnum max-fixnum

            instance?
            slot-ref slot-set! slot-bound? slot-exists?
            class-name class-direct-supers class-direct-subclasses
            class-direct-methods class-direct-slots class-precedence-list
            class-slots
            generic-function-name
            generic-function-methods method-generic-function
            method-specializers method-formals
            primitive-generic-generic enable-primitive-generic!
            method-procedure accessor-method-slot-definition
            make find-method get-keyword)
  #:no-backtrace)


;;;
;;; Booting GOOPS is a tortuous process.  We begin by loading a small
;;; set of primitives from C.
;;;
(eval-when (expand load eval)
  (load-extension (string-append "libguile-" (effective-version))
                  "scm_init_goops_builtins")
  (add-interesting-primitive! 'class-of))


\f

;;;
;;; We then define the slots that must appear in all classes (<class>
;;; objects) and slot definitions (<slot> objects).  These slots must
;;; appear in order.  We'll use this list to statically compute offsets
;;; for the various fields, to compute the struct layout for <class>
;;; instances, and to compute the slot definition lists for <class>.
;;; Because the list is needed at expansion-time, we define it as a
;;; macro.
;;;
(define-syntax macro-fold-left
  (syntax-rules ()
    ((_ folder seed ()) seed)
    ((_ folder seed (head . tail))
     (macro-fold-left folder (folder head seed) tail))))

(define-syntax macro-fold-right
  (syntax-rules ()
    ((_ folder seed ()) seed)
    ((_ folder seed (head . tail))
     (folder head (macro-fold-right folder seed tail)))))

(define-syntax-rule (define-macro-folder macro-folder value ...)
  (define-syntax macro-folder
    (lambda (x)
      (syntax-case x ()
        ((_ fold visit seed)
         ;; The datum->syntax makes it as if each `value' were present
         ;; in the initial form, which allows them to be used as
         ;; (components of) introduced identifiers.
         #`(fold visit seed #,(datum->syntax #'visit '(value ...))))))))

(define-macro-folder fold-class-slots
  (layout <protected-read-only-slot>)
  (flags <hidden-slot>)
  (self <self-slot>)
  (instance-finalizer <hidden-slot>)
  (print)
  (name <protected-hidden-slot>)
  (nfields <hidden-slot>)
  (%reserved <hidden-slot>)
  (redefined)
  (direct-supers)
  (direct-slots)
  (direct-subclasses)
  (direct-methods)
  (cpl)
  (slots)
  (getters-n-setters))

(define-macro-folder fold-slot-slots
  (name #:init-keyword #:name)
  (allocation #:init-keyword #:allocation #:init-value #:instance)
  (init-form #:init-keyword #:init-form)
  (init-thunk #:init-keyword #:init-thunk #:init-value #f)
  (options)
  (getter #:init-keyword #:getter)
  (setter #:init-keyword #:setter)
  (index #:init-keyword #:index)
  (size #:init-keyword #:size))

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

;;;
;;; Structs that are vtables have a "flags" slot, which corresponds to
;;; class-index-flags.  `vtable-flag-vtable' indicates that instances of
;;; a vtable are themselves vtables, and `vtable-flag-validated'
;;; indicates that the struct's layout has been validated.  goops.c
;;; defines a couple of additional flags: one to indicate that a vtable
;;; is actually a class, and one to indicate that the class is "valid",
;;; meaning that it hasn't been redefined.
;;;
(define vtable-flag-goops-metaclass
  (logior vtable-flag-vtable vtable-flag-goops-class))

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

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

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

(define-inlinable (class? obj)
  (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))

(define-inlinable (instance? obj)
  (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))

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

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

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

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

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


\f

;;;
;;; The "getters-n-setters" define how to access slot values for a
;;; particular class.  In general, there are many ways to access slot
;;; values, but for standard classes it's pretty easy: each slot is
;;; associated with a field in the object.
;;;
(define (%compute-getters-n-setters slots)
  (define (compute-init-thunk options)
    (cond
     ((kw-arg-ref options #:init-value) => (lambda (val) (lambda () val)))
     ((kw-arg-ref options #:init-thunk))
     (else #f)))
  (let lp ((slots slots) (n 0))
    (match slots
      (() '())
      (((name . options) . slots)
       (let ((init-thunk (compute-init-thunk options)))
         (cons `(,name ,init-thunk . ,n)
               (lp slots (1+ n))))))))

(struct-set! <class> class-index-getters-n-setters
             (%compute-getters-n-setters (class-slots <class>)))


\f

;;;
;;; At this point, we have <class> but no other objects.  We need to
;;; define a standard way to make subclasses: how to compute the
;;; precedence list of subclasses, how to compute the list of slots in a
;;; subclass, and what layout to use for instances of those classes.
;;;

(define (compute-std-cpl c get-direct-supers)
  "The standard class precedence list computation algorithm."
  (define (only-non-null lst)
    (filter (lambda (l) (not (null? l))) lst))

  (define (merge-lists reversed-partial-result inputs)
    (cond
     ((every null? inputs)
      (reverse! reversed-partial-result))
     (else
      (let* ((candidate (lambda (c)
                          (and (not (any (lambda (l)
                                           (memq c (cdr l)))
                                         inputs))
                               c)))
             (candidate-car (lambda (l)
                              (and (not (null? l))
                                   (candidate (car l)))))
             (next (any candidate-car inputs)))
        (unless next
          (goops-error "merge-lists: Inconsistent precedence graph"))
        (let ((remove-next (lambda (l)
                             (if (eq? (car l) next)
                                 (cdr l)
                                 l))))
          (merge-lists (cons next reversed-partial-result)
                       (only-non-null (map remove-next inputs))))))))
  (let ((c-direct-supers (get-direct-supers c)))
    (merge-lists (list c)
                 (only-non-null (append (map class-precedence-list
                                             c-direct-supers)
                                        (list c-direct-supers))))))

;; This version of compute-cpl is replaced with a generic function once
;; GOOPS has booted.
(define (compute-cpl class)
  (compute-std-cpl class class-direct-supers))

(define (build-slots-list dslots cpl)
  (define (check-cpl slots class-slots)
    (when (or-map (match-lambda ((name . options) (assq name slots)))
                  class-slots)
      (scm-error 'misc-error #f
                 "a predefined <class> inherited field cannot be redefined"
                 '() '())))
  (define (remove-duplicate-slots slots)
    (let lp ((slots (reverse slots)) (res '()) (seen '()))
      (match slots
        (() res)
        (((and slot (name . options)) . slots)
         (if (memq name seen)
             (lp slots res seen)
             (lp slots (cons slot res) (cons name seen)))))))
  (let* ((class-slots (and (memq <class> cpl)
                           (struct-ref <class> class-index-slots))))
    (when class-slots
      (check-cpl dslots class-slots))
    (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
      (match cpl
        (() (remove-duplicate-slots (append class-slots res)))
        ((head . cpl)
         (let ((new-slots (struct-ref head class-index-direct-slots)))
           (cond
            ((not class-slots)
             (lp cpl (append new-slots res) class-slots))
            ((eq? head <class>)
             ;; Move class slots to the head of the list.
             (lp cpl res new-slots))
            (else
             (check-cpl new-slots class-slots)
             (lp cpl (append new-slots res) class-slots)))))))))

(define (%compute-layout slots getters-n-setters nfields is-class?)
  (define (instance-allocated? g-n-s)
    (match g-n-s
      ((name init-thunk . (? exact-integer? index)) #t)
      ((name init-thunk getter setter index size) #t)
      (_ #f)))

  (define (allocated-index g-n-s)
    (match g-n-s
      ((name init-thunk . (? exact-integer? index)) index)
      ((name init-thunk getter setter index size) index)))

  (define (allocated-size g-n-s)
    (match g-n-s
      ((name init-thunk . (? exact-integer? index)) 1)
      ((name init-thunk getter setter index size) size)))

  (define (slot-protection-and-kind options)
    (define (subclass? class parent)
      (memq parent (class-precedence-list class)))
    (let ((type (kw-arg-ref options #:class)))
      (if (and type (subclass? type <foreign-slot>))
          (values (cond
                   ((subclass? type <self-slot>) #\s)
                   ((subclass? type <protected-slot>) #\p)
                   (else #\u))
                  (cond
                   ((subclass? type <opaque-slot>) #\o)
                   ((subclass? type <read-only-slot>) #\r)
                   ((subclass? type <hidden-slot>) #\h)
                   (else #\w)))
          (values #\p #\w))))

  (let ((layout (make-string (* nfields 2))))
    (let lp ((n 0) (slots slots) (getters-n-setters getters-n-setters))
      (match getters-n-setters
        (()
         (unless (= n nfields) (error "bad nfields"))
         (unless (null? slots) (error "inconsistent g-n-s/slots"))
         (when is-class?
           (let ((class-layout (struct-ref <class> class-index-layout)))
             (unless (string-prefix? (symbol->string class-layout) layout)
               (error "bad layout for class"))))
         layout)
        ((g-n-s . getters-n-setters)
         (match slots
           (((name . options) . slots)
            (cond
             ((instance-allocated? g-n-s)
              (unless (< n nfields) (error "bad nfields"))
              (unless (= n (allocated-index g-n-s)) (error "bad allocation"))
              (call-with-values (lambda () (slot-protection-and-kind options))
                (lambda (protection kind)
                  (let init ((n n) (size (allocated-size g-n-s)))
                    (cond
                     ((zero? size) (lp n slots getters-n-setters))
                     (else
                      (string-set! layout (* n 2) protection)
                      (string-set! layout (1+ (* n 2)) kind)
                      (init (1+ n) (1- size))))))))
             (else
              (lp n slots getters-n-setters))))))))))


\f

;;;
;;; With all of this, we are now able to define subclasses of <class>.
;;;
(define (%prep-layout! class)
  (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
         (layout (%compute-layout
                  (struct-ref class class-index-slots)
                  (struct-ref class class-index-getters-n-setters)
                  (struct-ref class class-index-nfields)
                  is-class?)))
    (%init-layout! class layout)))

(define (make-standard-class class name dsupers dslots)
  (let ((z (make-struct/no-tail class)))
    (struct-set! z class-index-direct-supers dsupers)
    (let* ((cpl (compute-cpl z))
           (dslots (map (lambda (slot)
                          (if (pair? slot) slot (list slot)))
                        dslots))
           (slots (build-slots-list dslots cpl))
           (nfields (length slots))
           (g-n-s (%compute-getters-n-setters slots)))
      (struct-set! z class-index-name name)
      (struct-set! z class-index-nfields nfields)
      (struct-set! z class-index-direct-slots dslots)
      (struct-set! z class-index-direct-subclasses '())
      (struct-set! z class-index-direct-methods '())
      (struct-set! z class-index-cpl cpl)
      (struct-set! z class-index-slots slots)
      (struct-set! z class-index-getters-n-setters g-n-s)
      (struct-set! z class-index-redefined #f)
      (for-each
       (lambda (super)
         (let ((subclasses (struct-ref super class-index-direct-subclasses)))
           (struct-set! super class-index-direct-subclasses
                        (cons z subclasses))))
       dsupers)
      (%prep-layout! z)
      z)))

(define-syntax define-standard-class
  (syntax-rules ()
    ((define-standard-class name (super ...) #:metaclass meta slot ...)
     (define name
       (make-standard-class meta 'name (list super ...) '(slot ...))))
    ((define-standard-class name (super ...) slot ...)
     (define-standard-class name (super ...) #:metaclass <class> slot ...))))


\f

;;;
;;; Sweet!  Now we can define <top> and <object>, and finish
;;; initializing the `direct-subclasses', `direct-supers', and `cpl'
;;; slots of <class>.
;;;
(define-standard-class <top> ())
(define-standard-class <object> (<top>))

;; <top>, <object>, and <class> were partially initialized.  Correct
;; them here.
(struct-set! <object> class-index-direct-subclasses (list <class>))
(struct-set! <class> class-index-direct-supers (list <object>))
(struct-set! <class> class-index-cpl (list <class> <object> <top>))


\f

;;;
;;; We can also define the various slot types, and finish initializing
;;; `direct-slots', `slots', and `getters-n-setters' of <class>.
;;;
(define-standard-class <foreign-slot> (<top>))
(define-standard-class <protected-slot> (<foreign-slot>))
(define-standard-class <hidden-slot> (<foreign-slot>))
(define-standard-class <opaque-slot> (<foreign-slot>))
(define-standard-class <read-only-slot> (<foreign-slot>))
(define-standard-class <self-slot> (<read-only-slot>))
(define-standard-class <protected-opaque-slot> (<protected-slot>
                                                <opaque-slot>))
(define-standard-class <protected-hidden-slot> (<protected-slot>
                                                <hidden-slot>))
(define-standard-class <protected-read-only-slot> (<protected-slot>
                                                   <read-only-slot>))
(define-standard-class <scm-slot> (<protected-slot>))
(define-standard-class <int-slot> (<foreign-slot>))
(define-standard-class <float-slot> (<foreign-slot>))
(define-standard-class <double-slot> (<foreign-slot>))

(let-syntax ((visit
              (syntax-rules ()
                ((_ (name) tail)
                 (cons (list 'name) tail))
                ((_ (name class) tail)
                 (cons (list 'name #:class class) tail)))))
  (let* ((dslots (fold-class-slots macro-fold-right visit '()))
         (g-n-s (%compute-getters-n-setters dslots)))
    (struct-set! <class> class-index-direct-slots dslots)
    (struct-set! <class> class-index-slots dslots)
    (struct-set! <class> class-index-getters-n-setters g-n-s)))


\f

;;;
;;; Now, to build out the class hierarchy.
;;;

(define-standard-class <procedure-class> (<class>))

(define-standard-class <applicable-struct-class>
  (<procedure-class>))
(class-add-flags! <applicable-struct-class>
                  vtable-flag-applicable-vtable)

(define-standard-class <applicable-struct-with-setter-class>
  (<applicable-struct-class>))
(class-add-flags! <applicable-struct-with-setter-class>
                  vtable-flag-setter-vtable)

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

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

(define-standard-class <boolean> (<top>))
(define-standard-class <char> (<top>))
(define-standard-class <list> (<top>))
(define-standard-class <pair> (<list>))
(define-standard-class <null> (<list>))
(define-standard-class <string> (<top>))
(define-standard-class <symbol> (<top>))
(define-standard-class <vector> (<top>))
(define-standard-class <foreign> (<top>))
(define-standard-class <hashtable> (<top>))
(define-standard-class <fluid> (<top>))
(define-standard-class <dynamic-state> (<top>))
(define-standard-class <frame> (<top>))
(define-standard-class <vm-continuation> (<top>))
(define-standard-class <bytevector> (<top>))
(define-standard-class <uvec> (<bytevector>))
(define-standard-class <array> (<top>))
(define-standard-class <bitvector> (<top>))
(define-standard-class <number> (<top>))
(define-standard-class <complex> (<number>))
(define-standard-class <real> (<complex>))
(define-standard-class <integer> (<real>))
(define-standard-class <fraction> (<real>))
(define-standard-class <keyword> (<top>))
(define-standard-class <unknown> (<top>))
(define-standard-class <procedure> (<applicable>)
  #:metaclass <procedure-class>)
(define-standard-class <primitive-generic> (<procedure>)
  #:metaclass <procedure-class>)
(define-standard-class <port> (<top>))
(define-standard-class <input-port> (<port>))
(define-standard-class <output-port> (<port>))
(define-standard-class <input-output-port> (<input-port> <output-port>))

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


\f

;;;
;;; At this point we have defined the class hierarchy, and it's time to
;;; move on to instance allocation and generics.  Once we have generics,
;;; we'll fill out the metaobject protocol.
;;;
;;; Here we define a limited version of `make', so that we can allocate
;;; instances of specific classes.  This definition will be replaced
;;; later.
;;;
(define (%invalidate-method-cache! gf)
  (slot-set! gf 'procedure (delayed-compile gf))
  (slot-set! gf 'effective-methods '()))

;; Boot definition.
(define (invalidate-method-cache! gf)
  (%invalidate-method-cache! gf))

(define* (get-keyword key l #:optional default)
  "Determine an associated value for the keyword @var{key} from the list
@var{l}.  The list @var{l} has to consist of an even number of elements,
where, starting with the first, every second element is a keyword,
followed by its associated value.  If @var{l} does not hold a value for
@var{key}, the value @var{default} is returned."
  (unless (keyword? key)
    (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list key) #f))
  (let lp ((l l))
    (match l
      (() default)
      ((kw arg . l)
       (unless (keyword? kw)
         (scm-error 'wrong-type-arg #f "Not a keyword: ~S" (list kw) #f))
       (if (eq? kw key) arg (lp l))))))

(define *unbound* (list 'unbound))

(define-inlinable (unbound? x)
  (eq? x *unbound*))

(define (%allocate-instance class)
  (let ((obj (allocate-struct class (struct-ref class class-index-nfields))))
    (%clear-fields! obj *unbound*)
    obj))

(define (make class . args)
  (cond
   ((or (eq? class <generic>) (eq? class <accessor>))
    (let ((z (make-struct/no-tail class #f '() 0 '())))
      (set-procedure-property! z 'name (get-keyword #:name args #f))
      (invalidate-method-cache! z)
      (when (eq? class <accessor>)
        (let ((setter (get-keyword #:setter args #f)))
          (when setter
            (slot-set! z 'setter setter))))
      z))
   (else
    (let ((z (%allocate-instance class)))
      (cond
       ((or (eq? class <method>) (eq? class <accessor-method>))
        (for-each (match-lambda
                   ((kw slot default)
                    (slot-set! z slot (get-keyword kw args default))))
                  '((#:generic-function generic-function #f)
                    (#:specializers specializers ())
                    (#:procedure procedure #f)
                    (#:formals formals ())
                    (#:body body ())
                    (#:make-procedure make-procedure #f))))
       ((memq <class> (class-precedence-list class))
        (class-add-flags! z (logior vtable-flag-goops-class
                                    vtable-flag-goops-valid))
        (for-each (match-lambda
                   ((kw slot default)
                    (slot-set! z slot (get-keyword kw args default))))
                  '((#:name name ???)
                    (#:dsupers direct-supers ())
                    (#:slots direct-slots ()))))
       (else
        (error "boot `make' does not support this class" class)))
      z))))

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


\f

;;;
;;; Slot access.  This protocol is a bit of a mess: there's the `slots'
;;; slot, which ostensibly holds "slot definitions" but really just has
;;; specially formatted lists.  And then there's the `getters-n-setters'
;;; slot, which mirrors `slots' but should in theory indicates how to
;;; get at slots for a particular instance -- never mind that `slots'
;;; was also computed for a particular instance, and that
;;; `getters-n-setters' is a strangely structured chain of pairs.
;;; Perhaps we can fix this in the future, following the CLOS MOP, to
;;; have proper <effective-slot-definition> objects.
;;;
(define (get-slot-value-using-name class obj slot-name)
  (match (assq slot-name (struct-ref class class-index-getters-n-setters))
    (#f (slot-missing class obj slot-name))
    ((name init-thunk . (? exact-integer? index))
     (struct-ref obj index))
    ((name init-thunk getter setter . _)
     (getter obj))))

(define (set-slot-value-using-name! class obj slot-name value)
  (match (assq slot-name (struct-ref class class-index-getters-n-setters))
    (#f (slot-missing class obj slot-name value))
    ((name init-thunk . (? exact-integer? index))
     (struct-set! obj index value))
    ((name init-thunk getter setter . _)
     (setter obj value))))

(define (test-slot-existence class obj slot-name)
  (and (assq slot-name (struct-ref class class-index-getters-n-setters))
       #t))

;;;
;;; Before we go on, some notes about class redefinition.  In GOOPS,
;;; classes can be redefined.  Redefinition of a class marks the class
;;; as invalid, and instances will be lazily migrated over to the new
;;; representation as they are accessed.  Migration happens when
;;; `class-of' is called on an instance.  For more technical details on
;;; object redefinition, see struct.h.
;;;
;;; In the following interfaces, class-of handles the redefinition
;;; protocol.  I would think though that there is some thread-unsafety
;;; here though as the { class, object data } pair needs to be accessed
;;; atomically, not the { class, object } pair.
;;;

(define (slot-ref obj slot-name)
  "Return the value from @var{obj}'s slot with the nam var{slot_name}."
  (unless (symbol? slot-name)
    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
               (list slot-name) #f))
  (let* ((class (class-of obj))
         (val (get-slot-value-using-name class obj slot-name)))
    (if (unbound? val)
        (slot-unbound class obj slot-name)
        val)))

(define (slot-set! obj slot-name value)
  "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
  (unless (symbol? slot-name)
    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
               (list slot-name) #f))
  (set-slot-value-using-name! (class-of obj) obj slot-name value))

(define (slot-bound? obj slot-name)
  "Return the value from @var{obj}'s slot with the nam var{slot_name}."
  (unless (symbol? slot-name)
    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
               (list slot-name) #f))
  (not (unbound? (get-slot-value-using-name (class-of obj) obj slot-name))))

(define (slot-exists? obj slot-name)
  "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
  (unless (symbol? slot-name)
    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
               (list slot-name) #f))
  (test-slot-existence (class-of obj) obj slot-name))

(begin-deprecated
 (define (check-slot-args class obj slot-name)
   (unless (eq? class (class-of obj))
     (scm-error 'wrong-type-arg #f "~S is not the class of ~S"
                (list class obj) #f))
   (unless (symbol? slot-name)
     (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
                (list slot-name) #f)))

 (define (slot-ref-using-class class obj slot-name)
   (issue-deprecation-warning "slot-ref-using-class is deprecated.  "
                              "Use slot-ref instead.")
   (check-slot-args class obj slot-name)
   (slot-ref obj slot-name))

 (define (slot-set-using-class! class obj slot-name value)
   (issue-deprecation-warning "slot-set-using-class! is deprecated.  "
                              "Use slot-set! instead.")
   (check-slot-args class obj slot-name)
   (slot-set! obj slot-name value))

 (define (slot-bound-using-class? class obj slot-name)
   (issue-deprecation-warning "slot-bound-using-class? is deprecated.  "
                              "Use slot-bound? instead.")
   (check-slot-args class obj slot-name)
   (slot-bound? obj slot-name))

 (define (slot-exists-using-class? class obj slot-name)
   (issue-deprecation-warning "slot-exists-using-class? is deprecated.  "
                              "Use slot-exists? instead.")
   (check-slot-args class obj slot-name)
   (slot-exists? obj slot-name)))


\f

;;;
;;; Method accessors.
;;;
(define (method-generic-function obj)
  "Return the generic function for the method @var{obj}."
  (unless (is-a? obj <method>)
    (scm-error 'wrong-type-arg #f "Not a method: ~S"
               (list obj) #f))
  (slot-ref obj 'generic-function))

(define (method-specializers obj)
  "Return specializers of the method @var{obj}."
  (unless (is-a? obj <method>)
    (scm-error 'wrong-type-arg #f "Not a method: ~S"
               (list obj) #f))
  (slot-ref obj 'specializers))

(define (method-procedure obj)
  "Return the procedure of the method @var{obj}."
  (unless (is-a? obj <method>)
    (scm-error 'wrong-type-arg #f "Not a method: ~S"
               (list obj) #f))
  (slot-ref obj 'procedure))


\f

;;;
;;; Generic functions!
;;;
(define *dispatch-module* (current-module))

;;;
;;; Generic functions have an applicable-methods cache associated with
;;; them. Every distinct set of types that is dispatched through a
;;; generic adds an entry to the cache. This cache gets compiled out to
;;; a dispatch procedure. In steady-state, this dispatch procedure is
;;; never recompiled; but during warm-up there is some churn, both to
;;; the cache and to the dispatch procedure.
;;;
;;; So what is the deal if warm-up happens in a multithreaded context?
;;; There is indeed a window between missing the cache for a certain set
;;; of arguments, and then updating the cache with the newly computed
;;; applicable methods. One of the updaters is liable to lose their new
;;; entry.
;;;
;;; This is actually OK though, because a subsequent cache miss for the
;;; race loser will just cause memoization to try again. The cache will
;;; eventually be consistent. We're not mutating the old part of the
;;; cache, just consing on the new entry.
;;;
;;; It doesn't even matter if the dispatch procedure and the cache are
;;; inconsistent -- most likely the type-set that lost the dispatch
;;; procedure race will simply re-trigger a memoization, but since the
;;; winner isn't in the effective-methods cache, it will likely also
;;; re-trigger a memoization, and the cache will finally be consistent.
;;; As you can see there is a possibility for ping-pong effects, but
;;; it's unlikely given the shortness of the window between slot-set!
;;; invocations. We could add a mutex, but it is strictly unnecessary,
;;; and would add runtime cost and complexity.
;;;

(define (emit-linear-dispatch gf-sym nargs methods free rest?)
  (define (gen-syms n stem)
    (let lp ((n (1- n)) (syms '()))
      (if (< n 0)
          syms
          (lp (1- n) (cons (gensym stem) syms)))))
  (let* ((args (gen-syms nargs "a"))
         (types (gen-syms nargs "t")))
    (let lp ((methods methods)
             (free free)
             (exp `(cache-miss ,gf-sym
                               ,(if rest?
                                    `(cons* ,@args rest)
                                    `(list ,@args)))))
      (match methods
       (()
        (values `(,(if rest? `(,@args . rest) args)
                  (let ,(map (lambda (t a)
                               `(,t (class-of ,a)))
                             types args)
                    ,exp))
                free))
       ((#(_ specs _ cmethod) . methods)
        (let build-dispatch ((free free)
                             (types types)
                             (specs specs)
                             (checks '()))
          (match types
            (()
             (let ((m-sym (gensym "p")))
               (lp methods
                   (acons cmethod m-sym free)
                   `(if (and . ,checks)
                        ,(if rest?
                             `(apply ,m-sym ,@args rest)
                             `(,m-sym . ,args))
                        ,exp))))
            ((type . types)
             (match specs
               ((spec . specs)
                (let ((var (assq-ref free spec)))
                  (if var
                      (build-dispatch free
                                      types
                                      specs
                                      (cons `(eq? ,type ,var)
                                            checks))
                      (let ((var (gensym "c")))
                        (build-dispatch (acons spec var free)
                                        types
                                        specs
                                        (cons `(eq? ,type ,var)
                                              checks)))))))))))))))

(define (compute-dispatch-procedure gf cache)
  (define (scan)
    (let lp ((ls cache) (nreq -1) (nrest -1))
      (match ls
        (()
         (collate (make-vector (1+ nreq) '())
                  (make-vector (1+ nrest) '())))
        ((#(len specs rest? cmethod) . ls)
         (if rest?
             (lp ls nreq (max nrest len))
             (lp ls (max nreq len) nrest))))))
  (define (collate req rest)
    (let lp ((ls cache))
      (match ls
        (() (emit req rest))
        (((and entry #(len specs rest? cmethod)) . ls)
         (if rest?
             (vector-set! rest len (cons entry (vector-ref rest len)))
             (vector-set! req len (cons entry (vector-ref req len))))
         (lp ls)))))
  (define (emit req rest)
    (let ((gf-sym (gensym "g")))
      (define (emit-rest n clauses free)
        (if (< n (vector-length rest))
            (match (vector-ref rest n)
              (() (emit-rest (1+ n) clauses free))
              ;; FIXME: hash dispatch
              (methods
               (call-with-values
                   (lambda ()
                     (emit-linear-dispatch gf-sym n methods free #t))
                 (lambda (clause free)
                   (emit-rest (1+ n) (cons clause clauses) free)))))
            (emit-req (1- (vector-length req)) clauses free)))
      (define (emit-req n clauses free)
        (if (< n 0)
            (comp `(lambda ,(map cdr free)
                     (case-lambda ,@clauses))
                  (map car free))
            (match (vector-ref req n)
              (() (emit-req (1- n) clauses free))
              ;; FIXME: hash dispatch
              (methods
               (call-with-values
                   (lambda ()
                     (emit-linear-dispatch gf-sym n methods free #f))
                 (lambda (clause free)
                   (emit-req (1- n) (cons clause clauses) free)))))))

      (emit-rest 0
                 (if (or (zero? (vector-length rest))
                         (null? (vector-ref rest 0)))
                     (list `(args (cache-miss ,gf-sym args)))
                     '())
                 (acons gf gf-sym '()))))
  (define (comp exp vals)
    ;; When cross-compiling Guile itself, the native Guile must generate
    ;; code for the host.
    (with-target %host-type
      (lambda ()
        (let ((p ((@ (system base compile) compile) exp
                  #:env *dispatch-module*
                  #:from 'scheme
                  #:opts '(#:partial-eval? #f #:cse? #f))))
          (apply p vals)))))

  ;; kick it.
  (scan))

;; o/~  ten, nine, eight
;;        sometimes that's just how it goes
;;          three, two, one
;;
;;            get out before it blows    o/~
;;
(define timer-init 30)
(define (delayed-compile gf)
  (let ((timer timer-init))
    (lambda args
      (set! timer (1- timer))
      (cond
       ((zero? timer)
        (let ((dispatch (compute-dispatch-procedure
                         gf (slot-ref gf 'effective-methods))))
          (slot-set! gf 'procedure dispatch)
          (apply dispatch args)))
       (else
        ;; interestingly, this catches recursive compilation attempts as
        ;; well; in that case, timer is negative
        (cache-dispatch gf args))))))

(define (cache-dispatch gf args)
  (define (map-until n f ls)
    (if (or (zero? n) (null? ls))
        '()
        (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
  (define (equal? x y) ; can't use the stock equal? because it's a generic...
    (cond ((pair? x) (and (pair? y)
                          (eq? (car x) (car y))
                          (equal? (cdr x) (cdr y))))
          ((null? x) (null? y))
          (else #f)))
  (if (slot-ref gf 'n-specialized)
      (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
        (let lp ((cache (slot-ref gf 'effective-methods)))
          (cond ((null? cache)
                 (cache-miss gf args))
                ((equal? (vector-ref (car cache) 1) types)
                 (apply (vector-ref (car cache) 3) args))
                (else (lp (cdr cache))))))
      (cache-miss gf args)))

(define (cache-miss gf args)
  (apply (memoize-method! gf args) args))

(define (memoize-effective-method! gf args applicable)
  (define (first-n ls n)
    (if (or (zero? n) (null? ls))
        '()
        (cons (car ls) (first-n (cdr ls) (- n 1)))))
  (define (parse n ls)
    (cond ((null? ls)
           (memoize n #f (map class-of args)))
          ((= n (slot-ref gf 'n-specialized))
           (memoize n #t (map class-of (first-n args n))))
          (else
           (parse (1+ n) (cdr ls)))))
  (define (memoize len rest? types)
    (let* ((cmethod (compute-cmethod applicable types))
           (cache (cons (vector len types rest? cmethod)
                        (slot-ref gf 'effective-methods))))
      (slot-set! gf 'effective-methods cache)
      (slot-set! gf 'procedure (delayed-compile gf))
      cmethod))
  (parse 0 args))

;;;
;;; Compiling next methods into method bodies
;;;

;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
;;; compilation. A task for the future.
;;;
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.

(define (compute-cmethod methods types)
  (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
    (if make-procedure
        (make-procedure
         (if (null? (cdr methods))
             (lambda args
               (no-next-method (method-generic-function (car methods)) args))
             (compute-cmethod (cdr methods) types)))
        (method-procedure (car methods)))))

;;;
;;; Memoization
;;;

(define (memoize-method! gf args)
  (let ((applicable ((if (eq? gf compute-applicable-methods)
                         %compute-applicable-methods
                         compute-applicable-methods)
                     gf args)))
    (cond (applicable
           (memoize-effective-method! gf args applicable))
          (else
           (no-applicable-method gf args)))))

(set-procedure-property! memoize-method! 'system-procedure #t)

(define no-applicable-method
  (make <generic> #:name 'no-applicable-method))

(%goops-early-init)

;; Then load the rest of GOOPS

\f
;; FIXME: deprecate.
(define min-fixnum (- (expt 2 29)))
(define max-fixnum (- (expt 2 29) 1))

;;
;; goops-error
;;
(define (goops-error format-string . args)
  (scm-error 'goops-error #f format-string args '()))

;;;
;;; {Meta classes}
;;;

(define ensure-metaclass-with-supers
  (let ((table-of-metas '()))
    (lambda (meta-supers)
      (let ((entry (assoc meta-supers table-of-metas)))
        (if entry
            ;; Found a previously created metaclass
            (cdr entry)
            ;; Create a new meta-class which inherit from "meta-supers"
            (let ((new (make <class> #:dsupers meta-supers
                                     #:slots   '()
                                     #:name   (gensym "metaclass"))))
              (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
              new))))))

(define (ensure-metaclass supers)
  (if (null? supers)
      <class>
      (let* ((all-metas (map (lambda (x) (class-of x)) supers))
             (all-cpls  (append-map (lambda (m)
                                      (cdr (class-precedence-list m)))
                                    all-metas))
             (needed-metas '()))
        ;; Find the most specific metaclasses.  The new metaclass will be
        ;; a subclass of these.
        (for-each
         (lambda (meta)
           (when (and (not (member meta all-cpls))
                      (not (member meta needed-metas)))
             (set! needed-metas (append needed-metas (list meta)))))
         all-metas)
        ;; Now return a subclass of the metaclasses we found.
        (if (null? (cdr needed-metas))
            (car needed-metas)  ; If there's only one, just use it.
            (ensure-metaclass-with-supers needed-metas)))))

;;;
;;; {Classes}
;;;

;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;;   OPTION ::= KEYWORD VALUE
;;;

(define (make-class supers slots . options)
  (define (find-duplicate l)
    (match l
      (() #f)
      ((head . tail)
       (if (memq head tail)
           head
           (find-duplicate tail)))))

  (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-definition-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 ...))
    (if (and (defined? 'name)
             (is-a? name <class>)
             (memq <object> (class-precedence-list name)))
        (class-redefinition name
                            (class supers slot ... #:name 'name))
        (toplevel-define! 'name (class supers slot ... #:name 'name)))))

(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 lp ((specs (method-specializers m)) (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)
  (%invalidate-method-cache! gf)
  (slot-set! gf 'n-specialized (calculate-n-specialized 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-definition-name car)

(define slot-definition-options cdr)

(define (slot-definition-allocation s)
  (get-keyword #:allocation (cdr s) #:instance))

(define (slot-definition-getter s)
  (get-keyword #:getter (cdr s) #f))

(define (slot-definition-setter s)
  (get-keyword #:setter (cdr s) #f))

(define (slot-definition-accessor s)
  (get-keyword #:accessor (cdr s) #f))

(define (slot-definition-init-value s)
  ;; can be #f, so we can't use #f as non-value
  (get-keyword #:init-value (cdr s) *unbound*))

(define (slot-definition-init-form s)
  (get-keyword #:init-form (cdr s) *unbound*))

(define (slot-definition-init-thunk s)
  (get-keyword #:init-thunk (cdr s) #f))

(define (slot-definition-init-keyword s)
  (get-keyword #:init-keyword (cdr s) #f))

(define (class-slot-definition class slot-name)
  (assq slot-name (class-slots class)))

(define (slot-init-function class slot-name)
  (cadr (assq slot-name (struct-ref class class-index-getters-n-setters))))

(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 (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-g-n-s class slot-name)
  (let* ((this-slot (assq slot-name (struct-ref class class-index-slots)))
         (getters-n-setters (struct-ref class class-index-getters-n-setters))
         (g-n-s (cddr (or (assq slot-name getters-n-setters)
                          (slot-missing class slot-name)))))
    (unless (memq (slot-definition-allocation this-slot)
                  '(#:class #:each-subclass))
      (slot-missing class slot-name))
    g-n-s))

(define (class-slot-ref class slot)
  (let ((x ((car (class-slot-g-n-s class slot)) #f)))
    (if (unbound? x)
        (slot-unbound class slot)
        x)))

(define (class-slot-set! class slot value)
  ((cadr (class-slot-g-n-s class 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))

;;;
;;; {Class redefinition utilities}
;;;

;;; (class-redefinition OLD NEW)
;;;

;;; Has correct the following conditions:

;;; Methods
;;;
;;; 1. New accessor specializers refer to new header
;;;
;;; Classes
;;;
;;; 1. New class cpl refers to the new class header
;;; 2. Old class header exists on old super classes direct-subclass lists
;;; 3. New class header exists on new super classes direct-subclass lists

(define-method (class-redefinition (old <class>) (new <class>))
  ;; Work on direct methods:
  ;;            1. Remove accessor methods from the old class
  ;;            2. Patch the occurences of new in the specializers by old
  ;;            3. Displace the methods from old to new
  (remove-class-accessors! old)                                 ;; -1-
  (let ((methods (class-direct-methods new)))
    (for-each (lambda (m)
                 (update-direct-method! m new old))     ;; -2-
              methods)
    (struct-set! new
                 class-index-direct-methods
                 (append methods (class-direct-methods old))))

  ;; Substitute old for new in new cpl
  (set-car! (struct-ref new class-index-cpl) old)

  ;; Remove the old class from the direct-subclasses list of its super classes
  (for-each (lambda (c) (struct-set! c class-index-direct-subclasses
                                     (delv! old (class-direct-subclasses c))))
            (class-direct-supers old))

  ;; Replace the new class with the old in the direct-subclasses of the supers
  (for-each (lambda (c)
              (struct-set! c class-index-direct-subclasses
                           (cons old (delv! new (class-direct-subclasses c)))))
            (class-direct-supers new))

  ;; Swap object headers
  (%modify-class old new)

  ;; Now old is NEW!

  ;; Redefine all the subclasses of old to take into account modification
  (for-each
   (lambda (c)
     (update-direct-subclass! c new old))
   (class-direct-subclasses new))

  ;; Invalidate class so that subsequent instances slot accesses invoke
  ;; change-object-class
  (struct-set! new class-index-redefined old)
  (class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set!

  old)

;;;
;;; remove-class-accessors!
;;;

(define-method (remove-class-accessors! (c <class>))
  (for-each (lambda (m)
              (when (is-a? m <accessor-method>)
                (let ((gf (slot-ref m 'generic-function)))
                  ;; remove the method from its GF
                  (slot-set! gf 'methods
                             (delq1! m (slot-ref gf 'methods)))
                  (invalidate-method-cache! gf)
                  ;; remove the method from its specializers
                  (remove-method-in-classes! m))))
            (class-direct-methods c)))

;;;
;;; update-direct-method!
;;;

(define-method (update-direct-method! (m  <method>)
                                      (old <class>)
                                      (new <class>))
  (let loop ((l (method-specializers m)))
    ;; Note: the <top> in dotted list is never used.
    ;; So we can work as if we had only proper lists.
    (when (pair? l)
      (when (eqv? (car l) old)
        (set-car! l new))
      (loop (cdr l)))))

;;;
;;; update-direct-subclass!
;;;

(define-method (update-direct-subclass! (c <class>)
                                        (old <class>)
                                        (new <class>))
  (class-redefinition c
                      (make-class (class-direct-supers c)
                                  (class-direct-slots c)
                                  #:name (class-name c)
                                  #:metaclass (class-of c))))

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

;;; compute-slot-accessors
;;;
(define (compute-slot-accessors class slots)
  (for-each
      (lambda (s g-n-s)
        (let ((getter-function (slot-definition-getter   s))
              (setter-function (slot-definition-setter   s))
              (accessor        (slot-definition-accessor s)))
          (if getter-function
              (add-method! getter-function
                           (compute-getter-method class g-n-s)))
          (if setter-function
              (add-method! setter-function
                           (compute-setter-method class g-n-s)))
          (if accessor
              (begin
                (add-method! accessor
                             (compute-getter-method class g-n-s))
                (add-method! (setter accessor)
                             (compute-setter-method class g-n-s))))))
      slots (struct-ref class class-index-getters-n-setters)))

(define-method (compute-getter-method (class <class>) slotdef)
  (let ((init-thunk (cadr slotdef))
        (g-n-s (cddr slotdef)))
    (make <accessor-method>
          #:specializers (list class)
          #:procedure (cond ((pair? g-n-s)
                             (make-generic-bound-check-getter (car g-n-s)))
                            (init-thunk
                             (standard-get g-n-s))
                            (else
                             (bound-check-get g-n-s)))
          #:slot-definition slotdef)))

(define-method (compute-setter-method (class <class>) slotdef)
  (let ((g-n-s (cddr slotdef)))
    (make <accessor-method>
          #:specializers (list class <top>)
          #:procedure (if (pair? g-n-s)
                          (cadr g-n-s)
                          (standard-set g-n-s))
          #:slot-definition slotdef)))

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

;;; Pre-generate getters and setters for the first 20 slots.
(define-syntax define-standard-accessor-method
  (lambda (stx)
    (define num-standard-pre-cache 20)
    (syntax-case stx ()
      ((_ ((proc n) arg ...) body)
       #`(define proc
           (let ((cache (vector #,@(map (lambda (n*)
                                          #`(lambda (arg ...)
                                              (let ((n #,n*))
                                                body)))
                                        (iota num-standard-pre-cache)))))
             (lambda (n)
               (if (< n #,num-standard-pre-cache)
                   (vector-ref cache n)
                   (lambda (arg ...) body)))))))))

(define-standard-accessor-method ((bound-check-get n) o)
  (let ((x (struct-ref o n)))
    (if (unbound? x)
        (slot-unbound o)
        x)))

(define-standard-accessor-method ((standard-get n) o)
  (struct-ref o n))

(define-standard-accessor-method ((standard-set n) o v)
  (struct-set! o n v))

;;; compute-getters-n-setters
;;;
(define (compute-getters-n-setters class slots)

  (define (compute-slot-init-function name s)
    (or (let ((thunk (slot-definition-init-thunk s)))
          (and thunk
               (if (thunk? thunk)
                   thunk
                   (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
                                name class thunk))))
        (let ((init (slot-definition-init-value s)))
          (and (not (unbound? init))
               (lambda () init)))))

  (define (verify-accessors slot l)
    (cond ((integer? l))
          ((not (and (list? l) (= (length l) 2)))
           (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
                        slot class l))
          (else
           (let ((get (car l))
                 (set (cadr l)))
             (unless (procedure? get)
               (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
                            slot class get))
             (unless (procedure? set)
               (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
                            slot class set))))))

  (map (lambda (s)
         ;; The strange treatment of nfields is due to backward compatibility.
         (let* ((index (slot-ref class 'nfields))
                (g-n-s (compute-get-n-set class s))
                (size (- (slot-ref class 'nfields) index))
                (name  (slot-definition-name s)))
           ;; NOTE: The following is interdependent with C macros
           ;; defined above goops.c:scm_sys_prep_layout_x.
           ;;
           ;; For simple instance slots, we have the simplest form
           ;; '(name init-function . index)
           ;; For other slots we have
           ;; '(name init-function getter setter . alloc)
           ;; where alloc is:
           ;;   '(index size) for instance allocated slots
           ;;   '() for other slots
           (verify-accessors name g-n-s)
           (case (slot-definition-allocation s)
             ((#:each-subclass #:class)
              (unless (and (zero? size) (pair? g-n-s))
                (error "Class-allocated slots should not reserve fields"))
              ;; Don't initialize the slot; that's handled when the slot
              ;; is allocated, in compute-get-n-set.
              (cons name (cons #f g-n-s)))
             (else
              (cons name
                    (cons (compute-slot-init-function name s)
                          (if (or (integer? g-n-s)
                                  (zero? size))
                              g-n-s
                              (append g-n-s (list index size)))))))))
       slots))

;;; 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-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))))

  (case (slot-definition-allocation s)
    ((#:instance) ;; Instance slot
     ;; get-n-set is just its offset
     (let ((already-allocated (struct-ref class class-index-nfields)))
       (struct-set! 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 loop ((l (cdr (class-precedence-list class))))
             (let ((r (assoc name
                             (struct-ref (car l)
                                         class-index-getters-n-setters))))
               (if r
                   (cddr r)
                   (loop (cdr l))))))))

    ((#: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 (make-closure-variable class value)
  (list (lambda (o) value)
        (lambda (o v) (set! value v))))

(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}."
  (unless (instance? obj)
    (scm-error 'wrong-type-arg #f "Not an object: ~S"
               (list obj) #f))
  (unless (even? (length initargs))
    (scm-error 'wrong-type-arg #f "Initargs has odd length: ~S"
               (list initargs) #f))
  (let ((class (class-of obj)))
    (define (get-initarg kw)
      (if kw
          (get-keyword kw initargs *unbound*)
          *unbound*))
    (let lp ((get-n-set (struct-ref class class-index-getters-n-setters))
             (slots (struct-ref class class-index-slots)))
      (match slots
        (() obj)
        (((name . options) . slots)
         (match get-n-set
           (((_ init-thunk . _) . get-n-set)
            (let ((initarg (get-initarg (get-keyword #:init-keyword options))))
              (cond
               ((not (unbound? initarg))
                (slot-set! obj name initarg))
               (init-thunk
                (slot-set! obj name (init-thunk)))))
            (lp get-n-set slots))))))))

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

(define-method (initialize (class <class>) initargs)
  (next-method)
  (let ((dslots (get-keyword #:slots initargs '()))
        (supers (get-keyword #:dsupers    initargs '())))
    (class-add-flags! class (logior vtable-flag-goops-class
                                    vtable-flag-goops-valid))
    (let ((name (get-keyword #:name initargs '???)))
      (struct-set! class class-index-name            name))
    (struct-set! class class-index-nfields           0)
    (struct-set! class class-index-direct-supers     supers)
    (struct-set! class class-index-direct-slots      dslots)
    (struct-set! class class-index-direct-subclasses '())
    (struct-set! class class-index-direct-methods    '())
    (struct-set! class class-index-cpl               (compute-cpl class))
    (struct-set! class class-index-redefined         #f)
    (let ((slots (compute-slots class)))
      (struct-set! class class-index-slots           slots)
      (let ((getters-n-setters (compute-getters-n-setters class slots)))
        (struct-set! class class-index-getters-n-setters getters-n-setters))
      ;; Build getters - setters - accessors
      (compute-slot-accessors class 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))))
              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)))


;;;
;;; {Change-class}
;;;

(define (change-object-class old-instance old-class new-class)
  (let ((new-instance (allocate-instance new-class '())))
    ;; Initialize the slots of the new instance
    (for-each
     (lambda (slot)
       (if (and (slot-exists? old-instance slot)
                (eq? (slot-definition-allocation
                      (class-slot-definition old-class slot))
                     #:instance)
                (slot-bound? old-instance slot))
           ;; Slot was present and allocated in old instance; copy it
           (slot-set! new-instance slot (slot-ref old-instance slot))
           ;; slot was absent; initialize it with its default value
           (let ((init (slot-init-function new-class slot)))
             (when init
               (slot-set! new-instance slot (init))))))
     (map slot-definition-name (class-slots new-class)))
    ;; Exchange old and new instance in place to keep pointers valid
    (%modify-instance old-instance new-instance)
    ;; Allow class specific updates of instances (which now are swapped)
    (update-instance-for-different-class new-instance old-instance)
    old-instance))


(define-method (update-instance-for-different-class (old-instance <object>)
                                                    (new-instance
                                                     <object>))
  ;;not really important what we do, we just need a default method
  new-instance)

(define-method (change-class (old-instance <object>) (new-class <class>))
  (change-object-class old-instance (class-of old-instance) new-class))

;;;
;;; {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
;;; `cache-dispatch' 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.
;; *fixme* use let
(define %%compute-applicable-methods
  (make <generic> #:name 'compute-applicable-methods))

(define-method (%%compute-applicable-methods (gf <generic>) args)
  (%compute-applicable-methods gf args))

(set! compute-applicable-methods %%compute-applicable-methods)

(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-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
                ))

;;;
;;; {Final initialization}
;;;

;; Tell C code that the main bulk of Goops has been loaded
(%goops-loaded)


\f

;;;
;;; {SMOB and port classes}
;;;

(define <arbiter> (find-subclass <top> '<arbiter>))
(define <promise> (find-subclass <top> '<promise>))
(define <thread> (find-subclass <top> '<thread>))
(define <mutex> (find-subclass <top> '<mutex>))
(define <condition-variable> (find-subclass <top> '<condition-variable>))
(define <regexp> (find-subclass <top> '<regexp>))
(define <hook> (find-subclass <top> '<hook>))
(define <bitvector> (find-subclass <top> '<bitvector>))
(define <random-state> (find-subclass <top> '<random-state>))
(define <async> (find-subclass <top> '<async>))
(define <directory> (find-subclass <top> '<directory>))
(define <array> (find-subclass <top> '<array>))
(define <character-set> (find-subclass <top> '<character-set>))
(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
(define <guardian> (find-subclass <applicable> '<guardian>))
(define <macro> (find-subclass <top> '<macro>))

(define (define-class-subtree class)
  (define! (class-name class) class)
  (for-each define-class-subtree (class-direct-subclasses class)))

(define-class-subtree (find-subclass <port> '<file-port>))