chiark - git - mdw - sod/blob - class-finalize.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Class finalization
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Class finalization.
  30
  31 ;; Protocol.
  32
  33 (defgeneric compute-chains (class)
  34   (:documentation
  35    "Compute the layout chains for CLASS.
  36
  37    Returns the following three values.
  38
  39      * the head of the class's primary chain;
  40
  41      * the class's primary chain as a list, most- to least-specific; and
  42
  43      * the complete collection of chains, as a list of lists, each most- to
  44        least-specific, with the primary chain first.
  45
  46    These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots.
  47
  48    If the chains are ill-formed (i.e., not distinct) then an error is
  49    signalled."))
  50
  51 (defgeneric check-sod-class (class)
  52   (:documentation
  53    "Check the CLASS for validity.
  54
  55    This is done as part of class finalization.  The checks performed are as
  56    follows.
  57
  58      * The class name and nickname, and the names of messages, obey the
  59        rules (see VALID-NAME-P).
  60
  61      * The messages and slots have distinct names.
  62
  63      * The classes in the class-precedence-list have distinct nicknames.
  64
  65      * The chain-link is actually a proper (though not necessarily direct)
  66        superclass.
  67
  68      * The chosen metaclass is actually a subclass of all of the
  69        superclasses' metaclasses.
  70
  71    Returns true if all is well; false (and signals errors) if anything was
  72    wrong."))
  73
  74 (defgeneric finalize-sod-class (class)
  75   (:documentation
  76    "Computes all of the gory details about a class.
  77
  78    Once one has stopped inserting methods and slots and so on into a class,
  79    one needs to finalize it to determine the layout structure and the class
  80    precedence list and so on.  More precisely that gets done is this:
  81
  82      * Related classes (i.e., direct superclasses and the metaclass) are
  83        finalized if they haven't been already.
  84
  85      * If you've been naughty and failed to store a list of slots or
  86        whatever, then an empty list is inserted.
  87
  88      * The class precedence list is computed and stored.
  89
  90      * The class is checked for compiance with the well-formedness rules.
  91
  92      * The layout chains are computed.
  93
  94    Other stuff will need to happen later, but it's not been done yet.  In
  95    particular:
  96
  97      * Actually computing the layout of the instance and the virtual tables.
  98
  99      * Combining the applicable methods into effective methods.
 100
 101    FIXME this needs doing."))
 102
 103 ;; Implementation.
 104
 105 (defun sod-subclass-p (class-a class-b)
 106   "Return whether CLASS-A is a descendent of CLASS-B."
 107   (member class-b (sod-class-precedence-list class-a)))
 108
 109 (defun valid-name-p (name)
 110   "Checks whether NAME is a valid name.
 111
 112    The rules are:
 113
 114      * the name must be a string
 115      * which is nonempty
 116      * whose first character is alphabetic
 117      * all of whose characters are alphanumeric or underscores
 118      * and which doesn't contain two consecutive underscores."
 119
 120   (and (stringp name)
 121        (plusp (length name))
 122        (alpha-char-p (char name 0))
 123        (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
 124        (not (search "__" name))))
 125
 126 (defmethod compute-chains ((class sod-class))
 127   (with-default-error-location (class)
 128     (with-slots (chain-link class-precedence-list) class
 129       (let* ((head (if chain-link
 130                        (sod-class-chain-head chain-link)
 131                        class))
 132              (chain (cons class (and chain-link
 133                                      (sod-class-chain chain-link))))
 134              (table (make-hash-table)))
 135
 136         ;; Check the chains.  We work through each superclass, maintaining a
 137         ;; hash table keyed by class.  If we encounter a class C which links
 138         ;; to L, then we store C as L's value; if L already has a value then
 139         ;; we've found an error.  By the end of all of this, the classes
 140         ;; which don't have an entry are the chain tails.
 141         (dolist (super class-precedence-list)
 142           (let ((link (sod-class-chain-link super)))
 143             (when link
 144               (when (gethash link table)
 145                 (error "Conflicting chains in class ~A: ~
 146                         (~A and ~A both link to ~A)"
 147                        class super (gethash link table) link))
 148               (setf (gethash link table) super))))
 149
 150         ;; Done.
 151         (values head chain
 152                 (cons chain
 153                       (mapcar #'sod-class-chain
 154                               (remove-if (lambda (super)
 155                                            (gethash super table))
 156                                          (cdr class-precedence-list)))))))))
 157
 158 (defmethod check-sod-class ((class sod-class))
 159   (with-default-error-location (class)
 160
 161     ;; Check the names of things are valid.
 162     (with-slots (name nickname messages) class
 163       (unless (valid-name-p name)
 164         (error "Invalid class name `~A'" class))
 165       (unless (valid-name-p nickname)
 166         (error "Invalid class nickname `~A' on class `~A'" nickname class))
 167       (dolist (message messages)
 168         (unless (valid-name-p (sod-message-name message))
 169           (error "Invalid message name `~A' on class `~A'"
 170                  (sod-message-name message) class))))
 171
 172       ;; Check that the slots and messages have distinct names.
 173     (with-slots (slots messages class-precedence-list) class
 174       (flet ((check-list (list what namefunc)
 175                (let ((table (make-hash-table :test #'equal)))
 176                  (dolist (item list)
 177                    (let ((name (funcall namefunc item)))
 178                      (if (gethash name table)
 179                          (error "Duplicate ~A name `~A' on class `~A'"
 180                                 what name class)
 181                          (setf (gethash name table) item)))))))
 182         (check-list slots "slot" #'sod-slot-name)
 183         (check-list messages "message" #'sod-message-name)
 184         (check-list class-precedence-list "nickname" #'sod-class-name)))
 185
 186     ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
 187     ;; eliminates hairy things like a class being its own link.)
 188     (with-slots (class-precedence-list chain-link) class
 189       (unless (or (not chain-link)
 190                   (member chain-link (cdr class-precedence-list)))
 191         (error "In `~A~, chain-to class `~A' is not a proper superclass"
 192                class chain-link)))
 193
 194     ;; Check that the metaclass is a subclass of each direct superclass's
 195     ;; metaclass.
 196     (with-slots (metaclass direct-superclasses) class
 197       (dolist (super direct-superclasses)
 198         (unless (sod-subclass-p metaclass (sod-class-metaclass super))
 199           (error "Incompatible metaclass for `~A': ~
 200                   `~A' isn't a subclass of `~A' (of `~A')"
 201                  class metaclass (sod-class-metaclass super) super))))))
 202
 203 (defmethod finalize-sod-class ((class sod-class))
 204
 205   ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief)
 206   ;; clone of the CPL and chain establishment code.  If the interface changes
 207   ;; then BOOTSTRAP-CLASSES will need to be changed too.
 208
 209   (with-default-error-location (class)
 210     (ecase (sod-class-state class)
 211       ((nil)
 212
 213        ;; If this fails, mark the class as a loss.
 214        (setf (sod-class-state class) :broken)
 215
 216        ;; Finalize all of the superclasses.  There's some special pleading
 217        ;; here to make bootstrapping work: we don't try to finalize the
 218        ;; metaclass if we're a root class (no direct superclasses -- because
 219        ;; in that case the metaclass will have to be a subclass of us!), or
 220        ;; if it's equal to us.  This is enough to tie the knot at the top of
 221        ;; the class graph.
 222        (with-slots (name direct-superclasses metaclass) class
 223          (dolist (super direct-superclasses)
 224            (finalize-sod-class super))
 225          (unless (or (null direct-superclasses)
 226                      (eq class metaclass))
 227            (finalize-sod-class metaclass)))
 228
 229        ;; Clobber the lists of items if they've not been set.
 230        (dolist (slot '(slots instance-initializers class-initializers
 231                        messages methods))
 232          (unless (slot-boundp class slot)
 233            (setf (slot-value class slot) nil)))
 234
 235        ;; If the CPL hasn't been done yet, compute it.
 236        (with-slots (class-precedence-list) class
 237          (unless (slot-boundp class 'class-precedence-list)
 238            (setf class-precedence-list (compute-cpl class))))
 239
 240        ;; If no metaclass has been established, then choose one.
 241        (with-slots (metaclass) class
 242          (unless (and (slot-boundp class 'metaclass) metaclass)
 243            (setf metaclass (guess-metaclass class))))
 244
 245        ;; If no nickname has been set, choose a default.  This might cause
 246        ;; conflicts, but, well, the user should have chosen an explicit
 247        ;; nickname.
 248        (with-slots (name nickname) class
 249          (unless (and (slot-boundp class 'nickname) nickname)
 250            (setf nickname (string-downcase name))))
 251
 252        ;; Check that the class is fairly sane.
 253        (check-sod-class class)
 254
 255        ;; Determine the class's layout.
 256        (with-slots (chain-head chain chains) class
 257          (setf (values chain-head chain chains) (compute-chains class)))
 258
 259        (with-slots (ilayout effective-methods vtables) class
 260          (setf ilayout (compute-ilayout class))
 261          (setf effective-methods (compute-effective-methods class))
 262          (setf vtables (compute-vtables class)))
 263
 264        ;; Done.
 265        (setf (sod-class-state class) :finalized)
 266        t)
 267
 268       (:broken
 269        nil)
 270
 271       (:finalized
 272        t))))
 273
 274 ;;;----- That's all, folks --------------------------------------------------