chiark - git - mdw - sod/blob - src/class-utilities.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; A collection of utility functions for SOD classes
   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 ;;; Finding things by name
  30
  31 (export 'find-superclass-by-nick)
  32 (defun find-superclass-by-nick (class nick)
  33   "Returns the superclass of CLASS with nickname NICK, or signals an error."
  34
  35   ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
  36   ;; trundle through its superclasses and hope for the best.
  37   (if (string= nick (sod-class-nickname class))
  38       class
  39       (or (some (lambda (super)
  40                   (find nick (sod-class-precedence-list super)
  41                         :key #'sod-class-nickname
  42                         :test #'string=))
  43                 (sod-class-direct-superclasses class))
  44           (error "No superclass of `~A' with nickname `~A'" class nick))))
  45
  46 (export '(find-instance-slot-by-name find-class-slot-by-name
  47           find-message-by-name))
  48 (flet ((find-thing-by-name (what class list name key)
  49          (or (find name list :key key :test #'string=)
  50              (error "No ~A in class `~A' with name `~A'" what class name))))
  51
  52   (defun find-instance-slot-by-name (class super-nick slot-name)
  53     (let ((super (find-superclass-by-nick class super-nick)))
  54       (find-thing-by-name "instance slot" super (sod-class-slots super)
  55                           slot-name #'sod-slot-name)))
  56
  57   (defun find-class-slot-by-name (class super-nick slot-name)
  58     (let* ((meta (sod-class-metaclass class))
  59            (super (find-superclass-by-nick meta super-nick)))
  60       (find-thing-by-name "class slot" super (sod-class-slots super)
  61                           slot-name #'sod-slot-name)))
  62
  63   (defun find-message-by-name (class super-nick message-name)
  64     (let ((super (find-superclass-by-nick class super-nick)))
  65       (find-thing-by-name "message" super (sod-class-messages super)
  66                           message-name #'sod-message-name))))
  67
  68 ;;;--------------------------------------------------------------------------
  69 ;;; Describing class inheritance paths in diagnostics.
  70
  71 (export 'inheritance-path-reporter-state)
  72 (defclass inheritance-path-reporter-state ()
  73   ((%class :type sod-class :initarg :class)
  74    (paths :type list :initarg :paths)
  75    (seen :type hash-table :initform (make-hash-table))))
  76
  77 (export 'make-inheritance-path-reporter-state)
  78 (defun make-inheritance-path-reporter-state (class)
  79   (make-instance 'inheritance-path-reporter-state :class class))
  80
  81 (export 'report-inheritance-path)
  82 (defun report-inheritance-path (state super)
  83   "Issue informational messages showing how CLASS inherits from SUPER."
  84   (with-slots (paths (class %class) include-boundary seen) state
  85     (unless (slot-boundp state 'paths)
  86       (setf paths (distinguished-point-shortest-paths
  87                    class
  88                    (lambda (c)
  89                      (mapcar (lambda (super) (cons super 1))
  90                              (sod-class-direct-superclasses c))))))
  91     (dolist (hop (mapcon (lambda (subpath)
  92                            (let ((super (car subpath))
  93                                  (sub (and (cdr subpath)
  94                                            (cadr subpath))))
  95                              (if (or (not sub) (gethash super seen))
  96                                  nil
  97                                  (progn
  98                                    (setf (gethash super seen) t)
  99                                    (list (cons super sub))))))
 100                          (cdr (find super paths :key #'cadr))))
 101       (let ((super (car hop))
 102             (sub (cdr hop)))
 103         (info-with-location sub
 104                             "Class `~A' is a direct superclass ~
 105                              of `~A', defined here"
 106                             super sub)))))
 107
 108 ;;;--------------------------------------------------------------------------
 109 ;;; Metaclass inference.
 110
 111 (export 'select-minimal-class-property)
 112 (defun select-minimal-class-property (supers key order default what
 113                                       &key (present (lambda (x)
 114                                                       (format nil "`~A'" x)))
 115                                            allow-empty)
 116   "Return the minimal partially-ordered key from the SUPERS.
 117
 118    KEY is a function of one argument which returns some interesting property
 119    of a class.  The keys are assumed to be partially ordered by ORDER, a
 120    function of two arguments which returns non-nil if its first argument
 121    precedes its second.  If there is a unique minimal key then return it;
 122    otherwise report a useful error and pick some candidate in an arbitrary
 123    way; the DEFAULT may be chosen if no better choices are available.  If
 124    ALLOW-EMPTY is non-nil, then no error is reported if there are no SUPERS,
 125    and the DEFAULT choice is returned immediately.
 126
 127    In an error message, the keys are described as WHAT, which should be a
 128    noun phrase; keys are filtered through PRESENT, a function of one
 129    argument, before presentation.
 130
 131    The function returns two values: the chosen value, and a flag which is
 132    non-nil if it was chosen without errors."
 133
 134   (let ((candidates (partial-order-minima (mapcar key supers) order)))
 135     (cond ((and (null candidates) allow-empty)
 136            (values default t))
 137           ((and candidates (null (cdr candidates)))
 138            (values (car candidates) t))
 139           (t
 140            (cerror* "No obvious choice for implicit ~A: ~
 141                      ~{~#[root classes must specify explicitly~:;~
 142                           candidates are ~
 143                           ~#[~;~A~;~A and ~A~:;~@{~A, ~#[~;and ~A~]~}~]~]~:}"
 144                     what (mapcar present candidates))
 145            (dolist (candidate candidates)
 146              (let ((super (find candidate supers :key key)))
 147                (info-with-location super
 148                                    "Direct superclass `~A' defined here ~
 149                                     has ~A ~A"
 150                                    super what (funcall present candidate))))
 151            (values (if candidates (car candidates) default) nil)))))
 152
 153 ;;;--------------------------------------------------------------------------
 154 ;;; Miscellaneous useful functions.
 155
 156 (export 'sod-subclass-p)
 157 (defun sod-subclass-p (class-a class-b)
 158   "Return whether CLASS-A is a descendent of CLASS-B.
 159
 160    Careful!  Assumes that the class precedence list of CLASS-A has been
 161    computed!"
 162   (member class-b (sod-class-precedence-list class-a)))
 163
 164 (export 'valid-name-p)
 165 (defun valid-name-p (name)
 166   "Checks whether NAME is a valid name.
 167
 168    The rules are:
 169
 170      * the name must be a string
 171      * which is nonempty
 172      * whose first character is alphabetic
 173      * all of whose characters are alphanumeric or underscores
 174      * and which doesn't contain two consecutive underscores."
 175
 176   (or (typep name 'temporary-variable)
 177       (and (stringp name)
 178            (plusp (length name))
 179            (alpha-char-p (char name 0))
 180            (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
 181            (not (search "__" name)))))
 182
 183 (export 'find-root-superclass)
 184 (defun find-root-superclass (class)
 185   "Returns the `root' superclass of CLASS.
 186
 187    The root superclass is the superclass which itself has no direct
 188    superclasses.  In universes not based on the provided builtin module, the
 189    root class may not be our beloved `SodObject'; however, there must be one
 190    (otherwise the class graph is cyclic, which should be forbidden), and we
 191    insist that it be unique."
 192
 193   ;; The root superclass must be a chain head since the chains partition the
 194   ;; superclasses; the root has no superclasses so it can't have a link and
 195   ;; must therefore be a head.  This narrows the field down quite a lot.
 196   ;;
 197   ;; Note!  This function gets called from `check-sod-class' before the
 198   ;; class's chains have been computed.  Therefore we iterate over the direct
 199   ;; superclasses' chains rather than the class's own.  This misses a chain
 200   ;; only in the case where the class is its own chain head.  There are two
 201   ;; subcases: if there are no direct superclasses at all, then the class is
 202   ;; its own root; otherwise, it clearly can't be the root and the omission
 203   ;; is harmless.
 204
 205   (let* ((supers (sod-class-direct-superclasses class))
 206          (roots (if supers
 207                     (remove-duplicates
 208                      (remove-if #'sod-class-direct-superclasses
 209                                 (mappend (lambda (super)
 210                                            (mapcar (lambda (chain)
 211                                                      (sod-class-chain-head
 212                                                       (car chain)))
 213                                                    (sod-class-chains super)))
 214                                          supers)))
 215                     (list class))))
 216     (cond ((null roots)
 217            (error "Class ~A has no root class!" class))
 218           ((cdr roots)
 219            (cerror* "Class ~A has multiple root classes ~
 220                      ~{~#[~;~A~;~A and ~A~:; ~@{~A, ~#[~;and ~A~]~}~]~}"
 221                     class roots)
 222            (let ((state (make-inheritance-path-reporter-state class)))
 223              (dolist (root roots)
 224                (report-inheritance-path state root))))
 225           (t (car roots)))))
 226
 227 (export 'find-root-metaclass)
 228 (defun find-root-metaclass (class)
 229   "Returns the `root' metaclass of CLASS.
 230
 231    The root metaclass is the metaclass of the root superclass -- see
 232    `find-root-superclass'."
 233   (sod-class-metaclass (find-root-superclass class)))
 234
 235 ;;;--------------------------------------------------------------------------
 236 ;;; Type hacking.
 237
 238 (export 'argument-lists-compatible-p)
 239 (defun argument-lists-compatible-p (message-args method-args)
 240   "Compare argument lists for compatibility.
 241
 242    Return true if METHOD-ARGS is a suitable method argument list
 243    corresponding to the message argument list MESSAGE-ARGS.  This is the case
 244    if the lists are the same length, each message argument has a
 245    corresponding method argument with the same type, and if the message
 246    arguments end in an ellpisis, the method arguments must end with a
 247    `va_list' argument.  (We can't pass actual variable argument lists around,
 248    except as `va_list' objects, which are devilish inconvenient things and
 249    require much hacking.  See the method combination machinery for details.)"
 250
 251   (and (= (length message-args) (length method-args))
 252        (every (lambda (message-arg method-arg)
 253                 (if (eq message-arg :ellipsis)
 254                     (c-type-equal-p (argument-type method-arg)
 255                                     c-type-va-list)
 256                     (c-type-equal-p (argument-type message-arg)
 257                                     (argument-type method-arg))))
 258               message-args method-args)))
 259
 260 ;;;--------------------------------------------------------------------------
 261 ;;; Names of things.
 262
 263 (export 'islots-struct-tag)
 264 (defun islots-struct-tag (class)
 265   (format nil "~A__islots" class))
 266
 267 (export 'ichain-struct-tag)
 268 (defun ichain-struct-tag (class chain-head)
 269   (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
 270
 271 (export 'ichain-union-tag)
 272 (defun ichain-union-tag (class chain-head)
 273   (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
 274
 275 (export 'ilayout-struct-tag)
 276 (defun ilayout-struct-tag (class)
 277   (format nil "~A__ilayout" class))
 278
 279 (export 'vtmsgs-struct-tag)
 280 (defun vtmsgs-struct-tag (class super)
 281   (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
 282
 283 (export 'vtable-union-tag)
 284 (defun vtable-union-tag (class chain-head)
 285   (format nil "~A__vtu_~A" class (sod-class-nickname chain-head)))
 286
 287 (export 'vtable-struct-tag)
 288 (defun vtable-struct-tag (class chain-head)
 289   (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
 290
 291 (export 'vtable-name)
 292 (defun vtable-name (class chain-head)
 293   (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
 294
 295 (export 'message-macro-name)
 296 (defun message-macro-name (class entry)
 297   (format nil "~A_~A" class (method-entry-slot-name entry)))
 298
 299 ;;;----- That's all, folks --------------------------------------------------