(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
-;;; Class definitions.
+;;; Classes.
(defclass sod-class ()
((name :initarg :name
(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)
+ (chain-link :initarg :link
+ :type (or sod-class null)
+ :reader sod-class-chain-link)
(metaclass :initarg :metaclass
:type sod-class
:reader sod-class-metaclass)
(chain :type list :accessor sod-class-chain)
(chains :type list :accessor sod-class-chains)
+ (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:
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;
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-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."))
+
+(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
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
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.
(defmethod print-c-type (stream (type c-class-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<CLASS ~@_~S~:>" (c-type-name type)))
+ (format stream "~:@<CLASS ~@_~S~{ ~_~S~}~:>"
+ (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.
"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
(t
(setf (c-type-class type) class))))))
-(define-c-type-syntax class (name)
- "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
+(defun sod-class-type (class)
+ "Returns the C type corresponding to CLASS."
+ (find-class-type (sod-class-name class)))
- * 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))))
+(define-c-type-syntax class (name &rest quals)
+ "Returns a type object for the named class."
+ (if quals
+ `(qualify-type (make-class-type ,name) (list ,@quals))
+ `(make-class-type ,name)))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff