Another day, another commit.

[sod] / class-finalize.lisp

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