;;; -*- Mode: Lisp; Package: STELLA; Syntax: COMMON-LISP; Base: 10 -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;; BEGIN LICENSE BLOCK ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                                            ;
; Version: MPL 1.1/GPL 2.0/LGPL 2.1                                          ;
;                                                                            ;
; The contents of this file are subject to the Mozilla Public License        ;
; Version 1.1 (the "License"); you may not use this file except in           ;
; compliance with the License. You may obtain a copy of the License at       ;
; http://www.mozilla.org/MPL/                                                ;
;                                                                            ;
; Software distributed under the License is distributed on an "AS IS" basis, ;
; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License   ;
; for the specific language governing rights and limitations under the       ;
; License.                                                                   ;
;                                                                            ;
; The Original Code is the STELLA Programming Language.                      ;
;                                                                            ;
; The Initial Developer of the Original Code is                              ;
; UNIVERSITY OF SOUTHERN CALIFORNIA, INFORMATION SCIENCES INSTITUTE          ;
; 4676 Admiralty Way, Marina Del Rey, California 90292, U.S.A.               ;
;                                                                            ;
; Portions created by the Initial Developer are Copyright (C) 1996-2006      ;
; the Initial Developer. All Rights Reserved.                                ;
;                                                                            ;
; Contributor(s):                                                            ;
;                                                                            ;
; Alternatively, the contents of this file may be used under the terms of    ;
; either the GNU General Public License Version 2 or later (the "GPL"), or   ;
; the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),   ;
; in which case the provisions of the GPL or the LGPL are applicable instead ;
; of those above. If you wish to allow use of your version of this file only ;
; under the terms of either the GPL or the LGPL, and not to allow others to  ;
; use your version of this file under the terms of the MPL, indicate your    ;
; decision by deleting the provisions above and replace them with the notice ;
; and other provisions required by the GPL or the LGPL. If you do not delete ;
; the provisions above, a recipient may use your version of this file under  ;
; the terms of any one of the MPL, the GPL or the LGPL.                      ;
;                                                                            ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END LICENSE BLOCK ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Version: classes.ste,v 1.128 2006/05/11 07:05:48 hans Exp

;;; Procedures that bootstrap the STELLA class hierarchy and implement 
;;; class definition.  Note that there are two kinds of class objects:
;;; (1) the STELLA class meta objects describing them and (2) the native
;;; CLOS/C++/Java classes implementing them.  Native class definitions
;;; are generated by the various translators when they translate a STELLA
;;; class definition or object, and materialized during the compilation
;;; and linking phase of the native code.

(in-package "STELLA")

(in-module "/STELLA")


  ;;
;;;;;; Accessors and lookup
  ;;

(defun (class-name STRING) ((class CLASS))
  :public? TRUE
  (return (symbol-name (class-type class))) )

(defun (class-symbol SYMBOL) ((class CLASS))
  :public? TRUE
  (return (type-to-symbol (class-type class))) )

(defmethod (primary-class CLASS) ((self OBJECT))
  :public? TRUE
  (when (defined? (primary-type self))
    (return (type-class (primary-type self))))
  (return NULL))

(defmethod (lookup-class CLASS) ((name STRING))
  :documentation "Return a class with name `name'.  Scan all
visible surrogates looking for one that has a class defined for it."
  :public? TRUE
  (let ((class CLASS NULL)
        (surrogate SURROGATE NULL))
    (foreach 
     module in (visible-modules *module*)
     do
     (when (and 
            (setq? surrogate
                   (lookup-rigid-symbol-locally name module SURROGATE-SYM))
            (setq? class (surrogate-value surrogate))
            (isa? class @CLASS))
       (return class)))
    (return NULL) ))

(defmethod (lookup-class CLASS) ((name SYMBOL))
  :documentation "Return a class with name `name'.  Scan all
visible surrogates looking for one that has a class defined for it."
  :public? TRUE
  (special ((*module* (interned-in name)))
    (return (lookup-class (symbol-name name)))))

(defun (type-to-class CLASS) ((type TYPE))
  ;; A version of `type-class' that doesn't use a cast and, hence,
  ;;   can be used during finalization.
  (return (safe-cast (surrogate-value type) CLASS)))
  
(defmethod (get-stella-class CLASS) ((class-name TYPE) (error? BOOLEAN))
  :documentation "Return a class with name `class-name'.  If none exists, break
if `error?', else return `null'."
  :public? TRUE
  (let ((class (surrogate-value class-name)))
    (when (and (defined? class)
               (stella-class? class))
      (return class))
    (when  error?
      (continuable-error "Class " class-name " does not exist."))
    (return NULL) ))

(defmethod (get-stella-class CLASS) ((class-name STRING) (error? BOOLEAN))
  :documentation "Return a class with name `class-name'.  If none exists, break
if `error?', else return `null'."
  :public? TRUE
  (let ((type (lookup-surrogate class-name)))
    (when (defined? type)
      (return (get-stella-class type error?)))
    (when error?
      (continuable-error "Class " class-name " does not exist."))
    (return NULL) ))

(defmethod (get-stella-class CLASS) ((class-name SYMBOL) (error? BOOLEAN))
  :documentation "Return a class with name `class-name'.  If non exists, break
if `error?', else return `null'."
  :public? TRUE
  (return (get-stella-class (symbol-name class-name) error?)) )


  ;;
;;;;;; Binding and unbinding of surrogates
  ;;

;;; Collect preference variables together somewhere:
(defspecial *warnIfRedefine?* BOOLEAN TRUE
  :documentation "If set, warn about each redefinition."
  :public? TRUE)

(defun (bind-to-surrogate? BOOLEAN OBJECT SURROGATE)
       ((self OBJECT) (name STRING) 
        (clipOldValue? BOOLEAN) (askForPermission? BOOLEAN))
  :public? TRUE
  ;; Link a surrogate with name `name' to `self' in the
  ;;    context of *module*.  Return TRUE if the binding succeeds.
  ;;    Return a second value if a previous binding got clipped.
  ;;    Return a third value representing the (possibly new) surrogate
  ;;    that was bound to `self'.
  ;; Fail if the surrogate is already bound to other object in *module*,
  ;;    or if its bound to an object of a different type.
  ;; The link from `surrogate' to `self' is context sensitive.
  
  ;; start by finding or creating a surrogate named `name' interned 
  ;;    in '(cardinal-module *module*)':
  (let ((oldSurrogate (lookup-surrogate name))
        (oldValue (only-if (defined? oldSurrogate) 
                           (surrogate-value oldSurrogate)))
        (surrogate (shadow-surrogate name))
        (oldModule MODULE NULL))
    (when (null? oldValue)
      (setf (surrogate-value surrogate) self)
      (return TRUE NULL surrogate))
    (when (eql? oldValue self)
      ;; should never happen, since `self' is newly-defined
      (return TRUE NULL surrogate))
    ;; begin to figure out if `value' and `self' are interned into the
    ;;    same module:
    (setq oldModule (interned-in oldSurrogate))
    (cond 
     ((not (eql? oldModule *module*))
      (setf (surrogate-value surrogate) self)
      (when askForPermission?
        (warn "Shadowing the " (symbol-name (primary-type self))
              " named " name)
        (inform
         "CAUTION: Automatic shadowing can be dangerous, because forward " EOL
         "   references to a shadowed object may be bound to the now-shadowed "
         EOL "   object.  Suggestion: Explicitly shadow the name using" EOL
         "   DEFMODULE's `:shadow' option.")
        (when (yes-or-no? "Do it anyway? ")
          ;;; hc: SOMETHING SEEMS WRONG, SINCE WE ALREADY SET THE VALUE ABOVE:
          (setf (surrogate-value surrogate) self)
          (return TRUE oldValue surrogate)))
      (return TRUE NULL surrogate))
     (clipOldValue?
      (when *warnIfRedefine?*
        (inform "Redefining the " (symbol-name (primary-type self))
                " named " name))
      (setf (surrogate-value surrogate) self)
      ;; avoid breaking if, for example, a class definition redefined
      ;;    a surrogate that previously pointed at a non-class:
      (when (not (eql? (primary-type self) (primary-type oldValue)))
        (setq oldValue NULL))
      (return TRUE oldValue surrogate))
     (otherwise
      ;; failure:
      (when askForPermission?
        (warn "Can't define the " (symbol-name (primary-type self))
              " named " name " in module " *module* EOL
              "   because that term is already bound to " oldValue EOL)
        (when (yes-or-no? "Do it anyway? ")
          (setf (surrogate-value surrogate) self)
          (return TRUE oldValue surrogate)))
      (return FALSE NULL surrogate))) ))

(defmethod unbind-from-surrogate ((self CLASS))
  ;; Unlink the class `self' from its surrogate.
  (let ((surrogate (class-type self)))
    (when (defined? surrogate)
      (setf (surrogate-value surrogate) NULL)
      (setf (class-type self) NULL)) ))

;;; Shadowing (of surrogates)

(defun (shadow-symbol SYMBOL) ((name STRING))
  :public? TRUE
  ;; Find or create a symbol in '(cardinal-module *module*)'
  ;;    named `name'.
  (return
   (intern-rigid-symbol-locally name *module* SYMBOL-SYM)) )
  
(defun (shadow-surrogate SURROGATE) ((name STRING))
  :public? TRUE
  ;; Find or create a surrogate in '(cardinal-module *module*)'.
  ;; Side-effect: Call `shadow-symbol' on `name' as well.
  ;; If a local binding for the surrogate already exists, it
  ;;    is left as is (its not nullified).
  (shadow-symbol name)
  (return
   (intern-rigid-symbol-locally name *module* SURROGATE-SYM)) )

(defun (shadowed-symbol? BOOLEAN) ((symbol GENERALIZED-SYMBOL))
  :documentation "Return `true' if `symbol' is shadowed in its home module."
  :public? TRUE
  (let ((symbolName (symbol-name symbol))
        (module (interned-in symbol)))
    (return
      (and (defined? module)
           (exists shadow in (shadowed-surrogates module)
             where (eql? (symbol-name shadow) symbolName))))))


  ;;
;;;;;; Run-time instantiation
  ;;

(defun (get-constructor FUNCTION-CODE) ((class CLASS) (warn? BOOLEAN))
  ;; Return class constructor code for the class for `type'.
  (let ((constructor (class-constructor-code class)))
    (when (defined? constructor)
      (return constructor))
    (when warn?
      (when (class-abstract? class)
        (warn "The abstract class " (class-symbol class) " cannot have a constructor.")
        (return NULL))
      (warn "The "
            (choose (private? class) "private " "")
            "class " (class-symbol class) " does not have a callable constructor."))
    (return NULL) ))

(defun (create-object OBJECT) ((type TYPE) &rest (initial-value-pairs OBJECT))
  :documentation "Funcallable version of the `new' operator.
Return an instance of the class named by `type'.  If `initial-value-pairs'
is supplied, it has to be a key/value list similar to what's accepted by `new'
and the named slots will be initialized with the supplied values.  Similar to
`new', all required arguments for `type' must be included.  Since all the
slot initialization, etc. is handled dynamically at run time, `create-object'
is much slower than `new'; therefore, it should only be used if `type' cannot
be known at translation time."
  :public? TRUE
  (let ((class (get-stella-class type TRUE))
        (constructorCode (get-constructor class TRUE))
        (initialValues
         (choose (= (length initial-value-pairs) 0)
                 NULL
                 (new PROPERTY-LIST
                      :the-plist (coerce-&rest-to-cons initial-value-pairs))))
        (requiredSlots (class-required-slot-names class))
        (requiredSlotValues NIL)
        (slotValue OBJECT NULL)
        (slot SLOT NULL)
        (object OBJECT NULL))
    (when (not (defined? constructorCode))
      (error "create-object: no funcallable constructor available for " type))
    (when (non-empty? requiredSlots)
      (when (null? initialValues)
        (error "create-object: missing initial values for " type
               "'s required slots"))
      (foreach reqSlotName in requiredSlots
          do (setq slot (lookup-slot class reqSlotName))
             (unless (subtype-of? (type slot) @OBJECT)
               (error "create-object: can't yet initialize required slot "
                      type "." reqSlotName
                      ", since its type is not a subtype of OBJECT"))
            (setq slotValue (lookup initialValues (keywordify reqSlotName)))
             (remove-at initialValues (keywordify reqSlotName))
             (when (null? slotValue)
               (error "create-object: missing initial value for required slot "
                      type "." reqSlotName))
          collect slotValue into requiredSlotValues))
    (setq object (apply constructorCode requiredSlotValues))
    (when (defined? initialValues)
      ;; fill in remaining non-required values:
      (foreach (slotName value) in initialValues
          do (typecase slotName
               (KEYWORD
                (setq slot
                  (lookup-slot
                   class
                   (intern-derived-symbol type (symbol-name slotName))))
                (when (not (storage-slot? slot))
                  (error "create-object: slot " slotName
                         " does not exist on class " type))
                (put-slot-value object slot value))
               (otherwise
                (error "create-object: illegal initialization option: "
                       slotName)))))
    (return object)))


  ;;
;;;;;; Object destruction
  ;;

(defmethod free ((self OBJECT))
  :documentation "Default method.  Deallocate storage for `self'."
  :public? TRUE
  (unmake self) )

(defmethod free ((self ACTIVE-OBJECT))
  :documentation "Remove all pointers between `self' and other objects,
and then deallocate the storage for self."
  "NOT YET IMPLEMENTED"
  :public? TRUE
  (unmake self) )


