stk/STklos/stklos.stk

;;;;
;;;; s t k l o s . s t k    -- A variation of the Gregor Kickzales Tiny CLOS
;;;;			      for STk
;;;;
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 20-Feb-1994 21:09
;;;; Last file update: 27-Sep-1999 12:05 (eg)

(when (provided? "stklos") 
  (error "STklos already initialized."))

(%init-stklos)			  ; Initialize STklos
(with-module STk (import STklos)) ; Import the STklos module
(select-module STklos)		  ; Rest of file belongs to the STklos module
(export				  ; Define the exported symbols of this file
    find-class is-a?
    ensure-metaclass ensure-metaclass-with-supers
    define-class   make-class ensure-class
    define-generic make-generic-function ensure-generic-function
    define-method  ensure-method method add-method
    object-eqv? object-equal?
    write-object display-object Tk-write-object
    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-form slot-definition-init-keyword 
    slot-init-function class-slot-definition
    method-body
    compute-get-n-set
    allocate-instance initialize make-instance make
    no-next-method  no-applicable-method no-method next-method-exists?
    change-class 
    shallow-clone deep-clone
    apply-generic apply-method apply-methods compute-applicable-methods 
    method-more-specific? sort-applicable-methods
    class-subclasses class-methods
    slot-value (setter slot-value)
)

;=============================================================================
;
;			      U t i l i t i e s
;
;=============================================================================

