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 Sensble 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-type-subtype)
  61 (defgeneric c-type-subtype (type)
  62   (:documentation
  63    "For compound types, return the base type."))
  64
  65 ;;;--------------------------------------------------------------------------
  66 ;;; Comparison protocol.
  67
  68 (export 'c-type-equal-p)
  69 (defgeneric c-type-equal-p (type-a type-b)
  70   (:method-combination and)
  71   (:documentation
  72    "Answers whether two types TYPE-A and TYPE-B are structurally equal.
  73
  74    Here, `structurally equal' means that they have the same qualifiers,
  75    similarly spelt names, and structurally equal components.")
  76   (:method and (type-a type-b)
  77     (eql (class-of type-a) (class-of type-b))))
  78
  79 (defmethod c-type-equal-p and ((type-a qualifiable-c-type)
  80                                (type-b qualifiable-c-type))
  81   (equal (canonify-qualifiers (c-type-qualifiers type-a))
  82          (canonify-qualifiers (c-type-qualifiers type-b))))
  83
  84 ;;;--------------------------------------------------------------------------
  85 ;;; C syntax output protocol.
  86
  87 (export 'pprint-c-type)
  88 (defgeneric pprint-c-type (type stream kernel)
  89   (:documentation
  90    "Pretty-printer for C types.
  91
  92    Print TYPE to STREAM.  In the middle of the declarator, call the function
  93    KERNEL with one argument: whether it needs a leading space.")
  94   (:method :around (type stream kernel)
  95     (typecase kernel
  96       (null (pprint-c-type type stream
  97                            (lambda (stream prio spacep)
  98                              (declare (ignore stream prio spacep))
  99                              nil)))
 100       ((or function symbol) (call-next-method))
 101       (t (pprint-c-type type stream
 102                         (lambda (stream prio spacep)
 103                           (declare (ignore prio))
 104                           (when spacep
 105                             (c-type-space stream))
 106                           (princ kernel stream)))))))
 107
 108 (export 'c-type-space)
 109 (defun c-type-space (stream)
 110   "Print a space and a miser-mode newline to STREAM.
 111
 112    This is the right function to call in a `pprint-c-type' kernel function
 113    when the SPACEP argument is true."
 114   (pprint-indent :block 2 stream)
 115   (write-char #\space stream)
 116   (pprint-newline :miser stream))
 117
 118 (defun maybe-in-parens* (stream condition thunk)
 119   "Helper function for the `maybe-in-parens' macro."
 120   (multiple-value-bind (prefix suffix)
 121       (if condition (values "(" ")") (values "" ""))
 122     (pprint-logical-block (stream nil :prefix prefix :suffix suffix)
 123       (funcall thunk stream))))
 124
 125 (export 'maybe-in-parens)
 126 (defmacro maybe-in-parens ((stream condition) &body body)
 127   "Evaluate BODY; if CONDITION, write parens to STREAM around it.
 128
 129    This macro is useful for implementing the `pprint-c-type' method on
 130    compound types.  The BODY is evaluated in the context of a logical block
 131    printing to STREAM.  If CONDITION is non-nil, then the block will have
 132    open/close parens as its prefix and suffix; otherwise they will be empty.
 133
 134    The STREAM is passed to `pprint-logical-block', so it must be a symbol."
 135   `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
 136
 137 (export 'format-qualifiers)
 138 (defun format-qualifiers (quals)
 139   "Return a string listing QUALS, with a space after each."
 140   (format nil "~{~(~A~) ~}" quals))
 141
 142 ;;;--------------------------------------------------------------------------
 143 ;;; S-expression notation protocol.
 144
 145 (export 'print-c-type)
 146 (defgeneric print-c-type (stream type &optional colon atsign)
 147   (:documentation
 148    "Print an abbreviated syntax for TYPE to the STREAM.
 149
 150    This function is suitable for use in `format's ~/.../ command."))
 151
 152 (export '(expand-c-type-spec expand-c-type-form))
 153 (eval-when (:compile-toplevel :load-toplevel :execute)
 154   (defgeneric expand-c-type-spec (spec)
 155     (:documentation
 156      "Expand SPEC into Lisp code to construct a C type.")
 157     (:method ((spec list))
 158       (expand-c-type-form (car spec) (cdr spec))))
 159   (defgeneric expand-c-type-form (head tail)
 160     (:documentation
 161      "Expand a C type list beginning with HEAD.")
 162     (:method ((name (eql 'lisp)) tail)
 163       `(progn ,@tail))))
 164
 165 (export 'c-type)
 166 (defmacro c-type (spec)
 167   "Expands to code to construct a C type, using `expand-c-type-spec'."
 168   (expand-c-type-spec spec))
 169
 170 (export 'define-c-type-syntax)
 171 (defmacro define-c-type-syntax (name bvl &rest body)
 172   "Define a C-type syntax function.
 173
 174    A function defined by BODY and with lambda-list BVL is associated with the
 175    NAME.  When `expand-c-type' sees a list (NAME . STUFF), it will call this
 176    function with the argument list STUFF."
 177   (with-gensyms (head tail)
 178     (multiple-value-bind (doc decls body) (parse-body body)
 179       `(eval-when (:compile-toplevel :load-toplevel :execute)
 180          (defmethod expand-c-type-form ((,head (eql ',name)) ,tail)
 181            ,@doc
 182            (destructuring-bind ,bvl ,tail
 183              ,@decls
 184              (block ,name ,@body)))
 185          ',name))))
 186
 187 (export 'c-type-alias)
 188 (defmacro c-type-alias (original &rest aliases)
 189   "Make ALIASES behave the same way as the ORIGINAL type."
 190   (with-gensyms (head tail)
 191     `(eval-when (:compile-toplevel :load-toplevel :execute)
 192        ,@(mapcar (lambda (alias)
 193                    `(defmethod expand-c-type-form
 194                         ((,head (eql ',alias)) ,tail)
 195                       (expand-c-type-form ',original ,tail)))
 196                  aliases)
 197        ',aliases)))
 198
 199 (export 'defctype)
 200 (defmacro defctype (names value)
 201   "Define NAMES all to describe the C-type VALUE.
 202
 203    NAMES can be a symbol (treated as a singleton list), or a list of symbols.
 204    The VALUE is a C type S-expression, acceptable to `expand-c-type'.  It
 205    will be expanded once at run-time."
 206   (let* ((names (if (listp names) names (list names)))
 207          (namevar (gensym "NAME"))
 208          (typevar (symbolicate 'c-type- (car names))))
 209     `(progn
 210        (defparameter ,typevar ,(expand-c-type-spec value))
 211        (eval-when (:compile-toplevel :load-toplevel :execute)
 212          ,@(mapcar (lambda (name)
 213                      `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
 214                         ',typevar))
 215                    names))
 216        'names)))
 217
 218 (export 'c-name-case)
 219 (defun c-name-case (name)
 220   "Convert NAME to suitable case.
 221
 222    Strings are returned as-is; symbols are squashed to lower-case and hyphens
 223    are replaced by underscores."
 224   (typecase name
 225     (symbol (with-output-to-string (out)
 226               (loop for ch across (symbol-name name)
 227                     do (cond ((alpha-char-p ch)
 228                               (write-char (char-downcase ch) out))
 229                              ((or (digit-char-p ch)
 230                                   (char= ch #\_))
 231                               (write-char ch out))
 232                              ((char= ch #\-)
 233                               (write-char #\_ out))
 234                              (t
 235                               (error "Bad character in C name ~S." name))))))
 236     (t name)))
 237
 238 ;;;--------------------------------------------------------------------------
 239 ;;; Function arguments.
 240
 241 (export '(argument argumentp make-argument argument-name argument-type))
 242 (defstruct (argument (:constructor make-argument (name type
 243                                                   &aux (%type type)))
 244                      (:predicate argumentp))
 245   "Simple structure representing a function argument."
 246   name
 247   %type)
 248 (define-access-wrapper argument-type argument-%type)
 249
 250 (export 'commentify-argument-name)
 251 (defgeneric commentify-argument-name (name)
 252   (:documentation
 253    "Produce a `commentified' version of the argument.
 254
 255    The default behaviour is that temporary argument names are simply omitted
 256    (nil is returned); otherwise, `/*...*/' markers are wrapped around the
 257    printable representation of the argument.")
 258   (:method ((name null)) nil)
 259   (:method ((name t)) (format nil "/*~A*/" name)))
 260
 261 ;;;--------------------------------------------------------------------------
 262 ;;; Printing objects.
 263
 264 (defmethod print-object ((object c-type) stream)
 265   (if *print-escape*
 266       (format stream "~:@<C-TYPE ~/sod:print-c-type/~:>" object)
 267       (pprint-c-type object stream nil)))
 268
 269 ;;;----- That's all, folks --------------------------------------------------