(defun (coerce-to-boolean BOOLEAN-WRAPPER) ((object OBJECT))
  :public? TRUE
  ;; Return the boolean object represented by `object'.
  ;; Primarily used during parsing of boolean valued slots within class 
  ;;    and method definitions.
  (cond ((or (eql? object (quote TRUE))
             (eql? object :TRUE))
         (return TRUE-WRAPPER))
        ((or (eql? object (quote FALSE))
             (eql? object :FALSE))
         (return FALSE-WRAPPER)))
  ;; careful with this `typecase', since this is called early in the bootstrap:
  (typecase object
    ((SYMBOL KEYWORD)
     (cond ((string-equal? (symbol-name object) "TRUE")
            (return TRUE-WRAPPER))
           ((string-equal? (symbol-name object) "FALSE")
            (return FALSE-WRAPPER))))
    (BOOLEAN-WRAPPER
     (return object))
    (otherwise NULL))
  (inform "Don't know how to coerce " object " of type "
          (choose (defined? object)
                  (primary-type object)
                  @UNKNOWN)
          EOL "   into a boolean.")
  (return NULL))


  ;;
;;;;;; `define-stella-class'
  ;;

;;; Storage note:  Routines that call `define-stella-class' and
;;;    `define-stella-slot' must agree to a protocol regarding which
;;;    objects are transient and which are not.  All types and
;;;    symbols passed are permanent.  All collections are
;;;    temporary (they always get copied).

(defun (define-stella-class CLASS)
       ((name TYPE) (supers (LIST OF TYPE))
        (slots (LIST OF SLOT)) (options KEYWORD-KEY-VALUE-LIST))
  :documentation "Return a Stella class with name `name'.
Caution:  If the class already exists, the Stella class object gets
redefined, but the native C++ class is not redefined."
  :public? TRUE
  ;; TO DO: IF THE CLASS DEFINITION REFERENCES AN UNDEFINED CLASS,
  ;;    WHEN DOES THIS GET FIXED?
  ;; TO DO: INITIALIZE THE VALUE OF THE CLASS'S FREE LIST.
  ;; TO DO: FIGURE OUT HOW NON-OBJECT CLASSES WORK HERE.
  (let ((class CLASS (new CLASS))
        (parameterSlots (LIST OF SLOT) (lookup options :parameters))
        (oldClass OBJECT NULL)
        (success? FALSE))
    (when (and (not (eql? (home-context name) *module*))
               (not (visible-from? (home-context name) *module*)))
      (warn "Can't define a class named " name " because the module " EOL
            "   " (context-name (home-context name))
            " is not visible from the current module "
            (context-name *module*) "." EOL)
      (return NULL))
    (mv-setq (success? oldClass name)
             (bind-to-surrogate? class (symbol-name name) TRUE TRUE))
    (when (not success?)
      ;; abort class definition:
      (return NULL))
    ;; add back-link to surrogate:
    ;; BUG: LINKS TO SHADOWED SURROGATE:
    (setf (class-type class) name)    
    ;; push any parameter slots onto local slots.  Make them last, to
    ;;    speed slot lookup by a miniscule amount:
    (when (defined? parameterSlots)
      (foreach s in parameterSlots
               do
               ;; TO DO: FIGURE OUT HOW TO OVERRIDE THIS DEFAULT:
               (setf (abstract? s) TRUE)
               (insert-last slots s)))
    ;; allocate a cache vector:
    (initialize-slot-and-method-cache class)
    ;; fill in direct superclasses from list of types:
    ;; TO DO: HANDLE DEFINED TYPES.
    (foreach s in supers
        do (when (and (not (stella-class? (surrogate-value s)))
                      (not (eql? (interned-in s) *module*))
                      (visible-from? (interned-in s) *module*))
             ;; We probably have an unintended forward reference to
             ;;    a bogus surrogate inherited from a parent module:
             (when (>= *debugLevel* 3)
               ;; Issue a warning for now until this becomes too obnoxious:
               (inform "Automatically shadowing bogus super " s
                       " of class " name))
             (setq s (shadow-surrogate (symbol-name s))))
        collect s into (class-direct-supers class))
    (incorporate-class-options class options)
    (when (and (not (primitive? class))
               (exists slot in slots
                       where (primitive? slot)))
      (warn "Defined class " class " illegally specifies primitive slots."))
    (setf (class-local-slots class) slots)
    (when (and (defined? oldClass)
               (isa? oldClass @CLASS))
      ;; transfer subclasses, taxonomy node, extension, demons, etc.
      ;;    from `oldClass' to `class':
      (undefine-old-class oldClass class))
    ;; If there was an old class, we reused its taxonomy node; otherwise:
    (when (null? (class-taxonomy-node class))
      (setf (class-taxonomy-node class)
        (create-taxonomy-node
         *class-taxonomy-graph* NULL class
         (empty? (class-direct-supers class)))))
    ;; Now that the class has been successfully defined, register its slots
    ;;    (what about matching function and macro definitions?):
    (foreach slot in slots
        do (register-slot-name slot))
    (remember-unfinalized-class class TRUE)
    (return class) ))

(defun (define-stella-slot SLOT)
       ((name SYMBOL) (owner TYPE) (baseType TYPE)
        (typeSpecifier CONS)
        ;;(options (DICTIONARY OF KEYWORD OBJECT))
        (options KEYWORD-KEY-VALUE-LIST))
  ;; Return a slot with facets filled in.
  (let ((slot (new STORAGE-SLOT)))
    (setf (slot-name slot) name)
    (setf (slot-owner slot) owner)
    (setf (slot-base-type slot) baseType)
    (when (non-empty? typeSpecifier)    ; WHERE DOES GC OF INPUT HAPPEN?:
      (setf (slot-type-specifier slot) (yield-type-specifier typeSpecifier)))
    (foreach (key value) in options
             do
             (case key
               (:public?
                (setf (slot-public? slot) (cast value BOOLEAN-WRAPPER)))
               (:required?
                (setf (slot-required? slot) (cast value BOOLEAN-WRAPPER)))
               (:component?
                (setf (slot-component? slot) (cast value BOOLEAN-WRAPPER)))
               (:read-only?
                (setf (slot-read-only? slot) (cast value BOOLEAN-WRAPPER)))
               (:active?
                (setf (stored-active? slot) (cast value BOOLEAN-WRAPPER)))
               (:context-sensitive?
                (setf (slot-context-sensitive? slot)
                      (cast value BOOLEAN-WRAPPER)))
               (:hardwired?
                (setf (slot-hardwired? slot) (cast value BOOLEAN-WRAPPER)))
               (:abstract?
                (setf (abstract? slot) (cast value BOOLEAN-WRAPPER)))
               (:allocation
                (if (eq? value :class)
                    (warn "In definition of slot " slot
                          ": ':class' allocation is unsupported right now." EOL
                          " Maybe use ':hardwired? TRUE' for read-only slots.")
                  (setf (slot-allocation slot) (cast value KEYWORD))))
               (:initially
                (setf (slot-initial-value slot) value))
               (:default
                (setf (slot-default-expression slot) value))
               (:reader
                (setf (slot-reader slot) (cast value SYMBOL)))
               (:writer
                (setf (slot-writer slot) (cast value SYMBOL)))
               (:inverse
                (setf (slot-inverse slot) (cast value SYMBOL)))
               (:renames
                (setf (slot-renames slot) (cast value SYMBOL)))
               (:documentation
                (setf (slot-documentation slot)
                      (wrapper-value (cast value STRING-WRAPPER))))
               (:properties
                (setf (properties slot) (cast value LIST)))
               (:meta-attributes
                (setf (meta-attributes slot) (cast value KEY-VALUE-LIST)))
               (:option-keyword
                (setf (slot-option-keyword slot) (cast value KEYWORD)))
               (:option-handler
                (setf (slot-option-handler slot) (cast value SYMBOL)))
               (otherwise
                (unless (run-option-handler? slot key value)
                  (walk-warn "Skipping invalid slot option " key EOL
                             "in the definition of slot "
                             (type-to-symbol owner) "." name)))))
    (when (and (null? (slot-allocation slot))
               (eq? baseType @BOOLEAN))
      (setf (slot-allocation slot) :bit))
    (return slot) ))

(defun incorporate-class-options 
       ((class CLASS) (options KEYWORD-KEY-VALUE-LIST))
  ;; Helping function for `define-stella-class'.
  ;; Write the values of `options' into the appropriate slots.
  (foreach (key value) in options
           do
           (case key
             (:documentation
              (setf (class-documentation class)
                    (wrapper-value (cast value STRING-WRAPPER))))
             (:cl-native-type
              (setf (class-cl-native-type class)
                    (wrapper-value (cast value STRING-WRAPPER))))
             (:cpp-native-type
              (setf (class-cpp-native-type class)
                    (wrapper-value (cast value STRING-WRAPPER))))
             (:idl-native-type
              (setf (class-idl-native-type class)
                    (wrapper-value (cast value STRING-WRAPPER))))
             (:java-native-type
              (setf (class-java-native-type class)
                    (wrapper-value (cast value STRING-WRAPPER))))
             (:public?
              (setf (class-public? class) (cast value BOOLEAN-WRAPPER)))
             (:abstract?
              (setf (class-abstract? class) (cast value BOOLEAN-WRAPPER)))
             (:active?
              (setf (stored-active? class) (cast value BOOLEAN-WRAPPER)))
             (:cl-struct?
              (setf (class-cl-struct? class) (cast value BOOLEAN-WRAPPER)))
             (:mixin?
              (setf (class-mixin? class) (cast value BOOLEAN-WRAPPER))
              (when (class-mixin? class)
                (setf (class-abstract? class) TRUE)))
             (:recycle-method
              (setf (class-recycle-method class) value))
             (:extension (setf (class-extension-name class) value))
             (:creator (setf (class-creator class) value))
             (:initializer (setf (class-initializer class) value))
             (:terminator (setf (class-terminator class) value))
             (:destructor (setf (class-destructor class) value))
             (:initial-value (setf (class-initial-value class) value))
             (:print-form (setf (class-print-form class) value))
             (:equality-test
              ;; THIS HAS BEEN ELIMINATED:
;              (setf (class-equality-test class) value)
              )
             (:key
              (setf (class-key class) (new LIST))
              (foreach slotName in (cast value CONS)
                       collect slotName
                       into (class-key class)))
             ;; parametric class options:
             (:parameters
              ;; store list of names of parameter slots:
              (setf (class-parameters class) (new (LIST OF SYMBOL)))
              (foreach slot in (cast value (LIST OF SLOT))
                       collect (slot-name slot)
                       into (class-parameters class)))
             (:synonyms
              (setf (class-synonyms class) (new LIST))
              (foreach type in (cast value (CONS OF TYPE))
                       collect type into (class-synonyms class)))
             (:properties
              (setf (properties class) (cast value LIST)))
             (:meta-attributes
              (setf (meta-attributes class) (cast value KEY-VALUE-LIST)))
             (:children
              (setf (class-direct-subs class) (cast value LIST))
              (push *classes-with-unresolved-children-references* class))
             (otherwise
              (unless (run-option-handler? class key value)
                (walk-warn "Skipping invalid class option " key EOL
                           "in the definition of class "
                           (class-symbol class)))))))

(defun (inline-method? BOOLEAN) ((slot SLOT))
  ;; Return `true' if `slot' is an internal method slot.
  ;; Note1: Relies on the fact that inline methods get their parameters
  ;;        and body stringified in `define-inline-method'.
  ;; Note2: This used to additionally check for a non-empty method body,
  ;;        but it does not anymore.  Whoever needs to know that has to
  ;;        check for it explicitly.
  (return (and (not (slot-external? slot))
               (isa? slot @METHOD-SLOT)
               (not (method-function? (cast slot METHOD-SLOT))))))

(defun transfer-external-slot-to-new-class ((externalSlot SLOT)
                                            (newClass CLASS))
  ;; Helping function for `undefine-old-class'.
  ;; Transfer `externalSlot' onto the list of local slots in `newClass' unless
  ;;    it loses out to another local slot having the same name.
  ;; Note: The logic here is a variation on the one in `attach-slot-to-owner'.
  (let ((newClassSlot (lookup-local-slot newClass (slot-name externalSlot))))
    (cond ((null? newClassSlot)
           ;; no competing local slot; transfer the slot: 
           (insert (class-local-slots newClass) externalSlot))
          ;; `newClassSlot' is local:
          ((or (inline-method? newClassSlot)
               (not (eq? (primary-type newClassSlot)
                         (primary-type externalSlot)))
               ;; the inline slot overrides the external slot; no transfer:
               NULL))
          ;; Can/should we ever get here?
          (otherwise
           ;; wipe out `newClassSlot' and put `externalSlot' in its place:
           (substitute (class-local-slots newClass) externalSlot newClassSlot)
           (free newClassSlot))) ))

