| 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 | (and (stringp name) |
| 177 | (plusp (length name)) |
| 178 | (alpha-char-p (char name 0)) |
| 179 | (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name) |
| 180 | (not (search "__" name)))) |
| 181 | |
| 182 | (export 'find-root-superclass) |
| 183 | (defun find-root-superclass (class) |
| 184 | "Returns the `root' superclass of CLASS. |
| 185 | |
| 186 | The root superclass is the superclass which itself has no direct |
| 187 | superclasses. In universes not based on the provided builtin module, the |
| 188 | root class may not be our beloved `SodObject'; however, there must be one |
| 189 | (otherwise the class graph is cyclic, which should be forbidden), and we |
| 190 | insist that it be unique." |
| 191 | |
| 192 | ;; The root superclass must be a chain head since the chains partition the |
| 193 | ;; superclasses; the root has no superclasses so it can't have a link and |
| 194 | ;; must therefore be a head. This narrows the field down quite a lot. |
| 195 | ;; |
| 196 | ;; Note! This function gets called from `check-sod-class' before the |
| 197 | ;; class's chains have been computed. Therefore we iterate over the direct |
| 198 | ;; superclasses' chains rather than the class's own. This misses a chain |
| 199 | ;; only in the case where the class is its own chain head. There are two |
| 200 | ;; subcases: if there are no direct superclasses at all, then the class is |
| 201 | ;; its own root; otherwise, it clearly can't be the root and the omission |
| 202 | ;; is harmless. |
| 203 | |
| 204 | (let* ((supers (sod-class-direct-superclasses class)) |
| 205 | (roots (if supers |
| 206 | (remove-duplicates |
| 207 | (remove-if #'sod-class-direct-superclasses |
| 208 | (mappend (lambda (super) |
| 209 | (mapcar (lambda (chain) |
| 210 | (sod-class-chain-head |
| 211 | (car chain))) |
| 212 | (sod-class-chains super))) |
| 213 | supers))) |
| 214 | (list class)))) |
| 215 | (cond ((null roots) (error "Class ~A has no root class!" class)) |
| 216 | ((cdr roots) (error "Class ~A has multiple root classes ~ |
| 217 | ~{~A~#[~; and ~;, ~]~}" |
| 218 | class roots)) |
| 219 | (t (car roots))))) |
| 220 | |
| 221 | (export 'find-root-metaclass) |
| 222 | (defun find-root-metaclass (class) |
| 223 | "Returns the `root' metaclass of CLASS. |
| 224 | |
| 225 | The root metaclass is the metaclass of the root superclass -- see |
| 226 | `find-root-superclass'." |
| 227 | (sod-class-metaclass (find-root-superclass class))) |
| 228 | |
| 229 | ;;;-------------------------------------------------------------------------- |
| 230 | ;;; Type hacking. |
| 231 | |
| 232 | (export 'argument-lists-compatible-p) |
| 233 | (defun argument-lists-compatible-p (message-args method-args) |
| 234 | "Compare argument lists for compatibility. |
| 235 | |
| 236 | Return true if METHOD-ARGS is a suitable method argument list |
| 237 | corresponding to the message argument list MESSAGE-ARGS. This is the case |
| 238 | if the lists are the same length, each message argument has a |
| 239 | corresponding method argument with the same type, and if the message |
| 240 | arguments end in an ellpisis, the method arguments must end with a |
| 241 | `va_list' argument. (We can't pass actual variable argument lists around, |
| 242 | except as `va_list' objects, which are devilish inconvenient things and |
| 243 | require much hacking. See the method combination machinery for details.)" |
| 244 | |
| 245 | (and (= (length message-args) (length method-args)) |
| 246 | (every (lambda (message-arg method-arg) |
| 247 | (if (eq message-arg :ellipsis) |
| 248 | (c-type-equal-p (argument-type method-arg) |
| 249 | c-type-va-list) |
| 250 | (c-type-equal-p (argument-type message-arg) |
| 251 | (argument-type method-arg)))) |
| 252 | message-args method-args))) |
| 253 | |
| 254 | ;;;-------------------------------------------------------------------------- |
| 255 | ;;; Names of things. |
| 256 | |
| 257 | (export 'islots-struct-tag) |
| 258 | (defun islots-struct-tag (class) |
| 259 | (format nil "~A__islots" class)) |
| 260 | |
| 261 | (export 'ichain-struct-tag) |
| 262 | (defun ichain-struct-tag (class chain-head) |
| 263 | (format nil "~A__ichain_~A" class (sod-class-nickname chain-head))) |
| 264 | |
| 265 | (export 'ichain-union-tag) |
| 266 | (defun ichain-union-tag (class chain-head) |
| 267 | (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head))) |
| 268 | |
| 269 | (export 'ilayout-struct-tag) |
| 270 | (defun ilayout-struct-tag (class) |
| 271 | (format nil "~A__ilayout" class)) |
| 272 | |
| 273 | (export 'vtmsgs-struct-tag) |
| 274 | (defun vtmsgs-struct-tag (class super) |
| 275 | (format nil "~A__vtmsgs_~A" class (sod-class-nickname super))) |
| 276 | |
| 277 | (export 'vtable-union-tag) |
| 278 | (defun vtable-union-tag (class chain-head) |
| 279 | (format nil "~A__vtu_~A" class (sod-class-nickname chain-head))) |
| 280 | |
| 281 | (export 'vtable-struct-tag) |
| 282 | (defun vtable-struct-tag (class chain-head) |
| 283 | (format nil "~A__vt_~A" class (sod-class-nickname chain-head))) |
| 284 | |
| 285 | (export 'vtable-name) |
| 286 | (defun vtable-name (class chain-head) |
| 287 | (format nil "~A__vtable_~A" class (sod-class-nickname chain-head))) |
| 288 | |
| 289 | (export 'message-macro-name) |
| 290 | (defun message-macro-name (class entry) |
| 291 | (format nil "~A_~A" class (method-entry-slot-name entry))) |
| 292 | |
| 293 | ;;;----- That's all, folks -------------------------------------------------- |