;;;; tinyclos.scm
;;;; A port of Kiczales TinyCLOS to Chicken - felix

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

; [felix] I have stolen several optimizations from Eli Barzilay's Swindle code
; - thanks anyway!

(module tinyclos

  (;export
    ;
    define-class define-generic define-method
    define-class*
    ;
    make-class make-generic make-method add-method
    make initialize
    slot-ref slot-value slot-set!
    class-of
    class-direct-supers class-direct-slots
    class-cpl class-slots
    generic-methods
    method-specializers method-procedure
    allocate-instance compute-cpl compute-slots
    compute-getter-and-setter
    compute-apply-generic compute-methods
    compute-method-more-specific?
    compute-apply-methods
    ;
    class? instance? generic?
    subclass? instance-of?
    class-name generic-name
    ;
    print-object
    ;
    add-primitive-class-of delete-primitive-class-of
    add-structure-class-of delete-structure-class-of
    add-extended-procedure-class-of delete-extended-procedure-class-of
    add-tagged-pointer-class-of delete-tagged-pointer-class-of
    ;
    <top> <object> <class>
    <procedure-class> <entity-class> <generic> <method>
    <immediate> <void> <null> <end-of-file> <boolean> <char>
    <number> <integer> <exact> <inexact>
    <symbol> <sequence> <vector> <pair> <string>
    <port> <input-port> <output-port> <procedure>
    <blob> <byte-vector> <structure> <environment> <hash-table>
    <promise> <queue> <condition> <condition-variable>
    <continuation> <char-set> <time> <lock> <mmap> <array>
    <tcp-listener> <thread> <mutex> <regexp> <read-table>
    <locative> <pointer> <swig-pointer> <tagged-pointer>
    <u8vector> <u16vector> <u32vector>
    <s8vector> <s16vector> <s32vector> <f32vector>
    <f64vector> <c++-object>
    <primitive> <primitive-class>)

  (import
    scheme
    chicken
    foreign
    (only extras randomize fprintf)
    (only data-structures sort)
    (only lolevel procedure-data))

  (require-library extras data-structures lolevel)

;;; Macros:

;;

(define-syntax define-class
  (syntax-rules ()

    ((_ ?name () ?slots)
      (define-class ?name (<object>) ?slots) )

    ((_ ?name ?supers ?slots)
      (define-class ?name ?supers ?slots <class>) )

    ((_ ?name () ?slots ?meta)
      (define-class ?name (<object>) ?slots ?meta) )

    ((_ ?name (?supers ...) (?slots ...) ?meta)
      (define ?name
        (make ?meta
          'name '?name
          'direct-supers (list ?supers ...)
          'direct-slots (list '?slots ...))) ) ) )

