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