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