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 ;;; Miscellaneous useful functions.
  70
  71 (export 'sod-subclass-p)
  72 (defun sod-subclass-p (class-a class-b)
  73   "Return whether CLASS-A is a descendent of CLASS-B.
  74
  75    Careful!  Assumes that the class precedence list of CLASS-A has been
  76    computed!"
  77   (member class-b (sod-class-precedence-list class-a)))
  78
  79 (export 'valid-name-p)
  80 (defun valid-name-p (name)
  81   "Checks whether NAME is a valid name.
  82
  83    The rules are:
  84
  85      * the name must be a string
  86      * which is nonempty
  87      * whose first character is alphabetic
  88      * all of whose characters are alphanumeric or underscores
  89      * and which doesn't contain two consecutive underscores."
  90
  91   (and (stringp name)
  92        (plusp (length name))
  93        (alpha-char-p (char name 0))
  94        (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
  95        (not (search "__" name))))
  96
  97 (export 'find-root-superclass)
  98 (defun find-root-superclass (class)
  99   "Returns the `root' superclass of CLASS.
 100
 101    The root superclass is the superclass which itself has no direct
 102    superclasses.  In universes not based on the provided builtin module, the
 103    root class may not be our beloved `SodObject'; however, there must be one
 104    (otherwise the class graph is cyclic, which should be forbidden), and we
 105    insist that it be unique."
 106
 107   ;; The root superclass must be a chain head since the chains partition the
 108   ;; superclasses; the root has no superclasses so it can't have a link and
 109   ;; must therefore be a head.  This narrows the field down quite a lot.
 110   ;;
 111   ;; Note!  This function gets called from `check-sod-class' before the
 112   ;; class's chains have been computed.  Therefore we iterate over the direct
 113   ;; superclasses' chains rather than the class's own.  This misses a chain
 114   ;; only in the case where the class is its own chain head.  There are two
 115   ;; subcases: if there are no direct superclasses at all, then the class is
 116   ;; its own root; otherwise, it clearly can't be the root and the omission
 117   ;; is harmless.
 118
 119   (let* ((supers (sod-class-direct-superclasses class))
 120          (roots (if supers
 121                     (remove-duplicates
 122                      (remove-if #'sod-class-direct-superclasses
 123                                 (mappend (lambda (super)
 124                                            (mapcar (lambda (chain)
 125                                                      (sod-class-chain-head
 126                                                       (car chain)))
 127                                                    (sod-class-chains super)))
 128                                          supers)))
 129                     (list class))))
 130     (cond ((null roots) (error "Class ~A has no root class!" class))
 131           ((cdr roots) (error "Class ~A has multiple root classes ~
 132                                ~{~A~#[~; and ~;, ~]~}"
 133                               class roots))
 134           (t (car roots)))))
 135
 136 (export 'find-root-metaclass)
 137 (defun find-root-metaclass (class)
 138   "Returns the `root' metaclass of CLASS.
 139
 140    The root metaclass is the metaclass of the root superclass -- see
 141    `find-root-superclass'."
 142   (sod-class-metaclass (find-root-superclass class)))
 143
 144 ;;;--------------------------------------------------------------------------
 145 ;;; Type hacking.
 146
 147 (export 'argument-lists-compatible-p)
 148 (defun argument-lists-compatible-p (message-args method-args)
 149   "Compare argument lists for compatibility.
 150
 151    Return true if METHOD-ARGS is a suitable method argument list
 152    corresponding to the message argument list MESSAGE-ARGS.  This is the case
 153    if the lists are the same length, each message argument has a
 154    corresponding method argument with the same type, and if the message
 155    arguments end in an ellpisis, the method arguments must end with a
 156    `va_list' argument.  (We can't pass actual variable argument lists around,
 157    except as `va_list' objects, which are devilish inconvenient things and
 158    require much hacking.  See the method combination machinery for details.)"
 159
 160   (and (= (length message-args) (length method-args))
 161        (every (lambda (message-arg method-arg)
 162                 (if (eq message-arg :ellipsis)
 163                     (c-type-equal-p (argument-type method-arg)
 164                                     c-type-va-list)
 165                     (c-type-equal-p (argument-type message-arg)
 166                                     (argument-type method-arg))))
 167               message-args method-args)))
 168
 169 ;;;--------------------------------------------------------------------------
 170 ;;; Names of things.
 171
 172 (export 'islots-struct-tag)
 173 (defun islots-struct-tag (class)
 174   (format nil "~A__islots" class))
 175
 176 (export 'ichain-struct-tag)
 177 (defun ichain-struct-tag (class chain-head)
 178   (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
 179
 180 (export 'ichain-union-tag)
 181 (defun ichain-union-tag (class chain-head)
 182   (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
 183
 184 (export 'ilayout-struct-tag)
 185 (defun ilayout-struct-tag (class)
 186   (format nil "~A__ilayout" class))
 187
 188 (export 'vtmsgs-struct-tag)
 189 (defun vtmsgs-struct-tag (class super)
 190   (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
 191
 192 (export 'vtable-union-tag)
 193 (defun vtable-union-tag (class chain-head)
 194   (format nil "~A__vtu_~A" class (sod-class-nickname chain-head)))
 195
 196 (export 'vtable-struct-tag)
 197 (defun vtable-struct-tag (class chain-head)
 198   (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
 199
 200 (export 'vtable-name)
 201 (defun vtable-name (class chain-head)
 202   (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
 203
 204 (export 'message-macro-name)
 205 (defun message-macro-name (class entry)
 206   (format nil "~A_~A" class (method-entry-slot-name entry)))
 207
 208 ;;;----- That's all, folks --------------------------------------------------