;;; -*-lisp-*- ;;; ;;; Class finalization ;;; ;;; (c) 2009 Straylight/Edgeware ;;; ;;;----- Licensing notice --------------------------------------------------- ;;; ;;; This file is part of the Simple Object Definition system. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; SOD is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with SOD; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- ;;; Class finalization. ;; Protocol. (defgeneric compute-chains (class) (:documentation "Compute the layout chains for CLASS. Returns the following three values. * 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. These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots. If the chains are ill-formed (i.e., not distinct) then an error is signalled.")) (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 chain-link is actually a proper (though not necessarily direct) superclass. * 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. (defun sod-subclass-p (class-a class-b) "Return whether CLASS-A is a descendent of CLASS-B." (member class-b (sod-class-precedence-list class-a))) (defun valid-name-p (name) "Checks whether NAME is a valid name. The rules are: * the name must be a string * which is nonempty * whose first character is alphabetic * all of whose characters are alphanumeric or underscores * and which doesn't contain two consecutive underscores." (and (stringp name) (plusp (length name)) (alpha-char-p (char name 0)) (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name) (not (search "__" name)))) (defmethod compute-chains ((class sod-class)) (with-default-error-location (class) (with-slots (chain-link class-precedence-list) class (let* ((head (if chain-link (sod-class-chain-head chain-link) class)) (chain (cons class (and chain-link (sod-class-chain chain-link)))) (table (make-hash-table))) ;; Check the chains. We work through each superclass, maintaining a ;; hash table keyed by class. If we encounter a class C which links ;; to L, then we store C as L's value; if L already has a value then ;; we've found an error. By the end of all of this, the classes ;; which don't have an entry are the chain tails. (dolist (super class-precedence-list) (let ((link (sod-class-chain-link super))) (when link (when (gethash link table) (error "Conflicting chains in class ~A: ~ (~A and ~A both link to ~A)" class super (gethash link table) link)) (setf (gethash link table) super)))) ;; Done. (values head chain (cons chain (mapcar #'sod-class-chain (remove-if (lambda (super) (gethash super table)) (cdr class-precedence-list))))))))) (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'" class)) (unless (valid-name-p nickname) (error "Invalid class nickname `~A' on class `~A'" nickname class)) (dolist (message messages) (unless (valid-name-p (sod-message-name message)) (error "Invalid message name `~A' on class `~A'" (sod-message-name message) class)))) ;; Check that the slots and messages have distinct names. (with-slots (slots messages class-precedence-list) class (flet ((check-list (list what namefunc) (let ((table (make-hash-table :test #'equal))) (dolist (item list) (let ((name (funcall namefunc item))) (if (gethash name table) (error "Duplicate ~A name `~A' on class `~A'" what name class) (setf (gethash name 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 proper superclass. (This ;; eliminates hairy things like a class being its own link.) (with-slots (class-precedence-list chain-link) class (unless (or (not chain-link) (member chain-link (cdr class-precedence-list))) (error "In `~A~, chain-to class `~A' is not a proper superclass" class chain-link))) ;; Check for circularity in the superclass graph. Since the superclasses ;; should already be acyclic, it suffices to check that our class is not ;; a superclass of any of its own direct superclasses. (let ((circle (find-if (lambda (super) (sod-subclass-p super class)) (sod-class-direct-superclasses class)))) (when circle (error "Circularity: ~A is already a superclass of ~A" class circle))) ;; Check that the class has a unique root superclass. (find-root-superclass class) ;; Check that the metaclass is a subclass of each direct superclass's ;; metaclass. (with-slots (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 a subclass of `~A' (of `~A')" class metaclass (sod-class-metaclass super) super)))))) (defmethod finalize-sod-class ((class sod-class)) ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief) ;; clone of the CPL and chain establishment code. If the interface changes ;; then BOOTSTRAP-CLASSES will need to be changed too. (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))) ;; Stash the class's type. (setf (sod-class-type class) (make-class-type (sod-class-name class))) ;; 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. (with-slots (chain-head chain chains) class (setf (values chain-head chain chains) (compute-chains class))) (with-slots (ilayout effective-methods vtables) class (setf ilayout (compute-ilayout class)) (setf effective-methods (compute-effective-methods class)) (setf vtables (compute-vtables class))) ;; Done. (setf (sod-class-state class) :finalized) t) (:broken nil) (:finalized t)))) ;;;----- That's all, folks --------------------------------------------------