(define (mapappend func . args)
  (if (memv '()  args)
      '()
      (append (apply func (map car args))
	      (apply mapappend func (map cdr args)))))

(define (find-duplicate l)	; find a duplicate in a list; #f otherwise
  (cond 
    ((null? l)			#f)
    ((memv (car l) (cdr l))	(car l))
    (else 			(find-duplicate (cdr l)))))

;--------------------------------------------------
(define (set-symbol! symbol value env)
  (let ((module (%get-module env)))
    (eval `(define ,symbol ,value) (module-environment module))))

(define (lookup-symbol symbol env)
  (let ((module (%get-module env)))
    (eval symbol (module-environment module))))

(define make-closure eval)

;--------------------------------------------------
(define (specializers l)
  (cond
   ((null? l) '())
   ((pair? l) (cons (if (pair? (car l)) (cadar l) '<top>)
		    (specializers (cdr l))))
   (else      '<top>)))

(define (formals l)
  (if (pair? l)
      (cons (if (pair? (car l)) (caar l) (car l)) (formals (cdr l)))
      l))

;--------------------------------------------------
; 						[FIXME] This is too complicate
(define (%find-class name env . default)
  (if (symbol? name)
      ;; Search symbol in the globals of given env. (it must denote a class)
      (or (and (symbol-bound? name env)
	       (let ((cls (lookup-symbol name env)))
		 (and (is-a? cls <class>) cls)))
	  (if (null? default)
	      (error "find-class: class ~S not found" name)
	      (car default)))
      (if (is-a? name <class>) 
	  name
	  (error "find-class: bad-class ~S" name))))

;=============================================================================

;;
;; Find-class
;;
(define-macro (find-class name . default)
  (let ((%find-class (with-module STklos %find-class)))
    `(apply ,%find-class ,name ,(the-environment) ',default)))

;;
;; is-a?
;;
(define (is-a? obj class)
  (and (memv class (class-precedence-list (class-of obj))) #t))


;=============================================================================
;
; 			M e t a c l a s s e s   s t u f f
;
;=============================================================================

(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 env)
  (if (null? supers)
      (%find-class '<class> env)
      (let* ((all-metas (map (lambda (x)
			       (if (is-a? x <class>)
				   x
				   (class-of (%find-class x env))))
			     supers))
	     (all-cpls  (apply 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)))))

;=============================================================================
;
; 			D e f i n e - c l a s s
;
;=============================================================================

;==== Define-class
(define-macro (define-class name supers slots . options)
  `(begin 
     (make-class ,name ,supers ,slots ,@options) 
     (make-undefined)))

;==== Make-class
(define-macro (make-class name supers slots . options)
  `(ensure-class
       ',name							; name
       ',supers							; supers
       ',slots							; slots 
       ,(or (get-keyword :metaclass options #f)			; metaclass
	    `(ensure-metaclass ',supers (the-environment)))
       (the-environment)					; environment
       ,@options))

;==== Ensure-class
(define (ensure-class name supers slots metaclass env . options)
  (let ((supers (if (null? supers) 
		    (list (%find-class '<object> env))
		    (map (lambda (x) (%find-class x env)) 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))))
      (when tmp1
	(error "define-class: super class ~S is duplicate in class ~S" tmp1 name))
      (when tmp2
	(error "define-class: slot ~S is duplicate in class ~S" tmp2 name)))

    ;; Everything seems correct, build the class
    (let ((old (%find-class name env #f))
	  (cls (apply make metaclass :dsupers supers :slots slots 
		      :name name :environment env options)))
      (when old (class-redefinition old cls))
      (set-symbol! name cls env)
      cls)))

;=============================================================================
;
; 			D e f i n e - g e n e r i c
;
;=============================================================================

; ==== Define-generic
(define-macro (define-generic gf)
  `(begin
     (make-generic-function ,gf)
     (make-undefined)))
       

;==== Make-generic-function
(define-macro (make-generic-function gf)
  `(ensure-generic-function ',gf (the-environment)))

;==== Ensure-generic-function
(define (ensure-generic-function name env)
  (let* ((name      (extended-name->scheme-name name))
	 (old-value (and (symbol-bound? name env) 
;FIXME:			 (not (autoload? name module))
			 (lookup-symbol name env))))
    (set-symbol! name 
		 (make <generic> 
		       :name    name 
		       :default (and (procedure? old-value) old-value))
		 env)))
		 

;=============================================================================
;
; 			D e f i n e - m e t h o d
;
;=============================================================================

(define-macro (define-method name args . body)
  `(begin
     (ensure-method ',name
		    ',(formals args)
		    ',(specializers args)
		    ',body
		    (the-environment))
     (make-undefined)))

(define (ensure-method name formals specializers body env . kind-of-method)
  (let* ((name      (and name (extended-name->scheme-name name)))
	 (old-value (and name 
			 (symbol-bound? name env) 
;FIXME:			 (not (autoload? name module))
			 (lookup-symbol name env))))

    ;; See if a generic function must be defined for this method.
    (when (and name (not (is-a? old-value <generic>)))
      (ensure-generic-function name env))
    
    ;; Define the method and, eventually, add it to its generic
    (let ((method (make (if (null? kind-of-method) <method> (car kind-of-method))
			:specializers (map* (lambda (x) 
					      (if (symbol? x) 
						  (%find-class x env)
						  x))
					    specializers)
			:procedure (make-closure
				    `(lambda (next-method ,@formals) ,@body)
				    env))))
      (when name (add-method (lookup-symbol name env) method))
      ; Return the newly created method as result
      method)))

;====  Method

(define-macro (method args . body)
  `(begin
     (ensure-method #f
		    ',(formals args)
		    ',(specializers args)
		    ',body
		    (the-environment))))

;==== 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 (memv m dm)
		   (slot-set! x '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)
	       (slot-set! x 'direct-methods (remv m (class-direct-methods x))))
	      (method-specializers m)))

(define (compute-new-list-of-methods gf new)
  (let ((new-spec (method-specializers new))
	(methods  (generic-function-methods gf)))
    (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)))))))

;;
;; Add-method
;;
(define (add-method gf m)
  (slot-set! m  'generic-function gf)
  (slot-set! gf 'methods (compute-new-list-of-methods gf m))
  (add-method-in-classes m)
  m)

;=============================================================================
;
; 			      Access to Meta objects
;
; A lot of them are in C
;=============================================================================

;;;
;;; Methods
;;;
(define-method method-body ((m <method>))
  (let* ((spec (map class-name (slot-ref m 'specializers)))
	 (proc (procedure-body (slot-ref m 'procedure)))
	 (args (cdadr proc))
	 (body (cddr proc)))
    (list* 'method (map list args spec) body)))

;;;
;;; Slots
;;;
(define (slot-definition-name s)
  (if (pair? s) (car s) s))

(define (slot-definition-options s)
  (and (pair? s) (cdr s)))

(define (slot-definition-allocation s)
  (if (symbol? s)
      :instance
      (get-keyword :allocation (cdr s) :instance)))

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

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

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

(define (slot-definition-init-form s)
  (if (pair? s) 
      (let* ((none (list '**none**))
	     (v1   (get-keyword :init-form (cdr s) none))
	     (v2   (get-keyword :initform  (cdr s) none))) ; Backward compatibility
	(if (eq? v1 none)
	    (if (eq? v2 none)
		(make-unbound)
		v2)
	    v1))
      (make-unbound)))

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

(define (slot-init-function c s)
  (let ((s (slot-definition-name s)))
    (cadr (assoc s (slot-ref c 'getters-n-setters)))))

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


;=============================================================================
;
; 			    Standard methods   
; 			used by the C runtime
;
;=============================================================================

;==== Methods to compare objects

(define-method object-eqv? (x y)    #f)
(define-method object-equal? (x y)  (eqv? x y))

;==== 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-method write-object (o file)
  (format file "#[instance ~A]" (address-of o)))

(define-method write-object ((o <object>) file)
  (let ((class (class-of o)))
    (if (slot-bound? class 'name) 
	(format file "#[~A ~A]" (class-name class) (address-of o))
	(next-method))))

(define-method write-object((class <class>) file)
  (let ((meta (class-of class)))
    (if (and (slot-bound? class 'name) (slot-bound? meta 'name)) 
	(format file "#[~A ~A ~A]" (class-name meta) (class-name class)
				   (address-of class))
	(next-method))))

(define-method write-object((gf <generic>) file)
  (let ((meta (class-of gf)))
    (if (and (slot-bound? gf 'name) (slot-bound? meta 'name)
	     (slot-bound? gf 'methods))
	(format file "#[~A ~A (~A)]" (class-name meta)
				     (generic-function-name gf)
				     (length (generic-function-methods gf)))
	(next-method))))

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

;; Tk-write-object is called when a STklos object is passed to a Tk-command.
;; By default, we do the same job as write; but if an object is a <Tk-widget>
;; we will pass it its Eid. The method for <Tk-widget> is defined elsewhere.
(define-method Tk-write-object (o file)
  (write-object o file))

;==== Slot access

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

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

(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)
  (error "No next method when calling ~S\nwith ~S as argument" gf args))

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

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


(define-macro (next-method-exists?)
  `((with-module STklos %next-method-exists?) next-method))

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

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

(define-method deep-clone  ((self <object>))
  (let ((clone (%allocate-instance (class-of self)))
	(slots (map slot-definition-name
		    (class-slots (class-of self)))))
    (for-each (lambda (slot)
		(if (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

(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 old in the specializers by new
  ;;		3. Displace the methods from old to new
  (remove-class-accessors old)					;; -1-
  (let ((methods (class-direct-methods old)))
    (for-each (lambda (m) (update-direct-method m old new))	;; -2-
	      methods)
    (slot-set! new 'direct-methods methods))			;; -3-

  ;; Remove the old class from the direct-subclasses list of its super classes
  (for-each (lambda (c) (slot-set! c 'direct-subclasses 
				   (remv old (class-direct-subclasses c))))
	    (class-direct-supers old))

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

  ;; Invalidate class so that subsequent instances slot accesses invoke
  ;; change-object-class
  (slot-set! old 'redefined new))


;==== Remove-class-accessors

(define-method remove-class-accessors ((c <class>))
  (for-each 
     (lambda (m) (if (is-a? m <accessor-method>) (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)))
    (when (pair? l)       	; Note: the <top> in dotted list is never used. 
      (if (eqv? (car l) old)  ; So we can work if we had only proper lists.
	(set-car! l new))
      (Loop (cdr l)))))

;==== Update-direct-subclass

(define-method update-direct-subclass ((c <class>) (old <Class>) (new <Class>))
  (let ((new-supers (map (lambda (cls) (if (eqv? cls old) new cls))
			 (class-direct-supers c))))
    ;; Create a new class with same name as c. This will automagically call 
    ;; class-redefinition on this subclass and redefine all its descent
    (ensure-class (class-name c)
		  new-supers
		  (class-direct-slots c)
		  (class-of c)
		  (slot-ref c 'environment))))

;=============================================================================
;
; 			Utilities for INITIALIZE methods
;
;=============================================================================

;;;
;;; compute-slot-accessors
;;;
(define (compute-slot-accessors class slots env)
  (for-each
      (lambda (s)
	(let ((name     (slot-definition-name     s))
	      (getter   (slot-definition-getter   s))
	      (setter   (slot-definition-setter   s))
	      (accessor (slot-definition-accessor s)))
	  (when getter
	    (ensure-method getter (list 'o) (list class)
			   `((slot-ref o ',name)) 
			   env <accessor-method>))
	  (when setter
	    (ensure-method setter (list 'o 'v) (list class <top>)
			   `((slot-set! o ',name v)) 
			   env <accessor-method>))
	  (when accessor
	    (ensure-method accessor (list 'o) (list class)
			   `((slot-ref o ',name)) 
			   env <accessor-method>)
	    (ensure-method `(setter ,accessor) (list 'o 'v) (list class <top>)
			   `((slot-set! o ',name v))
			   env <accessor-method>))))
      slots))

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

  (define (compute-slot-init-function s)
    (let ((init (slot-definition-init-form s)))
      (and (not (unbound? init)) (make-closure `(lambda () ,init) env))))

  (define (verify-accessors slot l)
    (if (pair? l)
	(let ((get (car l)) 
	      (set (cadr l)))
	  (unless (and (closure? get) (= (%procedure-arity get) 1))
	    (error "Bad getter closure for slot `~S' in ~S: ~S" slot class get))
	  (unless (and (closure? set) (= (%procedure-arity set) 2))
	    (error "Bad setter closure for slot `~S' in ~S: ~S" slot class set)))))

  (map (lambda (s)
	 (let* ((s     (if (pair? s) s (list s)))
		(g-n-s (compute-get-n-set class s))
		(name  (slot-definition-name s)))
	   ; For each slot we have '(name init-function getter setter)
	   ; If slot, we have the simplest form '(name init-function . index)
	   (verify-accessors name g-n-s)
	   (list* name (compute-slot-init-function s) g-n-s)))
       slots))

;;;
;;; compute-cpl
;;;
(define (compute-cpl class)
  
  (define (filter-cpl class)
    (let ((res  '()))
      (for-each (lambda (item)
		  (unless (or (eq? item <object>) 
			      (eq? item <top>) 
			      (member item res))
		   (set! res (cons item res))))
	      class)
      res))

  (let* ((supers   (slot-ref class 'direct-supers))
	 (big-list (apply append (cons class supers) (map compute-cpl supers))))
    (reverse (list* <top> <object> (filter-cpl big-list)))))

;;;
;;; Compute-get-n-set
;;;
(define-method compute-get-n-set ((class <class>) s)
  (case (slot-definition-allocation s)
    (:instance ;; Instance slot
               ;; get-n-set is just its offset
     	       (let ((already-allocated (slot-ref class 'nfields)))
		 (slot-set! class '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. Since assignement to an unbound variable 
  	     ;; is not possible with our set! (in this case set! thinks that
	     ;; the variable has not been defined), our variable is in fact 
	     ;; a vector of length 1. This permits to circumvent this problem, 
             ;; without introducing a "set-environment" primitive.
             (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 cell
		   (let ((shared-cell (make-vector 1)))
		     (list (lambda (o)   (vector-ref shared-cell 0))
			   (lambda (o v) (vector-set! shared-cell 0 v))))
		   ;; Slot is inherited. Find its definition in superclass
		   (let Loop ((l (cdr (class-precedence-list class))))
		     (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
		       (if r
			   (cddr r)
			   (Loop (cdr l))))))))

    (:each-subclass ;; slot shared by instances of direct subclass.
		    ;; (Thomas Buerger, April 1998)
     		    (let ((shared-cell (make-vector 1)))
		      (list (lambda (o)   (vector-ref  shared-cell 0))
			    (lambda (o v) (vector-set! shared-cell 0 v)))))

    (: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))
		   (env (class-environment class)))
	       (unless (and get set)
		  (error "You must supply a :slot-ref and a :slot-set! in ~A" s))
	       (list (make-closure get env)
		     (make-closure set env))))
    (else    (next-method))))

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

;=============================================================================
;
; 			    I n i t i a l i z e
;
;=============================================================================

(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 '()))
	(env    (get-keyword :environment initargs (global-environment))))

    (slot-set! class 'name	  	(get-keyword :name initargs '???))
    (slot-set! class 'direct-supers 	supers)
    (slot-set! class 'direct-slots  	dslots)
    (slot-set! class 'direct-subclasses '())
    (slot-set! class 'direct-methods    '())
    (slot-set! class 'cpl		(compute-cpl class))
    (slot-set! class 'redefined		#f)
    (slot-set! class 'environment	env)
    (let ((slots (%compute-slots class)))
      (slot-set! class 'slots	  	  slots)
      (slot-set! class 'nfields	  	  0)
      (slot-set! class 'getters-n-setters (compute-getters-n-setters class 
								     slots 
								     env)))
    ;; Update the "direct-subclasses" of each inherited classes
    (for-each (lambda (x)
		(slot-set! x 'direct-subclasses 
			   (cons class (slot-ref x 'direct-subclasses))))
	      supers)

    ;; Build getters - setters - accessors
    (compute-slot-accessors class dslots env)))


(define-method initialize ((generic <generic>) initargs)
  (let ((previous-definition (get-keyword :default initargs #f)))
    (next-method)
    (slot-set! generic 'name    (get-keyword :name initargs '???))
    (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
				    (list (make <method>
						:specializers <top>
						:procedure
						    (lambda (nm . l)
						      (apply previous-definition 
							     l))))
				    '()))))

(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 (lambda l '()))))


;=============================================================================
;
; 			C h a n g e - c l a s s
;
;=============================================================================

(define (change-object-class old-instance old-class new-class)
  (let ((new-instance (allocate-instance new-class ())))
    ;; Initalize the slot of the new instance
    (for-each (lambda (slot)
		(if (slot-exists-using-class? old-class old-instance slot)
		    ;; Slot was present in old instance; set it 
		    (if (slot-bound-using-class? old-class old-instance slot)
			(slot-set-using-class!
			     new-class 
			     new-instance 
			     slot 
			     (slot-ref-using-class old-class old-instance slot)))
		    ;; slot was absent; initialize it with its default value
		    (let ((init (slot-init-function new-class slot)))
		      (if init
			  (slot-set-using-class!
			       new-class 
			       new-instance 
			       slot
			       (apply init '()))))))
	      (map slot-definition-name (class-slots new-class)))
    ;; Exchange old an new instance in place to keep pointers valids
    (%modify-instance old-instance new-instance)
    old-instance))


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

;=============================================================================
;
; 				     M a k e 
;
;     A new definition which overwrite 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)

;=============================================================================
;
;				a p p l y - g e n e r i c
;
; Protocol for calling standard generic functions.
; This protocol is  not used for real <generic> functions (in this case we use
; a completely C hard-coded protocol). 
; Apply-generic is used by STklos for calls to subclasses of <generic>.
;
; The code below is similar to the first MOP described in AMOP. In particular,
; it doesn't used the currified approach to gf call. There are 2 reasons for 
; that: 
;   - the protocol below is exposed to mimic completely the one written in C
;   - the currified protocol would be imho inefficient in C.
;=============================================================================

(define-method apply-generic ((gf <generic>) args)
  (if (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))))

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

(define-method sort-applicable-methods ((gf <generic>) methods args)
  (let ((targs (map class-of args)))
    (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))

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

;=============================================================================
;
;		     <Composite-metaclass> and <Active-metaclass>
; 
;=============================================================================

(autoload "active-slot"    <Active-metaclass>)
(autoload "composite-slot" <Composite-metaclass>)
(export <Composite-metaclass> <Active-metaclass>)

;=============================================================================
;
; 				T o o l s
;
;=============================================================================

(define (list2set l)			;; duplicate the standard list->set
  (let Loop ((l l) (res '()))		;; function but using eq instead of eqv
    (cond				;; which really sucks a lot, uselessly here
     ((null? l) 	 res)
     ((memq (car l) res) (Loop (cdr l) res))
     (else		 (Loop (cdr l) (cons (car l) res))))))


(define (class-subclasses c)
  (letrec ((allsubs (lambda (c)
		      (cons c (mapappend allsubs (class-direct-subclasses c))))))
    (list2set (cdr (allsubs c)))))

(define (class-methods c)
  (list2set (mapappend class-direct-methods (cons c (class-subclasses c)))))

;;
;; Clos like SLOT-VALUE 
;; Note: SLOT-VALUE is a gf whereas SLOT-REF and SLOT-SET! are functions.
;;
(define-method slot-value ((o <object>) s)
  (slot-ref o s))

(define-method (setter slot-value) ((o <object>) s v)
  (slot-set! o s v))

;=============================================================================
;
; 			     Backward compatibility
;
;=============================================================================
(define class-cpl 		 class-precedence-list)		; Don' use these
(define get-slot-allocation	 slot-definition-allocation)	; obolete defs
(define slot-definition-initform slot-definition-init-form)	; anymore

(export class-cpl get-slot-allocation slot-definition-initform)

(provide "stklos")