chiark - git - mdw - sod/blob - src/c-types-proto.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Protocol for C type representation
   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 ;;; Root classes and common access protocol.
  30
  31 ;; It seems more useful to put the root class here, so that we can provide
  32 ;; methods specialized on it, e.g., PRINT-OBJECT.
  33
  34 (export 'c-type)
  35 (defclass c-type ()
  36   ()
  37   (:documentation
  38    "Base class for C type objects."))
  39
  40 (export '(qualifiable-c-type c-type-qualifiers))
  41 (defclass qualifiable-c-type (c-type)
  42   ((qualifiers :initarg :qualifiers :initform nil
  43                :type list :reader c-type-qualifiers))
  44   (:documentation
  45    "Base class for C types which can be qualified."))
  46
  47 (export 'canonify-qualifiers)
  48 (defun canonify-qualifiers (qualifiers)
  49   "Return a canonical list of qualifiers."
  50   (delete-duplicates (sort (copy-list qualifiers) #'string<)))
  51
  52 (export 'qualify-c-type)
  53 (defgeneric qualify-c-type (type qualifiers)
  54   (:documentation
  55    "Return a type like TYPE but with the specified QUALIFIERS.
  56
  57    The qualifiers of the returned type are the union of the requested
  58    QUALIFIERS and the qualifiers already applied to TYPE."))
  59
  60 (export 'c-qualifier-keyword)
  61 (defgeneric c-qualifier-keyword (qualifier)
  62   (:documentation "Return the C keyword for the QUALIFIER (a Lisp keyword).")
  63   (:method ((qualifier symbol)) (string-downcase qualifier)))
  64
  65 (export 'c-type-qualifier-keywords)
  66 (defun c-type-qualifier-keywords (c-type)
  67   "Return the type's qualifiers, as a list of C keyword names."
  68   (mapcar #'c-qualifier-keyword (c-type-qualifiers c-type)))
  69
  70 (export 'c-type-subtype)
  71 (defgeneric c-type-subtype (type)
  72   (:documentation
  73    "For compound types, return the base type."))
  74
  75 ;;;--------------------------------------------------------------------------
  76 ;;; Comparison protocol.
  77
  78 (export 'c-type-equal-p)
  79 (defgeneric c-type-equal-p (type-a type-b)
  80   (:method-combination and)
  81   (:documentation
  82    "Answers whether two types TYPE-A and TYPE-B are structurally equal.
  83
  84    Here, `structurally equal' means that they have the same qualifiers,
  85    similarly spelt names, and structurally equal components.")
  86   (:method and (type-a type-b)
  87     (eql (class-of type-a) (class-of type-b))))
  88
  89 (defmethod c-type-equal-p and ((type-a qualifiable-c-type)
  90                                (type-b qualifiable-c-type))
  91   (equal (canonify-qualifiers (c-type-qualifiers type-a))
  92          (canonify-qualifiers (c-type-qualifiers type-b))))
  93
  94 ;;;--------------------------------------------------------------------------
  95 ;;; C syntax output protocol.
  96
  97 (export 'pprint-c-type)
  98 (defgeneric pprint-c-type (type stream kernel)
  99   (:documentation
 100    "Pretty-printer for C types.
 101
 102    Print TYPE to STREAM.  In the middle of the declarator, call the function
 103    KERNEL with one argument: whether it needs a leading space.")
 104   (:method :around (type stream kernel)
 105     (typecase kernel
 106       (null (pprint-c-type type stream
 107                            (lambda (stream prio spacep)
 108                              (declare (ignore stream prio spacep))
 109                              nil)))
 110       ((or function symbol) (call-next-method))
 111       (t (pprint-c-type type stream
 112                         (lambda (stream prio spacep)
 113                           (declare (ignore prio))
 114                           (when spacep
 115                             (c-type-space stream))
 116                           (princ kernel stream)))))))
 117
 118 (export 'c-type-space)
 119 (defun c-type-space (stream)
 120   "Print a space and a miser-mode newline to STREAM.
 121
 122    This is the right function to call in a `pprint-c-type' kernel function
 123    when the SPACEP argument is true."
 124   (pprint-indent :block 2 stream)
 125   (write-char #\space stream)
 126   (pprint-newline :miser stream))
 127
 128 (defun maybe-in-parens* (stream condition thunk)
 129   "Helper function for the `maybe-in-parens' macro."
 130   (multiple-value-bind (prefix suffix)
 131       (if condition (values "(" ")") (values "" ""))
 132     (pprint-logical-block (stream nil :prefix prefix :suffix suffix)
 133       (funcall thunk stream))))
 134
 135 (export 'maybe-in-parens)
 136 (defmacro maybe-in-parens ((stream condition) &body body)
 137   "Evaluate BODY; if CONDITION, write parens to STREAM around it.
 138
 139    This macro is useful for implementing the `pprint-c-type' method on
 140    compound types.  The BODY is evaluated in the context of a logical block
 141    printing to STREAM.  If CONDITION is non-nil, then the block will have
 142    open/close parens as its prefix and suffix; otherwise they will be empty.
 143
 144    The STREAM is passed to `pprint-logical-block', so it must be a symbol."
 145   `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
 146
 147 (export 'format-qualifiers)
 148 (defun format-qualifiers (quals)
 149   "Return a string listing QUALS, with a space after each."
 150   (format nil "~{~(~A~) ~}" quals))
 151
 152 ;;;--------------------------------------------------------------------------
 153 ;;; S-expression notation protocol.
 154
 155 (export 'print-c-type)
 156 (defgeneric print-c-type (stream type &optional colon atsign)
 157   (:documentation
 158    "Print an abbreviated syntax for TYPE to the STREAM.
 159
 160    This function is suitable for use in `format's ~/.../ command."))
 161
 162 (export '(expand-c-type-spec expand-c-type-form))
 163 (eval-when (:compile-toplevel :load-toplevel :execute)
 164   (defgeneric expand-c-type-spec (spec)
 165     (:documentation "Expand SPEC into Lisp code to construct a C type.")
 166     (:method ((spec list))
 167       (expand-c-type-form (car spec) (cdr spec))))
 168   (defgeneric expand-c-type-form (head tail)
 169     (:documentation "Expand a C type list beginning with HEAD.")
 170     (:method ((name (eql 'lisp)) tail)
 171       `(progn ,@tail))))
 172
 173 (export 'c-type)
 174 (defmacro c-type (spec)
 175   "Expands to code to construct a C type, using `expand-c-type-spec'."
 176   (expand-c-type-spec spec))
 177
 178 (export 'define-c-type-syntax)
 179 (defmacro define-c-type-syntax (name bvl &body body)
 180   "Define a C-type syntax function.
 181
 182    A function defined by BODY and with lambda-list BVL is associated with the
 183    NAME.  When `expand-c-type-spec' sees a list (NAME . STUFF), it will call
 184    this function with the argument list STUFF."
 185   (with-gensyms (head tail)
 186     (multiple-value-bind (doc decls body) (parse-body body)
 187       `(eval-when (:compile-toplevel :load-toplevel :execute)
 188          (defmethod expand-c-type-form ((,head (eql ',name)) ,tail)
 189            ,@doc
 190            (destructuring-bind ,bvl ,tail
 191              ,@decls
 192              (block ,name ,@body)))
 193          ',name))))
 194
 195 (export 'c-type-alias)
 196 (defmacro c-type-alias (original &rest aliases)
 197   "Make ALIASES behave the same way as the ORIGINAL type."
 198   (with-gensyms (head tail)
 199     `(eval-when (:compile-toplevel :load-toplevel :execute)
 200        ,@(mapcar (lambda (alias)
 201                    `(defmethod expand-c-type-form
 202                         ((,head (eql ',alias)) ,tail)
 203                       (expand-c-type-form ',original ,tail)))
 204                  aliases)
 205        ',aliases)))
 206
 207 (export 'defctype)
 208 (defmacro defctype (names value &key export)
 209   "Define NAMES all to describe the C-type VALUE.
 210
 211    NAMES can be a symbol (treated as a singleton list), or a list of symbols.
 212    The VALUE is a C type S-expression, acceptable to `expand-c-type-spec'.
 213    It will be expanded once at run-time."
 214   (let* ((names (if (listp names) names (list names)))
 215          (namevar (gensym "NAME"))
 216          (typevar (symbolicate 'c-type- (car names))))
 217     `(progn
 218        ,@(and export
 219               `((export '(,typevar ,@names))))
 220        (defparameter ,typevar ,(expand-c-type-spec value))
 221        (eval-when (:compile-toplevel :load-toplevel :execute)
 222          ,@(mapcar (lambda (name)
 223                      `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
 224                         ',typevar))
 225                    names))
 226        'names)))
 227
 228 (export 'c-name-case)
 229 (defun c-name-case (name)
 230   "Convert NAME to suitable case.
 231
 232    Strings are returned as-is; symbols are squashed to lower-case and hyphens
 233    are replaced by underscores."
 234   (typecase name
 235     (symbol (with-output-to-string (out)
 236               (loop for ch across (symbol-name name)
 237                     do (cond ((alpha-char-p ch)
 238                               (write-char (char-downcase ch) out))
 239                              ((or (digit-char-p ch)
 240                                   (char= ch #\_))
 241                               (write-char ch out))
 242                              ((char= ch #\-)
 243                               (write-char #\_ out))
 244                              (t
 245                               (error "Bad character in C name ~S." name))))))
 246     (t name)))
 247
 248 ;;;--------------------------------------------------------------------------
 249 ;;; Storage specifier protocol.
 250
 251 (export 'pprint-c-storage-specifier)
 252 (defgeneric pprint-c-storage-specifier (spec stream)
 253   (:documentation "Print the storage specifier SPEC to STREAM, as C syntax.")
 254   (:method ((spec symbol) stream) (princ (string-downcase spec) stream)))
 255
 256 (export 'print-c-storage-specifier)
 257 (defgeneric print-c-storage-specifier (stream spec &optional colon atsign)
 258   (:documentation
 259    "Print the storage specifier SPEC to STREAM, as an S-expression.
 260
 261    This function is suitable for use in `format's ~/.../ command.")
 262   (:method (stream (spec t) &optional colon atsign)
 263     (declare (ignore colon atsign))
 264     (prin1 spec stream))
 265   (:method (stream (spec symbol) &optional colon atsign)
 266     (declare (ignore colon atsign))
 267     (princ (string-downcase spec) stream)))
 268
 269 (export '(expand-c-storage-specifier expand-c-storage-specifier-form))
 270 (eval-when (:compile-toplevel :load-toplevel :execute)
 271   (defgeneric expand-c-storage-specifier (spec)
 272     (:documentation
 273      "Expand SPEC into Lisp code to construct a storage specifier.")
 274     (:method ((spec list))
 275       (expand-c-storage-specifier-form (car spec) (cdr spec)))
 276     (:method ((spec symbol))
 277       (if (keywordp spec) spec
 278           (expand-c-storage-specifier-form spec nil))))
 279   (defgeneric expand-c-storage-specifier-form (head tail)
 280     (:documentation
 281      "Expand a C storage-specifier form beginning with HEAD.")
 282     (:method ((name (eql 'lisp)) tail)
 283       `(progn ,@tail))))
 284
 285 (export 'define-c-storage-specifier-syntax)
 286 (defmacro define-c-storage-specifier-syntax (name bvl &body body)
 287   "Define a C storage-specifier syntax function.
 288
 289    A function defined by BODY and with lambda-list BVL is associated wth the
 290    NAME.  When `expand-c-storage-specifier' sees a list (NAME . STUFF), it
 291    will call this function with the argument list STUFF."
 292   (with-gensyms (head tail)
 293     (multiple-value-bind (doc decls body) (parse-body body)
 294       `(eval-when (:compile-toplevel :load-toplevel :execute)
 295          (defmethod expand-c-storage-specifier-form
 296              ((,head (eql ',name)) ,tail)
 297            ,@doc
 298            (destructuring-bind ,bvl ,tail
 299              ,@decls
 300              (block ,name ,@body)))
 301          ',name))))
 302
 303 ;;;--------------------------------------------------------------------------
 304 ;;; A type for carrying storage specifiers.
 305
 306 (export '(c-storage-specifiers-type c-type-specifiers))
 307 (defclass c-storage-specifiers-type (c-type)
 308   ((specifiers :initarg :specifiers :type list :reader c-type-specifiers)
 309    (subtype :initarg :subtype :type c-type :reader c-type-subtype))
 310   (:documentation
 311    "A type for carrying storage specifiers.
 312
 313    Properly, storage specifiers should only appear on an outermost type.
 314    This fake C type is a handy marker for the presence of storage specifiers,
 315    so that they can be hoisted properly when constructing derived types."))
 316
 317 (export 'wrap-c-type)
 318 (defun wrap-c-type (wrapper-func base-type)
 319   "Handle storage specifiers correctly when making a derived type.
 320
 321    WRAPPER-FUNC should be a function which will return some derived type of
 322    BASE-TYPE.  This function differs from `funcall' only when BASE-TYPE is
 323    actually a `c-storage-specifiers-type', in which case it invokes
 324    WRAPPER-FUNC on the underlying type, and re-attaches the storage
 325    specifiers to the derived type."
 326   (if (typep base-type 'c-storage-specifiers-type)
 327       (let* ((unwrapped-type (c-type-subtype base-type))
 328              (wrapped-type (funcall wrapper-func unwrapped-type))
 329              (specifiers (c-type-specifiers base-type)))
 330         (make-or-intern-c-type 'c-storage-specifiers-type unwrapped-type
 331                                :specifiers specifiers
 332                                :subtype wrapped-type))
 333       (funcall wrapper-func base-type)))
 334
 335 ;;;--------------------------------------------------------------------------
 336 ;;; Function arguments.
 337
 338 (export '(argument argumentp make-argument argument-name argument-type))
 339 (defstruct (argument (:constructor make-argument (name type
 340                                                   &aux (%type type)))
 341                      (:predicate argumentp))
 342   "Simple structure representing a function argument."
 343   (name nil :type t :read-only t)
 344   (%type nil :type c-type :read-only t))
 345 (define-access-wrapper argument-type argument-%type :read-only t)
 346
 347 (export 'commentify-argument-name)
 348 (defgeneric commentify-argument-name (name)
 349   (:documentation
 350    "Produce a `commentified' version of the argument.
 351
 352    The default behaviour is that temporary argument names are simply omitted
 353    (nil is returned); otherwise, `/*...*/' markers are wrapped around the
 354    printable representation of the argument.")
 355   (:method ((name null)) nil)
 356   (:method ((name t)) (format nil "/*~A*/" name)))
 357
 358 ;;;--------------------------------------------------------------------------
 359 ;;; Printing objects.
 360
 361 (defmethod print-object ((object c-type) stream)
 362   (if *print-escape*
 363       (format stream "~:@<C-TYPE ~/sod:print-c-type/~:>" object)
 364       (pprint-c-type object stream nil)))
 365
 366 ;;;----- That's all, folks --------------------------------------------------