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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Class finalization implementation
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  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 precedence lists.
  30
  31 ;; Just for fun, we implement a wide selection of precedence list algorithms.
  32 ;; C3 seems to be clearly the best, with fewer sharp edges for the unwary.
  33 ;;
  34 ;; The extended precedence graph (EPG) is constructed by adding edges to the
  35 ;; superclass graph.  If A and B are classes, then write A < B if A is a
  36 ;; (maybe indirect) subclass of B.  For every two classes A and B, and for
  37 ;; every /maximal/ subclass of both A and B (i.e., every C for which C < A
  38 ;; and C < B, but there does not exist D such that D < A, D < B and C < D):
  39 ;; if A precedes B in C's direct superclass list, then draw an edge A -> B,
  40 ;; otherwise draw the edge B -> A.
  41 ;;
  42 ;; A linearization respects the EPG if, whenever A precedes B in the
  43 ;; linearization, there is a path from A to B.  The EPG can be cyclic; in
  44 ;; that case, we don't care which order the classes in the cycle are
  45 ;; linearized.
  46 ;;
  47 ;; See Barrett, Cassels, Haahr, Moon, Playford, Withington, `A Monotonic
  48 ;; Superclass Linearization for Dylan' for more detail.
  49 ;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
  50
  51 ;;; Tiebreaker functions.
  52
  53 (defun clos-tiebreaker (candidates so-far)
  54   "The CLOS linearization tiebreaker function.
  55
  56    Intended for use with `merge-lists'.  Returns the member of CANDIDATES
  57    which has a direct subclass furthest to the right in the list SO-FAR.
  58
  59    This must disambiguate.  The SO-FAR list cannot be empty, since the class
  60    under construction precedes all of the others.  If two classes share a
  61    direct subclass then that subclass's direct superclasses list must order
  62    them relative to each other."
  63
  64   (let (winner)
  65     (dolist (class so-far)
  66       (dolist (candidate candidates)
  67         (when (member candidate (sod-class-direct-superclasses class))
  68           (setf winner candidate))))
  69     (unless winner
  70       (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
  71     winner))
  72
  73 (defun c3-tiebreaker (candidates cpls)
  74   "The C3 linearization tiebreaker function.
  75
  76    Intended for use with `merge-lists'.  Returns the member of CANDIDATES
  77    which appears in the earliest element of CPLS, which should be the list of
  78    the class precedence lists of the direct superclasses of the class in
  79    question, in the order specified in the class declaration.
  80
  81    The only class in the class precedence list which does not appear in one
  82    of these lists is the new class itself, which must precede all of the
  83    others.
  84
  85    This must disambiguate, since if two classes are in the same class
  86    precedence list, then one must appear in it before the other, which
  87    provides an ordering between them.  (In this situation we return the one
  88    that matches earliest anyway, which would still give the right answer.)
  89
  90    Note that this will merge the CPLs of superclasses /as they are/, not
  91    necessarily as C3 would have computed them.  This ensures monotonicity
  92    assuming that the superclass CPLs are already monotonic.  If they aren't,
  93    you're going to lose anyway."
  94
  95   (dolist (cpl cpls)
  96     (dolist (candidate candidates)
  97       (when (member candidate cpl)
  98         (return-from c3-tiebreaker candidate))))
  99   (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
 100
 101 ;;; Linearization functions.
 102
 103 (export 'clos-cpl)
 104 (defun clos-cpl (class)
 105   "Compute the class precedence list of CLASS using CLOS linearization rules.
 106
 107    We merge the direct-superclass lists of all of CLASS's superclasses,
 108    disambiguating using `clos-tiebreaker'.
 109
 110    The CLOS linearization preserves local class ordering, but is not
 111    monotonic, and does not respect the extended precedence graph.  CLOS
 112    linearization will succeed whenever Dylan or C3 linearization succeeds;
 113    the converse is not true."
 114
 115   (labels ((superclasses (class)
 116              (let ((direct-supers (sod-class-direct-superclasses class)))
 117                (remove-duplicates (cons class
 118                                         (mappend #'superclasses
 119                                                  direct-supers))))))
 120     (merge-lists (mapcar (lambda (class)
 121                            (cons class
 122                                  (sod-class-direct-superclasses class)))
 123                          (superclasses class))
 124                  :pick #'clos-tiebreaker)))
 125
 126 (export 'dylan-cpl)
 127 (defun dylan-cpl (class)
 128   "Compute the class precedence list of CLASS using Dylan linearization
 129    rules.
 130
 131    We merge the direct-superclass list of CLASS with the full class
 132    precedence lists of its direct superclasses, disambiguating using
 133    `clos-tiebreaker'.  (Inductively, these lists will be consistent with the
 134    CPLs of indirect superclasses, since those CPLs' orderings are reflected
 135    in the CPLs of the direct superclasses.)
 136
 137    The Dylan linearization preserves local class ordering and is monotonic,
 138    but does not respect the extended precedence graph.
 139
 140    Note that this will merge the CPLs of superclasses /as they are/, not
 141    necessarily as Dylan would have computed them.  This ensures monotonicity
 142    assuming that the superclass CPLs are already monotonic.  If they aren't,
 143    you're going to lose anyway."
 144
 145   (let ((direct-supers (sod-class-direct-superclasses class)))
 146     (merge-lists (cons (cons class direct-supers)
 147                        (mapcar #'sod-class-precedence-list direct-supers))
 148                  :pick #'clos-tiebreaker)))
 149
 150 (export 'c3-cpl)
 151 (defun c3-cpl (class)
 152   "Compute the class precedence list of CLASS using C3 linearization rules.
 153
 154    We merge the direct-superclass list of CLASS with the full class
 155    precedence lists of its direct superclasses, disambiguating using
 156    `c3-tiebreaker'.
 157
 158    The C3 linearization preserves local class ordering, is monotonic, and
 159    respects the extended precedence graph.  It is the linearization used in
 160    Python, Perl 6 and other languages.  It is the recommended linearization
 161    for SOD."
 162
 163   (let* ((direct-supers (sod-class-direct-superclasses class))
 164          (cpls (mapcar #'sod-class-precedence-list direct-supers)))
 165     (merge-lists (cons (cons class direct-supers) cpls)
 166                  :pick (lambda (candidates so-far)
 167                          (declare (ignore so-far))
 168                          (c3-tiebreaker candidates cpls)))))
 169
 170 (export 'flavors-cpl)
 171 (defun flavors-cpl (class)
 172   "Compute the class precedence list of CLASS using Flavors linearization
 173    rules.
 174
 175    We do a depth-first traversal of the superclass graph, ignoring duplicates
 176    of classes we've already visited.  Interestingly, this has the property of
 177    being able to tolerate cyclic superclass graphs, though defining cyclic
 178    graphs is syntactically impossible in SOD.
 179
 180    This linearization has few other redeeming features, however.  In
 181    particular, the top class tends not to be at the end of the CPL, despite
 182    it being unequivocally less specific than any other class."
 183
 184   (let ((done nil))
 185     (labels ((walk (class)
 186                (unless (member class done)
 187                  (push class done)
 188                  (dolist (super (sod-class-direct-superclasses class))
 189                    (walk super)))))
 190       (walk class)
 191       (nreverse done))))
 192
 193 (export 'python-cpl)
 194 (defun python-cpl (class)
 195   "Compute the class precedence list of CLASS using the documented Python 2.2
 196    linearization rules.
 197
 198    We do a depth-first traversal of the superclass graph, retaining only the
 199    last occurrence of each class visited.
 200
 201    This linearization has few redeeming features.  It was never actually
 202    implemented; the true Python 2.2 linearization seems closer to (but
 203    different from) L*LOOPS."
 204
 205   (let ((done nil))
 206     (labels ((walk (class)
 207                (push class done)
 208                (dolist (super (sod-class-direct-superclasses class))
 209                  (walk super))))
 210       (walk class)
 211       (delete-duplicates (nreverse done)))))
 212
 213 (export 'l*loops-cpl)
 214 (defun l*loops-cpl (class)
 215   "Compute the class precedence list of CLASS using L*LOOPS linearization
 216    rules.
 217
 218    We merge the class precedence lists of the direct superclasses of CLASS,
 219    disambiguating by choosing the earliest candidate which appears in a
 220    depth-first walk of the superclass graph.
 221
 222    The L*LOOPS rules are monotonic and respect the extended precedence
 223    graph.  However (unlike Dylan and CLOS) they don't respect local
 224    precedence order i.e., the direct-superclasses list orderings."
 225
 226   (let ((dfs (flavors-cpl class)))
 227     (cons class (merge-lists (mapcar #'sod-class-precedence-list
 228                                      (sod-class-direct-superclasses class))
 229                              :pick (lambda (candidates so-far)
 230                                      (declare (ignore so-far))
 231                                      (dolist (class dfs)
 232                                        (when (member class candidates)
 233                                          (return class))))))))
 234
 235 ;;; Default function.
 236
 237 (defmethod compute-cpl ((class sod-class))
 238   (handler-case (c3-cpl class)
 239     (inconsistent-merge-error ()
 240       (error "Failed to compute class precedence list for `~A'"
 241              (sod-class-name class)))))
 242
 243 ;;;--------------------------------------------------------------------------
 244 ;;; Chains.
 245
 246 (defmethod compute-chains ((class sod-class))
 247   (with-default-error-location (class)
 248     (with-slots (chain-link class-precedence-list) class
 249       (let* ((head (if chain-link
 250                        (sod-class-chain-head chain-link)
 251                        class))
 252              (chain (cons class (and chain-link
 253                                      (sod-class-chain chain-link))))
 254              (table (make-hash-table)))
 255
 256         ;; Check the chains.  We work through each superclass, maintaining a
 257         ;; hash table keyed by class.  If we encounter a class C which links
 258         ;; to L, then we store C as L's value; if L already has a value then
 259         ;; we've found an error.  By the end of all of this, the classes
 260         ;; which don't have an entry are the chain tails.
 261         (dolist (super class-precedence-list)
 262           (let ((link (sod-class-chain-link super)))
 263             (when link
 264               (when (gethash link table)
 265                 (error "Conflicting chains in class ~A: ~
 266                         (~A and ~A both link to ~A)"
 267                        class super (gethash link table) link))
 268               (setf (gethash link table) super))))
 269
 270         ;; Done.
 271         (values head chain
 272                 (cons chain
 273                       (mapcar #'sod-class-chain
 274                               (remove-if (lambda (super)
 275                                            (gethash super table))
 276                                          (cdr class-precedence-list)))))))))
 277
 278 ;;;--------------------------------------------------------------------------
 279 ;;; Metaclasses.
 280
 281 (defun maximum (items order what)
 282   "Return a maximum item according to the non-strict partial ORDER."
 283   (reduce (lambda (best this)
 284             (cond ((funcall order best this) best)
 285                   ((funcall order this best) this)
 286                   (t (error "Unable to choose best ~A." what))))
 287           items))
 288
 289 (defmethod guess-metaclass ((class sod-class))
 290   "Default metaclass-guessing function for classes.
 291
 292    Return the most specific metaclass of any of the CLASS's direct
 293    superclasses."
 294
 295   ;; During bootstrapping, our superclasses might not have their own
 296   ;; metaclasses resolved yet.  If we find this, then throw `bootstrapping'
 297   ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
 298   ;; across the bows of anyone else who calls us).
 299   (maximum (mapcar (lambda (super)
 300                      (if (slot-boundp super 'metaclass)
 301                          (slot-value super 'metaclass)
 302                          (throw 'bootstrapping nil)))
 303                    (sod-class-direct-superclasses class))
 304            #'sod-subclass-p
 305            (format nil "metaclass for `~A'" class)))
 306
 307 ;;;--------------------------------------------------------------------------
 308 ;;; Sanity checking.
 309
 310 (defmethod check-sod-class ((class sod-class))
 311   (with-default-error-location (class)
 312
 313     ;; Check the names of things are valid.
 314     (with-slots (name nickname messages) class
 315       (unless (valid-name-p name)
 316         (error "Invalid class name `~A'" class))
 317       (unless (valid-name-p nickname)
 318         (error "Invalid class nickname `~A' on class `~A'" nickname class))
 319       (dolist (message messages)
 320         (unless (valid-name-p (sod-message-name message))
 321           (error "Invalid message name `~A' on class `~A'"
 322                  (sod-message-name message) class))))
 323
 324     ;; Check that the slots and messages have distinct names.
 325     (with-slots (slots messages class-precedence-list) class
 326       (flet ((check-list (list what namefunc)
 327                (let ((table (make-hash-table :test #'equal)))
 328                  (dolist (item list)
 329                    (let ((name (funcall namefunc item)))
 330                      (if (gethash name table)
 331                          (error "Duplicate ~A name `~A' on class `~A'"
 332                                 what name class)
 333                          (setf (gethash name table) item)))))))
 334         (check-list slots "slot" #'sod-slot-name)
 335         (check-list messages "message" #'sod-message-name)
 336         (check-list class-precedence-list "nickname" #'sod-class-name)))
 337
 338     ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
 339     ;; eliminates hairy things like a class being its own link.)
 340     (with-slots (class-precedence-list chain-link) class
 341       (unless (or (not chain-link)
 342                   (member chain-link (cdr class-precedence-list)))
 343         (error "In `~A~, chain-to class `~A' is not a proper superclass"
 344                class chain-link)))
 345
 346     ;; Check that the initargs declare compatible types.  Duplicate entries,
 347     ;; even within a class, are harmless, but at most one initarg in any
 348     ;; class should declare a default value.
 349     (with-slots (class-precedence-list) class
 350       (let ((seen (make-hash-table :test #'equal)))
 351         (dolist (super class-precedence-list)
 352           (with-slots (initargs) super
 353             (dolist (initarg (reverse initargs))
 354               (let* ((initarg-name (sod-initarg-name initarg))
 355                      (initarg-type (sod-initarg-type initarg))
 356                      (initarg-default (sod-initarg-default initarg))
 357                      (found (gethash initarg-name seen))
 358                      (found-type (and found (sod-initarg-type found)))
 359                      (found-default (and found (sod-initarg-default found)))
 360                      (found-class (and found (sod-initarg-class found)))
 361                      (found-location (and found (file-location found))))
 362                 (with-default-error-location (initarg)
 363                   (cond ((not found)
 364                          (setf (gethash initarg-name seen) initarg))
 365                         ((not (c-type-equal-p initarg-type found-type))
 366                          (cerror* "Inititalization argument `~A' defined ~
 367                                    with incompatible types: ~
 368                                    ~A in class ~A, and ~
 369                                    ~A in class ~A (at ~A)"
 370                                 initarg-name initarg-type super
 371                                 found-type found-class found-location))
 372                         ((and initarg-default found-default
 373                               (eql super found-class))
 374                          (cerror* "Initialization argument `~A' redefined ~
 375                                    with default value ~
 376                                    (previous definition at ~A)"
 377                                   initarg-name found-location))
 378                         (initarg-default
 379                          (setf (gethash initarg-name seen) initarg))))))))))
 380
 381     ;; Check for circularity in the superclass graph.  Since the superclasses
 382     ;; should already be acyclic, it suffices to check that our class is not
 383     ;; a superclass of any of its own direct superclasses.
 384     (let ((circle (find-if (lambda (super)
 385                              (sod-subclass-p super class))
 386                            (sod-class-direct-superclasses class))))
 387       (when circle
 388         (error "Circularity: ~A is already a superclass of ~A"
 389                class circle)))
 390
 391     ;; Check that the class has a unique root superclass.
 392     (find-root-superclass class)
 393
 394     ;; Check that the metaclass is a subclass of each direct superclass's
 395     ;; metaclass.
 396     (with-slots (metaclass direct-superclasses) class
 397       (dolist (super direct-superclasses)
 398         (unless (sod-subclass-p metaclass (sod-class-metaclass super))
 399           (error "Incompatible metaclass for `~A': ~
 400                   `~A' isn't a subclass of `~A' (of `~A')"
 401                  class metaclass (sod-class-metaclass super) super))))))
 402
 403 ;;;--------------------------------------------------------------------------
 404 ;;; Finalization.
 405
 406 (defmethod finalize-sod-class ((class sod-class))
 407
 408   ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
 409   ;; clone of the CPL and chain establishment code.  If the interface changes
 410   ;; then `bootstrap-classes' will need to be changed too.
 411
 412   (with-default-error-location (class)
 413     (ecase (sod-class-state class)
 414       ((nil)
 415
 416        ;; If this fails, mark the class as a loss.
 417        (setf (slot-value class 'state) :broken)
 418
 419        ;; Set up the metaclass if it's not been set already.  This is delayed
 420        ;; to give bootstrapping a chance to set up metaclass and superclass
 421        ;; circularities.
 422        (default-slot (class 'metaclass) (guess-metaclass class))
 423
 424        ;; Finalize all of the superclasses.  There's some special pleading
 425        ;; here to make bootstrapping work: we don't try to finalize the
 426        ;; metaclass if we're a root class (no direct superclasses -- because
 427        ;; in that case the metaclass will have to be a subclass of us!), or
 428        ;; if it's equal to us.  This is enough to tie the knot at the top of
 429        ;; the class graph.
 430        (with-slots (name direct-superclasses metaclass) class
 431          (dolist (super direct-superclasses)
 432            (finalize-sod-class super))
 433          (unless (or (null direct-superclasses)
 434                      (eq class metaclass))
 435            (finalize-sod-class metaclass)))
 436
 437        ;; Stash the class's type.
 438        (setf (slot-value class '%type)
 439              (make-class-type (sod-class-name class)))
 440
 441        ;; Clobber the lists of items if they've not been set.
 442        (dolist (slot '(slots instance-initializers class-initializers
 443                        messages methods))
 444          (unless (slot-boundp class slot)
 445            (setf (slot-value class slot) nil)))
 446
 447        ;; If the CPL hasn't been done yet, compute it.
 448        (with-slots (class-precedence-list) class
 449          (unless (slot-boundp class 'class-precedence-list)
 450            (setf class-precedence-list (compute-cpl class))))
 451
 452        ;; Check that the class is fairly sane.
 453        (check-sod-class class)
 454
 455        ;; Determine the class's layout.
 456        (with-slots (chain-head chain chains) class
 457          (setf (values chain-head chain chains) (compute-chains class)))
 458
 459        ;; Done.
 460        (setf (slot-value class 'state) :finalized)
 461        t)
 462
 463       (:broken
 464        nil)
 465
 466       (:finalized
 467        t))))
 468
 469 (flet ((check-class-is-finalized (class)
 470          (unless (eq (sod-class-state class) :finalized)
 471            (error "Class ~S is not finalized" class))))
 472   (macrolet ((define-layout-slot (slot (class) &body body)
 473                `(define-on-demand-slot sod-class ,slot (,class)
 474                   (check-class-is-finalized ,class)
 475                   ,@body)))
 476     (define-layout-slot %ilayout (class)
 477       (compute-ilayout class))
 478     (define-layout-slot effective-methods (class)
 479       (compute-effective-methods class))
 480     (define-layout-slot vtables (class)
 481       (compute-vtables class))))
 482
 483 ;;;----- That's all, folks --------------------------------------------------