(defun transfer-demons-from-oldclass ((oldClass CLASS) (newClass CLASS))
  ;; Called by `undefine-old-class'.
  ;; Transfer activated slot demons and class demons from `oldClass'
  ;;    to `newClass'.
  ;; transfer activated slot demons:
  (let ((newSlot SLOT NULL))
    (foreach oldSlot in (class-local-slots oldClass)
             where (setq? newSlot
                          (lookup-local-slot newClass (slot-name oldSlot)))
             do
             (typecase oldSlot
               (STORAGE-SLOT
                (typecase newSlot
                  (STORAGE-SLOT
                   (setf (slot-guard-demons newSlot)
                         (slot-guard-demons oldSlot))
                   (setf (slot-guard-demons oldSlot) NULL)
                   (setf (slot-demons newSlot) (slot-demons oldSlot))
                   (setf (slot-demons oldSlot) NULL))
                  (otherwise NULL)))
               (otherwise NULL))))
  ;; transfer activated class demons:
  (setf (class-constructor-demons newClass)
        (class-constructor-demons oldClass))
  (setf (class-constructor-demons oldClass) NULL)
  (setf (class-guard-constructor-demons newClass)
        (class-guard-constructor-demons oldClass))
  (setf (class-guard-constructor-demons oldClass) NULL)
  (setf (class-destructor-demons newClass)
        (class-destructor-demons oldClass))
  (setf (class-destructor-demons oldClass) NULL)
  (setf (class-guard-destructor-demons newClass)
        (class-guard-destructor-demons oldClass))
  (setf (class-guard-destructor-demons oldClass) NULL) )

(defun undefine-old-class ((oldClass CLASS) (newClass CLASS))
  ;; Situation: `oldClass' is about to be retired in favor of `newClass'.
  ;; Unfinalize `oldClass' and its subclasses (thereby removing any
  ;;    structure-shared conses among them), and then transfer all of
  ;;    `oldClass's direct subtypes to `newClass'.
  ;; Also, transfer the class's demons and extension to `newClass'.
  (let ((newSubs
         ;; Make sure we don't loose explicitly specified :children
         ;;    during unfinalization, since that calls
         ;;    `remove-direct-supers-back-links':
         (copy-cons-list (the-cons-list (class-direct-subs newClass)))))
    (unfinalize-class-and-subclasses oldClass)
    (forget-unfinalized-class oldClass)
    ;; transfer subtype links (this scheme preserves the order of `newSubs'):
    (foreach oldSub in (class-direct-subs oldClass)
             collect oldSub into newSubs)
    (clear (class-direct-subs newClass))
    (setf (the-cons-list (class-direct-subs newClass))
      (remove-duplicates newSubs))
    (clear (class-direct-subs oldClass)))
  ;; Update taxonomy graph information:
  (let ((taxonomyNode (class-taxonomy-node oldClass)))
    (foreach super in (class-direct-supers oldClass)
        where (and (defined? (type-class super))
                   (not (member? (class-direct-supers newClass) super)))
        do (unlink-taxonomy-nodes
            *class-taxonomy-graph*
            (class-taxonomy-node (type-class super))
            taxonomyNode))
    (setf (class-taxonomy-node newClass) taxonomyNode)
    (setf (class-taxonomy-node oldClass) NULL))
  ;; transfer external slots:
  (foreach oldSlot in (class-local-slots oldClass)
           where (slot-external? oldSlot)
           do (transfer-external-slot-to-new-class oldSlot newClass))
  ;; transfer constructor for use until startup code resets it:
  (setf (class-constructor-code newClass) (class-constructor-code oldClass))
  (transfer-demons-from-oldclass oldClass newClass)
  ;; run redefine relation hook functions:
  (run-hooks *redefine-relation-hooks* (list oldClass newClass))
  (free oldClass) )

(defmethod destroy-class ((self CLASS))
  :documentation "Destroy the Stella class `self'.  
Unfinalize its subclasses (if it has any)."
  :public? TRUE
  ;; oddity: we remove 'self from *unfinalized-classes* twice, once
  ;;    right away in case something breaks inside of
  ;;   `unfinalize-class-and-subclasses', and again because `self'
  ;;  gets put back on the list.
  (when (deleted? self)
    (return))
  (when (eql? (home-context (class-type self)) *stella-module*)
    (warn "Can't delete STELLA class " (class-name self) ".")
    (return))
  (unfinalize-class-and-subclasses self)
  (unbind-from-surrogate self)
  (when (defined? (class-taxonomy-node self))
    ;; Unlink taxonomy node:
    (remove-taxonomy-node *class-taxonomy-graph* (class-taxonomy-node self)))
  (setf (deleted? self) TRUE)
  ;; Try to refinalize other classes as much as possible:
  ;; Disabled, since it slows down `clear-module'; should this be an option?
  ;(finalize-classes-and-slots)
  (free self) )

(defmethod destroy-class ((self TYPE))
  :public? TRUE
  (let ((class (type-class self)))
    (if (null? class)
      (inform "Can't destroy non-existent class " self ".")
      (destroy-class class)) ))

(defun destroy-class-and-subclasses ((self CLASS))
  :documentation "Destroy the Stella class `self' and all its subclasses."
  (foreach subType in (class-direct-subs self)
           where (defined? (type-class subType))
           do (destroy-class-and-subclasses (type-class subType)))
  (destroy-class self))

  ;;
;;;;;; Support for defined classes and slots
  ;;

;;; The next method is a top-level stub that will do the right thing
;;; even if the Stella kernel is run without the logic module.  Once the
;;; logic module is loaded, it gets specialized on CLASS and SLOT and
;;; will magically start to do its thing.

;;; TO DO: Since defined classes and slots are now completely handled by
;;;        the logic, maybe we can get rid of this whole mechanism?

(defmethod (primitive? BOOLEAN) ((self RELATION))
  :documentation "Return `true' if `self' is not a defined relation."
  :public? TRUE
  (return TRUE))

(defun insert-primitive-super ((newSuper TYPE) (supers (LIST OF TYPE)))
  ;; Add `newSuper' to `supers' unless it is already subsumed by
  ;;    some other member of `supers'.
  ;; Remove all members of `supers' that are subsumed by `newSuper'.
  (unless (exists sup in supers
                  where (subtype-of? newSuper sup))
    (let ((subsumedSuper TYPE NULL))
      ;; Remove all members of `supers' that are subsumed by `newSuper':
      (while (setq? subsumedSuper
                    (some sup in supers
                          where (subtype-of? sup newSuper)))
        (setq supers (remove supers subsumedSuper)))
      (insert supers newSuper))))

(defun collect-most-specific-primitive-supers
    ((class CLASS) (supers (LIST OF TYPE)))
  ;; Collect the most specific primitive supers of `class' into `supers'.
  (foreach super in (class-direct-supers class)
           do (if (primitive? (type-to-class super))
                  (insert-primitive-super super supers)
                ;; We have a defined class, try its supers:
                (collect-most-specific-primitive-supers
                 (type-to-class super) supers))))

(defun (most-specific-primitive-supers (LIST OF TYPE)) ((class CLASS))
  ;; Return a newly allocated list of most specific primitive supers
  ;;    of `class'.
  ;; For classes that do not have any defined superclasses as their
  ;;    immediate parents this will generate a copy of `class-direct-supers'.
  (let ((supers (new LIST)))
    (collect-most-specific-primitive-supers class supers)
    (return (reverse supers))))

(defun (class-native-supers (LIST OF TYPE)) ((class CLASS))
  ;; Return an iterator that iterates over the set of most specific
  ;;    superclasses of `class' that have corresponding native classes.
  ;; This tries to handle situations where a primitive class C is a subclass
  ;;    of a defined class D, and, hence, a primitive superclass of D needs
  ;;    to be chosen to serve as the native superclass of C.
  (if (forall super in (class-direct-supers class)
          always (primitive? (type-to-class super)))
      (return (class-direct-supers class))
    (return (most-specific-primitive-supers class))))

  ;;
;;;;;; Class finalization
  ;;

(defglobal *unfinalized-classes* (LIST OF CLASS) (new LIST)
  :documentation "List of classes whose class or slot inheritance is
currently unfinalized.")

(defglobal *newly-unfinalized-classes?* BOOLEAN FALSE
  :documentation "Set to `true' by `remember-unfinalized-class'; set
to `false' by `cleanup-unfinalized-classes'.  Minimizes the time that
`finalize-classes' spends searching for classes to finalize.")

(defglobal *classes-with-unresolved-children-references* (LIST OF CLASS)
  (new LIST)
  :documentation "List of classes defined with a :children option
which still have some of their children references unresolved.")

(defun remember-unfinalized-class ((class CLASS) (force? BOOLEAN))
  ;; Remember `class' as an unfinalized class for future finalization.
  ;; Only do so if `class' is currently finalized or if `force?' is TRUE.
  (when (or force?
            ;; When a class gets unfinalized its `class-finalized?'
            ;; and/or `class-slots-finalized?' slot are set to FALSE.
            ;; Thus we can use that to keep *unfinalized-classes* a set:
            (and (class-finalized? class)
                 (class-slots-finalized? class)))
    (push *unfinalized-classes* class)
    (setq *newly-unfinalized-classes?* TRUE) ))

;; THIS IS POTENTIALLY TOO SLOW:
(defun forget-unfinalized-class ((class CLASS))
  (unless (and (class-finalized? class)
               (class-slots-finalized? class))
    (remove *unfinalized-classes* class)))

(defun finalize-classes ()
  :documentation "Finalize all currently unfinalized classes."
  :public? TRUE
  (when (not *newly-unfinalized-classes?*)
    (return))
  (let ((hierarchyMightHaveChanged? FALSE))
    (remove-deleted-members *unfinalized-classes*)
    (resolve-children-references)
    (foreach class in *unfinalized-classes*
        where (and (not (class-finalized? class))
                   (not (bad? class)))
        do (finalize-class class)
           (setq hierarchyMightHaveChanged? TRUE))
    ;; If a slot gets added to a class (or modified) the class becomes
    ;;    unfinalized, even though the hierarchy didn't change at all.
    ;;    So, make sure we only recompute the taxonomy when necessary:
    (when hierarchyMightHaveChanged?
      (finalize-taxonomy-graph *class-taxonomy-graph*))))

(defun resolve-children-references ()
  ;; Try to resolve children references for classes that were defined
  ;;    with a :children option.
  (when (or (empty? *classes-with-unresolved-children-references*)
            ;; If there are still some classes with unresolved children but
            ;; not any unfinalized classes, then no new classes got defined
            ;; since the last finalization, and none of the still unresolved
            ;; forward references can be resolved now, thus, quick exit.  This
            ;; saves a lot during incremental translation and development.
            (empty? *unfinalized-classes*))
    (return))
  (let ((unresolvableClasses NIL))
    (remove-deleted-members *classes-with-unresolved-children-references*)
    (foreach class in *classes-with-unresolved-children-references*
             do
             (add-direct-subs-back-links class)             
             (when (exists sub in (class-direct-subs class)
                           where (not (defined? (type-to-class sub))))
               (pushq unresolvableClasses class)))
    (clear *classes-with-unresolved-children-references*)
    (setf (the-cons-list *classes-with-unresolved-children-references*)
      unresolvableClasses)))

(defun finalize-slots ()
  :public? TRUE
  :documentation "Finalize all currently unfinalized slots."
  (when (not *newly-unfinalized-classes?*)
    (return))
  (foreach class in *unfinalized-classes*
           where (and (class-finalized? class)
                      (not (class-slots-finalized? class))
                      (not (bad? class)))
           do (finalize-class-slots class)))

(defun cleanup-unfinalized-classes ()
  :public? TRUE
  :documentation "Remove all finalized classes from `*UNFINALIZED-CLASSES*',
and set `*NEWLY-UNFINALIZED-CLASSES?*' to `false'."
  (let ((unfinalizedClasses NIL))
    (foreach class in *unfinalized-classes*
             where (or (not (class-finalized? class))
                       (not (class-slots-finalized? class)))
             collect class into unfinalizedClasses)
    (clear *unfinalized-classes*)
    (setf (the-cons-list *unfinalized-classes*) unfinalizedClasses)
    (setq *newly-unfinalized-classes?* FALSE)))

(defun finalize-classes-and-slots ()
  :public? TRUE
  :documentation "Finalize all currently unfinalized classes and slots."
  (finalize-classes)
  (finalize-slots)
  (cleanup-unfinalized-classes))

(defun activate-class ((class CLASS))
  ;; Try to make `class' active by making it inherit ACTIVE-OBJECT.
  (let ((activeObjectClass (type-to-class @ACTIVE-OBJECT))
        (supers (class-direct-supers class)))
    (when (and (defined? activeObjectClass)
               (subclass-of? class activeObjectClass))
      (return))
    ;; Handle some special cases:
    (cond ((eq? (length supers) 0)
           (insert supers @ACTIVE-OBJECT))
          ((and (eq? (length supers) 1)
                (or (eq? (first supers) @OBJECT)
                    (eq? (first supers) @STANDARD-OBJECT)))
           (remove-direct-supers-back-links class)
           (clear supers)
           (insert supers @ACTIVE-OBJECT))
          (otherwise
           (setf (stored-active? class) FALSE)
           (when (defined? (class-extension-name class))
             (setf (class-extension-name class) NULL))
           (warn "Cannot convert " class " into an ACTIVE-OBJECT." EOL
                 "You have to modify its superclasses by hand.")
           (return)))
    (add-direct-supers-back-links class)
    (inherit-superclasses class)))

(defun add-primary-type ((class CLASS))
  ;; Add a `primary-type' method to `class' if necessary.
  (let ((classType (class-type class))
        (slotTree CONS NULL))
    (when (and (not (abstract? class))
               (subtype-of? classType @OBJECT)
               (not (exists slot in (class-local-slots class)
                            where (eq? (slot-name slot)
                                       (quote primary-type)))))
      (setq slotTree
        (bquote (((self & (type-to-symbol classType)))
                 :type TYPE :auxiliary? TRUE
                 ;; Overly-dependent on the `print-object' function:
                 (return & classType))))
      (push (class-local-slots class)
            (define-inline-method (quote primary-type) slotTree)))))

(defun finalize-one-class ((class CLASS))
  ;; Perform finalization of `class', e.g., compute class inheritance.
  (within-module (home-module class)
    (when (defined? (class-extension-name class))
      ;; Extensions are maintained by demons:
      (setf (stored-active? class) TRUE))
    ;; link super classes to `class':
    (add-direct-supers-back-links class)
    (inherit-superclasses class)
    (when (and (defined? (stored-active? class))
               (stored-active? class))
      (activate-class class))
    (add-primary-type class)
    (foreach alias in (class-synonyms class)
        do (if (and (defined? (type-class alias))
                    (not (eq? (type-class alias) class))
                    ;; alias points to old version of class
                    ;; that has now been redefined:
                    (not (string-eql? (class-name (type-class alias))
                                      (class-name class))))
               (warn "Alias " (type-to-symbol alias) " can't point to "
                     (class-symbol class) " because it already points to " EOL
                     "the class " (class-symbol (type-class alias)) ".")
             (setf (type-class alias) class)))
    ;; initialize extension:
    (when (and (defined? (class-extension-name class))
               (null? (class-extension class)))
      (setf (class-extension class) (new CLASS-EXTENSION)))
    (run-hooks *finalize-relation-hooks* class)
    (setf (class-finalized? class) TRUE)))

(defun (finalize-class BOOLEAN) ((class CLASS))
  ;; Perform finalization of `class', i.e., compute class inheritance.
  ;; Assure that all superclasses of `class' are finalized, and then
  ;;    finalize all its subclasses.
  ;; Return TRUE if `class' could be successfully finalized.
  (return (help-finalize-class class NULL)))

(defun (help-finalize-class BOOLEAN) ((class CLASS) (finalizedParent TYPE))
  ;; Do all the work for `finalize-class'.
  ;; The extra `finalizedParent' argument avoids a little bit of work
  ;;     in case this is called from an already finalized parent class.
  (when (class-finalized? class)
    (return TRUE))
  (setf (bad? class) TRUE)
  ;; Ensure that all but the already `finalizedParent' are finalized:
  (foreach super in (class-direct-supers class)
           where (not (eql? super finalizedParent))
           do
           (let ((superClass (type-to-class super)))
             (if (defined? superClass)
               (unless (help-finalize-class superClass NULL)
                 (return FALSE))
               (return FALSE))))
  ;; Finalizing a parent might have already finalized `class':
  (when (class-finalized? class)
    (setf (bad? class) NULL)
    (return TRUE))
  (finalize-one-class class)
  ;; now that `class' is finalized, try to finalize its subclasses:
  (foreach sub in (class-direct-subs class)
      do (let ((subClass (type-to-class sub)))
           (when (defined? subClass)
             (help-finalize-class subClass (class-type class)))))
  (setf (bad? class) NULL)
  (return TRUE))

(defun unfinalize-class-and-subclasses ((class CLASS))
  ;; Remove effects of class finalization on `class'.
  ;; CAREFUL: We unfinalize subclasses FIRST so that structure-shared
  ;;    lists don't get messed up.
  (when (not (class-finalized? class))
    (return))
  ;; unlink from supers right away in case something breaks (so that
  ;;    the bad class is maximally isolated).
  (remove-direct-supers-back-links class)
  (let ((subs (copy (class-direct-subs class))))
    (foreach subType in subs
             where (defined? (type-class subType))
             do (unfinalize-class-and-subclasses (type-class subType)))
    (free subs))
  ;; unlink any synonyms:
  (foreach alias in (class-synonyms class)
           where (eq? (type-class alias) class)
           do (setf (type-class alias) NULL))
  (uninherit-superclasses class)
  (unfinalize-class-slots class)
  ;; Doing this would be more efficient than copying the list of
  ;; direct subs and using `remove-direct-supers-back-links', but
  ;; then we wouldn't disconnect the top-level class from its supers.
  ;;(clear (class-direct-subs class))
  (remember-unfinalized-class class FALSE)
  (setf (class-finalized? class) FALSE))

(defun (attach-slot-to-owner SLOT) ((newSlot SLOT))
  :public? TRUE
  ;; Called by `attach-method-slot-to-owner'.
  ;; Add `newSlot' to the list of local slots on its owner, and
  ;;    unfinalize the local slots list for the owner class and
  ;;    all its subclasses.
  ;; Mark `newSlot' as `external', indicating that it was defined outside
  ;;    of the owner class, and hence must be preserved during class revision.
  ;; Return `null' if the old slot is a different kind of slot than `newSlot'
  ;;    and hence can't be redefined.
  ;; TO DO: CLEAR OUT FUNCTION AND MACRO DEFINITIONS.
  (let ((name (slot-name newSlot))
        (ownerClass (type-class (slot-owner newSlot)))
        (oldSlot (lookup-local-slot ownerClass name)))
    (setf (slot-external? newSlot) TRUE)
    (register-slot-name newSlot)
    (cond
     ((null? oldSlot)
      (insert (class-local-slots ownerClass) newSlot)
      (unfinalize-class-slots ownerClass)
      (return newSlot))
     ((not (local-slot? oldSlot ownerClass))
      ;; an inherited slot has the same name:
      (insert (class-local-slots ownerClass) newSlot)
      (unfinalize-class-slots ownerClass)
      (return newSlot))
     ((not (eq? (primary-type newSlot) (primary-type oldSlot)))
      ;; old local slot exists:
      (warn "Can't define a " (primary-type newSlot) " named " name
            " on the class " (class-name ownerClass) EOL
            "because it already has a " (primary-type oldSlot)
            " with the same name.")
      (return NULL))
     (otherwise
      ;; replace old slot with new one:
      (substitute (class-local-slots ownerClass) newSlot oldSlot)
      ;; run redefine relation hook functions:
      (run-hooks *redefine-relation-hooks* (list oldSlot newSlot))
      (free oldSlot)
      ;; Optimization: only unfinalize the slots of `ownerClass':
      (help-unfinalize-class-slots ownerClass)
      (return newSlot)))))

#|

;; Currently not used:

(defun (add-slot STORAGE-SLOT)
       ((name OBJECT) (class OBJECT) (slot-type OBJECT) &rest (options OBJECT))
  :documentation "Add a slot named `name' to the class `class'.  `slot-type'
is either a class surrogate or a complex type expression.  `options' is a
property list of keywords and values."
  (let ((classSurrogate (surrogatify class))
        (optionsDictionary (allocate PROPERTY-LIST ))
        (slotBaseType TYPE NULL)
        (slotTypeTree NIL)
        (slot STORAGE-SLOT NULL))
    (when (string? name)
      (setq name (intern-symbol (wrapper-value (cast name STRING-WRAPPER)))))
    (cond
     ((cons? slot-type)
      (setq slotTypeTree slot-type))
     ((surrogate? slot-type)
      (setq slotBaseType slot-type))
     (otherwise (error "Illegal type specifier " slot-type)))
    (let ((list NIL))
      (foreach item in options collect item into list)
      (setf (the-plist optionsDictionary) list))
    (setq slot (define-stella-slot
                 name classSurrogate slotBaseType slotTypeTree optionsDictionary))
    (attach-slot-to-owner slot)
    (free optionsDictionary)
    (return slot) ))
|#

  ;;
;;;;;; Class validation
  ;;

;;; Check validity of some storage slot options:

(defun compute-slot-direct-equivalent ((self SLOT))
  ;; Find direct super slot of `self', if it has one.
  ;; Also, set `slot-renamed?' on slot renamed by `self'.
  ;; TO DO: FINISH CONVERTING THIS TO SINGLE SLOT COMPUTATION.
  (let ((class (type-class (slot-owner self)))
        (slotName (slot-name self))
        (slotRenames (slot-renames self))
        (renamesSlot SLOT NULL))
    (cond ((defined? slotRenames)
           (setq renamesSlot
             (some s in (class-slots class)
                   where (eq? (slot-name s) slotRenames)))
           (cond ((defined? renamesSlot)
                  (setf (slot-direct-equivalent self) renamesSlot)
                  (setf (slot-renamed? renamesSlot) TRUE))
                 (otherwise
                  (warn "Slot " slotName " renames a non-existent self: "
                        slotRenames "." EOL "Cancelling the renames option.")
                  (setf (slot-renames self) NULL))))
          (otherwise
           ;; If `slot' is not renamed, point at super slot with the same name:
           (setf (slot-direct-equivalent self)
             (some s in (class-slots class)
                   where (and (not (eq? s self))
                              (eq? (slot-name s) slotName))))))))

(defun check-conformance-of-slot-signature ((self SLOT))
  ;; Complain if the return type of `self' is incompatible with an
  ;;    inherited equivalent (if there is one).
  (let ((equivalentSlot (slot-direct-equivalent self)))
    (when (and (defined? equivalentSlot)
               (not (conforming-signatures? self equivalentSlot)))
      (warn "The signature of slot " self " does not conform to the" EOL
            "   signature of the inherited slot " equivalentSlot)) ))

;; TO DO: FIGURE OUT HOW TO MAKE THIS EXTENSIBLE:
(defun (collection-to-active-collection TYPE) ((type TYPE))
  ;; Return the name of the collection representing the active
  ;;    version of the collection `type' (i.e., the version that
  ;;    can fill an active slot).
  (case type
    ((@SET @ACTIVE-SET) (return @ACTIVE-SET))
    ((@LIST @ACTIVE-LIST) (return @ACTIVE-LIST))
    (otherwise (return NULL))))

(defun activate-slot ((self STORAGE-SLOT))
  ;; If `self' is active and multi-valued, replace its type by an
  ;;    active collection.
  (when (collection-valued? self)
    (let ((activeCollection
           (collection-to-active-collection (slot-base-type self))))
      (when (null? activeCollection)
        (warn "No active collection defined for " (slot-base-type self) "."
              EOL "   Cannot activate slot " self ".")
        (setf (stored-active? self) FALSE)
        (return))
      (setf (slot-base-type self)
        (collection-to-active-collection (slot-base-type self)))))
  (setf (stored-active? self) TRUE))

(defmethod finalize-slot-type-computations ((self SLOT)) NULL)

(defmethod finalize-slot-type-computations ((self STORAGE-SLOT))
  ;; Finalize type information for storage slot `self'.
  ;; Finish computation of `slot-base-type':
  (when (defined? (slot-type-specifier self))
    (setf (slot-base-type self)
          (validate-type-specifier
           (slot-type-specifier self) (type-class (slot-owner self)) FALSE)))
  ;; inherit base type if its not locally defined:
  (when (null? (slot-base-type self))
    (setf (slot-base-type self) (type self)))
  (when (null? (slot-base-type self))
    (when (not (abstract? self))
      (warn "Missing type specification for the slot " self))
    (setf (slot-base-type self) @UNKNOWN)
;    (setf (bad? self) TRUE)
    (return))
  (when (active? self)
    (activate-slot self)))

(defun (multi-valued-slot-with-duplicates? BOOLEAN) ((self SLOT))
  (return (and (subtype-of? (type self) @COLLECTION)
               (not (subtype-of? (type self) @SET-MIXIN)))))

(defun compute-slot-inverses ((self SLOT))
  ;; Forward propagate inverse slots.
  ;; TO DO: FIGURE OUT HOW TO PROPAGATE TO RENAMING SLOTS.
  (when (null? (slot-inverse self))
    (return))
  (when (multi-valued-slot-with-duplicates? self)
    (warn "Can't define an inverse on slot " self
          " because it allows duplicate values.")
    (setf (slot-inverse self) NULL)
    (return))
  (let ((inverseClass (type-class (type self)))
        (inverseSlot (safe-lookup-slot inverseClass (slot-inverse self))))
    (when (defined? inverseSlot)
      (when (multi-valued-slot-with-duplicates? inverseSlot)
        (warn "Can't define an inverse on slot " inverseSlot
              " because it allows duplicate values.")
        (setf (slot-inverse self) NULL)
        (setf (slot-inverse inverseSlot) NULL)
        (return))
      (when (not (active? inverseSlot))
        (setf (slot-inverse inverseSlot) (slot-name self))
        ;; activate `inverseSlot':
        (finalize-slot-type-computations inverseSlot))
      ;; attach demon to `self':
      (setf (inverse inverseSlot) self)
      (attach-inverse-slot-demon self)
      ;; attach demon to `inverseSlot':
      (setf (inverse self) inverseSlot)
      (attach-inverse-slot-demon inverseSlot)
      (return))
    ;; bad inverse reference:
    (if (null? inverseClass)
      (warn "Can't finalize inverse slot computation for slot " self EOL
            " because the class " (type self) " is not defined.")
      (warn "Can't finalize inverse slot computation for slot " self EOL
            " because the inverse slot " (slot-inverse self)
            " does not exist."))))

(defmethod help-finalize-local-slot ((self SLOT)) NULL)

(defmethod help-finalize-local-slot ((self STORAGE-SLOT))
  ;; Set built-in default values.
  ;; Check validity of storage slot specification.
  (let ((owner (type-class (slot-owner self))))
    (when (and (dynamic-slot? self)
               (not (subtype-of? (class-type owner) @DYNAMIC-SLOTS-MIXIN))
               (not (class-abstract? owner)))
      (warn "Slot " (slot-name self) " on the class " (class-symbol owner) EOL
            "   can't have :dynamic slot allocation because the class doesn't" EOL
            "   inherit the class `DYNAMIC-SLOTS-MIXIN'.  Resetting the" EOL
            "   allocation to ':instance'.")
      (setf (slot-allocation self) :instance))
    (when (defined? (slot-renames self))
      (let ((renamesSlot
             STORAGE-SLOT (safe-lookup-slot owner (slot-renames self))))
        (cond
         ((not (eq? (primary-type self) (primary-type renamesSlot)))
          (warn "Slot " (slot-name self) " renames a slot of a different kind" EOL
                "   (e.g., a storage slot renaming a method slot, or vice-versa)." EOL
                "  Cancelling the renames option.")
          (setf (slot-renames self) NULL))
         ((not (eq? (allocation self) (allocation renamesSlot)))
          (warn "Slot " (slot-name self) " renames a slot with a different" EOL
                "   allocation.  Changing its allocation to "
                (allocation renamesSlot) ".")
          (setf (slot-allocation self) (allocation renamesSlot))))))
    (when (and (slot-context-sensitive? self)
               (not (subtype-of? (slot-owner self) @CONTEXT-SENSITIVE-OBJECT))
               (not (subtype-of? (class-type owner) @CONTEXT-SENSITIVE-MIXIN)))
      (error "Class " (symbol-name (slot-owner self)) " must inherit either the "
             "class CONTEXT-SENSITIVE-OBJECT" EOL
             "   or the class CONTEXT-SENSITIVE-MIXIN because it contains the" EOL
             "   context sensitive slot " (slot-name self) " " EOL)) ))

(defun finalize-local-slot ((self SLOT))
  ;; Do slot finalization common to both storage slots and method slots.
  ;; Then do finalization that is different.
  (compute-slot-direct-equivalent self)
  (finalize-slot-type-computations self)
  (check-conformance-of-slot-signature self)
  (compute-slot-inverses self)
  (help-finalize-local-slot self)
  (run-hooks *finalize-relation-hooks* self) )

(defmethod unfinalize-local-slot ((self SLOT)) NULL)

(defmethod unfinalize-local-slot ((self STORAGE-SLOT))
  ;; Most storage slot finalizations get overwritten.  
  NULL)

(defun finalize-class-slots ((class CLASS))
  ;; Finalize each of the local slots in `self'.
  ;; Assures that the slots of all superclasses of `class' are also
  ;;    finalized.
  ;; Used to inherit slots into the list `class-slots' which is now
  ;;    disabled since it is expensive and doesn't help very much.
  (setf (bad? class) TRUE)
  (foreach super in (class-direct-supers class)
           where (not (class-slots-finalized? (type-class super)))
           do (finalize-class-slots (type-class super)))
  ;; Note: Also fix `attach-slot-to-owner' if this gets reactivated:
  ;;(inherit-slots class)
  (compute-required-slot-names class)
  ;; make sure that slots that reference other local slots of `class'
  ;;    don't break:
  (let ((classType (class-type class)))
    (foreach slot in (class-local-slots class)
        do (register-slot-name slot)
           ;; Fixup owners to make sure slots of shadowing classes
           ;;    don't accidentally point to the shadowed class:
           (setf (slot-owner slot) classType)))
  ;; validate and/or derive data within slots:
  (foreach slot in (class-local-slots class)
      do (finalize-local-slot slot))
  ;; mark slots as finalized:
  (setf (class-slots-finalized? class) TRUE)
  (setf (bad? class) NULL))

(defun unfinalize-class-slots ((class CLASS))
  ;; Unfinalize slots local to `class'.
  ;; Used to undo slot inheritance which is now disabled (see above).
  (when (not (class-slots-finalized? class))
    ;; quick exit if slots already unfinalized (due to multiple inheritance)
    (return))
  (foreach subType in (class-direct-subs class)
           where (defined? (type-class subType))
           do (unfinalize-class-slots (type-class subType)))
  (help-unfinalize-class-slots class))

(defun help-unfinalize-class-slots ((class CLASS))
  ;; Unfinalize the slots of one `class'.
  (clear-slot-and-method-cache class)
  (when (not (class-slots-finalized? class))
    (return))
  ;;(uninherit-slots class)
  (free-required-slot-names class)
  (foreach slot in (local-slots class)
           do (unfinalize-local-slot slot))
  (remember-unfinalized-class class FALSE)
  ;; mark slots as unfinalized:
  (setf (class-slots-finalized? class) FALSE))

#|
;;; THIS IS NOT YET REAL:
(defun future-finalize-class? (class force?)
  ;; If `class' is has not yet generated a native class definition,
  ;;    search its dependents, recursively, to see if they are all
  ;;    defined.  If so, generate native class definitions for all
  ;;    of them and return `true'.  Otherwise return `false'.
  ;; `force?' indicates that we should generate an error if a native
  ;;    class cannot be generated for `class'.
  (when (finalized? class)
    (return-from finalize-class? TRUE))
  (foreach super in (class-direct-supers class)
           where (or (null? (type-class super))
                     (not (finalized? (type-class super))))
           do (return FALSE))
  (let ((unfinalizedReferents (new LIST))
        (undefinedReferents (new LIST)))
    (search-for-undefined-referents class unfinalizedReferents undefinedReferents)
    (if (empty? undefinedReferents)
      (progn
        (foreach c in unfinalizedReferents
                 where (not (finalized? c))
                 do (define-native-class class))
        (return-from finalize-class? TRUE))
      (when force?
        (warn "Can't create a native class named '~A' because it depends
 (directly or indirectly) on the following undefined classes:~%"
              (name class))
        (foreach c in undefinedReferents
                 do (format t "   '~A'~%"))
        (error ""))) ))

(defun search-for-undefined-referents
       (class unfinalizedReferents undefinedReferents)
  ;; Helping function for `finalize-class?'.
  ;; Collect all defined recursive referents of `class' into `unfinalizedReferents',
  ;;    and collect any undefined referents encountered into `undefinedReferents'.
  (when (undefined? class)
    (return-from search-for-undefined-referents nil))
  ;; `class' is a CLASS or a STRING-WRAPPER:
  (when (not (in-class? class @CLASS))
    ;; collect undefined referent
    (insert undefinedReferents class)
    (return-from search-for-undefined-referents nil))
  ;; `class' is a CLASS:
  (when (or (finalized? class)
            (in? unfinalizedReferents class))
    (return-from search-for-undefined-referents nil))
  ;; collect newly-discovered unfinalized referent:
  (insert unfinalizedReferents class)
  (foreach s in (class-direct-supers class)
           do (search-for-undefined-referents s))
  (foreach slot in (class-local-slots class)
           do
           (search-for-undefined-referents (slot-value-type slot))
           (search-for-undefined-referents (slot-base-type slot))) )

|#


  ;;
;;;;;; subclass and superclass computations
  ;;

;;; Classes use structure sharing cons lists to save space in
;;;    representing lists of all super classes.
;;; Trick:  A class with a single parent class structure shares,
;;;    and is responsible for the single cons it uses to point
;;;    to parents.  A class with multiple parents does not structure
;;;    share, and is responsible for all conses in its superclasses
;;;    list.


(defmethod (multiple-parents? BOOLEAN) ((class CLASS))
  :documentation "Return `true' if `class' has more than one direct superclass."
  :public? TRUE
  (return (non-empty? (rest (class-direct-supers class)))) )

(defun add-direct-supers-back-links ((class CLASS))
  ;; Remove any duplicate direct super types, and then push the class
  ;;    type onto the list of direct subs of each direct super class.
  (let ((directSupers (class-direct-supers class))
        (classType (class-type class)))
    (remove-duplicates directSupers)
    ;; add `class's name (surrogate) to the direct subs lists of its supers:
    (foreach superType in directSupers
        where (defined? (type-class superType))
        do (let ((superClass (type-class superType)))
             (insert-new (class-direct-subs superClass) classType)
             ;; Add taxonomy graph links:
             (link-taxonomy-nodes
              *class-taxonomy-graph*
              (class-taxonomy-node (type-class superType))
              (class-taxonomy-node class))))))

(defun add-direct-subs-back-links ((class CLASS))
  ;; Dual to `add-direct-supers-back-links'.
  ;; Remove any duplicate direct sub types, and then push the class
  ;;    type onto the list of direct supers of each direct sub class.
  ;; Side-effect: Unfinalize a sub class if `class' becomes its super.
  (let ((directSubs (class-direct-subs class))
        (classType (class-type class)))
    (remove-duplicates directSubs)
    ;; add `class's name (surrogate) to the direct supers lists of its subs:
    (foreach subType in directSubs
             where (defined? (type-class subType))
             do
             (let ((subClass (type-class subType)))
               (if (class-finalized? subClass)
                 (unless (member? (class-all-super-classes subClass) class)
                   (insert (class-direct-supers subClass) classType)
                   (unfinalize-class-and-subclasses class))
                 (insert-new (class-direct-supers subClass) classType))))))

(defun remove-direct-supers-back-links ((class CLASS))
  ;; Remove the `class' type from the list of direct subs of each of
  ;;   `class's direct super classes.
  (let ((classType (class-type class)))
    (foreach superType in (class-direct-supers class)
             where (defined? (type-class superType))
             do (remove (class-direct-subs (type-class superType))
                        classType))))

(defun collect-direct-super-classes ((class CLASS) (parents (LIST OF CLASS)))
  ;; Fill `parents' with the most-specific direct super classes of
  ;;    `class' (don't include classes that are ancestors of other direct
  ;;    super classes).
  ;; Generate a warning if the original direct supers are not all most
  ;;    specific.
  ;; Note: Its not safe to replace direct types with a list of most 
  ;;    specific direct types because that changes the class's definition
  ;;    in a manner that could go bad in the presence of revision of a
  ;;    superclass.
  (let ((directSuperTypes (class-direct-supers class))
        (nonDirectParents (new (LIST OF CLASS))))
    ;; collect direct classes:
    (foreach superType in directSuperTypes
             ;; QUESTION: WHY IS THIS HERE?  SHOULDN'T ALL DIRECT SUPERS
             ;;    BE DEFINED BEFORE WE GET TO THIS POINT?:
             where (defined? (type-class superType))
             collect (type-class superType) into parents)
    ;; detect direct super classes that are not most specific:
    (foreach
     superClass in parents
     do (foreach otherSuperClass in parents
                 where (not (eq? otherSuperClass superClass))
                 do (when (member? (class-all-super-classes superClass)
                                   otherSuperClass)
                      (insert nonDirectParents otherSuperClass))))
    ;; remove direct super classes that are not most specific:
    (foreach p in nonDirectParents
             do (remove parents p))
    (free nonDirectParents) ))

(defun inherit-superclasses ((class CLASS))
  ;; Fill the slot `class-all-super-classes' with a list of all
  ;;    superclasses of `class', ordered such that more specific
  ;;    classes always precede more general ones.
  ;; Generates a left-to-right precedence order for classes with
  ;;    multiple parents (similar to CLOS).
  ;; Assumes that `all-super-classes' has been computed for all parents
  ;;    of `class'.
  ;; Storage note: If `class' has a single parent, then the `all-super-classes'
  ;;    list shares structure with that parent's `all-super-classes' list.
  (let ((parentClasses (allocate (LIST OF CLASS))))        ; temporary list
    (collect-direct-super-classes class parentClasses)
    (when (not (multiple-parents? class))
      (let ((onlyParent (first parentClasses)))
        (when (null? onlyParent)
          (return))
        ;; structure share with parent list:
        (setf (class-all-super-classes class)
              (cons onlyParent (class-all-super-classes onlyParent)))
        (return)))
    ;; multiple parents; compute superclass precedence list:
    (setq parentClasses (reverse parentClasses))
    (let ((allSuperClasses NIL)
          (sublist CONS NULL))
      ;; do right union of reversed ancestors list:
      (foreach parent in parentClasses    ; reverse order traversal
               do
               (setq sublist NIL)
               (foreach ancestor in (class-all-super-classes parent)
                        where (not (member? allSuperClasses ancestor))
                        collect ancestor into sublist)
               (pushq sublist parent)
               (setq allSuperClasses (concatenate sublist allSuperClasses)))
      ;; store the result:
      (setf (class-all-super-classes class) allSuperClasses)) ))

(defun uninherit-superclasses ((class CLASS))
  ;; Free storage in `class-all-super-classes'.
  (setf (class-all-super-classes class) NIL) )

(defun (two-argument-least-common-superclass CLASS) ((class1 CLASS) (class2 CLASS))
  :documentation "Return the most specific class that is a superclass of
both `class1' and `class2'.  If there is more than one, arbitrarily pick one.
If there is none, return `null'."
  (when (subclass-of? class1 class2)
    (return class2))
  (when (subclass-of? class2 class1)
    (return class1))
  (foreach c in (class-all-super-classes class1)
           do (setf (class-marked? c) FALSE))
  (foreach c in (class-all-super-classes class2)
           do (setf (class-marked? c) TRUE))
  (foreach c in (class-all-super-classes class1)
           where (class-marked? c)
           do (return c))
  (return NULL) )

(defun (two-argument-least-common-supertype TYPE-SPEC)
    ((type1 TYPE-SPEC) (type2 TYPE-SPEC))
  :documentation "Return the most specific type that is a supertype of
both `type1' and `type2'.  If there is more than one, arbitrarily pick one.
If there is none, return @VOID.  If one or both types are parametric,
also try to generalize parameter types if necessary."
  (when (eql? type1 type2)
    (return type1))
  (let ((baseType1 (type-spec-to-base-type type1))
        (baseType2 (type-spec-to-base-type type2))
        (superClass (two-argument-least-common-superclass
                     (type-class baseType1) (type-class baseType2))))
    (when (null? superClass)
      (return @VOID))
    (when (and (eql? type1 baseType1)
               (eql? type2 baseType2))
      (return (class-type superClass)))
    ;; at least one type is parametric:
    (let ((superType (class-type superClass))
          (superTypeSpec (base-type-to-type-spec superType))
          (parameters (parameters superClass))
          (parameterTypes LIST NULL)
          (sPtype TYPE-SPEC NULL)
          (pType1 TYPE-SPEC NULL)
          (pType2 TYPE-SPEC NULL)
          (parameterExists? FALSE)
          (result PARAMETRIC-TYPE-SPECIFIER NULL))
      (when (empty? parameters)
        (return superType))
      (setq parameterTypes (new LIST))
      (foreach parameter in parameters
          do (mv-setq (pType1 parameterExists?)
               (extract-parameter-type type1 parameter))
             (when (or (not parameterExists?)
                       (unknown-type? pType1))
               ;; should this be @VOID instead?
               (return superType))
             (mv-setq (pType2 parameterExists?)
               (extract-parameter-type type2 parameter))
             (when (or (not parameterExists?)
                       (unknown-type? pType2))
               ;; should this be @VOID instead?
               (return superType))
             (setq sPtype (two-argument-least-common-supertype pType1 pType2))
             (when (and
                    ;; if they are eql?, some parameter must have been unknown:
                    (not (eql? superType superTypeSpec))
                    (not (sub-type-spec-of?
                          sPtype (extract-parameter-type superType parameter))))
               ;; should this be @VOID instead?
               (return superType))
          collect sPtype into parameterTypes)
      (setq result
        (new PARAMETRIC-TYPE-SPECIFIER
             :specifier-base-type superType
             :specifier-parameter-types parameterTypes))
      (when (and (array-type-specifier? type1)
                 (array-type-specifier? type2))
        (when (not (equal-cons-trees?
                    (the-cons-list (array-type-dimensions type1))
                    (the-cons-list (array-type-dimensions type2))))
          ;; dimension mismatch, maybe we should have a compatibility
          ;;    predicate for array types:
          (return superType))
        (setf (specifier-dimensions result)
          (specifier-dimensions (cast type1 PARAMETRIC-TYPE-SPECIFIER))))
      (return result))))


  ;;
;;;;;; Slot inheritance
  ;;

;;; If a non-structure shared list of local and inherited slots
;;;    were maintained by each class, the space requirements might
;;;    be prohibitive.  Hence, we adopt a structure sharing strategy
;;;    for slots similar to that used by `class-all-super-classes'.
;;; We DON'T REMOVE DUPLICATE SLOTS, i.e., if we inherit a slot
;;;    with the same owner as a local slot, both appear in the list.
;;;    This is because to do so (to remove duplicates) would invalidate
;;;    the structure sharing.  A more specific slot appears earlier in
;;;    the list than a more general slot -- thus, a lookup slot
;;;    operation will always find the most specific slot.

(defun inherit-slots ((class CLASS))
  ;; Add inherited slots to the local ones already in `class-all-slots'.
  ;; Assumes that the parents of `class' have already inherited their slots.
  (safety 3 (null? (class-all-slots class))
          "Need to uninherit slots on " class " first.")
  (let ((slots (copy-cons-list (the-cons-list (class-local-slots class)))))
    (cond
     ((empty? (class-direct-supers class))
      NULL)                             ; do nothing
     ((multiple-parents? class) ; multiple inheritance:
      ;; copy inherited slot lists from multiple parents. No structure sharing:
      (foreach
        superType in (class-direct-supers class)
        do (setq slots
                 (concatenate
                  slots
                  (copy-cons-list (class-all-slots (type-class superType))))))
      ;; remove duplicate slots, allow the right-most slots to remain:
      (setq slots (reverse slots))
      (remove-duplicates slots)
      (setq slots (reverse slots)))
     (otherwise ;; single inheritance -- use structure sharing:
      (let ((parentSlots
             (class-all-slots
              (type-class (first (class-direct-supers class))))))
        (setq slots (concatenate slots parentSlots)))))
    (setf (class-all-slots class) slots)))

(defun (local-slot? BOOLEAN) ((slot SLOT) (class CLASS))
  ;; Return `true' iff `slot' is not inherited from a superclass
  ;;    of `class'.
  (return (eq? (surrogate-value (slot-owner slot)) class)))

(defun uninherit-slots ((class CLASS))
  ;; Nullify inherited slots on `class-all-slots'.
  (let ((slotsCursor (class-all-slots class)))
    (when (defined? slotsCursor)
      (unless (multiple-parents? class)
        (foreach slot in (class-all-slots class)
                 do (if (and (non-empty? (rest slotsCursor))
                             (local-slot? (first (rest slotsCursor)) class))
                        (setq slotsCursor (rest slotsCursor))
                      (break)))
        (setf (rest slotsCursor) NIL))
      (setf (class-all-slots class) NULL))))

  ;;
;;;;;; Indexed slot lookup
  ;;

(defglobal *symbol-slot-offset-counter* INTEGER 0)      ; should be SHORT INT
(defglobal *slot-cache-size* INTEGER 20)

(defun initialize-slot-and-method-cache ((class CLASS))
  ;; Allocate a vector for the cache.
  (setf (class-slot-and-method-cache class)
        ;; The last cache position is used as a "dirty cache" indicator:
        (new VECTOR :array-size (+ *slot-cache-size* 1)) ))

;;; Slot Caching Algorithm
;;;    A slot name is a symbol containing an integer offset (a null value
;;;    indicates the absence of a slot for that symbol).  The offset is
;;;    used to access the slot and method cache attached to each class.
;;;    The offset can be set of reset to any value between 0 and
;;;    (*slot-cache-size* - 1).
;;;    In case of a cache miss, the slot is found by a linear search of
;;;    the list class-slots.  The found slot is added to the cache using
;;;    an offset is chosen by incrementing *symbol-slot-offset-counter*
;;;    (modulo *slot-cache-size*).  This invalidates the cache for the
;;;    slot that has been overwritten.  The new offset is recorded in
;;;    the symbol, thereby possibly invalidating other caches for that
;;;    symbol.

(defun register-slot-name ((slot SLOT))
  :public? TRUE
  :documentation "Register the name symbol of `slot' as a slot name, and
initialize its `symbol-slot-offset' so that it can be used by `lookup-slot'."
  (warn-about-slot-shadowed-by-a-function? slot)
  (setf (symbol-slot-offset (slot-name slot)) 0))

(defun unregister-slot-name ((slot SLOT))
  :public? TRUE
  :documentation "Unregister the name symbol of `slot' as a slot name,
so that it can no longer be used by `lookup-slot'."
  (setf (symbol-slot-offset (slot-name slot)) NULL))

(defun (registered-slot-name? BOOLEAN) ((slot-name SYMBOL))
  :globally-inline? TRUE :public? TRUE
  :documentation "Return `true' if `slot-name' is the name of some registered;
slot in the system."
  (return (defined? (symbol-slot-offset slot-name))))

(defun (warn-about-slot-shadowed-by-a-function? BOOLEAN) ((slot SLOT))
  ;; Generate a warning if `slot' is shadowed by a function or macro
  ;;    of the same name.
  ;; Return `true' if a warning was generated.
  (let ((name (slot-name slot)))
    (when (not (registered-slot-name? name))
      (when (defined? (lookup-macro name))
        (walk-warn "Slot " slot " is shadowed by the macro " name)
        (return TRUE))
      (when (defined? (lookup-function name))
        (walk-warn "Slot " slot " is shadowed by the function " name)
        (return TRUE)))
    (return FALSE)))

(defun (warn-about-function-shadowing-slots? BOOLEAN) ((function METHOD-SLOT))
  ;; Generate a warning if `function' shadows one or more slots with
  ;;    the same name.
  ;; Return `true' if a warning was generated.
  (let ((name (slot-name function)))
    (when (registered-slot-name? name)
      (let ((slots NIL))
        (foreach module in (all-modules)
            do (foreach slot in (all-slots module TRUE)
                   where (eql? (slot-name slot) name)
                   collect slot into slots))
        (if (method-macro? function)
            (walk-warn "Macro " name " shadows the following methods/slots:"
                       EOL "    " slots)
          (walk-warn "Function " name " shadows the following methods/slots:"
                     EOL "    " slots))
        (return TRUE)))
    (return FALSE)))

(defun (lookup-slot SLOT) ((class CLASS) (slot-name SYMBOL))
  :documentation
  "Return a slot owned by the class `class' with name `slot-name'.
Multiply inherited slots are disambiguated by a left-to-right class
precedence order for classes with multiple parents (similar to CLOS)."
  :public? TRUE
  ;; We implement a caching scheme that approximately emulates the double
  ;;    indexing scheme used in an efficient method dispatching algorithm.
  ;;    Our scheme is slower iff we experience too many cache misses, but
  ;;    it doesn't consume unreasonably large amounts of space like,
  ;;    for example, the C++ algorithm.
  ;; Oddity: The caching works for renamed slots, but not for slots with
  ;;    nested renaming.
  (when (null? class)
    (return NULL))
  (let ((offset (symbol-slot-offset slot-name))
        (cachedSlot SLOT NULL))
    (when (defined? offset)
      ;; go for fast lookup:
      (setq cachedSlot
        (nth (class-slot-and-method-cache class)
             (symbol-slot-offset slot-name)))
      (when (and (defined? cachedSlot)
                 (eql? (slot-name cachedSlot) slot-name))
        (return cachedSlot)))
    (setq cachedSlot NULL)
    ;; find slot the slow way:
    (foreach slot in (class-slots class)
        do (when (eq? (slot-name slot) slot-name)
             (setq cachedSlot slot)
             (break)))
    (when (null? cachedSlot)
      (return NULL))
    ;; compute new cache entry and insert slot into cache:
    (let ((newOffset 
           (rem (+ *symbol-slot-offset-counter* 1) *slot-cache-size*)))
      (setq *symbol-slot-offset-counter* newOffset)
      (setf (symbol-slot-offset slot-name) newOffset)
      (insert-at (class-slot-and-method-cache class) newOffset cachedSlot)
      ;; Use the last position as a "dirty cache" indicator:
      (insert-at (class-slot-and-method-cache class)
                 *slot-cache-size* cachedSlot)
      (return cachedSlot)) ))

(defun (safe-lookup-slot SLOT) ((class CLASS) (slot-name SYMBOL))
  :documentation "Alias for `lookup-slot'.  Kept for backwards compatibility."
  :public? TRUE :globally-inline? TRUE
  ;; This used to do safety checking that has been folded into `lookup-slot'.
  (return (lookup-slot class slot-name)))

(defun (lookup-visible-slot SLOT) ((class CLASS) (slot-name OBJECT))
  ;; EXPERIMENT: Lookup slot `slot-name' on `class' but lookup the visible
  ;;    symbols hierarchy in case of failure.  This is an attempt to make
  ;;    lookup more robust in case of multiply inherited symbols, etc.,
  ;;    however, we need much more machinery than that to really solve this.
  ;;    Once (if ever) this machinery is in place, we will revisit this.
  ;; NOT USED YET.
  (let ((slot SLOT NULL)
        (slotNameString STRING NULL)
        (module *module*))
    (typecase slot-name
      (SYMBOL
       ;; optimize the common case:
       (setq slot (lookup-slot class slot-name))
       (when (defined? slot)
         (return slot))
       (setq slotNameString (symbol-name slot-name))
       (setq module (interned-in slot-name)))
      (SURROGATE
       (setq slotNameString (symbol-name slot-name))
       (setq module (interned-in slot-name)))
      (KEYWORD
       (setq slotNameString (symbol-name slot-name)))
      (STRING-WRAPPER
       (setq slotNameString slot-name))
      (otherwise
       (error "Illegal slot name: " slot-name)))
    (foreach symbol in (lookup-visible-symbols-in-module
                        slotNameString module TRUE)
        do (setq slot (lookup-slot class symbol))
           (when (defined? slot)
             (return slot)))
    (return NULL)))

(defun (lookup-local-slot SLOT) ((class CLASS) (slot-name SYMBOL))
  :documentation "Lookup a local slot with `slot-name' on `class'."
  :public? TRUE
  (foreach slot in (class-local-slots class)
           where (eq? (slot-name slot) slot-name)
           do (return slot))
  (return NULL))

(defun clear-slot-and-method-cache ((class CLASS))
  ;; Called by `unfinalize-slots'.
  ;;    Clear slot entries in 'class.class-slot-and-method-cache'.
  ;; The last cache position is used as a "dirty cache" indicator:
  (when (defined? (nth (class-slot-and-method-cache class) *slot-cache-size*))
    (clear (class-slot-and-method-cache class)) ))

(defun resize-slot-caches ((size INTEGER))
  :documentation "Reset all slot caches to have size `size'."
  (setq *slot-cache-size* size)
  (foreach c in (all-classes NULL FALSE)
           do
           (setf (class-slot-and-method-cache c) 
             (new VECTOR :array-size size))
           (foreach s in (local-slots c)
                    do (setf (symbol-slot-offset (slot-name s)) 0))))

#|
(resize-slot-caches 10)
(CL:time (eval (lookup-slot (type-class @CLASS) (quote PUBLIC?))))
|#

(defun (get-slot SLOT) ((self STANDARD-OBJECT) (slot-name SYMBOL))
  :documentation "Return the slot named `slot-name' on the class
representing the type of `self'."
  :public? TRUE
  ;; TO DO: CONSIDER OPTIMIZING THIS BY DISPATCHING USING NATIVE METHODS.
  (return (lookup-slot (primary-class self) slot-name)) )

  ;;
;;;;;; Computed and stored slot values for classes
  ;;

(defun (conforming-type-spec? BOOLEAN)
       ((sub-type-spec TYPE-SPEC) (super-type-spec TYPE-SPEC))
  ;; Return `true' if `sub-type-spec' conforms to `super-type-spec'.
  ;; Assume conformance if one of them is not yet defined or is
  ;;    an anchored type specifier.
  (return
   (or (null? sub-type-spec) (eq? sub-type-spec @UNKNOWN)       
       (and (type? sub-type-spec) 
            (null? (type-class (cast sub-type-spec TYPE))))
       (anchored-type-specifier? sub-type-spec)
       (null? super-type-spec) (eq? super-type-spec @UNKNOWN)
       (and (type? super-type-spec) 
            (null? (type-class (cast super-type-spec TYPE))))
       (anchored-type-specifier? super-type-spec)
       (sub-type-spec-of? sub-type-spec super-type-spec))) )

(defmethod (conforming-signatures? BOOLEAN) ((self SLOT) (superSlot SLOT))
  (ignore superSlot)
  (error "conforming-signatures?: Not defined on " self)
  ; (return NULL)
  )

(defmethod (conforming-signatures? BOOLEAN) ((self STORAGE-SLOT) (superSlot SLOT))
  ;; Return `true' if the signature of `self' conforms to the signature of
  ;;    `superSlot'.
  (return
   (and (conforming-type-spec? (slot-base-type self) (type superSlot))
        ;; BUG: THIS SHOULD INHERIT A TYPE-SPEC FROM A NON-DIRECT SUPER, BUT
        ;;    IT DOESN'T:
        (conforming-type-spec? 
         (slot-type-specifier self) (slot-type-specifier superSlot))
        ;; PROBLEM: Specializing a method with a slot of the same name is
        ;;    legal in C++ but will most probably create unexpected results.
        ;;    So, maybe we should fail here if `superSlot' is a method?
        (eq? (method-argument-count superSlot) 1))) )

(defmethod (conforming-signatures? BOOLEAN)
    ((self METHOD-SLOT) (superSlot SLOT))
  (when (and (conforming-type-spec? (slot-base-type self) (type superSlot))
             ;; BUG: SAME AS ABOVE:
             (conforming-type-spec? 
              (slot-type-specifier self) (slot-type-specifier superSlot))
             (eq? (method-argument-count self)
                  (method-argument-count superSlot)))
    (typecase superSlot
      ;; PROBLEM: Specializing a storage slot with a method of the same name
      ;;    is legal in C++ but will most probably create unexpected results.
      ;;    So, maybe we should fail here if `superSlot' is a storage slot?
      (STORAGE-SLOT
       (return (eq? (length (method-return-type-specifiers self)) 1)))
      (METHOD-SLOT
       ;;
       ;; We implement the usual definition of `conformance' for
       ;;    methods T.m and S.m, T a supertype of S, where
       ;;    the signature of S.m conforms to that of T.m iff:
       ;;    (1) Contravariance of arguments: S.m has the same number
       ;;        of arguments as T.m, and the type of every argument
       ;;        of S.m (except for the first) is a SUPERTYPE of the
       ;;        corresponding argument of T.m.
       ;;    (2) Covariance of results:  S.m has the same number of
       ;;        results as T.m, and the type of every result of S.m
       ;;        is a SUBTYPE of the corresponding result of T.m.
       ;; This is the weakest set of rules that ensure that static type
       ;;    checking guarantees no run-time type errors (cf.,
       ;;    Andrew Black, et al. "Distribution and abstract types in
       ;;    Emerald."  IEEE Transactions on Software Engineering,
       ;;    SE-13(1):65-76, 1987.)
       ;; For exceptions we would also need covariance, i.e., the
       ;;    exceptions of S.m have to be a subset of the exceptions
       ;;    of T.m, and the result of each exception must be covariant
       ;;    (cf., Mark Day, et al. "Subtypes vs. where-clauses:
       ;;    Constraining parametric polymorphism."  Available at
       ;;    http://www.pmg.lcs.mit.edu/.)
       ;;
       (return
         (and
          (forall ts1 in (rest (method-parameter-type-specifiers self))
                  as ts2 in (rest (method-parameter-type-specifiers superSlot))
                  always (conforming-type-spec? ts2 ts1))
          (forall ts1 in (method-return-type-specifiers self)
                  as ts2 in (method-return-type-specifiers superSlot)
                  always (conforming-type-spec? ts1 ts2)))))
      (otherwise NULL)))
  (return FALSE))

(defmethod (conforming-signatures? BOOLEAN)
    ((self TABLE) (superSlot SLOT))
  (when (and (conforming-type-spec? (slot-base-type self) (type superSlot))
             ;; BUG: SAME AS ABOVE:
             (conforming-type-spec? 
              (slot-type-specifier self) (slot-type-specifier superSlot))
             (eq? (method-argument-count self)
                  (method-argument-count superSlot)))
    (typecase superSlot
      (TABLE
       (return (forall ts1 in (rest (tuple-domains self))
                   as ts2 in (rest (tuple-domains superSlot))
                   always (conforming-type-spec? ts2 ts1))))
      (otherwise NULL)))
  (return FALSE))

(defun (identical-signatures? BOOLEAN) ((method1 METHOD-SLOT)
                                        (method2 METHOD-SLOT))
  ;; Return `true' if the signatures of `method1' and `method2' are identical
  ;;    without considering the type of the first argument.
  (return 
    (and (forall ts1 in (rest (method-parameter-type-specifiers method1))
             as ts2 in (rest (method-parameter-type-specifiers method2))
             always (and (sub-type-spec-of?
                          (setq ts1
                            (compute-relative-type-spec ts1 (slot-owner method1)))
                          (setq ts2
                            (compute-relative-type-spec ts2 (slot-owner method2))))
                         (sub-type-spec-of? ts2 ts1)))
         (forall ts1 in (method-return-type-specifiers method1)
             as ts2 in (method-return-type-specifiers method2)
             always (and (sub-type-spec-of?
                          (setq ts1
                            (compute-relative-type-spec ts1 (slot-owner method1)))
                          (setq ts2
                            (compute-relative-type-spec ts2 (slot-owner method2))))
                         (sub-type-spec-of? ts2 ts1))))))

(defun compute-required-slot-names ((class CLASS))
  ;; Compute a list of names of slots whose values must be supplied 
  ;;    at creation time.
  (let ((slotNames (new (LIST OF SYMBOL))))
    (foreach slot in (class-slots class)
             where (and (storage-slot? slot)
                        (slot-required? (cast slot STORAGE-SLOT))
                        (not (member? slotNames (slot-name slot))))
             do (push slotNames (slot-name slot)))
    (if (empty? slotNames)
      (free slotNames)
      (setf (class-required-slot-names class) (reverse slotNames))) ))

(defun free-required-slot-names ((class CLASS))
  ;; Free up space unless it is the empty list.
  (when (non-empty? (class-required-slot-names class))
    (free (class-required-slot-names class))
    (setf (class-required-slot-names class) NULL)) )


  ;;
;;;;;; Computed slots
  ;;

(defmethod (dynamic-storage? BOOLEAN) ((self STORAGE-SLOT))
  (let ((allocation (allocation self)))
    (return (or (eq? allocation :dynamic)
                (eq? allocation :bit))) ))

(defmethod (private? BOOLEAN) ((self RELATION))
  :documentation "Return `true' if `self' is not public."
  :public? TRUE
  ;; Change this definition if we introduce other modes.
  ;; FUTURE: DEFINE IT USING :select.
  :public? TRUE
  (return (not (public? self))) )

(defmethod (public? BOOLEAN) ((self SLOT))
  :documentation "True if `self' or one it its ancestors is marked public."
  :public? TRUE
  (return (or (slot-public? self)
              (and (defined? (slot-direct-equivalent self))
                   (public? (slot-direct-equivalent self))))) )

(defmethod (public-slots (ITERATOR OF SLOT)) ((self CLASS))
  :documentation "Return an iterator over public slots of `self'."
  :public? TRUE
  (let ((publicSlots (cast NIL (CONS OF SLOT)))
        (iterator (new ALL-PURPOSE-ITERATOR)))
    (foreach slot in (class-slots self)
             where (and (slot-public? slot)
                        (not (exists ps in publicSlots
                                     where
                                     (eq? (slot-name ps) (slot-name slot)))))
             do (setq publicSlots
                  (cast (cons slot publicSlots) (CONS OF SLOT))))
    ;; initialize the iterator:
    (setf (iterator-next-code iterator)
      (the-code :function iterator-cons-list-next?))
    (setf (iterator-cons-list iterator) publicSlots)
    (setf (first-iteration? iterator) TRUE)
    (return iterator) ))

(defmethod (public-slots (ITERATOR OF SLOT)) ((self OBJECT))
  :documentation "Return an iterator over public slots of `self'."
  :public? TRUE
  (return (public-slots (primary-class self))) )

;;; USE A SPECIAL-PURPOSE `ALL-CLASS-SLOTS-ITERATOR', SINCE
;;;    `ALL-PURPOSE-ITERATOR's KILL US IN JAVA.
;;; TO DO: USE MORE DESCRIPTIVE SLOT NAMES INSTEAD OF THE ONES
;;;    TAKEN OVER FROM `ALL-PURPOSE-ITERATOR'.

(defclass ALL-CLASS-SLOTS-ITERATOR (ITERATOR)
  :parameters ((any-value :type SLOT))
  :slots
  ((iterator-cons-list :type CONS)
   (iterator-object :type OBJECT)))

(defmethod (all-class-slots (ITERATOR OF SLOT)) ((self CLASS))
  ;; Return an iterator over all local and inherited slots of `self'.
  ;;    Starts at the bottom of the slot-inheritance hierarchy and
  ;;    ends at the top.
  ;; Generates slots according to the left-to-right precedence order
  ;;    defined by `class-all-super-classes' (similar to CLOS).
  (let ((iterator (new ALL-CLASS-SLOTS-ITERATOR)))
    ;; initialize the iterator:
    ;; Holds the local slots of the current class:
    (setf (iterator-cons-list iterator)
      (the-cons-list (class-local-slots self)))
    ;; Holds all of `class's remaining superclasses:
    (setf (iterator-object iterator)
      (class-all-super-classes self))
    (setf (first-iteration? iterator) TRUE)
    (return iterator) ))

(defmethod (next? BOOLEAN) ((self ALL-CLASS-SLOTS-ITERATOR))
  ;; Iterates over all slots of a class stored within `self' from
  ;;    most specific to least specific.
  ;; Generates slots according to the left-to-right precedence order
  ;;    defined by `class-all-super-classes' (similar to CLOS).
  (let ((localSlots (iterator-cons-list self)))
    (cond
     ((empty? localSlots)
      (let ((classes (CONS OF CLASS) (iterator-object self)))
        ;; The current class didn't have any more slots, go up the hierarchy:
        (while (and (non-empty? classes)
                    (empty? localSlots))
          (setq localSlots (the-cons-list (class-local-slots (first classes))))
          (setq classes (rest classes)))
        (when (empty? classes)
          (when (empty? localSlots)
            (setf (slot-value self value) NULL)
            (setf (iterator-object self) NULL)
            (return FALSE)))
        (setf (iterator-object self) classes)
        (setf (slot-value self value) (value localSlots))
        (setf (iterator-cons-list self) (rest localSlots))
        (return TRUE)))
     (otherwise
      (setf (slot-value self value) (value localSlots))
      (setf (iterator-cons-list self) (rest localSlots))
      (return TRUE)))))

(defmethod (class-slots (ITERATOR OF SLOT)) ((self CLASS))
  ;; Replaces the storage slot `class-slots' which contained
  ;;   a CONS list with precomputed slot inheritance.
  (return (all-class-slots self)))

(defmethod (local-slots (LIST OF SLOT)) ((self CLASS))
  (return (class-local-slots self)))

(defmethod (direct-super-classes (ITERATOR OF CLASS)) ((self CLASS))
  :public? TRUE
  :documentation "Returns an iterator that generates all direct
super classes of `self'."
  (return (new TYPES-TO-CLASSES-ITERATOR
               :iterator-cursor
               (the-cons-list (class-direct-supers self)))) )

(defmethod (super-classes (ITERATOR OF CLASS)) ((self CLASS))
  :public? TRUE
  :documentation "Returns an iterator that generates all super classes
of `self'.  Non-reflexive."
  (let ((iterator (new LIST-ITERATOR)))
    (setf (list-iterator-cursor iterator) (class-all-super-classes self))
    (return iterator)))

(defmethod (active? BOOLEAN) ((slot SLOT))
  ;; A slot is active if its marked active, or if it has an inverse.
  (return
    (choose
     (defined? (stored-active? slot))
     (stored-active? slot)
     ;; The first three tests are a kludge so things won't break
     ;; during bootstrap or if we have forward references.  A better
     ;; finalization strategy should solve this problem.
     (and (defined? (type-class @COLLECTION))
	  (defined? (type-class (slot-base-type slot)))
	  (defined? (type-class (slot-owner slot)))
          (primitive? slot)
          (or (defined? (slot-inverse slot))
              ;; (active? (type-class (slot-owner slot)))
              (and (defined? (slot-direct-equivalent slot))
                   (active? (slot-direct-equivalent slot))))))))

  ;;
;;;;;; Public methods that inherit (private) slot values
  ;;

;;; Each of these methods computes an inherited slot value, based upon
;;;    an underlying private slot (indicated by the option :storage-slot):

(defmethod (initial-value OBJECT) ((self STORAGE-SLOT))
  :documentation "Return an initial value for `self', or `null'.  The
initial value can be defined by the slot itself, inherited from an
equivalent slot, or inherit from the :initial-value option for the 
class representing the type of `self'."
  (let ((slot self)
        (value (slot-initial-value slot)))
    (loop
      (when (defined? value)
        (return value))
      (setq slot (slot-direct-equivalent slot))
      (if (defined? slot)
        (setq value (slot-initial-value slot))
        (break)))
    ;; no initial value in slot hierarchy; try inheriting from class
    ;; (IMPORTANT: Don't use `initial-value' here, since inheriting from
    ;; a supertype will most likely yield a value with incorrect type):
    (return (class-initial-value (type-class (type self)))) ))

;;; THIS (TOP) METHOD APPEARS TO BE NEVER CALLED:
(defmethod (system-default-value OBJECT) ((self SLOT))
  :documentation "Return a default value expression, or if `self'
has dynamic storage, an initial value expression."
  ;; Note: method slots don't have initial values.
  (return (class-initial-value (type-class (type self)))) )

(defmethod (system-default-value OBJECT) ((self STORAGE-SLOT))
  :documentation "Return a default value expression, or if `self'
has dynamic storage, an initial value expression."
  (let ((value (default-form self)))
    (cond
     ((defined? value) (return value))
     ((and (dynamic-storage? self)
           (defined? (type-class (type self))))
      (return (class-initial-value (type-class (type self)))))
     (otherwise (return NULL))) ))

(defmethod (initially OBJECT) ((self STORAGE-SLOT))
  :documentation "Defines the value of a slot before it has been assigned
a value."
  ;; Note: Includes a rule specifying that Boolean slots are initially
  ;;    `false' by default.
  :public? TRUE
  (let ((value (slot-initial-value self)))
    (cond
     ((defined? value) (return value))
     ((defined? (slot-direct-equivalent self))
      (return (initially (cast (slot-direct-equivalent self) STORAGE-SLOT))))
     ((eq? (slot-base-type self) @BOOLEAN)
      (return (quote FALSE)))
     (otherwise (return NULL))) ))    


  ;;
;;;;;;; Debugging and Repair
  ;;

(defun repair-slots ()
  ;; Recompute slot inheritance for all classes.
  (let ((top (type-class @OBJECT)))
    (unfinalize-class-slots top)
    (finalize-classes-and-slots)))

(defun disconnect-classes ()
  ;; Eliminate all class objects by disconnecting them from their surrogates.
  (foreach surrogate in (all-surrogates *module* FALSE)
           where (and (defined? (surrogate-value surrogate))
                      (stella-class? (surrogate-value surrogate)))
           do (setf (surrogate-value surrogate) NULL)))

(defun (filter-unbound-surrogate? BOOLEAN)
    ((self SURROGATE) (iterator ALL-PURPOSE-ITERATOR))
  ;; Helping function for `unbound-surrogates'
  (ignore iterator)
  (return (not (defined? (surrogate-value self)))))

(defun (unbound-surrogates (ITERATOR OF SURROGATE))
    ((module MODULE) (local? BOOLEAN))
  :public? TRUE
  :documentation "Iterate over all unbound surrogates visible from `module'.
Look at all modules if `module' is `null'.  If `local?', only consider
surrogates interned in `module'."
  (let ((iterator (new ALL-PURPOSE-ITERATOR)))
    (setf (iterator-nested-iterator iterator) (all-surrogates module local?))
    (setf (iterator-next-code iterator)
      (the-code :function filtered-nested-iterator-next?))
    (setf (iterator-filter-code iterator)
      (the-code :function filter-unbound-surrogate?))
    (return iterator)))

(defun (name-to-string STRING) ((name OBJECT))
  :public? TRUE
  :documentation "Return the string represented by `name'.  Return `null'
if `name' is undefined or does not represent a string."
  (when (defined? name)
    (typecase name
      (GENERALIZED-SYMBOL (return (symbol-name name)))
      (STRING-WRAPPER (return (wrapper-value name)))
      (otherwise NULL)))
  (return NULL))

(defun print-unbound-surrogates (&rest (args OBJECT))
  :command? TRUE :public? TRUE :evaluate-arguments? FALSE
  :documentation
  "Print all unbound surrogates visible from the module named by the first
argument (a symbol or string).  Look at all modules if no module name or
`null' was supplied.  If the second argument is `true', only consider
surrogates interned in the specified module."
  (let ((arglist (coerce-&rest-to-cons args))
        (name (name-to-string (first arglist)))
        (module (choose (defined? name)
                        (get-stella-module name TRUE)
                        NULL))
        (local? FALSE))
    (when (eql? (second arglist) (quote TRUE))
      (setq local? TRUE))
    (foreach surrogate in (unbound-surrogates module local?)
        do (print surrogate EOL))))

(defun (coerce-to-symbol GENERALIZED-SYMBOL) ((name NAME))
  :public? TRUE
  :documentation "Return the (generalized) symbol represented by `name'.
Return `null' if `name' is undefined or does not represent a string."
  (when (defined? name)
    (typecase name
      (GENERALIZED-SYMBOL (return name))
      (STRING-WRAPPER (return (lookup-symbol (wrapper-value name))))
      (otherwise NULL)))
  (return NULL))

(defun print-undefined-super-classes ((class NAME))
  :command? TRUE :public? TRUE :evaluate-arguments? FALSE
  :documentation
  "Print all undefined or bad (indirect) super classes of `class'."
  (let ((type (typify (coerce-to-symbol class)))
        (badOnes (new (LIST OF TYPE))))
    (when (null? type)
      (print "Illegal class name: " class EOL)
      (return))
    (collect-bad-super-classes type badOnes)
    (when (member? badOnes type)
      (if (null? (surrogate-value type))
          (print type " is itself undefined." EOL)
        (print type " itself points to non-class " (surrogate-value type) EOL))
      (return))
    (when (exists super in badOnes
            where (null? (surrogate-value super)))
      (print "The following (indirect) super(s) of " type
             " are undefined:" EOL)
      (foreach super in badOnes
          where (null? (surrogate-value super))
          do (print "    " super EOL)))
    (when (exists super in badOnes
            where (defined? (surrogate-value super)))
      (print "The following (indirect) super(s) of " type
             " point to non-classes:" EOL)
      (foreach super in badOnes
          where (defined? (surrogate-value super))
          do (print "    " super " points to " (surrogate-value super) EOL)))))

(defun (collect-bad-super-classes (LIST OF TYPE))
    ((type TYPE) (badOnes (LIST OF TYPE)))
  :public? TRUE
  ;; Collect all bad or undefined supers of `type' into `badOnes'.
  (let ((value (surrogate-value type)))
    (if (stella-class? value)
        (foreach super in (class-direct-supers (safe-cast value CLASS))
            do (collect-bad-super-classes super badOnes))
      (insert-new badOnes type))
    (return badOnes)))

  ;;
;;;;;;; Computing class intervals (an interval-based subclass index)
  ;;

;;; Class intervals are used to implement a fast subclass test, which
;;; for N classes has O(1) time complexity and O(N) space complexity.
;;; Every class is associated with an integer interval, and one class
;;; is a subclass of another if its interval is a subinterval of the
;;; class interval of the superclass.  The only disadvantage of this
;;; scheme is that it only works for single inheritance, but, since
;;; Stella only allows multiple-inheritance from mixins, we can use
;;; class intervals to index the main (non-mixin) subclass tree of a
;;; root class such as OBJECT.  For mixin classes the class interval
;;; bounds are undefined in which case the standard (slower) subclass
;;; test is used.  Fast subclass tests are mainly important for
;;; run-time type tests in `typecase's, and there the walker can
;;; determine whether the requirements for a faster test are met.

;;; TO DO: The current interval compuation scheme is not incremental,
;;; and, hence, does not interface well with the finalization
;;; mechanism.  As a solution we only index the OBJECT hierarchy every
;;; time `finalize-classes' is called.  Since for the current
;;; hierarchy this is very cheap, we stick with the simple scheme.
;;; Should this ever become a problem, we can change the interval
;;; computation to leave "holes" so that in many cases class intervals
;;; for a subtree can be recomputed without having to recompute them
;;; for the whole hierarchy.

(defun (root-class? BOOLEAN) ((class CLASS))
  ;; TRUE if `class' is a top-level class that is not a mixin.
  (return (and (empty? (class-direct-supers class))
               (not (mixin? class)))))

  ;;
;;;;;; Fast multiple-inheritance isa scheme
  ;;

(defglobal *class-taxonomy-graph* TAXONOMY-GRAPH (new TAXONOMY-GRAPH))

(defun create-class-taxonomy ()
  ;; Create a class taxonomy graph from scratch (use in emergencies).
  (let ((graph *class-taxonomy-graph*))
    (if (null? graph)
        (setq graph (new TAXONOMY-GRAPH))
      (initialize-taxonomy-graph graph))
    (foreach class in (all-classes NULL FALSE)
        do (setf (class-taxonomy-node class)
             (create-taxonomy-node
              graph (class-taxonomy-node class) ;; reuse node if it exists
              class (empty? (class-direct-supers class)))))
    (foreach class in (all-classes NULL FALSE)
        do (foreach sub in (class-direct-subs class)
               where (defined? (type-class sub))
               do (link-taxonomy-nodes
                   graph
                   (class-taxonomy-node class)
                   (class-taxonomy-node (type-class sub)))))
    ;; Compute the intervals:
    (finalize-taxonomy-graph graph)
    (setq *class-taxonomy-graph* graph)))

(defun (subclass-of? BOOLEAN) ((subClass CLASS) (superClass CLASS))
  :documentation "Return `true' if `subClass' is a subclass of `superClass'."
  :public? TRUE
  ;; This will use a fast subclass test with class intervals if
  ;;    they are available, but will also work if they are not.
  (when (eq? subClass superClass)
    ;; This also catches bootstrap situations where both classes are `null':
    (return TRUE))
  (let ((subNode (class-taxonomy-node subClass))
	(superNode (class-taxonomy-node superClass))
	(subLabel INTEGER NULL))
    (when (or (null? subNode)
	      (null? superNode)
              ;; catch cases where we have nodes that aren't finalized yet
              ;;    (don't call INTEGER.null? since it doesn't get inlined):
              (eq? (setq subLabel (label subNode)) NULL-INTEGER))
      ;; Use a slow membership test (this should eventually go away):
      (return (memb? (class-all-super-classes subClass) superClass)))
    (foreach interval in (intervals superNode)
        where (and (>= subLabel (lower-bound interval))
                   (<= subLabel (upper-bound interval)))
        do (return TRUE))
    (return FALSE)))

(defun (fast-subclass-of? BOOLEAN)
    ((subClass CLASS) (superClass CLASS)) 
  ;; Fast version of taxonomy-subclass-of?: Assumes taxonomy nodes exist.
  (let ((subLabel (label (class-taxonomy-node subClass))))
    (foreach interval in (intervals (class-taxonomy-node superClass))
        where (and (>= subLabel (lower-bound interval))
                   (<= subLabel (upper-bound interval)))
        do (return TRUE))
    (return FALSE)))

(defun (subtype-of? BOOLEAN) ((sub-type TYPE) (super-type TYPE))
  :documentation "Return `true' iff the class named `sub-type' is a subclass 
of the class named `super-type'."
  :public? TRUE
  (inline subclass-of?)
  (let ((subClass (type-to-class sub-type))
        (superClass (type-to-class super-type)))
    (when (null? subClass)
      (walk-error "Reference to non-existent class: " sub-type EOL)
      (return FALSE))
    (when (null? superClass)
      (walk-error "Reference to non-existent class: " super-type EOL)
      (return FALSE))
    (return
     (subclass-of?
      ;; This avoids a cast in Common-Lisp (the CL version of `cast' itself
      ;; uses `subtype-of?' (via `isa?') which leads to infinite recursion):
      subClass
      superClass)) ))

(defun (isa? BOOLEAN) ((object OBJECT) (type TYPE))
  :documentation
  "Return `true' iff `object' is an instance of the class named `type'."
  :public? TRUE
  (return
    (subclass-of? (safe-cast (surrogate-value (primary-type object)) CLASS)
                  (safe-cast (surrogate-value type) CLASS))))

(defun (taxonomy-subclass-of? BOOLEAN) ((subClass class) (superClass class))
  ;; Keep for backward compatibility.
  :globally-inline? TRUE
  (return (subclass-of? subClass superClass)))

(defun (taxonomy-isa? BOOLEAN) ((object OBJECT) (type TYPE))
  ;; Keep for backward compatibility.
  :globally-inline? TRUE
  (return (isa? object type)))

  ;;
;;;;;; Slot surrogates - SlotRef's
  ;;

;; Type used for function slotRefs 
(deftype ANY UNKNOWN)

(defun (intern-slotref SLOTREF) ((className STRING) (slotName STRING))
  (return
    (intern-surrogate (concatenate className (concatenate "." slotName)))))

(defun (lookup-slotref SLOTREF) ((self TYPE) (slotName SYMBOL))
  ;; Return a slotRef '@<type name>.<slotName>'.
  ;; If the class and slot exist, create the slotRef if it does not already 
  ;;    exist and doubly-link it to the slot.
  :public? TRUE
  (setq self (real-type-specifier self))
  (let  ((class (type-class self))
         (slot SLOT NULL)
         (slotRef SLOTREF NULL))
    (setq slot (lookup-function slotName))
    (when (null? slot)
      (setq slot (safe-lookup-slot class slotName)))
    (cond ((null? slot)
           (when (defined? class)
             (return NULL)))
          (otherwise
           ;; Ensure, that slot slotrefs are created with the proper owner:
           (setq self (slot-owner slot))
           (when (null? self)
             ;; For 0-argument function slotrefs we use the owner @ANY:
             (setq self @ANY))
           (setq slotRef (slot-slotRef slot))))
    (when (null? slotRef)
      ;; Create new SLOTREF; place links between it and slot; if class was
      ;;    undefined, create SLOTREF with null link to slot, on the hope
      ;;    that when the class is defined, it will have this slot:
      (within-module (choose (defined? slot)
                      ;; When we upgrade function and slot lookup, these
                      ;;    modules will not necessarily be the same:
                      (home-module slot)
                      (interned-in (permanentify slotName)))
        (setq slotRef
          (intern-slotref (symbol-name self) (symbol-name slotName))))
      (setf (slotRef-slot slotRef) slot)
      (when (defined? slot)
        (setf (slot-slotRef slot) slotRef)))
    (return slotRef) ))

(defun (slotref? BOOLEAN) ((self SURROGATE))
  ;; Return TRUE if `self' is a slot surrogate (SLOTREF).
  (return (defined? (position (symbol-name self) #\. 0))))

(defun (lookup-slot-from-slotref SLOT) ((slotRef SLOTREF))
  ;; Lookup a function or slot from the slot surrogate `slotRef'.
  ;; If `slotRef' is unbound, parse its name and try to find the
  ;;    named function or slot.
  ;; If a slot was found `slotRef' will then be bound to it.
  ;; NOTE: If `slotRef' is interned in a child of the home module of the
  ;;    named slot, a separate slot surrogate in the slot's home module
  ;;    will be allocated, and both surrogates will be pointed to the slot.
  (let ((value (surrogate-value slotRef)))
    (when (defined? value)
      (when (isa? value @SLOT)
        (return value))
      (warn "lookup-slot-from-slotref: " slotRef
            " already points to non-slot " value)
      (return NULL)))
  (let ((slotRefName (symbol-name slotRef))
        (slotRefModule (interned-in slotRef))
        (dotPosition (position slotRefName #\. 0))
        (type TYPE NULL)
        (slotName SYMBOL NULL)
        (slot SLOT NULL))
    (cond ((defined? dotPosition)
           (setq type
             (lookup-surrogate-in-module
              (subsequence slotRefName 0 dotPosition) slotRefModule FALSE)))
          (otherwise
           ;; Handle undotted slotrefs that might point to functions
           ;;    (is this too lenient?):
           (setq type @ANY)
           (setq dotPosition -1)))
    (when (defined? type)
      (setq type (real-type-specifier type)))
    (when (and (defined? type)
               (stella-class? (surrogate-value type)))
      (setq slotName
        (lookup-symbol-in-module
         (subsequence slotRefName (1+ dotPosition) NULL)
         slotRefModule
         FALSE))
      (when (defined? slotName)
        (setq slot (lookup-function slotName))
        (when (null? slot)
          (setq slot (safe-lookup-slot (type-class type) slotName)))
        (when (defined? slot)
          (when (null? (slot-slotRef slot))
            ;; Create or link the actual slotref of `slot':
            (lookup-slotref
             (choose (null? (slot-owner slot)) @ANY (slot-owner slot))
             (slot-name slot)))
          ;; Link `slotRef' which might be different from `(slot-slotRef slot)'
          ;;    in case it was created in a child of `(home-module slot)':
          (setf (slotRef-slot slotRef) slot))))
    (return slot)))

;; TO DO:  ADD LOGIC TO `redefine-slot' THAT NULLIFIES THE LINK BETWEEN
;;    AN OUTGOING SLOT AND ITS SLOTREF.

(defun (slotRef-type TYPE) ((slotRef SLOTREF))
  (return (type (slotRef-slot slotRef))))