;*              Copyright 1992 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;*
;*			Director, Cambridge Research Lab
;*			Digital Equipment Corp
;*			One Kendall Square, Bldg 700
;*			Cambridge MA 02139
;*
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.
;*
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

; $Id: class.scm,v 1.24 1992/09/21 20:41:56 birkholz Exp $

;;;; Class, Instance, and Singleton data types.

;;; Conventions:
;;;
;;; "dylan:" is a prefix used for variables used in the expanded code
;;;          generated by our dylan->scheme compiler.  All such
;;;          functions are expecting to be called using Dylan calling
;;;          syntax (i.e. they send both a multiple-value and a next-method
;;;          argument).  These are typically called from Scheme using the
;;;          dylan-call procedure which defaults the special arguments.
;;;
;;; "dylan::" is a prefix for functions used by the Runtime library, but
;;;           not directly available from Dylan.  These use the normal
;;;           scheme calling convensions.
;;;
;;; Capitalization (per word) is used for Dylan variables defined in
;;; Scheme.

;;; Things visible to converted Dylan code.  Just the names here...

(define dylan::make-a-class '...)
(define Add-Slot '...)
(define Id? eq?)
(define dylan::add-slot '...)
(define dylan::false-fn (lambda () #F))
(define Subclass? '...)
(define map-over-all-superclasses! '...)
(define map-over-all-subclasses! '...)

; (let ()
;;; Scheme structure for representing the Dylan class DAG

(define class-type
  (make-record-type
   'dylan-class
   '(debug-name				; Name, for debugging
     instances				; Population of all direct
					; instances of this class
     subclasses				; Population of all direct
					; subclasses of this class
     superclasses			; Ordered list of direct
					; superclasses
     slots				; Vector of slot descriptors
     class-data				; Vector of data belonging to
					; this class -- either from
					; CLASS allocated data in one
					; of my slots or from
					; ALL-SUBCLASSES from
					; inherited slots
     instance-data-size			; Number of slots in each INSTANCE
     sealed?				; Has the class been sealed?
     read-only?
     abstract?				; Is the class abstract?
     specificity			; Longest path from root.
     specificity-token			; Unique to a specificity labeling.
     )))
(define class? (record-predicate class-type))
(define make-class (record-constructor class-type))
(define class.debug-name (record-accessor class-type 'debug-name))
(define class.instances (record-accessor class-type 'instances))
(define class.subclasses (record-accessor class-type 'subclasses))
(define class.superclasses (record-accessor class-type 'superclasses))
(define class.slots (record-accessor class-type 'slots))
(define class.class-data (record-accessor class-type 'class-data))
(define class.instance-data-size
  (record-accessor class-type 'instance-data-size))
(define class.sealed? (record-accessor class-type 'sealed?))
(define class.read-only? (record-accessor class-type 'read-only?))
(define class.abstract? (record-accessor class-type 'abstract?))
(define class.specificity (record-accessor class-type 'specificity))
(define class.specificity-token (record-accessor class-type 'specificity-token))
(define set-class.instances!
  (record-updater class-type 'instances))
(define set-class.subclasses!
  (record-updater class-type 'subclasses))
(define set-class.superclasses!
  (record-updater class-type 'superclasses))
(define set-class.slots!
  (record-updater class-type 'slots))
(define set-class.class-data!
  (record-updater class-type 'class-data))
(define set-class.instance-data-size!
  (record-updater class-type 'instance-data-size))
(define set-class.sealed?!
  (record-updater class-type 'sealed?))
(define set-class.read-only?!
  (record-updater class-type 'read-only?))
(define set-class.abstract?!
  (record-updater class-type 'abstract?))
(define set-class.specificity! (record-updater class-type 'specificity))
(define set-class.specificity-token!
  (record-updater class-type 'specificity-token))

;;; Scheme structure for representing Dylan singletons

(define singleton-type
  (make-record-type
   'dylan-singleton
   '(object				; The actual singleton object
     extra-slot-descriptors		; Vector of slot descriptors
					; for slots only in singleton
					; and not in class definition
     extra-slot-values)))		; Vector of extra slot data

(define singleton? (record-predicate singleton-type))
(define make-singleton (record-constructor singleton-type))
(define singleton.object (record-accessor singleton-type 'object))
(define singleton.extra-slot-descriptors
  (record-accessor singleton-type 'extra-slot-descriptors))
(define singleton.extra-slot-values
  (record-accessor singleton-type 'extra-slot-values))
(define set-singleton.extra-slot-descriptors!
  (record-updater singleton-type 'extra-slot-descriptors))
(define set-singleton.extra-slot-values!
  (record-updater singleton-type 'extra-slot-values))

;;; Scheme structure for representing Dylan slot descriptors

;; moved to support.scm -- used by compiler and runtime

;;; Scheme structure for representing Dylan instances

(define instance-type
  (make-record-type
   'dylan-instance
   '(class				; Direct class of this object
     singleton				; Singleton for this obj. (or #F)
     data)))				; Vector of object's instance data
(define instance? (record-predicate instance-type))
(define make-instance (record-constructor instance-type))
(define instance.class (record-accessor instance-type 'class))
(define instance.singleton (record-accessor instance-type 'singleton))
(define instance.data (record-accessor instance-type 'data))
(define set-instance.class! (record-updater instance-type 'class))
(define set-instance.singleton! (record-updater instance-type 'singleton))
(define set-instance.data! (record-updater instance-type 'data))

;;; And now the good stuff ...

(define (test-that-all-slots-for-this-getter-are-identical
	 my-slot my-getter slots)
  (define (slots-equal? slot1 slot2)
    (define (slot->list slot)
      (map (lambda (f) (f slot))
	   (list slot.debug-name slot.getter slot.setter slot.type
		 slot.init-value slot.init-function slot.init-keyword
		 slot.required-init-keyword slot.allocation)))
    (define (all? fn l1 l2)
      (or (null? l1)
	  (and (fn (car l1) (car l2))
	       (all? fn (cdr l1) (cdr l2)))))
    (all? eq? (slot->list slot1) (slot->list slot2)))
  (let loop ((slots slots))
    (cond ((null? slots) #T)
	  ((eq? (slot.getter (car slots)) my-getter)
	   (if (not (slots-equal? my-slot (car slots)))
	       (dylan-call dylan:error
			   "multiple inheritance slot clash"
			   my-slot (car slots))
	       (loop (cdr slots))))
	  (else (loop (cdr slots))))))

(define (vector-iterate v fn)
  (do ((length (vector-length v))
       (i 0 (+ i 1)))
      ((= i length))
    (fn i (vector-ref v i))))

(define (grow-vector v . values)
  (let* ((values (list->vector values))
	 (n-old-values (vector-length v))
	 (new-v (make-vector (+ n-old-values
				(vector-length values)))))
    (vector-iterate v
      (lambda (i entry) (vector-set! new-v i entry)))
    (vector-iterate values
      (lambda (i entry)
	(vector-set! new-v (+ i n-old-values) entry)))
      new-v))

(define (find-empty-slot v)
  (let ((length (vector-length v)))
    (let loop ((i 0))
      (cond ((= i length) #F)
	    ((not (vector-ref v i)) i)
	    (else (loop (+ i 1)))))))

(define (set-next-vector-entry! vec value update-vec!)
  (let ((next-entry (find-empty-slot vec)))
    (if next-entry
	(vector-set! vec next-entry value)
	(let ((new-vec (grow-vector vec #F #F #F #F #F #F #F #F #F #F)))
	  (update-vec! new-vec)
	  (set-next-vector-entry! new-vec value update-vec!)))))

(define (copy-slot slot inherited? data-location)
  (apply make-slot
	 (map (lambda (fn) (fn slot))
	      (list slot.debug-name slot.getter slot.setter
		    slot.type slot.init-value
		    slot.has-initial-value? slot.init-function
		    slot.init-keyword slot.required-init-keyword
		    slot.allocation (lambda (s) s inherited?)
		    (lambda (s) s data-location)))))

(define (combine-slots class slots new-getter-fns)
  (let ((class-data-index -1)
	(instance-data-index -1))

    (define (figure-slot-data-location slot)
      (case (slot.allocation slot)
	((CLASS CONSTANT) (slot.data-location slot))
	((INSTANCE)
	 (set! instance-data-index (+ 1 instance-data-index))
	 (if (not (= instance-data-index (slot.data-location slot)))
	     (begin
	       (add-method (slot.getter slot)
			   (make-instance-getter class
						 instance-data-index
						 (slot.debug-name slot)))
	       (if (slot.setter slot)
		   (add-method (slot.setter slot)
			       (make-instance-setter
				class instance-data-index
				(slot.type slot))))))
	 instance-data-index)
	((EACH-SUBCLASS)
	 (set! class-data-index (+ 1 class-data-index))
	 (if (not (= class-data-index (slot.data-location slot)))
	     (begin
	       (add-method (slot.getter slot)
			   (make-each-subclass-getter class
						      class-data-index
						      (slot.debug-name slot)))
	       (if (slot.setter slot)
		   (add-method
		    (slot.setter slot)
		    (make-each-subclass-setter class class-data-index
					       (slot.type slot))))))
	 class-data-index)
	((VIRTUAL) #F)))

    (define (combine-two-slotlists a b)
      ;; NOTE: Question 8 resolved here by using EQ? on the
      ;; superclass slot getter functions
      (let loop ((slots a)
		 (getters (map slot.getter a))
		 (new-slots b))
	(if (null? new-slots)
	    slots
	    (let* ((this-slot (car new-slots))
		   (this-getter (slot.getter this-slot)))
	      (if (memq this-getter getters) ; Slot already inherited?
		  (begin
		    (if (not (memq this-getter new-getter-fns))
					; Not being overridden?
			(test-that-all-slots-for-this-getter-are-identical
			 this-slot this-getter slots)) ; Must be identical
		    (loop slots getters (cdr new-slots)))
		  (loop (cons (copy-slot this-slot
					 #T
					 (figure-slot-data-location this-slot))
			      slots)
			(cons this-getter getters)
			(cdr new-slots)))))))

    (define (reduce fn initial-value l)
      (let loop ((value initial-value)
		 (l l))
	(if (null? l)
	    value
	    (loop (fn value (car l)) (cdr l)))))

    (let ((final-slot-list (reverse (reduce combine-two-slotlists '() slots))))
      (vector (list->vector final-slot-list)
	      (+ 1 class-data-index)
	      (+ 1 instance-data-index)))))

(define (recompute-class-specificities!)
  (let ((new-token (cons 'SPECIFICITY 'TOKEN)))

    (define (level-me me level)
      (if (eq? new-token (class.specificity-token me))
	  (if (> level (class.specificity me))
	      (set-class.specificity! me level))
	  (begin
	    (set-class.specificity-token! me new-token)
	    (set-class.specificity! me level)))
      (let ((sublevel (+ 1 level)))
	(map-over-population!
	 (class.subclasses me)
	 (lambda (subclass)
	   (level-me subclass sublevel)))))

    (level-me <object> 0)))

(define (get-initial-slot-value slot)
  (cond ((slot.init-function slot) => (lambda (f) (dylan-call f)))
	((not (slot.has-initial-value? slot)) *the-uninitialized-slot-value*)
	(else (slot.init-value slot))))

(define (initialize-slot! slot keywords vector which-allocation-types)
  (let ((allocation (slot.allocation slot)))
    (if (memq allocation which-allocation-types)
	(case allocation
	  ((INSTANCE EACH-SUBCLASS)
	   (let ((keyword (or (slot.required-init-keyword slot)
			      (slot.init-keyword slot))))
	     (vector-set! vector (slot.data-location slot)
	       (if keyword
		   (dylan::find-keyword keywords keyword
		     (lambda () (get-initial-slot-value slot)))
		   (get-initial-slot-value slot)))))
	  ((CLASS)
	   (vector-set! vector (cdr (slot.data-location slot))
			(get-initial-slot-value slot)))
	  ((VIRTUAL CONSTANT) 'done))))
  'DONE)

(set! dylan::make-a-class
  (lambda (name superclasses new-getter-fns)
    (make-dylan-class name superclasses new-getter-fns #F)))

(define (make-dylan-class name superclasses new-getter-fns top?)
  (if (and (not top?)
	   (null? superclasses))
      (dylan-call dylan:error "must specify at least one superclass"))
  (if (not (unique? superclasses memq))
      (dylan-call dylan:error
		  "multiple inheritance from identical superclasses"))
  (let* ((the-class
	  (make-class
	   name				; debug-name
	   (make-population)		; instances
	   (make-population)		; subclasses
	   superclasses			; superclasses
	   '#()				; slots
	   '#()				; class-data
	   0				; instance-data-size
	   #F				; sealed?
	   #F				; read-only?
	   #F				; abstract?
	   #F				; specificity
	   #F				; specificity-token
	   ))
	 (combined-slots
	  (combine-slots
	   the-class
	   (map (lambda (class) (vector->list (class.slots class)))
		superclasses)
	   new-getter-fns))
	 (slots (vector-ref combined-slots 0))
	 (class-data-size (vector-ref combined-slots 1))
	 (instance-data-size (vector-ref combined-slots 2)))
    (set-class.slots! the-class slots)
    (set-class.class-data!
     the-class
     ;; Design note: we flatten out the slot list here to make
     ;; instance creation fast at the expense of speed of class
     ;; redefinition and space.
     (let ((result
	    (make-vector class-data-size *the-uninitialized-slot-value*)))
       (vector-iterate slots
		       (lambda (i slot)
			 i
			 (initialize-slot! slot '() result '(EACH-SUBCLASS))))
       result))
    (set-class.instance-data-size! the-class instance-data-size)
    (for-each
     (lambda (parent-class)
       (add-to-population! (class.subclasses parent-class) the-class))
     superclasses)
    (if (not top?) (recompute-class-specificities!))
    the-class))

(set! Subclass?
  (lambda (class1 class2)
    ; Is class1 a subclass of class2?
    (or (Id? class1 class2)
	(let loop ((classes-left (class.superclasses class1)))
	  (cond ((null? classes-left) #F)
		((Id? class2 (car classes-left)) #T)
		(else (loop (append (class.superclasses (car classes-left))
				    (cdr classes-left)))))))))

(set! Add-Slot
  (lambda (owner . keyword-list)
    ;; Keywords allowed are: getter, setter, type, init-value,
    ;; init-function, init-keyword, required-init-keyword, debug-name, and
    ;; allocation. See page 52.
    (dylan::keyword-validate
     #F keyword-list
     '(getter: setter: type: init-value: init-function: init-keyword:
	       required-init-keyword: allocation: debug-name:))
    (let* ((getter (dylan::find-keyword
		    keyword-list 'getter:
		    (lambda ()
		      (dylan-call dylan:error "no getter defined"))))
	   (setter (dylan::find-keyword keyword-list 'setter:
				       dylan::false-fn))
	   (type (dylan::find-keyword keyword-list 'type:
				     (lambda () <Object>)))
	   (have-init-value? #T)
	   (init-value (dylan::find-keyword
			keyword-list 'init-value:
			(lambda ()
			  (set! have-init-value? #F)
			  'no-value)))
	   (init-function (dylan::find-keyword
			   keyword-list 'init-function:
			   dylan::false-fn))
	   (init-keyword (dylan::find-keyword
			  keyword-list 'init-keyword:
			  dylan::false-fn))
	   (allocation (dylan::find-keyword
			keyword-list 'allocation:
			(lambda () 'instance)))
	   (debug-name (dylan::find-keyword
			keyword-list 'debug-name:
			(lambda () '*the-unnamed-slot*)))
	   (required-init-keyword (dylan::find-keyword
				   keyword-list 'required-init-keyword:
				   (lambda () #F))))
      (dylan::add-slot owner
		       type allocation setter getter debug-name init-value
		       have-init-value? init-function init-keyword
		       required-init-keyword))))

(define (same-slot-getter-in-slot-vector->slot getter slots)
  (let loop ((slots (vector->list slots)))
    (cond ((null? slots) #F)
	  ((Id? (slot.getter (car slots)) getter) (car slots))
	  (else (loop (cdr slots))))))

(define (conflict-test owner new-slot)
  (define (stricter-than-all? type type-list)
    ; type-list may contain #F entries!
    (let loop ((rest-list type-list))
      (cond ((null? rest-list) #T)
	    ((or (not (car rest-list)) (subclass? type (car rest-list)))
	     (loop (cdr rest-list)))
	    (else #F))))
  (if (not (stricter-than-all?
	    (slot.type new-slot)
	    (map (lambda (class)
		   (cond ((same-slot-getter-in-slot-vector->slot
			   (slot.getter new-slot)
			   (class.slots class)) => slot.type)
			 (else #F)))
		 (class.superclasses
		  (if (class? owner)
		      owner
		      (instance.class (singleton.object owner)))))))
      (dylan-call
       dylan:error
       "conflict-test -- new slot type not a subclass of inherited type"
       'owner owner
       'new-slot new-slot
       'new-slot-type (slot.type new-slot))))

(define (remove-this-slot-only! owner slot-vector slot)
  (vector-iterate slot-vector
    (lambda (index entry)
      (if (Id? slot entry)
	  (let ((allocation (slot.allocation slot))
		(data-location (slot.data-location slot)))
	    (vector-set! slot-vector index #F)
	    (if (class? owner)
		(case allocation
		  ((CLASS)
		   (if (eq? (car data-location) owner)
		       (vector-set! (class.class-data owner)
				    (cdr data-location)
				    '<<EMPTY-SLOT-VALUE>>)))
		  ((EACH-SUBCLASS)
		   (vector-set! (class.class-data owner)
				data-location
				'<<EMPTY-SLOT-VALUE>>))
		  ((INSTANCE)
		   (map-over-population
		    (class.instances owner)
		    (lambda (ins)
		      (vector-set! (instance.data ins)
				   data-location
				   '<<EMPTY-SLOT-VALUE>>)))))
		;; Not a class, must be a singleton
		(if (eq? allocation 'instance)
		    (vector-set! owner
				 data-location
				 '<<EMPTY-SLOT-VALUE>>))))))))

(define (add-a-slot owner new-slot accessor updater fixit-fn)
  ;; Adds new-slot (a slot descriptor) to the owner, using accessor to
  ;; find the current list of slot descriptors and updater to store
  ;; the modified list back if needed.  Fixit-Fn is then called with
  ;; the slot descriptor and owner to update the instances as needed.
  (let* ((current-descriptors (accessor owner))
	 (getter (slot.getter new-slot))
	 (old-slot (same-slot-getter-in-slot-vector->slot
		    getter current-descriptors)))
    (if old-slot
	(begin				; Redefining existing slot
	  (if (slot.inherited? old-slot)
	      (conflict-test owner new-slot))
	  (remove-this-slot-only! owner current-descriptors old-slot)
	  (set! current-descriptors (accessor owner))))
    (let ((offset (find-empty-slot current-descriptors)))
      (if offset
	  (vector-set! current-descriptors offset new-slot)
	  (updater owner (grow-vector current-descriptors new-slot)))
      (fixit-fn owner new-slot))))

(set! map-over-all-subclasses!
  (lambda (predicate fn classes)
    ;; Predicate is #T if you want to continue to children of this class
    ;; FN receives two arguments: a class and (predicate class)
    ;; Classes appear only once, even if multiple inheritance
    ;; makes a non-tree
    (let loop ((subclasses (population->list classes))
	       (already-seen '()))
      (if (null? subclasses)
	  'done
	  (let* ((this-subclass (car subclasses))
		 (test (predicate this-subclass)))
	    (if (not (memq this-subclass already-seen))
		(fn this-subclass test))
	    (loop (if test
		      (append (cdr subclasses)
			      (population->list
			       (class.subclasses (car subclasses))))
		      (cdr subclasses))
		  (cons this-subclass already-seen)))))))

(set! map-over-all-superclasses!
  (lambda (class fn)
    (let loop ((superclasses (class.superclasses class))
	       (already-seen (list class)))
      (if (null? superclasses)
	  (reverse already-seen)
	  (let ((this-class (car superclasses)))
	    (let ((new-ones
		   (set-difference (class.superclasses this-class)
				   already-seen
				   memq)))
	      (fn this-class)
	      (loop (append (cdr superclasses) new-ones)
		    (cons this-class already-seen))))))))

(define (add-slot-to-class! class new-slot)
  (case (slot.allocation new-slot)
    ((INSTANCE)
     (map-over-population!
      (class.instances class)
      (lambda (instance)
	(set-instance.data! instance
			    (grow-vector (instance.data instance)
					 (get-initial-slot-value new-slot)))))
     (add-method (slot.getter new-slot)
		 (make-instance-getter class
				       (class.instance-data-size class)
				       (slot.debug-name new-slot)))
     (if (slot.setter new-slot)
	 (add-method (slot.setter new-slot)
		     (make-instance-setter class
					   (class.instance-data-size class)
					   (slot.type new-slot))))
     (set-class.instance-data-size! class (+ (class.instance-data-size class)
					     1)))
    ((EACH-SUBCLASS)
     (add-method (slot.getter new-slot)
		 (make-each-subclass-getter
		  class
		  (vector-length (class.class-data class))
		  (slot.debug-name new-slot)))
     (if (slot.setter new-slot)
	 (add-method (slot.setter new-slot)
		     (make-each-subclass-setter
		      class
		      (vector-length (class.class-data class))
		      (slot.type new-slot))))
     (set-class.class-data! class
			    (grow-vector (class.class-data class)
					 (get-initial-slot-value new-slot))))
    ((CLASS)
     (let ((data-location (slot.data-location new-slot)))
       (if (eq? class (car data-location))
	   (let ((offset (cdr data-location)))
	     (set-class.class-data! class
				    (grow-vector
				     (class.class-data class)
				     (get-initial-slot-value new-slot)))
	     (add-method (slot.getter new-slot)
			 (make-class-getter class
					    offset
					    (slot.debug-name new-slot)))
	     (if (slot.setter new-slot)
		 (add-method (slot.setter new-slot)
			 (make-class-setter class offset
					    (slot.type new-slot))))))))
    ((VIRTUAL CONSTANT) #T)))

(define (add-slot-to-singleton! singleton new-slot)
  (if (eq? (slot.allocation new-slot) 'INSTANCE)
      (begin
	(set-singleton.extra-slot-values!
	 singleton
	 (grow-vector (singleton.extra-slot-values singleton)
		      (get-initial-slot-value new-slot)))
	(add-method (slot.getter new-slot)
		    (make-singleton-getter singleton
					   (slot.data-location new-slot)
					   (slot.debug-name new-slot)))
	(if (slot.setter new-slot)
	    (add-method (slot.setter new-slot)
			(make-singleton-setter
			 singleton (slot.data-location new-slot)
			 (slot.type new-slot)))))))

(set! dylan::add-slot
  (lambda (owner type allocation setter getter debug-name init-value
	   has-init-value? init-function init-keyword required-init-keyword)
    (define (figure-data-location current-class allocation)
      (if (class? current-class)
	  (case allocation		; CLASS
	    ((VIRTUAL) #F)
	    ((CONSTANT) init-value)
	    ((INSTANCE) (class.instance-data-size current-class))
	    ((EACH-SUBCLASS) (vector-length (class.class-data current-class)))
	    ((CLASS) (cons owner (vector-length (class.class-data owner)))))
	  (case allocation		; SINGLETON
	    ((VIRTUAL) #F)
	    ((CONSTANT) init-value)
	    ((INSTANCE)
	     (vector-length (singleton.extra-slot-values current-class)))
	    (else
	     (dylan-call dylan:error
			 "dylan::add-slot -- bad allocation for singleton"
			 current-class debug-name allocation)))))
    (cond ((singleton? owner)
	   (if (not (memq allocation '(instance constant virtual)))
	       (dylan-call dylan:error
			   "dylan::add-slot -- bad singleton allocation"
			   allocation))
	   (if init-keyword
	       (dylan-call dylan:error
			   "dylan::add-slot -- singleton with init-keyword"
			   init-keyword)))
	  ((and (class? owner) (class.read-only? owner))
	   (dylan-call dylan:error "add-slot -- class is read-only" owner))
	  ((not (class? owner))
	   (dylan-call dylan:error
		       "dylan::add-slot -- owner not a singleton or class"
		       owner)))
    (if (and required-init-keyword
	     (or init-keyword has-init-value? init-function))
	(dylan-call dylan:error
		    "dylan::add-slot -- incompatible slot initialization"
		    'required-init-keyword required-init-keyword
		    'init-keyword init-keyword
		    'init-value init-value
		    'init-function init-function))
    (if (and has-init-value? init-function)
	(dylan-call dylan:error
		    "dylan::add-slot -- both initial value and function"
		    'init-value init-value
		    'init-function init-function))
    (if (not (memq allocation '(instance class each-subclass
					 constant virtual)))
	(dylan-call dylan:error
		    "dylan::add-slot -- bad allocation type" allocation))
    (if (and (memq allocation '(class each-subclass))
	     (or init-function required-init-keyword init-keyword))
	(dylan-call
	 dylan:error
	 "dylan::add-slot -- bad combination of allocation and initialization"
	 allocation init-function required-init-keyword init-keyword))
    (let ((new-slot (make-slot
		     debug-name getter setter type init-value
		     has-init-value? init-function init-keyword
		     required-init-keyword allocation #F
		     (figure-data-location owner allocation))))
      (if (class? owner)
	  (begin
	    (add-a-slot owner new-slot
			class.slots set-class.slots!
			add-slot-to-class!)
	    (map-over-all-subclasses!
	     (lambda (class)
	       ;; Stop showering down if we hit a class that already has a
	       ;; generic function for this slot.
	       (not (memq getter (map slot.getter
				      (vector->list (class.slots class))))))
	     (lambda (class test)
	       (if test
		   (add-a-slot
		    class
		    (copy-slot new-slot #T
			       (figure-data-location class allocation))
		    class.slots set-class.slots! add-slot-to-class!)
		   (conflict-test class (copy-slot new-slot #T 0))))
	     (class.subclasses owner)))
	  (add-a-slot owner new-slot	; SINGLETON
		      singleton.extra-slot-descriptors
		      set-singleton.extra-slot-descriptors!
		      add-slot-to-singleton!))
      new-slot)))

(define (make-getter-param-list class)
  (make-param-list `((OBJ ,class)) #F #F #F))

(define (make-setter-param-list class)
  (make-param-list `((OBJ ,class) (VALUE ,<object>)) #F #F #F))

(define (object-ref data offset object name)
  (let ((value (vector-ref data offset)))
    (if (eq? value *the-uninitialized-slot-value*)
	(dylan-call dylan:error "uninitialized slot accessed" object name)
	value)))

(define (make-class-getter class offset name)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj) obj (object-ref (class.class-data class) offset class name))))

(define (make-each-subclass-getter class offset name)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj)
     (let ((class (instance.class obj)))
       (object-ref (class.class-data class) offset class name)))))

(define (make-instance-getter class offset name)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj)
     (object-ref (instance.data obj) offset obj name))))

(define (make-singleton-getter class singleton offset name)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj)
     obj				; Ignored
     (object-ref (singleton.extra-slot-values singleton) offset
		 singleton name))))

(define (make-class-setter class offset type)
  (dylan::function->method
   (make-setter-param-list class)
   (if (eq? type <object>)
       (lambda (obj value)
	 obj				; Ignored
	 (vector-set! (class.class-data class) offset value)
	 value)
       (lambda (obj value)
	 obj
	 (dylan-call dylan:check-type value type)
	 (vector-set! (class.class-data class) offset value)
	 value))))

(define (make-each-subclass-setter class offset type)
  (dylan::function->method
   (make-setter-param-list class)
   (if (eq? type <object>)
       (lambda (obj value)
	 (vector-set! (class.class-data (instance.class obj)) offset value)
	 value)
       (lambda (obj value)
	 (dylan-call dylan:check-type value type)
	 (vector-set! (class.class-data (instance.class obj)) offset value)
	 value))))

(define (make-instance-setter class offset type)
  (dylan::function->method
   (make-setter-param-list class)
   (if (eq? type <object>)
       (lambda (obj value)
	 (vector-set! (instance.data obj) offset value)
	 value)
       (lambda (obj value)
	 (dylan-call dylan:check-type value type)
	 (vector-set! (instance.data obj) offset value)
	 value))))

(define (make-singleton-setter class singleton offset type)
  (dylan::function->method
   (make-setter-param-list class)
   (if (eq? type <object>)
       (lambda (obj value)
	 obj				; Ignored
	 (vector-set! (singleton.extra-slot-values singleton) offset value)
	 value)
       (lambda (obj value)
	 obj
	 (dylan-call dylan:check-type value type)
	 (vector-set! (singleton.extra-slot-values singleton) offset value)
	 value))))

(define (make-constant-getter class constant)
  (dylan::function->method
   (make-getter-param-list class)
   (lambda (obj)
     obj				;Ignored
     constant)))

(define (dylan::make-singleton object)
  (if (instance? object)
      (or (instance.singleton object)
	  (let ((singleton (make-singleton object '#() '#())))
	    (set-instance.singleton! object singleton)
	    singleton))
      (make-singleton object '#() '#())))