;confusing name, it doesn't `define' in the usual sense
;maybe `make-anonymous-class'?

(define-syntax define-class*
  (syntax-rules ()

    ((_ () ?slots)
      (define-class* (<object>) ?slots) )

    ((_ ?supers ?slots)
      (define-class* ?supers ?slots <class>) )

    ((_ () ?slots ?meta)
      (define-class* (<object>) ?slots ?meta) )

    ((_ (?supers ...) (?slots ...) ?meta)
      (make ?meta
        'direct-supers (list ?supers ...)
        'direct-slots (list '?slots ...)) ) ) )

;;

(define-syntax define-generic
  (syntax-rules ()

    ((_ ?name ?class)
      (define ?name (make ?class 'name '?name)) )

    ((_ ?name)
      (define ?name (make-generic '?name)) ) ) )

;confusing name, it doesn't `define' in the usual sense
;maybe `new-method'?

(define-syntax (define-method f r c)
  (let ((head (cadr f))
        (body (cddr f)) )
    (##sys#check-syntax 'define-method head '(symbol . _))
    (##sys#check-syntax 'define-method body '#(_ 1))
    (let gather ((args (cdr head))
                 (specs '())
                 (vars '()) )
      (if (or (not (pair? args))
              (memq (car args) '(#!optional #!key #!rest)))
          (let ((name (car head)))
            `(,(r 'add-method) ,name
               (,(r 'make-method) (,(r 'list) ,@(reverse specs))
                 ;; `call-next-method' not renamed:
                 (,(r 'lambda) (call-next-method ,@(reverse vars) . ,args) ,@body) ) ) )
          (let ((arg (car args)))
            (gather (cdr args)
                    (cons (if (pair? arg) (cadr arg) (r '<top>)) specs)
                    (cons (if (pair? arg) (car arg) arg) vars) ) ) ) ) ) )

;;; Helpers:

;; Aliases for some non-obvious sys routines

(define-inline (%undefined? x) (##core#inline "C_undefinedp" x))

(define-inline (%unbound? x) (eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0)))

(define-inline (%string-length s) (##sys#size s))

(define-inline (%car p) (##sys#slot p 0))
(define-inline (%cdr p) (##sys#slot p 1))
(define-inline (%cadr p) (%car (%cdr p)))
(define-inline (%cddr p) (%cdr (%cdr p)))
(define-inline (%set-car! p y) (##sys#setslot p 0 y))
(define-inline (%set-cdr! p y) (##sys#setslot p 1 y))

(define-inline (%stream-port x) (and (port? x) (eq? 'stream (##sys#slot x 7))))
(define-inline (%custom-port x) (and (port? x) (eq? 'custom (##sys#slot x 7))))
(define-inline (%string-port x) (and (port? x) (eq? 'string (##sys#slot x 7))))
(define-inline (%tcp-port x) (and (port? x) (eq? 'tcp (##sys#slot x 7))))

(define-inline (%vector-ref v i) (##sys#slot v i))
(define-inline (%vector-set! v i x) (##sys#setslot v i x))
(define-inline (%vector-length v) (##sys#size v))
(define-inline (%vector-become-structure! v) (##core#inline "C_vector_to_structure" v))
(define-inline (%vector-become-closure! v) (##core#inline "C_vector_to_closure" v))

; (%make-structure+ tag extra-fields-count fixed-field-initial-value ...)
; this is a common pattern
; assume compiler will constant-fold
; note that the tag is an identifier, quoted for actual tag, also used as the
; temp variable

(define-syntax %make-structure+
  (syntax-rules ()

    ((_ "aux" () ?count ?initial ?struc ?fixed (?body ...))
      (let ((?struc (make-vector (+ ?count ?fixed) ?initial)))
        (%vector-become-structure! ?struc)
        ?body ...
        ?struc ) )

    ((_ "aux" (?field ?rest ...) ?count ?initial ?struc ?fixed (?body ...))
      (%make-structure+ "aux"
        (?rest ...)
        ?count ?initial ?struc (fx+ ?fixed 1)
        ((%structure-set! ?struc ?fixed ?field) ?body ...)) )

    ((_ ?tag (?count ?initial) ?field ...)
      (%make-structure+ "aux"
        ('?tag ?field ...)
        ?count ?initial ?tag 0
        ()) )

    ((_ ?tag ?count ?field ...)
      (%make-structure+ ?tag (?count #f) ?field ...) ) ) )

(define-syntax %structure?
  (syntax-rules ()

    ((_ ?x)
      (##sys#generic-structure? ?x) )

    ((_ ?x ?t)
      (##sys#structure? ?x ?t) ) ) )

(define-inline (%structure-ref r i) (##sys#slot r i))
(define-inline (%structure-set! r i x) (##sys#setslot r i x))
(define-inline (%structure-length r) (##sys#size r))
(define-inline (%structure-tag r) (##sys#slot r 0))

(define-inline (%closure-ref c i) (##sys#slot c i))
(define-inline (%closure-length c) (##sys#size c))
(define-inline (%closure-copy-address! from to) (##core#inline "C_copy_pointer" from to))

(define-inline (%pointer? x) (##core#inline "C_pointerp" x)) ;not anypointer
(define-inline (%null-pointer? p) (##sys#null-pointer? p))

(define-inline (%tagged-pointer? x) (##core#inline "C_taggedpointerp" x))
(define-inline (%tagged-pointer-data p) (##sys#slot p 1))

(define-inline (%swig-pointer? x) (##core#inline "C_swigpointerp" x))

(define-inline (%locative? x) (##core#inline "C_locativep" x))

(define-inline (%random-fixnum x) (##core#inline "C_random_fixnum" x))

; Error messages will not mutate!

(define-syntax %error
  (syntax-rules ()
    ((_ ?msg ?arg0 ...)
      (##sys#error (##core#immutable '?msg) ?arg0 ...) ) ) )

(define-syntax %error@
  (syntax-rules ()
    ((_ ?loc ?msg ?arg0 ...)
      (##sys#error ?loc (##core#immutable '?msg) ?arg0 ...) ) ) )
;;

(define-inline (->boolean x)
  (and x
       #t) )

(define-inline (every/1 test lst)
  (let loop ((lst lst))
    (or (null? lst)
        (and (test (%car lst))
             (loop (%cdr lst)) ) ) ) )

(define-inline (delete!/1 test lst)
  (let loop ((cpair lst) (ppair #f))
    (cond ((null? cpair) lst )
          ((test (%car cpair))
            (if ppair
                (begin (%set-cdr! ppair (%cdr cpair)) lst)
                (%cdr cpair)) )
          (else (loop (%cdr cpair) cpair) ) ) ) )

(define-inline (any/1 test lst)
  (let loop ((lst lst))
    (and (not (null? lst))
         (if (test (%car lst))
             (%car lst)
             (loop (%cdr lst)) ) ) ) )

(define (filter-in f l)
  (let loop ((l l))
    (cond ((null? l) '())
          (else
            (let ((h (%car l ))
                  (r (%cdr l)) )
              (if (f h)
                  ; Unlike SRFI-1 filter this doesn't share the undeleted longest tail
                  #;(let ([t (loop r)]) (if (eq? r t) l (cons h t)))
                  (cons h (loop r))
                  (loop r) ) ) ) ) ) )

; more descriptive than a gensym
(define-syntax define-unique-object
  (syntax-rules ()
    ((_ ?name)
      (define ?name (vector '?name)) ) ) )

;;

#; ;UNUSED
(define (check-class loc x)
  (unless (class? x)
    (##sys#signal-hook #:type-error loc "bad argument type - not a class" x) )
  x )

;;; TinyCLOS:

;
; A very simple CLOS-like language, embedded in Scheme, with a simple
; MOP.  The features of the default base language are:
;
;   * Classes, with instance slots, but no slot options.
;   * Multiple-inheritance.
;   * Generic functions with multi-methods and class specializers only.
;   * Primary methods and call-next-method; no other method combination.
;   * Uses Scheme's lexical scoping facilities as the class and generic
;     function naming mechanism.  Another way of saying this is that
;     class, generic function and methods are first-class (meta)objects.
;
; While the MOP is simple, it is essentially equal in power to both MOPs
; in AMOP.  This implementation is not at all optimized, but the MOP is
; designed so that it can be optimized.  In fact, this MOP allows better
; optimization of slot access extenstions than those in AMOP.
;
;
; In addition to calling a generic, the entry points to the default base
; language are:
;
;   (MAKE-CLASS list-of-superclasses list-of-slot-names)
;   (MAKE-GENERIC)
;   (MAKE-METHOD list-of-specializers procedure)
;   (ADD-METHOD generic method)
;
;   (MAKE class . initargs)
;   (INITIALIZE instance initargs)            ;Add methods to this,
;                                             ;don't call it directly.
;
;   (SLOT-REF  object slot-name)
;   (SLOT-SET! object slot-name new-value)
;
;
; So, for example, one might do (but only within this file! 'getl' is not exported):
;
;   (define <position> (make-class (list <object>) (list 'x 'y)))
;   (add-method initialize
;       (make-method (list <position>)
;         (lambda (call-next-method pos initargs)
;           (for-each (lambda (initarg-name slot-name)
;                       (slot-set! pos slot-name (getl initargs initarg-name 0)))
;                     '(x y)
;                     '(x y)))))
;
;   (set! p1 (make <position> 'x 1 'y 3))
;
;
; NOTE!  Do not use EQUAL? to compare objects!  Use EQ? or some hand
;        written procedure.  Objects have a pointer to their class,
;        and classes are circular structures, and ...
;
;
; The introspective part of the MOP looks like the following.  Note that
; these are ordinary procedures, not generics.
;
;   CLASS-OF
;
;   CLASS-DIRECT-SUPERS
;   CLASS-DIRECT-SLOTS
;   CLASS-CPL
;   CLASS-SLOTS
;
;   GENERIC-METHODS
;
;   METHOD-SPECIALIZERS
;   METHOD-PROCEDURE
;
;
; The intercessory protocol looks like (generics in uppercase):
;
;   make
;     ALLOCATE-INSTANCE
;     INITIALIZE                   (really a base-level generic)
;
;   class initialization
;     COMPUTE-CPL
;     COMPUTE-SLOTS
;     COMPUTE-GETTER-AND-SETTER
;
;   add-method                     (Notice this is not a generic!)
;     COMPUTE-APPLY-GENERIC
;       COMPUTE-METHODS
;         COMPUTE-METHOD-MORE-SPECIFIC?
;       COMPUTE-APPLY-METHODS
;

(define fast-getl
  (foreign-lambda* scheme-object ((scheme-object initargs) (scheme-object name) (scheme-object def)) "
    while(initargs != C_SCHEME_END_OF_LIST) {
      if(name == C_block_item(initargs, 0)) {
        if((initargs = C_block_item(initargs, 1)) == C_SCHEME_END_OF_LIST) return(def);
        else return(C_block_item(initargs, 0));
      }
      initargs = C_block_item(initargs, 1);
    }
    return(def);") )

(define-unique-object not-found-object)

(define (getl initargs name . def)
  (let ((value (fast-getl initargs name not-found-object)))
    (if (eq? value not-found-object)
        (optional def (%error@ 'getl "cannot find item" name initargs))
        value ) ) )

;
; A simple topological sort.
;
; This is a fairly modified version of code I originally got from Anurag
; Mendhekar <anurag@moose.cs.indiana.edu>.
;

(define (compute-std-cpl c get-direct-supers)

  (define (top-sort elements constraints tie-breaker)
    (let loop ((elements    elements)
               (constraints constraints)
               (result      '()))
        (if (null? elements)
            result
            (let ((can-go-in-now
                    (filter-in
                      (lambda (x)
                        (every/1 (lambda (constraint)
                                   (or (not (eq? (%cadr constraint) x))
                                       (memq (%car constraint) result)))
                               constraints))
                      elements)))
              (if (null? can-go-in-now)
                  (%error@ 'top-sort "invalid constraints")
                  (let ((choice (if (null? (%cdr can-go-in-now))
                                    (%car can-go-in-now)
                                    (tie-breaker result can-go-in-now))))
                    (loop (filter-in (lambda (x) (not (eq? x choice))) elements)
                          ; Include all constraints
                          #;(filter-in (lambda (x) (not (eq? (%cadr x) choice))) constraints)
                          constraints
                          (append result (list choice))))))) ) )

  (define ((std-tie-breaker get-supers) partial-cpl min-elts)
    (let loop ((pcpl (reverse partial-cpl)))
      (let* ((current-elt (%car pcpl))
            (ds-of-ce (get-supers current-elt))
            (common (filter-in (cut memq <> ds-of-ce) min-elts)))
        (if (null? common)
            (let ((r (%cdr pcpl)))
              (if (null? r)
                  (%error@ 'std-tie-breaker "nothing valid")
                  (loop r)) )
            (%car common)) ) ) )

  (define ((build-transitive-closure get-follow-ons) x)
    (let track ((result '())
                (pending (list x)))
         (if (null? pending)
             result
             (let ((next (%car pending)))
               (if (memq next result)
                   (track result (%cdr pending))
                   (track (cons next result)
                          (append (get-follow-ons next)
                                  (%cdr pending)))))) ) )

  (define ((build-constraints get-follow-ons) x)
    (let loop ((elements ((build-transitive-closure get-follow-ons) x))
               (this-one '())
               (result '()))
         (if (or (null? this-one) (null? (%cdr this-one)))
             (if (null? elements)
                 result
                 (loop (%cdr elements)
                       (cons (%car elements)
                             (get-follow-ons (%car elements)))
                       result))
             (loop elements
                   (%cdr this-one)
                   (cons (list (%car this-one) (%cadr this-one))
                         result))) ) )

  (top-sort ((build-transitive-closure get-direct-supers) c)
            ((build-constraints get-direct-supers) c)
            (std-tie-breaker get-direct-supers) ) )

;;; Method cache support code:

#>
#define C_METHOD_CACHE_SIZE 8
<#

(define-foreign-variable method-cache-size int "C_METHOD_CACHE_SIZE")

(define method-caching-enabled #f)

(define method-cache-tag #f)

(define (make-method-cache)
  (cons method-cache-tag (make-vector (arithmetic-shift method-cache-size 1) #f)) )

(define method-cache-lookup
  (foreign-lambda* scheme-object ((scheme-object mcache) (scheme-object hash) (scheme-object classes)) "
    C_word v = C_block_item(mcache, 1);
    C_word clist, x, y;
    int free_index = -1;
    int i = ((C_unfix(hash) & (C_METHOD_CACHE_SIZE - 1)) << 1) & 0xffff,
        i0, i2;
    for(i0 = i;; i = i2) {
      clist = C_block_item(v, i);
      if(clist != C_SCHEME_FALSE) {
        x = classes;
        y = clist;
        while(x != C_SCHEME_END_OF_LIST && y != C_SCHEME_END_OF_LIST) {
          if(C_block_item(x, 0) != C_block_item(y, 0)) goto mismatch;
          else {
            x = C_block_item(x, 1);
            y = C_block_item(y, 1);
          }
        }
        if (x == C_SCHEME_END_OF_LIST && y == C_SCHEME_END_OF_LIST)
          return(C_block_item(v, i + 1));
        else
          goto mismatch;
      }
      else if(free_index == -1) free_index = i;
    mismatch:
      i2 = (i + 2) & ((C_METHOD_CACHE_SIZE << 1) - 1);
      if(i2 == i0) return(free_index == -1 ? C_SCHEME_FALSE : C_fix(free_index));
    }") )

;
; Then, we need to build what, in a more real implementation, would be
; the interface to the memory subsystem: instances and entities.  The
; former are used for instances of instances of <class>; the latter
; are used for instances of instances of <entity-class>.  In this MOP,
; none of this is visible to base- or MOP-level programmers.
;
; A few things to note, that have influenced the way all this is done:
;
;   - R4RS doesn't provide a mechanism for specializing the
;     behavior of the printer for certain objects.
;
;   - Some Scheme implementations bomb when printing circular
;     structures -- that is, arrays and/or lists that somehow
;     point back to themselves.
;
; So, the natural implementation of instances -- vectors whose first
; field point to the class -- is straight on out.  Instead, we use a
; procedure to `encapsulate' that natural representation.
;
; Having gone that far, it makes things simpler to unify the way normal
; instances and entities are handled, at least in the lower levels of
; the system.  Don't get faked out by this -- the user shouldn't think
; of normal instances as being procedures, they aren't. (At least not
; in this language.)  If you are using this to teach, you probably want
; to hide the implementation of instances and entities from people.
;

;
; (One might consider rewriting the definition of instances using
; define-record or something.  It doesn't turn out to make it much
; simpler, at least not to me.  It also breaks the nice parallelism
; with entities.)
;
; %allocate-instance, %allocate-entity, get-field, set-field!, and class-of are
; the normal interface, from the rest of the code, to the low-level memory
; system.
;
; One thing to take note of is that the protocol does not allow the user
; to add low-level instance representations.  I have never seen a way to make
; that work.
;

; Instance

(define the-slots-of-a-class            ;
  '(direct-supers                       ;(class ...)
    direct-slots                        ;((name . options) ...)
    cpl                                 ;(class ...)
    slots                               ;((name . options) ...)
    nfields                             ;an integer
    field-initializers                  ;(proc ...)
    getters-n-setters                   ;((slot-name getter . setter) ...)
    name) )                             ;name

