X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/abdf50aad1a95f1df8d11c54ff1623077eb84193..a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa:/class-defs.lisp diff --git a/class-defs.lisp b/class-defs.lisp index 570322b..59c8716 100644 --- a/class-defs.lisp +++ b/class-defs.lisp @@ -26,62 +26,49 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- -;;; Class definitions. +;;; Classes. (defclass sod-class () - ((name :initarg :name - :type string - :reader sod-class-name) - (location :initarg :location - :initform (file-location nil) - :type file-location - :reader file-location) - (nickname :initarg :nick - :type string - :reader sod-class-nickname) - (direct-superclasses :initarg :superclasses - :type list + ((name :initarg :name :type string :reader sod-class-name) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (nickname :initarg :nick :type string :reader sod-class-nickname) + (direct-superclasses :initarg :superclasses :type list :reader sod-class-direct-superclasses) - (chained-superclass :initarg :chain-to - :type (or sod-class null) - :reader sod-class-chained-superclass) - (metaclass :initarg :metaclass - :type sod-class + (chain-link :initarg :link :type (or sod-class null) + :reader sod-class-chain-link) + (metaclass :initarg :metaclass :type sod-class :reader sod-class-metaclass) - (slots :initarg :slots - :type list - :initform nil - :accessor sod-class-slots) - (instance-initializers :initarg :instance-initializers + (slots :initarg :slots :initform nil + :type list :accessor sod-class-slots) + (instance-initializers :initarg :instance-initializers :initform nil :type list - :initform nil :accessor sod-class-instance-initializers) - (class-initializers :initarg :class-initializers - :type list - :initform nil - :accessor sod-class-class-initializers) - (messages :initarg :messages - :type list - :initform nil - :accessor sod-class-messages) - (methods :initarg :methods - :type list - :initform nil - :accessor sod-class-methods) + (class-initializers :initarg :class-initializers :initform nil + :type list :accessor sod-class-class-initializers) + (messages :initarg :messages :initform nil + :type list :accessor sod-class-messages) + (methods :initarg :methods :initform nil + :type list :accessor sod-class-methods) (class-precedence-list :type list :accessor sod-class-precedence-list) + (type :type c-class-type :accessor sod-class-type) + (chain-head :type sod-class :accessor sod-class-chain-head) (chain :type list :accessor sod-class-chain) (chains :type list :accessor sod-class-chains) - (state :initform nil - :type (member nil :finalized broken) + (ilayout :type ilayout :accessor sod-class-ilayout) + (effective-methods :type list :accessor sod-class-effective-methods) + (vtables :type list :accessor sod-class-vtables) + + (state :initform nil :type (member nil :finalized broken) :accessor sod-class-state)) (:documentation "Classes describe the layout and behaviour of objects. - The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAINED-SUPERCLASS and + The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAIN-LINK and METACLASS slots are intended to be initialized when the class object is constructed: @@ -112,23 +99,22 @@ precedence list is computed from the DIRECT-SUPERCLASSES lists of all of the superclasses involved. - * The CHAINED-SUPERCLASS is either NIL or one of the - DIRECT-SUPERCLASSES. Class chains are a means for recovering most of - the benefits of simple hierarchy lost by the introduction of multiple - inheritance. A class's superclasses (including itself) are - partitioned into chains, consisting of a class, its CHAINED- - SUPERCLASS, that class's CHAINED-SUPERCLASS, and so on. It is an - error if two direct subclasses of any class appear in the same - chain (a global property which requires global knowledge of an entire - program's class hierarchy in order to determine sensibly). Slots of - superclasses in the same chain can be accessed efficiently; there is - an indirection needed to access slots of superclasses in other chains. - Furthermore, an indirection is required to perform a cross-chain - conversion (i.e., converting a pointer to an instance of some class - into a pointer to an instance of one of its superclasses in a - different chain), an operation which occurs implicitly in effective - methods in order to call direct methods defined on cross-chain - superclasses. + * The CHAIN-LINK is either NIL or one of the DIRECT-SUPERCLASSES. Class + chains are a means for recovering most of the benefits of simple + hierarchy lost by the introduction of multiple inheritance. A class's + superclasses (including itself) are partitioned into chains, + consisting of a class, its CHAIN-LINK superclass, that class's + CHAIN-LINK, and so on. It is an error if two direct subclasses of any + class appear in the same chain (a global property which requires + global knowledge of an entire program's class hierarchy in order to + determine sensibly). Slots of superclasses in the same chain can be + accessed efficiently; there is an indirection needed to access slots + of superclasses in other chains. Furthermore, an indirection is + required to perform a cross-chain conversion (i.e., converting a + pointer to an instance of some class into a pointer to an instance of + one of its superclasses in a different chain), an operation which + occurs implicitly in effective methods in order to call direct methods + defined on cross-chain superclasses. * The METACLASS is the class of the class object. Classes are objects in their own right, and therefore must be instances of some class; @@ -162,26 +148,164 @@ Other slots are computed from these in order to describe the class's layout and effective methods; this is done by FINALIZE-SOD-CLASS. - FIXME: Add the necessary slots and describe them.")) + * The CLASS-PRECEDENCE-LIST is a list of superclasses in a linear order. + It is computed by the generic function COMPUTE-CLASS-PRECEDENCE-LIST, + whose default implementation ensures that the order of superclasses is + such that (a) subclasses appear before their superclasses; (b) the + direct superclasses of a given class appear in the order in which they + were declared by the programmer; and (c) classes always appear in the + same relative order in all class precedence lists in the same + superclass graph. + + * The CHAIN-HEAD is the least-specific class in the class's chain. If + there is no link class then the CHAIN-HEAD is the class itself. This + slot, like the next two, is computed by the generic function + COMPUTE-CHAINS. + + * The CHAIN is the list of classes on the complete primary chain, + starting from this class and ending with the CHAIN-HEAD. + + * The CHAINS are the complete collection of chains (most-to-least + specific) for the class and all of its superclasses. + + * The ILAYOUT describes the layout for an instance of the class. It's + quite complicated; see the documentation of the ILAYOUT class for + detais. + + * The EFFECTIVE-METHODS are a list of effective methods, specialized for + the class. + + * The VTABLES are a list of descriptions of vtables for the class. The + individual elements are VTABLE objects, which are even more + complicated than ILAYOUT structures. See the class documentation for + details.")) (defmethod print-object ((class sod-class) stream) - (print-unreadable-object (class stream :type t) - (prin1 (sod-class-name class) stream))) + (maybe-print-unreadable-object (class stream :type t) + (princ (sod-class-name class) stream))) + +;;;-------------------------------------------------------------------------- +;;; Slots and initializers. + +(defclass sod-slot () + ((name :initarg :name :type string :reader sod-slot-name) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (class :initarg :class :type sod-class :reader sod-slot-class) + (type :initarg :type :type c-type :reader sod-slot-type)) + (:documentation + "Slots are units of information storage in instances. + + Each class defines a number of slots, which function similarly to (data) + members in structures. An instance contains all of the slots defined in + its class and all of its superclasses. + + A slot carries the following information. + + * A NAME, which distinguishes it from other slots defined by the same + class. Unlike most (all?) other object systems, slots defined in + different classes are in distinct namespaces. There are no special + restrictions on slot names. + + * A LOCATION, which states where in the user's source the slot was + defined. This gets used in error messages. + + * A CLASS, which states which class defined the slot. The slot is + available in instances of this class and all of its descendents. + + * A TYPE, which is the C type of the slot. This must be an object type + (certainly not a function type, and it must be a complete type by the + time that the user header code has been scanned).")) + +(defmethod print-object ((slot sod-slot) stream) + (maybe-print-unreadable-object (slot stream :type t) + (pprint-c-type (sod-slot-type slot) stream + (format nil "~A.~A" + (sod-class-nickname (sod-slot-class slot)) + (sod-slot-name slot))))) + +(defclass sod-initializer () + ((slot :initarg :slot :type sod-slot :reader sod-initializer-slot) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (class :initarg :class :type sod-class :reader sod-initializer-class) + (value-kind :initarg :value-kind :type keyword + :reader sod-initializer-value-kind) + (value-form :initarg :value-form :type c-fragment + :reader sod-initializer-value-form)) + (:documentation + "Provides an initial value for a slot. + + The slots of an initializer are as follows. + + * The SLOT specifies which slot this initializer is meant to initialize. + + * The LOCATION states the position in the user's source file where the + initializer was found. This gets used in error messages. (Depending + on the source layout style, this might differ from the location in the + VALUE-FORM C fragment.) + + * The CLASS states which class defined this initializer. For instance + slot initializers (SOD-INSTANCE-INITIALIZER), this will be the same as + the SLOT's class, or be one of its descendants. For class slot + initializers (SOD-CLASS-INITIALIZER), this will be an instance of the + SLOT's class, or an instance of one of its descendants. + + * The VALUE-KIND states what manner of initializer we have. It can be + either :SINGLE, indicating a standalone expression, or :COMPOUND, + indicating a compound initializer which must be surrounded by braces + on output. + + * The VALUE-FORM gives the text of the initializer, as a C fragment. + + Typically you'll see instances of subclasses of this class in the wild + rather than instances of this class directly. See SOD-CLASS-INITIALIZER + and SOD-INSTANCE-INITIALIZER.")) + +(defmethod print-object ((initializer sod-initializer) stream) + (if *print-escape* + (print-unreadable-object (initializer stream :type t) + (format stream "~A = ~A" + (sod-initializer-slot initializer) + initializer)) + (format stream "~:[{~A}~;~A~]" + (eq (sod-initializer-value-kind initializer) :single) + (sod-initializer-value-form initializer)))) + +(defclass sod-class-initializer (sod-initializer) + () + (:documentation + "Provides an initial value for a class slot. + + A class slot initializer provides an initial value for a slot in the class + object (i.e., one of the slots defined by the class's metaclass). Its + VALUE-FORM must have the syntax of an initializer, and its consituent + expressions must be constant expressions. + + See SOD-INITIALIZER for more details.")) + +(defclass sod-instance-initializer (sod-initializer) + () + (:documentation + "Provides an initial value for a slot in all instances. + + An instance slot initializer provides an initial value for a slot in + instances of the class. Its VALUE-FORM must have the syntax of an + initializer. Furthermore, if the slot has aggregate type, then you'd + better be sure that your compiler supports compound literals (6.5.2.5) + because that's what the initializer gets turned into. + + See SOD-INITIALIZER for more details.")) + +;;;-------------------------------------------------------------------------- +;;; Messages and methods. (defclass sod-message () - ((name :initarg :name - :type string - :reader sod-message-name) - (location :initarg :location - :initform (file-location nil) - :type file-location - :reader file-location) - (class :initarg :class - :type sod-class - :reader sod-message-class) - (type :initarg :type - :type c-function-type - :reader sod-message-type)) + ((name :initarg :name :type string :reader sod-message-name) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (class :initarg :class :type sod-class :reader sod-message-class) + (type :initarg :type :type c-function-type :reader sod-message-type)) (:documentation "Messages the means for stimulating an object to behave. @@ -219,23 +343,20 @@ Subclasses can (and probably will) define additional slots.")) +(defmethod print-object ((message sod-message) stream) + (maybe-print-unreadable-object (message stream :type t) + (pprint-c-type (sod-message-type message) stream + (format nil "~A.~A" + (sod-class-nickname (sod-message-class message)) + (sod-message-name message))))) + (defclass sod-method () - ((message :initarg :message - :type sod-message - :reader sod-method-message) - (location :initarg :location - :initform (file-location nil) - :type file-location - :reader file-location) - (class :initarg :class - :type sod-class - :reader sod-method-class) - (type :initarg :type - :type c-function-type - :reader sod-method-type) - (body :initarg :body - :type (or c-fragment null) - :reader sod-method-body)) + ((message :initarg :message :type sod-message :reader sod-method-message) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (class :initarg :class :type sod-class :reader sod-method-class) + (type :initarg :type :type c-function-type :reader sod-method-type) + (body :initarg :body :type (or c-fragment null) :reader sod-method-body)) (:documentation "(Direct) methods are units of behaviour. @@ -294,122 +415,17 @@ subclasses of SOD-METHOD in order to carry the additional metadata they need to keep track of.")) -(defclass sod-slot () - ((name :initarg :name - :type string - :reader sod-slot-name) - (location :initarg :location - :initform (file-location nil) - :type file-location - :reader file-location) - (class :initarg :class - :type sod-class - :reader sod-slot-class) - (type :initarg :type - :type c-type - :reader sod-slot-type)) - (:documentation - "Slots are units of information storage in instances. - - Each class defines a number of slots, which function similarly to (data) - members in structures. An instance contains all of the slots defined in - its class and all of its superclasses. - - A slot carries the following information. - - * A NAME, which distinguishes it from other slots defined by the same - class. Unlike most (all?) other object systems, slots defined in - different classes are in distinct namespaces. There are no special - restrictions on slot names. - - * A LOCATION, which states where in the user's source the slot was - defined. This gets used in error messages. - - * A CLASS, which states which class defined the slot. The slot is - available in instances of this class and all of its descendents. - - * A TYPE, which is the C type of the slot. This must be an object type - (certainly not a function type, and it must be a complete type by the - time that the user header code has been scanned).")) - -(defclass sod-initializer () - ((slot :initarg :slot - :type sod-slot - :reader sod-initializer-slot) - (location :initarg :location - :initform (file-location nil) - :type file-location - :reader file-location) - (class :initarg :class - :type sod-class - :reader sod-initializer-clas) - (value-kind :initarg :value-kind - :type keyword - :reader sod-initializer-value-kind) - (value-form :initarg :value-form - :type c-fragment - :reader sod-initializer-value-form)) - (:documentation - "Provides an initial value for a slot. - - The slots of an initializer are as follows. - - * The SLOT specifies which slot this initializer is meant to initialize. - - * The LOCATION states the position in the user's source file where the - initializer was found. This gets used in error messages. (Depending - on the source layout style, this might differ from the location in the - VALUE-FORM C fragment.) - - * The CLASS states which class defined this initializer. For instance - slot initializers (SOD-INSTANCE-INITIALIZER), this will be the same as - the SLOT's class, or be one of its descendants. For class slot - initializers (SOD-CLASS-INITIALIZER), this will be an instance of the - SLOT's class, or an instance of one of its descendants. - - * The VALUE-KIND states what manner of initializer we have. It can be - either :SINGLE, indicating a standalone expression, or :COMPOUND, - indicating a compound initializer which must be surrounded by braces - on output. - - * The VALUE-FORM gives the text of the initializer, as a C fragment. - - Typically you'll see instances of subclasses of this class in the wild - rather than instances of this class directly. See SOD-CLASS-INITIALIZER - and SOD-INSTANCE-INITIALIZER.")) - -(defclass sod-class-initializer (sod-initializer) - () - (:documentation - "Provides an initial value for a class slot. - - A class slot initializer provides an initial value for a slot in the class - object (i.e., one of the slots defined by the class's metaclass). Its - VALUE-FORM must have the syntax of an initializer, and its consituent - expressions must be constant expressions. - - See SOD-INITIALIZER for more details.")) - -(defclass sod-instance-initializer (sod-initializer) - () - (:documentation - "Provides an initial value for a slot in all instances. - - An instance slot initializer provides an initial value for a slot in - instances of the class. Its VALUE-FORM must have the syntax of an - initializer. Furthermore, if the slot has aggregate type, then you'd - better be sure that your compiler supports compound literals (6.5.2.5) - because that's what the initializer gets turned into. - - See SOD-INITIALIZER for more details.")) +(defmethod print-object ((method sod-method) stream) + (maybe-print-unreadable-object (method stream :type t) + (format stream "~A ~@_~A" + (sod-method-message method) + (sod-method-class method)))) ;;;-------------------------------------------------------------------------- ;;; Classes as C types. (defclass c-class-type (simple-c-type) - ((class :initarg :class - :type (or null sod-class) - :accessor c-type-class)) + ((class :initarg :class :type (or null sod-class) :accessor c-type-class)) (:documentation "A SOD class, as a C type. @@ -431,7 +447,9 @@ (defmethod print-c-type (stream (type c-class-type) &optional colon atsign) (declare (ignore colon atsign)) - (format stream "~:@" (c-type-name type))) + (format stream "~:@" + (c-type-name type) + (c-type-qualifiers type))) (defun find-class-type (name &optional floc) "Look up NAME and return the corresponding C-CLASS-TYPE. @@ -455,18 +473,19 @@ "Return a class type for NAME, creating it if necessary. FLOC is the location to use in error reports." - (multiple-value-bind (type winp) (find-class-type name floc) - (cond ((not winp) nil) - (type type) - (t (setf (gethash name *type-map*) - (make-instance 'c-class-type :name name :class nil)))))) + (let ((name (etypecase name + (sod-class (sod-class-name name)) + (string name)))) + (or (find-class-type name floc) + (setf (gethash name *type-map*) + (make-instance 'c-class-type :name name :class nil))))) (defun find-sod-class (name &optional floc) "Return the SOD-CLASS object with the given NAME. FLOC is the location to use in error reports." (with-default-error-location (floc) - (multiple-value-bind (type winp) (find-class-type name floc) + (let ((type (find-class-type name floc))) (cond ((not type) (error "Type `~A' not known" name)) (t (let ((class (c-type-class type))) (unless class @@ -487,226 +506,10 @@ (t (setf (c-type-class type) class)))))) -(define-c-type-syntax class (name) +(define-c-type-syntax class (name &rest quals) "Returns a type object for the named class." - (make-class-type (c-name-case name))) - -;;;-------------------------------------------------------------------------- -;;; Class finalization. - -;; Protocol. - -(defgeneric compute-chains (class) - (:documentation - "Compute the layout chains for CLASS. - - Fills in - - * the head of the class's primary chain; - - * the class's primary chain as a list, most- to least-specific; and - - * the complete collection of chains, as a list of lists, each most- to - least-specific, with the primary chain first. - - If the chains are ill-formed (i.e., not distinct) then an error is - reported and the function returns nil; otherwise it returns a true - value.")) - -(defgeneric check-sod-class (class) - (:documentation - "Check the CLASS for validity. - - This is done as part of class finalization. The checks performed are as - follows. - - * The class name and nickname, and the names of messages, obey the - rules (see VALID-NAME-P). - - * The messages and slots have distinct names. - - * The classes in the class-precedence-list have distinct nicknames. - - * The chained-superclass is actually one of the direct superclasses. - - * The chosen metaclass is actually a subclass of all of the - superclasses' metaclasses. - - Returns true if all is well; false (and signals errors) if anything was - wrong.")) - -(defgeneric finalize-sod-class (class) - (:documentation - "Computes all of the gory details about a class. - - Once one has stopped inserting methods and slots and so on into a class, - one needs to finalize it to determine the layout structure and the class - precedence list and so on. More precisely that gets done is this: - - * Related classes (i.e., direct superclasses and the metaclass) are - finalized if they haven't been already. - - * If you've been naughty and failed to store a list of slots or - whatever, then an empty list is inserted. - - * The class precedence list is computed and stored. - - * The class is checked for compiance with the well-formedness rules. - - * The layout chains are computed. - - Other stuff will need to happen later, but it's not been done yet. In - particular: - - * Actually computing the layout of the instance and the virtual tables. - - * Combining the applicable methods into effective methods. - - FIXME this needs doing.")) - -;; Implementation. - -(defmethod compute-chains ((class sod-class)) - (with-default-error-location (class) - (let* ((head (with-slots (chained-superclass) class - (if chained-superclass - (sod-class-chain-head chained-superclass) - class))) - (chain (with-slots (chained-superclass) class - (cons class (and chained-superclass - (sod-class-chain chained-superclass))))) - (chains (list chain))) - - ;; Compute the chains. This is (unsurprisingly) the hard bit. The - ;; chain of this class must either be a new chain or the same as one of - ;; its superclasses. Therefore, the chains are well-formed if the - ;; chains of the superclasses are distinct. We can therefore scan the - ;; direct superclasses from left to right as follows. - (with-slots (direct-superclasses) class - (let ((table (make-hash-table))) - (dolist (super direct-superclasses) - (let* ((head (sod-class-chain-head super)) - (tail (gethash head table))) - (cond ((not tail) - (setf (gethash head table) super)) - ((not (sod-subclass-p super tail)) - (error "Conflicting chains (~A and ~A) in class ~A" - (sod-class-name tail) - (sod-class-name super) - (sod-class-name class))) - (t - (let ((ch (sod-class-chain super))) - (unless (eq ch chain) - (push ch chains))))))))) - - ;; Done. - (values head chain (nreverse chains))))) - -(defmethod check-sod-class ((class sod-class)) - (with-default-error-location (class) - - ;; Check the names of things are valid. - (with-slots (name nickname messages) class - (unless (valid-name-p name) - (error "Invalid class name `~A'" name)) - (unless (valid-name-p nickname) - (error "Invalid class nickname `~A' on class `~A'" nickname name)) - (dolist (message messages) - (unless (valid-name-p (sod-message-name message)) - (error "Invalid message name `~A' on class `~A'" - (sod-message-name message) name)))) - - ;; Check that the slots and messages have distinct names. - (with-slots (name slots messages class-precedence-list) class - (flet ((check-list (list what namefunc) - (let ((table (make-hash-table :test #'equal))) - (dolist (item list) - (let ((itemname (funcall namefunc item))) - (if (gethash itemname table) - (error "Duplicate ~A name `~A' on class `~A'" - what itemname name) - (setf (gethash itemname table) item))))))) - (check-list slots "slot" #'sod-slot-name) - (check-list messages "message" #'sod-message-name) - (check-list class-precedence-list "nickname" #'sod-class-name))) - - ;; Check that the CHAIN-TO class is actually a superclass. - (with-slots (name direct-superclasses chained-superclass) class - (unless (or (not chained-superclass) - (member chained-superclass direct-superclasses)) - (error "In `~A~, chain-to class `~A' is not a direct superclass" - name (sod-class-name chained-superclass)))) - - ;; Check that the metaclass is a subclass of each of the - ;; superclasses' metaclasses. - (with-slots (name metaclass direct-superclasses) class - (dolist (super direct-superclasses) - (unless (sod-subclass-p metaclass (sod-class-metaclass super)) - (error "Incompatible metaclass for `~A': ~ - `~A' isn't subclass of `~A' (of `~A')" - name - (sod-class-name metaclass) - (sod-class-name (sod-class-metaclass super)) - (sod-class-name super))))))) - -(defmethod finalize-sod-class ((class sod-class)) - (with-default-error-location (class) - (ecase (sod-class-state class) - ((nil) - - ;; If this fails, mark the class as a loss. - (setf (sod-class-state class) :broken) - - ;; Finalize all of the superclasses. There's some special pleading - ;; here to make bootstrapping work: we don't try to finalize the - ;; metaclass if we're a root class (no direct superclasses -- because - ;; in that case the metaclass will have to be a subclass of us!), or - ;; if it's equal to us. This is enough to tie the knot at the top of - ;; the class graph. - (with-slots (name direct-superclasses metaclass) class - (dolist (super direct-superclasses) - (finalize-sod-class super)) - (unless (or (null direct-superclasses) - (eq class metaclass)) - (finalize-sod-class metaclass))) - - ;; Clobber the lists of items if they've not been set. - (dolist (slot '(slots instance-initializers class-initializers - messages methods)) - (unless (slot-boundp class slot) - (setf (slot-value class slot) nil))) - - ;; If the CPL hasn't been done yet, compute it. - (with-slots (class-precedence-list) class - (unless (slot-boundp class 'class-precedence-list) - (setf class-precedence-list (compute-cpl class)))) - - ;; If no metaclass has been established, then choose one. - (with-slots (metaclass) class - (unless (and (slot-boundp class 'metaclass) metaclass) - (setf metaclass (guess-metaclass class)))) - - ;; If no nickname has been set, choose a default. This might cause - ;; conflicts, but, well, the user should have chosen an explicit - ;; nickname. - (with-slots (name nickname) class - (unless (and (slot-boundp class 'nickname) nickname) - (setf nickname (string-downcase name)))) - - ;; Check that the class is fairly sane. - (check-sod-class class) - - ;; Determine the class's layout. - (compute-chains class) - - ;; Done. - (setf (sod-class-state class) :finalized) - t) - - (:broken - nil) - - (:finalized - t)))) + (if quals + `(qualify-type (make-class-type ,name) (list ,@quals)) + `(make-class-type ,name))) ;;;----- That's all, folks --------------------------------------------------