; structure: tag class cache direct-supers ... name
(define-constant basic-class-instance-size 11)

(define (%allocate-instance class nfields)
  (%make-structure+ instance nfields class #f) )

(define-inline (%instance? x)
  (%structure? x 'instance))

(define-inline (%instance-class instance)
  (%structure-ref instance 1))

(define-inline (%set-instance-class! instance new-value)
  (%structure-set! instance 1 new-value))

(define-inline (%instance-cache-ref instance)
  (%structure-ref instance 2))

(define-inline (%instance-cache-set! instance x)
  (%structure-set! instance 2 x))

(define-inline (%instance-ref instance index)
  (%structure-ref instance (+ index 3)))

(define-inline (%instance-set! instance index new-value)
  (%structure-set! instance (+ index 3) new-value))

; Class

(define-inline (%class? x)
  (and (%instance? x) (%instance-cache-ref x)) )

; Entity

(define-unique-object entity-tag)

(define %allocate-entity
  (let ((default-proc
          (lambda args
            (%error@ '%allocate-entity "called entity without first setting proc"))) )
    (lambda (class nfields name)
      (letrec ((entity-def (%make-structure+ entity nfields default-proc class name #f))
               (closure (lambda args (apply (%structure-ref entity-def 1) args))))
        (let ((len (%closure-length closure)))
          (let ((entity (make-vector (+ len 2))) )
            (do ((i 1 (add1 i)))
                ((<= len i)
                 (%vector-set! entity i entity-def)
                 (%vector-set! entity (add1 i) entity-tag)
                 (%vector-become-closure! entity)
                 (%closure-copy-address! closure entity)
                 entity)
              (%vector-set! entity i (%closure-ref closure i)) ) ) ) ) ) ) )

(define-inline (%entity? x)
  (and (procedure? x)
       (let ((len (%closure-length x)))
         (and (< 3 len)
              (eq? entity-tag (%closure-ref x (sub1 len))) ) ) ) )

(define-inline (%entity-def entity)
  (%closure-ref entity (- (%closure-length entity) 2)) )

(define-inline (%set-entity-proc! entity proc)
  (%structure-set! (%entity-def entity) 1 proc) )

(define-inline (%entity-class entity)
  (%structure-ref (%entity-def entity) 2) )

(define-inline (%entity-name entity)
  (%structure-ref (%entity-def entity) 3) )

(define-inline (%set-entity-name! entity x)
  (%structure-set! (%entity-def entity) 3 x) )

(define-inline (%entity-cache-ref entity)
  (%structure-ref (%entity-def entity) 4) )

(define-inline (%entity-cache-set! entity x)
  (%structure-set! (%entity-def entity) 4 x) )

(define-inline (%entity-ref entity index)
  (%structure-ref (%entity-def entity) (+ index 5)) )

(define-inline (%entity-set! entity index new-value)
  (%structure-set! (%entity-def entity) (+ index 5) new-value) )

; Instance/Entity field accessors

(define get-field
  (lambda (object field)
    (cond ((%instance? object) (%instance-ref object field))
          ((%entity?   object) (%entity-ref   object field))
          (else
           (##sys#signal-hook #:type-error 'get-field
            "can only get-field of instances and entities" object)))))

(define set-field!
  (lambda (object field new-value)
    (cond ((%instance? object) (%instance-set! object field new-value))
          ((%entity?   object) (%entity-set!   object field new-value))
          (else
           (##sys#signal-hook #:type-error 'set-field!
            "can only set-field! of instances and entities" object)))))

;
; Note that this implementation of class-of assumes the names of the
; primitive classes that are set up later.
;

; Class-of extension helpers
;
; Implemented as a map: "test" <-> "class"

; symbol
(define-inline (classmap-item-key cmi)
  (%car cmi) )

; predicate
(define-inline (classmap-item-predicate cmi)
  (%car cmi) )

; class
(define-inline (classmap-item-class cmi)
  (%cdr cmi) )

;

(define-inline (classmap-item-key-set! cmi key)
  (%set-car! cmi key) )

#; ;UNUSED - predicate treated same as tag
(define-inline (classmap-item-predicate-set! cmi key)
  (%set-car! cmi key) )

(define-inline (classmap-item-class-set! cmi class)
  (%set-cdr! cmi class) )

;

(define-inline (classmap-add! cm key class)
  (cons (cons key class) cm) )

;

(define (classmap-item?/eq cmi key)
  (eq? key (classmap-item-key cmi)) )

(define (classmap-item?/predicate cmi key)
  ((classmap-item-predicate cmi) key) )

(define (classmap-item?/class cmi class)
  (eq? class (classmap-item-class cmi)) )

;

(define-inline (classmap-item/eq cm key)
  (any/1 (cut classmap-item?/eq <> key) cm) )

(define-inline (classmap-item/predicate cm key)
  (any/1 (cut classmap-item?/predicate <> key) cm) )

(define (classmap-item/class cm class)
  (any/1 (cut classmap-item?/class <> class) cm) )

;

(define-inline (classmap-class/eq cm key)
  (and-let* ((cmi (classmap-item/eq cm key)))
    (classmap-item-class cmi) ) )

(define-inline (classmap-class/predicate cm key)
  (and-let* ((cmi (classmap-item/predicate cm key)))
    (classmap-item-class cmi) ) )

;

(define (classmap-delete!/key cm key)
  (delete!/1 (cut classmap-item?/eq <> key) cm) )

(define (classmap-delete!/class cm class)
  (delete!/1 (lambda (cmi) (eq? class (classmap-item-class cmi))) cm) )

(define (classmap-delete! cm obj)
  (if (%class? obj)
      (classmap-delete!/class cm obj)
      (classmap-delete!/key cm obj) ) )

;

(define (classmap-update!/key cm key class)
  (let ((cmi (classmap-item/eq cm key)))
    (if cmi
        (begin (classmap-item-class-set! cmi class) cm)
        (classmap-add! cm key class) ) ) )

#; ;UNUSED - update only by key (test object)
(define (classmap-update!/class cm key class)
  (let ((cmi (classmap-item/class cm class)))
    (if cmi
        (begin (classmap-item-key-set! cmi key) cm)
        (classmap-add! cm key class) ) ) )

; Primitive class-of extensions

(define +primitive-class-map+ '())

(define-inline (primitive-class-of x)
  (classmap-class/predicate +primitive-class-map+ x) )

(define (delete-primitive-class-of obj)
  (set! +primitive-class-map+
        (classmap-delete! +primitive-class-map+ obj)) )

(define (add-primitive-class-of pred class)
  (set! +primitive-class-map+
        (classmap-update!/key +primitive-class-map+ pred class)) )

; Structure class-of extensions

(define +structure-class-map+ '())

(define-inline (structure-class-of x)
  (or (classmap-class/eq +structure-class-map+ (%structure-tag x))
      <structure>) )

(define (delete-structure-class-of obj)
  (set! +structure-class-map+
        (classmap-delete! +structure-class-map+ obj)) )

(define (add-structure-class-of tag class)
  (set! +structure-class-map+
        (classmap-update!/key +structure-class-map+ tag class)) )

; Tagged-pointer class-of extensions

(define +tagged-pointer-class-map+ '())

(define-inline (tagged-pointer-class-of x)
  (or (classmap-class/eq +tagged-pointer-class-map+ (%tagged-pointer-data x))
      <tagged-pointer>) )

(define (delete-tagged-pointer-class-of obj)
  (set! +tagged-pointer-class-map+
        (classmap-delete! +tagged-pointer-class-map+ obj)) )

(define (add-tagged-pointer-class-of tag class)
  (set! +tagged-pointer-class-map+
        (classmap-update!/key +tagged-pointer-class-map+ tag class)) )

; Extended-procedure class-of extensions

(define +extended-procedure-class-map+ '())

(define-inline (procedure-class-of x)
  (or (classmap-class/predicate +extended-procedure-class-map+ (procedure-data x))
      <procedure>) )

(define (delete-extended-procedure-class-of obj)
  (set! +extended-procedure-class-map+
        (classmap-delete! +extended-procedure-class-map+ obj)) )

(define (add-extended-procedure-class-of pred class)
  (set! +extended-procedure-class-map+
        (classmap-update!/key +extended-procedure-class-map+ pred class)) )

;

(define (class-of x)
  (cond ((%unbound? x)
         (%error@ 'class-of "unbound object"))
        ((%instance? x)                 (%instance-class x)) ;assume most common
        ((fixnum? x)                    <exact>)
        ((null? x)                      <null>)
        ((boolean? x)                   <boolean>)
        ((char? x)                      <char>)
        ((eof-object? x)                <end-of-file>)
        ((%undefined? x)                <void>)
        ((##sys#immediate? x)
         (%error@ 'class-of "unidentified immediate object - cannot infer class" x))
        ((flonum? x)                    <inexact>)
        ((integer? x)                   <integer>)
        ((symbol? x)                    <symbol>)
        ((%entity? x)                   (%entity-class x))
        ((procedure? x)                 (procedure-class-of x))
        ((vector? x)                    <vector>)
        ((pair? x)                      <pair>)
        ((string? x)                    <string>)
        ((port? x)                      (if (input-port? x) <input-port> <output-port>))
        ((##sys#bytevector? x)          <blob>)
        ((%tagged-pointer? x)           (tagged-pointer-class-of x))
        ((%swig-pointer? x)             <swig-pointer>)
        ((%pointer? x)                  <pointer>)
        ((%locative? x)                 <locative>)
        ((%structure? x)
         (case (%structure-tag x)
           ((environment)               <environment>)
           ((array)                     <array>)
           ((hash-table)                <hash-table>)
           ((queue)                     <queue>)
           ((condition)                 <condition>)
           ((condition-variable)        <condition-variable>)
           ((char-set)                  <char-set>)
           ((time)                      <time>)
           ((lock)                      <lock>)
           ((mmap)                      <mmap>)
           ((promise)                   <promise>)
           ((u8vector)                  <u8vector>)
           ((s8vector)                  <s8vector>)
           ((u16vector)                 <u16vector>)
           ((s16vector)                 <s16vector>)
           ((u32vector)                 <u32vector>)
           #;((s64vector)                 <s64vector>)
           #;((u64vector)                 <u64vector>)
           ((s32vector)                 <s32vector>)
           ((f32vector)                 <f32vector>)
           ((f64vector)                 <f64vector>)
           ((tcp-listener)              <tcp-listener>)
           ((thread)                    <thread>)
           ((mutex)                     <mutex>)
           ((continuation)              <continuation>)
           ((read-table)                <read-table>)
           ((regexp)                    <regexp>)
           (else
             (structure-class-of x)) ) )
        ((primitive-class-of x))
        (else
          (%error@ 'class-of "unidentified primitive object - cannot infer class" x) ) ) )

;
; Now we can get down to business.  First, we initialize the braid.
;
; For Bootstrapping, we define an early version of MAKE.  It will be
; changed to the real version later on.  String search for ``set! make''.
;

;
; These are the real versions of slot-ref and slot-set!. Because of the
; way the new slot access protocol works, with no generic call inline,
; they can be defined up front like this.  Cool eh?
;

(define-inline (checked-basic-slot-name->index loc object slot-name)
  (case slot-name
    ((direct-supers)        0)
    ((direct-slots)         1)
    ((cpl)                  2)
    ((slots)                3)
    ((nfields)              4)
    ((field-initializers)   5)
    ((getters-n-setters)    6)
    ((name)                 7)
    (else
      (%error@ loc "no such basic slot" slot-name object)) ) )

(define-inline (ensure-slot-info loc class slot-name)
  (or (lookup-slot-info class slot-name)
      (%error@ loc "no such slot in instances of class" slot-name class) ) )

(define (*slot-ref object slot-name)
  ; if true, then this is an instance of <class>, with no additional slots
  (if (%class? object)
      (%instance-ref object (checked-basic-slot-name->index 'slot-ref object slot-name))
      (let* ((info   (ensure-slot-info 'slot-ref (class-of object) slot-name))
             (getter (%car info)))
        (getter object))) )

(define (*slot-set! object slot-name new-value)
  (let* ((info   (ensure-slot-info 'slot-set! (class-of object) slot-name))
         (setter (%cdr info)) )
    (setter object new-value)) )

(define slot-ref (getter-with-setter *slot-ref *slot-set!))
(define slot-value slot-ref) ;for compatibility with "coops"
(define slot-set! *slot-set!)

(define (lookup-slot-info class slot-name)
  (let* ((getters-n-setters
          (if (eq? class <class>)         ;* This grounds out
              getters-n-setters-for-class ;* the slot-ref tower.
              (*slot-ref class 'getters-n-setters)))
         (entry (assq slot-name getters-n-setters)))
    (and entry (%cdr entry)) ) )

;
; Given that the early version of MAKE is allowed to call accessors on
; class metaobjects, the definitions for them come here, before the
; actual class definitions, which are coming up right afterwards.
;

(define (class-direct-slots class)
  (*slot-ref class 'direct-slots) )

(define (class-direct-supers class)
  (*slot-ref class 'direct-supers))

(define (class-slots class)
  (*slot-ref class 'slots) )

(define (class-name class)
  (*slot-ref class 'name))

(define (generic-methods generic)
  (*slot-ref generic 'methods) )

(define (method-specializers method)
  (*slot-ref method 'specializers) )

(define (method-procedure method)
  (*slot-ref method 'procedure) )

(define (class-cpl class)
  (*slot-ref class 'cpl) )

;;

(randomize)

(define (make class . initargs)
  (cond ((or (eq? class <class>)
             (eq? class <entity-class>))
         (let* ((new (%allocate-instance class (length the-slots-of-a-class)))
                (dsupers (fast-getl initargs 'direct-supers '()))
                (name (fast-getl initargs 'name "(anonymous)"))
                (dslots  (map list (fast-getl initargs 'direct-slots '())))
                (cpl     (let loop ((sups dsupers) (so-far (list new)))
                           (if (null? sups)
                               (reverse so-far)
                               (let ((cls (%car sups)))
                                 (loop (class-direct-supers cls) (cons cls so-far))))))
                (slots (apply append dslots (map class-direct-slots (%cdr cpl))))
                (nfields 0)
                (field-initializers '())
                (allocator
                 (lambda (init)
                   (let ((f nfields))
                     (set! nfields (add1 nfields))
                     (set! field-initializers
                       (cons init field-initializers))
                     (values (lambda (o)   (get-field  o f))
                             (lambda (o n) (set-field! o f n))))))
                (getters-n-setters
                 (map (lambda (s)
                        (cons (%car s)
                              (call-with-values (lambda () (allocator (lambda () (void))))
                                                cons) ) )
                      slots)))
           (*slot-set! new 'direct-supers      dsupers)
           (*slot-set! new 'direct-slots       dslots)
           (*slot-set! new 'cpl                cpl)
           (*slot-set! new 'slots              slots)
           (*slot-set! new 'nfields            nfields)
           (*slot-set! new 'field-initializers (reverse field-initializers))
           (*slot-set! new 'getters-n-setters  getters-n-setters)
           (*slot-set! new 'name               name)
           (%instance-cache-set! new (%random-fixnum #x10000))
           new))
        ((eq? class <generic>)
         (let ((new (%allocate-entity class (length (class-slots class))
                                      (fast-getl initargs 'name "(unnamed)") ) ) )
           (*slot-set! new 'methods '())
           new))
        ((eq? class <method>)
         (let ((new (%allocate-instance class (length (class-slots class)))))
           (*slot-set! new 'specializers (getl initargs 'specializers))
           (*slot-set! new 'procedure    (getl initargs 'procedure))
           new))
        (else
          (%error@ 'make "bootstrap: unknown class" class)) ) )

;;; Direct slot access inside this module only:

(define-syntax define-direct-accessor
  (syntax-rules ()
    ((_ ?name ?slot) (define-inline (?name class) (slot-ref class '?slot))) ) )

(define-direct-accessor class-direct-slots direct-slots)
(define-direct-accessor class-direct-supers direct-supers)
(define-direct-accessor class-slots slots)
(define-direct-accessor class-name name)
(define-direct-accessor generic-methods methods)
(define-direct-accessor method-specializers specializers)
(define-direct-accessor method-procedure procedure)
(define-direct-accessor class-cpl cpl)

;
; The next 7 clusters define the 6 initial classes.  It takes 7 to 6
; because the first and fourth both contribute to <class>.
;

(define getters-n-setters-for-class       ;see lookup-slot-info
  (let loop ((lst the-slots-of-a-class) (i 0))
    (if (null? lst)
        '()
        (cons (cons (%car lst)
                    (cons (lambda (o)   (%instance-ref  o i))
                          (lambda (o n) (%instance-set! o i n)) ) )
              (loop (%cdr lst) (add1 i)) ) ) ) )

(define <class> (%allocate-instance #f (length the-slots-of-a-class)))
(%set-instance-class! <class> <class>)

(define <top>          (make <class>
                             'direct-supers '()
                             'direct-slots  '()
                             'name          "top"))

(define <object>       (make <class>
                             'direct-supers (list <top>)
                             'direct-slots  '()
                             'name          "object"))

;
; This cluster, together with the first cluster above that defines
; <class> and sets its class, have the effect of:
;
;   (define <class>
;     (make <class>
;           'direct-supers (list <object>)
;           'direct-slots  (list 'direct-supers ...)))
;

(%instance-set! <class> 0 (list <object>))                  ;d supers
(%instance-set! <class> 1 (map list the-slots-of-a-class))  ;d slots
(%instance-set! <class> 2 (list <class> <object> <top>))    ;cpl
(%instance-set! <class> 3 (map list the-slots-of-a-class))  ;slots
(%instance-set! <class> 4 (length the-slots-of-a-class))    ;nfields
(%instance-set! <class> 5 (map (lambda (s)                  ;field-ini..
                                 (lambda () (void)))
                               the-slots-of-a-class))
(%instance-set! <class> 6 '())
(%instance-set! <class> 7 "class")
(%instance-cache-set! <class> (%random-fixnum #x10000))

(define <procedure-class> (make <class>
                                'direct-supers (list <class>)
                                'direct-slots  '()
                                'name          "procedure-class"))

(define <entity-class>    (make <class>
                                'direct-supers (list <procedure-class>)
                                'direct-slots  '()
                                'name          "entity-class"))

(define <generic>         (make <entity-class>
                                'direct-supers (list <object>)
                                'direct-slots  (list 'methods)
                                'name          "generic"))

(define <method>          (make <class>
                                'direct-supers (list <object>)
                                'direct-slots  (list 'specializers 'procedure)
                                'name          "method"))

;
; These are the convenient syntax we expose to the base-level user.
;

(define (make-class direct-supers direct-slots . name)
  (make <class>
        'direct-supers direct-supers
        'direct-slots  direct-slots
        'name          (optional name "(anonymous)")) )

(define (make-generic . name)
  (make <generic>
        'name         (optional name "(unnamed)")) )

(define (make-method specializers procedure)
  (make <method>
        'specializers specializers
        'procedure    procedure) )

;
; The initialization protocol
;

(define initialize (make-generic "initialize"))

;
; The instance structure protocol.
;

(define allocate-instance (make-generic "allocate-instance"))
(define compute-getter-and-setter (make-generic "compute-getter-and-setter"))

;
; The class initialization protocol.
;

(define compute-cpl (make-generic "compute-cpl"))
(define compute-slots (make-generic "compute-slots"))

;
; The generic invocation protocol.
;

(define compute-apply-generic         (make-generic "compute-apply-generic"))
(define compute-methods               (make-generic "compute-methods"))
(define compute-method-more-specific? (make-generic "compute-method-more-specific?"))
(define compute-apply-methods         (make-generic "compute-apply-methods"))

;
; The next thing to do is bootstrap generic functions.
;

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

(define (add-method generic method)
  (*slot-set!
    generic
    'methods
    (let* ((ms1 (method-specializers method))
           (l1 (length ms1)) )
      (let filter-in-method ((methods (*slot-ref generic 'methods)))
        (if (null? methods)
            (list method)
            (let* ((mm (%car methods))
                   (ms2 (method-specializers mm))
                   (l2 (length ms2)))
              (cond ((< l2 l1)
                     (cons mm (filter-in-method (%cdr methods))))
                    ((< l1 l2)
                     (cons method methods))
                    (else
                     (let check-method ((ms1 ms1) (ms2 ms2))
                       (cond ((and (null? ms1) (null? ms2))
                              (cons method (%cdr methods))) ;; skip existing methods
                             ((eq? (%car ms1) (%car ms2))
                              (check-method (%cdr ms1) (%cdr ms2)))
                             (else
                              (cons mm (filter-in-method (%cdr methods)))))))))))))
    (if (memq generic generic-invocation-generics)
        (set! method-cache-tag (vector))
        (%entity-cache-set! generic #f) )
    (%set-entity-proc! generic (compute-apply-generic generic)) )

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

(%set-entity-proc! compute-apply-generic
     (lambda (generic)      ;The ONE time this is called
                            ;it doesn't get cnm.
       (lambda args
         (apply (method-procedure (car (generic-methods generic)))
                #f args)))) ;But, the ONE time it is run,
                            ;it needs to pass a dummy
                            ;value for cnm!

(let ((symbol-vector (vector 'instance entity-tag)))

  ; Compute class ID from object
  (define hash-arg-list
    (foreign-lambda* unsigned-int ((scheme-object args) (scheme-object svector)) "
      C_word tag, h, x;
      int n, i, j, len = 0;
      for(i = 0; args != C_SCHEME_END_OF_LIST; args = C_block_item(args, 1)) {
        x = C_block_item(args, 0);
        if(C_immediatep(x)) {
          switch(x) {
            case C_SCHEME_END_OF_LIST: i += 1; break;
            case C_SCHEME_TRUE:
            case C_SCHEME_FALSE: i += 3; break;
            case C_SCHEME_END_OF_FILE: i += 7; break;
            case C_SCHEME_UNDEFINED: i += 5; break;
            default:
              if(x & C_FIXNUM_BIT) i += 2;
              else i += 4;
          }
        }
        else {
          h = C_header_bits(x);
          switch(h) {
          case C_STRUCTURE_TYPE:
            tag = C_block_item(x, 0);
            if(tag == C_block_item(svector, 0)) { /* instance */
              if((tag = C_block_item(C_block_item(x, 1), 2)) != C_SCHEME_FALSE) i += C_unfix(tag);
              else i += C_header_size(x) << 4;
            }
            else i += 17;
            break;
          case C_CLOSURE_TYPE:
            n = C_header_size(x);
            if(n > 3 && C_block_item(svector, 1) == C_block_item(x, n - 1)) {
              if((tag = C_block_item(C_block_item(C_block_item(x, n - 2), 2), 2)) != C_SCHEME_FALSE) i += C_unfix(tag);
              else i += 13;
            }
            break;
          case C_SYMBOL_TYPE: i += 8; break;
          case C_BYTEVECTOR_TYPE: i += 16; break;
          case C_VECTOR_TYPE: i += 9; break;
          case C_PAIR_TYPE: i += 10; break;
          case C_FLONUM_TYPE: i += 11; break;
          case C_STRING_TYPE: i += 12; break;
          case C_PORT_TYPE: i += C_block_item(x, 1) ? 15 : 14; break;
          default: i += 255;
          }
        }
        ++len;
      }
      return((i + len) & (C_METHOD_CACHE_SIZE - 1));") )

  (add-method compute-apply-generic
    (make-method (list <generic>)
      (lambda (call-next-method generic)
        (lambda args
          (let ((mc (%entity-cache-ref generic)))
            (when (or (not mc) (not (eq? method-cache-tag (%car mc))))
              (set! mc (make-method-cache))
              (%entity-cache-set! generic mc) )
            (let* ((classes (and method-caching-enabled (map class-of args)))
                   (key (and classes (hash-arg-list args symbol-vector)))
                   (e (and classes (method-cache-lookup mc key classes))) )
              ;(unless (##sys#immediate? e) (print (%entity-name generic) ": " key))
              (if (not (##sys#immediate? e))
                  (e args)
                  (let ((cam
                         (if (and (memq generic generic-invocation-generics)
                                  (memq (car args) generic-invocation-generics))
                             (let ((proc
                                    (method-procedure
                                      ; select the first method of one argument
                                     (let loop ((lis (generic-methods generic)))
                                       (if (null? lis)
                                         (%error@ 'compute-apply-generic
                                          "cannot find original")
                                         (let* ((h (%car lis))
                                                (ms (method-specializers h)))
                                           (if (= 1 (length ms))
                                               h
                                               (loop (%cdr lis))))))) ) )
                               (lambda (args) (apply proc #f args)) )
                             (let ((x (compute-apply-methods generic))
                                   (y ((compute-methods generic) args)) )
                               (lambda (args) (x y args)) ) ) ) )
                    (when (and e method-caching-enabled)
                      (let ((v (%cdr mc)))
                        (%vector-set! v e classes)
                        (%vector-set! v (add1 e) cam) ) )
                    (cam args) ) ) ) ) ) ) ) ) )

;Only used by `compute-methods' directly below
(define-inline (applicable? c arg)
  (memq c (class-cpl (class-of arg))) )

(add-method compute-methods
  (make-method (list <generic>)
    (lambda (call-next-method generic)
      (lambda (args)
        (let ((applicable
               (filter-in (lambda (method)
                            (let check-applicable ((lst1 (method-specializers method))
                                                   (lst2 args))
                              (cond ((null? lst1) #t)
                                    ((null? lst2) #f)
                                    (else
                                      (and (applicable? (%car lst1) (%car lst2))
                                           (check-applicable (%cdr lst1) (%cdr lst2)))))))
                          (generic-methods generic) ) ) )
          (if (or (null? applicable) (null? (%cdr applicable)))
              applicable
              (let ((cmms (compute-method-more-specific? generic)))
                (sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) )

;Only used by `compute-method-more-specific?' directly below
(define-inline (more-specific? c1 c2 arg)
  (memq c2 (memq c1 (class-cpl (class-of arg)))) )

(add-method compute-method-more-specific?
  (make-method (list <generic>)
    (lambda (call-next-method generic)
      (lambda (m1 m2 args)
        (let loop ((specls1 (method-specializers m1))
                   (specls2 (method-specializers m2))
                   (args args))
          (cond-expand
           (unsafe
            (let ((c1  (%car specls1))
                  (c2  (%car specls2))
                  (arg (%car args)))
              (if (eq? c1 c2)
                  (loop (%cdr specls1)
                        (%cdr specls2)
                        (%cdr args))
                  (more-specific? c1 c2 arg))) )
           (else
            (cond ((and (null? specls1) (null? specls2))
                   (%error@ 'compute-method-more-specific?
                    "two methods are equally specific" generic))
                  #; ; Ok to have diff # of specializers
                  ((or (null? specls1) (null? specls2))
                   (%error@ 'compute-method-more-specific?
                    "two methods have different number of specializers" generic))
                  ((null? specls1) #f)
                  ((null? specls2) #t)
                  ((null? args)
                   (%error@ 'compute-method-more-specific?
                    "fewer arguments than specializers" generic))
                  (else
                   (let ((c1  (%car specls1))
                         (c2  (%car specls2))
                         (arg (%car args)))
                     (if (eq? c1 c2)
                         (loop (%cdr specls1)
                               (%cdr specls2)
                               (%cdr args))
                         (more-specific? c1 c2 arg)))) ) ) ) ) ) ) ) )

(add-method compute-apply-methods
  (make-method (list <generic>)
    (lambda (call-next-method generic)
      (lambda (methods args)
        (letrec ((one-step
                  (lambda (tail)
                    (lambda ()
                      (cond-expand
                       (unsafe)
                       (else
                        (when (null? tail)
                          (%error "call-next-method: no methods left" generic) ) ) )
                      (apply (method-procedure (%car tail))
                             (one-step (%cdr tail)) args)))))
          ((one-step methods)))))))

(add-method initialize
  (make-method (list <top>)
    (lambda (call-next-method object initargs)
      (%error@ 'initialize "top: cannot initialize object" object) ) ) )

(add-method initialize
  (make-method (list <object>)
    (lambda (call-next-method object initargs) object)))

; canonicalize name
; - public class name nomenclature of '<' ... '>' -> ...
; - #f -> ""
; - name

;Only used by `initialize' directly below
(define-inline (canonicalize-class-name loc initname dfltname)
  (if (not initname)
      dfltname
      (let* ((namestr
              (cond ((string? initname) initname)
                    ((symbol? initname) (##sys#symbol->string initname))
                    (else
                     (##sys#signal-hook #:type-error loc
                      "invalid class name" initname) ) ) )
             (namestrlen (%string-length namestr)) )
        (cond ((zero? namestrlen)
               "" )
              ((and (char=? #\< (string-ref namestr 0))
                    (char=? #\> (string-ref namestr (sub1 namestrlen))) )
               (substring namestr 1 (sub1 namestrlen)) )
              ((symbol? initname)
               (string-copy namestr) ) ;do not use the symbol's "raw" printname
              (else
               namestr ) ) ) ) )

(add-method initialize
  (make-method (list <class>)
    (lambda (call-next-method class initargs)
      (call-next-method)
      (*slot-set! class 'direct-supers (fast-getl initargs 'direct-supers '()))
      (let ((dslots
              (map (lambda (s) (if (pair? s) s (list s)))
                   (fast-getl initargs 'direct-slots '()))))
        (*slot-set! class 'direct-slots dslots)
        (*slot-set! class 'cpl (compute-cpl class))
        (*slot-set! class 'name
                           (canonicalize-class-name 'initialize
                            (let ((name (fast-getl initargs 'name not-found-object)))
                              (and (not (eq? name not-found-object)) name) )
                            "(anonymous)"))
        (let ((slots (compute-slots class)))
          (*slot-set! class 'slots slots)
          (when (= basic-class-instance-size (%structure-length class))
            (%instance-cache-set! class (%random-fixnum #x10000)) )
          (let* ((nfields 0)
                 (field-initializers '())
                 (allocator
                  (lambda (init)
                    (let ((f nfields))
                      (set! nfields (add1 nfields))
                      (set! field-initializers (cons init field-initializers))
                      (values (lambda (o)   (get-field  o f))
                              (lambda (o n) (set-field! o f n))))))
                 (getters-n-setters
                  (map (lambda (slot)
                         (cons (%car slot)
                               (call-with-values
                                (lambda ()
                                  (compute-getter-and-setter class slot allocator))
                                cons) ) )
                       slots) ) )
            (*slot-set! class 'nfields nfields)
            (*slot-set! class 'field-initializers (reverse field-initializers))
            (*slot-set! class 'getters-n-setters getters-n-setters))))) ) )

(add-method initialize
  (make-method (list <generic>)
    (lambda (call-next-method generic initargs)
      (call-next-method)
      (unless (%entity? generic)
        (%error@ 'initialize "generic: not an entity" generic) )
      (*slot-set! generic 'methods '())
      (%set-entity-name! generic (fast-getl initargs 'name "(unnamed)"))
      (%set-entity-proc! generic (lambda args (%error "generic: has no methods" generic))))))

(add-method initialize
  (make-method (list <method>)
    (lambda (call-next-method method initargs)
      (call-next-method)
      (*slot-set! method 'specializers (getl initargs 'specializers))
      (*slot-set! method 'procedure    (getl initargs 'procedure)))))

(add-method allocate-instance
  (make-method (list <class>)
    (lambda (call-next-method class)
      (let* ((field-initializers (*slot-ref class 'field-initializers))
             (new (%allocate-instance class (length field-initializers))))
        (let loop ((n 0) (inits field-initializers))
          (if (null? inits)
              new
              (begin
                (%instance-set! new n ((%car inits)))
                (loop (add1 n) (%cdr inits)))))))))

(add-method allocate-instance
  (make-method (list <entity-class>)
    (lambda (call-next-method class)
      (let* ((field-initializers (*slot-ref class 'field-initializers))
             (new (%allocate-entity class (length field-initializers) "(unnamed)") ) )
        (let loop ((n 0) (inits field-initializers))
          (if (null? inits)
              new
              (begin
                (%entity-set! new n ((%car inits)))
                (loop (add1 n) (%cdr inits)))))))))

(add-method compute-cpl
  (make-method (list <class>)
    (lambda (call-next-method class)
      (compute-std-cpl class class-direct-supers))))

(add-method compute-slots
  (make-method (list <class>)
    (lambda (call-next-method class)
      (let collect ((to-process (apply append (map class-direct-slots (class-cpl class))))
                    (result '()))
        (if (null? to-process)
            (reverse result)
            (let* ((current (%car to-process))
                   (name (%car current))
                   (others '())
                   (remaining-to-process
                     (filter-in (lambda (o)
                                  (or (not (eq? (%car o) name))
                                      (begin (set! others (cons o others)) #f)))
                                (%cdr to-process))))
              (collect remaining-to-process
                       (cons (append current (apply append (map (lambda (x) (%cdr x)) others)))
                             result))))))))

(add-method compute-getter-and-setter
  (make-method (list <class>)
    (lambda (call-next-method class slot allocator)
      (allocator (lambda () (void))))))

; The definition of <primitive> needs to be before the definition of the real MAKE,
; which needs to check for attempts to make a primitive object.

(define <primitive>
  (make <class>
        'direct-supers (list <top>)
        'direct-slots  '()
        'name          "primitive"))

;
; Now everything works, both generic functions and classes, so we can
; turn on the real MAKE.
;

; Re-define `make'

(set! make
  (lambda (class . initargs)
    (if (memq <primitive> (compute-cpl class)) ; subclass of <primitive>?
        (void) ; unspecified - cannot make!
        (let ((instance (allocate-instance class)))
          (initialize instance initargs)
          instance))))

;
; Now define what CLOS calls `built in' classes.
;

(define-class <primitive-class> (<class>) ())

(define-method (initialize (object <primitive>) #!optional (initargs '()))
  object )

(define (make-primitive-class name . supers)
  (make <primitive-class>
        'direct-supers (if (null? supers) (list <primitive>) supers)
        'direct-slots '()
        'name         name) )

;convenience routines to elide an argument

(define (make-immediate-class name . supers)
  (apply make-primitive-class name <immediate> supers) )

(define (make-sequence-class name . supers)
  (apply make-primitive-class name <sequence> supers) )

(define (make-port-class name . supers)
  (apply make-primitive-class name <port> supers) )

(define (make-vector-class name . supers)
  (apply make-primitive-class name <vector> supers) )

(define (make-pointer-class name . supers)
  (apply make-primitive-class name <pointer> supers) )

(define (make-structure-class name . supers)
  (apply make-primitive-class name <structure> supers) )

;the primitives

(define <immediate>             (make-primitive-class "immediate"))
(define <void>                  (make-immediate-class "void"))
#;(define <unspecified>           (make-immediate-class "unspecified")) ;better?
(define <end-of-file>           (make-immediate-class "end-of-file"))
(define <boolean>               (make-immediate-class "boolean"))
(define <char>                  (make-immediate-class "char"))

(define <symbol>                (make-primitive-class "symbol"))

(define <sequence>              (make-primitive-class "null"))
(define <null>                  (make-immediate-class "null" <sequence>))
(define <vector>                (make-sequence-class "vector"))
(define <pair>                  (make-sequence-class "pair"))
(define <string>                (make-sequence-class "string"))

(define <number>                (make-primitive-class "number"))
(define <integer>               (make-primitive-class "integer" <number>))
(define <exact>                 (make-primitive-class "exact" <integer>))
(define <inexact>               (make-primitive-class "inexact" <number>))

(define <port>                  (make-primitive-class "port"))
(define <input-port>            (make-port-class "input-port"))
(define <output-port>           (make-port-class "output-port"))

(define <procedure>             (make-primitive-class "procedure" <primitive> <procedure-class>))

(define <blob>                  (make-primitive-class "blob"))
(define <byte-vector>           (make-primitive-class "byte-vector")) ; DEPRECATED

(define <locative>              (make-primitive-class "locative"))

(define <pointer>               (make-primitive-class "pointer"))
(define <swig-pointer>          (make-pointer-class "swig-pointer"))
(define <tagged-pointer>        (make-pointer-class "tagged-pointer"))

;? structure -> record

(define <structure>             (make-primitive-class "structure"))
(define <environment>           (make-structure-class "environment" <sequence>))
(define <promise>               (make-structure-class "promise"))
(define <condition>             (make-structure-class "condition"))
(define <condition-variable>    (make-structure-class "condition-variable"))
(define <continuation>          (make-structure-class "continuation"))
(define <read-table>            (make-structure-class "read-table"))
(define <queue>                 (make-structure-class "queue" <sequence>))
(define <hash-table>            (make-structure-class "hash-table" <sequence>))
(define <char-set>              (make-structure-class "char-set" <sequence>))
(define <time>                  (make-structure-class "time"))
(define <thread>                (make-structure-class "thread"))
(define <mutex>                 (make-structure-class "mutex"))
(define <lock>                  (make-structure-class "lock"))
(define <mmap>                  (make-structure-class "mmap"))
(define <tcp-listener>          (make-structure-class "tcp-listener"))
(define <regexp>                (make-structure-class "regexp"))

(define <array>                 (make-structure-class "array" <sequence>))

(define <u8vector>              (make-vector-class "u8vector"))
(define <s8vector>              (make-vector-class "s8vector"))
(define <u16vector>             (make-vector-class "u16vector"))
(define <s16vector>             (make-vector-class "s16vector"))
(define <u32vector>             (make-vector-class "u32vector"))
(define <s32vector>             (make-vector-class "s32vector"))
#;(define <u64vector>             (make-vector-class "u64vector"))
#;(define <s64vector>             (make-vector-class "s64vector"))
(define <f32vector>             (make-vector-class "f32vector"))
(define <f64vector>             (make-vector-class "f64vector"))

;;

(define-class <c++-object> (<object>) (this))

(define-method (initialize (obj <c++-object>) #!optional (initargs '()))
  (when (and (pair? initargs) (eq? 'this (car initargs)))
    (*slot-set! obj 'this (cadr initargs)) ) )

;;

(set! method-caching-enabled #t)

;;; Introspection extras:

(define (class? x)
  (->boolean (%class? x)) )

; generic procedures are considered "instances"
(define (instance? x)
  (or (%instance? x) (%entity? x)) )

(define (generic? x)
  (%entity? x) )

(define (subclass? x y)
  (->boolean (and (%class? x) (memq y (compute-cpl x)))) )

(define (instance-of? x class)
  (let ((x-class (class-of x)))
    (or (eq? x-class class)
        (subclass? x-class class) ) ) )

(define (generic-name x)
  (and (%entity? x)
       (%entity-name x)) )

;;; Extra Protocol:

;;

(define-generic print-object)

(define-method (print-object (x <object>) #!optional (port ##sys#standard-output))
  (fprintf port "#<~A>" (class-name (class-of x))) )

(define-method (print-object (x <primitive>) #!optional (port ##sys#standard-output))
  (write x port) )

(define-method (print-object (x <class>) #!optional (port ##sys#standard-output))
  (fprintf port "#<class ~A>" (class-name x)) )

(define-method (print-object (x <generic>) #!optional (port ##sys#standard-output))
  (fprintf port "#<generic ~A>" (generic-name x)) )

(define-record-printer (instance x out)
	(print-object x out) )

;;

  (import
    (only extras sprintf)
    (only data-structures intersperse))

  (require-library extras data-structures)

  (export describe-object)

  (include "describe-object-body")

;;; Utilities:

  (export
    slot@ initialize-slots make/copy make-instance/pointer)

  (include "tinyclos-utils-body")

) ;module tinyclos