mdw@git.distorted.org.uk Git - sod/blob - src/impl-c-types.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; C type representation implementation
   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 ;;; Interning types.
  30
  31 (defparameter *c-type-intern-map* (make-hash-table :test #'equal)
  32   "Hash table mapping lists describing types to their distinguished
  33    representations.")
  34
  35 (defun intern-c-type (class &rest initargs)
  36   "If the CLASS and INITARGS have already been interned, then return the
  37    existing object; otherwise make a new one."
  38   (let ((list (cons class initargs)))
  39     (or (gethash list *c-type-intern-map*)
  40         (let ((new (apply #'make-instance class initargs)))
  41           (setf (gethash new *c-type-intern-map*) t
  42                 (gethash list *c-type-intern-map*) new)))))
  43
  44 #+test
  45 (defun check-type-intern-map ()
  46   "Sanity check for the type-intern map."
  47   (let ((map (make-hash-table)))
  48
  49     ;; Pass 1: check that interned types are consistent with their keys.
  50     ;; Remember interned types.
  51     (maphash (lambda (k v)
  52                (when (listp k)
  53                  (let ((ty (apply #'make-instance k)))
  54                    (assert (c-type-equal-p ty v)))
  55                  (setf (gethash v map) t)))
  56              *c-type-intern-map*)
  57
  58     ;; Pass 2: check that the interned type indicators are correct.
  59     (maphash (lambda (k v)
  60                (declare (ignore v))
  61                (assert (gethash k *c-type-intern-map*)))
  62              map)
  63     (maphash (lambda (k v)
  64                (declare (ignore v))
  65                (when (typep k 'c-type)
  66                  (assert (gethash k map))))
  67              *c-type-intern-map*)))
  68
  69 ;;;--------------------------------------------------------------------------
  70 ;;; Simple C types.
  71
  72 ;; Class definition.
  73
  74 (export '(simple-c-type c-type-name))
  75 (defclass simple-c-type (qualifiable-c-type)
  76   ((name :initarg :name :type string :reader c-type-name))
  77   (:documentation
  78    "C types with simple forms."))
  79
  80 ;; Constructor function and interning.
  81
  82 (export 'make-simple-type)
  83 (defun make-simple-type (name &optional qualifiers)
  84   "Make a distinguished object for the simple type called NAME."
  85   (intern-c-type 'simple-c-type
  86                  :name name
  87                  :qualifiers (canonify-qualifiers qualifiers)))
  88
  89 ;; Comparison protocol.
  90
  91 (defmethod c-type-equal-p and
  92     ((type-a simple-c-type) (type-b simple-c-type))
  93   (string= (c-type-name type-a) (c-type-name type-b)))
  94
  95 ;; C syntax output protocol.
  96
  97 (defmethod pprint-c-type ((type simple-c-type) stream kernel)
  98   (pprint-logical-block (stream nil)
  99     (format stream "~{~(~A~) ~@_~}~A"
 100             (c-type-qualifiers type)
 101             (c-type-name type))
 102     (funcall kernel stream 0 t)))
 103
 104 ;; S-expression notation protocol.
 105
 106 (defparameter *simple-type-map* (make-hash-table)
 107   "Hash table mapping strings of C syntax to symbolic names.")
 108
 109 (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
 110   (declare (ignore colon atsign))
 111   (let* ((name (c-type-name type))
 112          (symbol (gethash name *simple-type-map*)))
 113     (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]"
 114             (c-type-qualifiers type) (or symbol name))))
 115
 116 (eval-when (:compile-toplevel :load-toplevel :execute)
 117   (defmethod expand-c-type-spec ((spec string))
 118     `(make-simple-type ,spec))
 119   (defmethod expand-c-type-form ((head string) tail)
 120     `(make-simple-type ,head (list ,@tail))))
 121
 122 (export 'define-simple-c-type)
 123 (defmacro define-simple-c-type (names type)
 124   "Define each of NAMES to be a simple type called TYPE."
 125   (let ((names (if (listp names) names (list names))))
 126     `(progn
 127        (setf (gethash ,type *simple-type-map*) ',(car names))
 128        (defctype ,names ,type)
 129        (define-c-type-syntax ,(car names) (&rest quals)
 130          `(make-simple-type ,',type (list ,@quals))))))
 131
 132 ;; Built-in C types.
 133
 134 (export '(void float double long-double va-list size-t ptrdiff-t
 135           char unsigned-char uchar signed-char schar
 136           int signed signed-int sint unsigned unsigned-int uint
 137           short signed-short short-int signed-short-int sshort
 138           unsigned-short unsigned-short-int ushort
 139           long signed-long long-int signed-long-int slong
 140           unsigned-long unsigned-long-int ulong
 141           long-long signed-long-long long-long-int signed-long-long-int
 142           unsigned-long-long unsigned-long-long-int llong sllong ullong))
 143
 144 (define-simple-c-type void "void")
 145
 146 (define-simple-c-type char "char")
 147 (define-simple-c-type (unsigned-char uchar) "unsigned char")
 148 (define-simple-c-type (signed-char schar) "signed char")
 149
 150 (define-simple-c-type (int signed signed-int sint) "int")
 151 (define-simple-c-type (unsigned unsigned-int uint) "unsigned")
 152
 153 (define-simple-c-type (short signed-short short-int signed-short-int sshort)
 154   "short")
 155 (define-simple-c-type (unsigned-short unsigned-short-int ushort)
 156   "unsigned short")
 157
 158 (define-simple-c-type (long signed-long long-int signed-long-int slong)
 159   "long")
 160 (define-simple-c-type (unsigned-long unsigned-long-int ulong)
 161   "unsigned long")
 162
 163 (define-simple-c-type (long-long signed-long-long long-long-int
 164                        signed-long-long-int llong sllong)
 165   "long long")
 166 (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
 167   "unsigned long long")
 168
 169 (define-simple-c-type float "float")
 170 (define-simple-c-type double "double")
 171 (define-simple-c-type long-double "long double")
 172
 173 (define-simple-c-type va-list "va_list")
 174 (define-simple-c-type size-t "size_t")
 175 (define-simple-c-type ptrdiff-t "ptrdiff_t")
 176
 177 ;;;--------------------------------------------------------------------------
 178 ;;; Tagged types (enums, structs and unions).
 179
 180 ;; Class definition.
 181
 182 (export '(tagged-c-type c-type-tag))
 183 (defclass tagged-c-type (qualifiable-c-type)
 184   ((tag :initarg :tag :type string :reader c-type-tag))
 185   (:documentation
 186    "C types with tags."))
 187
 188 ;; Subclass definitions.
 189
 190 (export 'c-tagged-type-kind)
 191 (defgeneric c-tagged-type-kind (type)
 192   (:documentation
 193    "Return the kind of tagged type that TYPE is, as a keyword."))
 194
 195 (export 'kind-c-tagged-type)
 196 (defgeneric kind-c-tagged-type (kind)
 197   (:documentation
 198    "Given a keyword KIND, return the appropriate class name."))
 199
 200 (export 'make-c-tagged-type)
 201 (defun make-c-tagged-type (kind tag &optional qualifiers)
 202   "Return a tagged type with the given KIND (keyword) and TAG (string)."
 203   (intern-c-type (kind-c-tagged-type kind)
 204                  :tag tag
 205                  :qualifiers (canonify-qualifiers qualifiers)))
 206
 207 (macrolet ((define-tagged-type (kind what)
 208              (let* ((type (symbolicate 'c- kind '-type))
 209                     (keyword (intern (symbol-name kind) :keyword))
 210                     (constructor (symbolicate 'make- kind '-type)))
 211                `(progn
 212                   (export '(,type ,constructor))
 213                   (defclass ,type (tagged-c-type) ()
 214                     (:documentation ,(format nil "C ~a types." what)))
 215                   (defmethod c-tagged-type-kind ((type ,type))
 216                     ',keyword)
 217                   (defmethod kind-c-tagged-type ((kind (eql ',keyword)))
 218                     ',type)
 219                   (defun ,constructor (tag &optional qualifiers)
 220                     (intern-c-type ',type :tag tag
 221                                    :qualifiers (canonify-qualifiers
 222                                                 qualifiers)))
 223                   (define-c-type-syntax ,kind (tag &rest quals)
 224                     ,(format nil "Construct ~A type named TAG" what)
 225                     `(,',constructor ,tag (list ,@quals)))))))
 226   (define-tagged-type enum "enumerated")
 227   (define-tagged-type struct "structure")
 228   (define-tagged-type union "union"))
 229
 230 ;; Comparison protocol.
 231
 232 (defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type))
 233   (string= (c-type-tag type-a) (c-type-tag type-b)))
 234
 235 ;; C syntax output protocol.
 236
 237 (defmethod pprint-c-type ((type tagged-c-type) stream kernel)
 238   (pprint-logical-block (stream nil)
 239     (format stream "~{~(~A~) ~@_~}~(~A~) ~A"
 240             (c-type-qualifiers type)
 241             (c-tagged-type-kind type)
 242             (c-type-tag type))
 243     (funcall kernel stream 0 t)))
 244
 245 ;; S-expression notation protocol.
 246
 247 (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
 248   (declare (ignore colon atsign))
 249   (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>"
 250           (c-tagged-type-kind type)
 251           (c-type-tag type)
 252           (c-type-qualifiers type)))
 253
 254 ;;;--------------------------------------------------------------------------
 255 ;;; Pointer types.
 256
 257 ;; Class definition.
 258
 259 (export 'c-pointer-type)
 260 (defclass c-pointer-type (qualifiable-c-type)
 261   ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
 262   (:documentation "C pointer types."))
 263
 264 ;; Constructor function.
 265
 266 (export 'make-pointer-type)
 267 (defun make-pointer-type (subtype &optional qualifiers)
 268   "Return a (maybe distinguished) pointer type."
 269   (let ((canonical (canonify-qualifiers qualifiers)))
 270     (funcall (if (gethash subtype *c-type-intern-map*)
 271                  #'intern-c-type #'make-instance)
 272              'c-pointer-type
 273              :subtype subtype
 274              :qualifiers canonical)))
 275
 276 ;; Comparison protocol.
 277
 278 (defmethod c-type-equal-p and ((type-a c-pointer-type)
 279                                (type-b c-pointer-type))
 280   (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
 281
 282 ;; C syntax output protocol.
 283
 284 (defmethod pprint-c-type ((type c-pointer-type) stream kernel)
 285   (pprint-c-type (c-type-subtype type) stream
 286                  (lambda (stream prio spacep)
 287                    (when spacep (c-type-space stream))
 288                    (maybe-in-parens (stream (> prio 1))
 289                      (format stream "*~{~(~A~)~^ ~@_~}"
 290                              (c-type-qualifiers type))
 291                      (funcall kernel stream 1 (c-type-qualifiers type))))))
 292
 293 ;; S-expression notation protocol.
 294
 295 (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
 296   (declare (ignore colon atsign))
 297   (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
 298           (c-type-subtype type)
 299           (c-type-qualifiers type)))
 300
 301 (export '(* pointer ptr))
 302 (define-c-type-syntax * (sub &rest quals)
 303   "Return the type of pointer-to-SUB."
 304   `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
 305 (c-type-alias * pointer ptr)
 306
 307 ;; Built-in C types.
 308
 309 (export '(string const-string))
 310 (defctype string (* char))
 311 (defctype const-string (* (char :const)))
 312
 313 ;;;--------------------------------------------------------------------------
 314 ;;; Array types.
 315
 316 ;; Class definition.
 317
 318 (export '(c-array-type c-array-dimensions))
 319 (defclass c-array-type (c-type)
 320   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
 321    (dimensions :initarg :dimensions :type list :reader c-array-dimensions))
 322   (:documentation
 323    "C array types."))
 324
 325 ;; Constructor function.
 326
 327 (export 'make-array-type)
 328 (defun make-array-type (subtype dimensions)
 329   "Return a new array of SUBTYPE with given DIMENSIONS."
 330   (make-instance 'c-array-type :subtype subtype
 331                  :dimensions (or dimensions '(nil))))
 332
 333 ;; Comparison protocol.
 334
 335 (defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type))
 336
 337   ;; Messy.  C doesn't have multidimensional arrays, but we fake them for
 338   ;; convenience's sake.  But it means that we have to arrange for
 339   ;; multidimensional arrays to equal vectors of vectors -- and in general
 340   ;; for multidimensional arrays of multidimensional arrays to match each
 341   ;; other properly, even when their dimensions don't align precisely.
 342   (labels ((check (sub-a dim-a sub-b dim-b)
 343              (cond ((endp dim-a)
 344                     (cond ((endp dim-b)
 345                            (c-type-equal-p sub-a sub-b))
 346                           ((typep sub-a 'c-array-type)
 347                            (check (c-type-subtype sub-a)
 348                                   (c-array-dimensions sub-a)
 349                                   sub-b dim-b))
 350                           (t
 351                            nil)))
 352                    ((endp dim-b)
 353                     (check sub-b dim-b sub-a dim-a))
 354                    ((equal (car dim-a) (car dim-b))
 355                     (check sub-a (cdr dim-a) sub-b (cdr dim-b)))
 356                    (t
 357                     nil))))
 358     (check (c-type-subtype type-a) (c-array-dimensions type-a)
 359            (c-type-subtype type-b) (c-array-dimensions type-b))))
 360
 361 ;; C syntax output protocol.
 362
 363 (defmethod pprint-c-type ((type c-array-type) stream kernel)
 364   (pprint-c-type (c-type-subtype type) stream
 365                  (lambda (stream prio spacep)
 366                    (maybe-in-parens (stream (> prio 2))
 367                      (funcall kernel stream 2 spacep)
 368                      (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
 369                              (c-array-dimensions type))))))
 370
 371 ;; S-expression notation protocol.
 372
 373 (defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
 374   (declare (ignore colon atsign))
 375   (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>"
 376           (c-type-subtype type)
 377           (c-array-dimensions type)))
 378
 379 (export '([] array vec))
 380 (define-c-type-syntax [] (sub &rest dims)
 381   "Return the type of arrays of SUB with the dimensions DIMS.
 382
 383    If the DIMS are omitted, a single unknown-length dimension is added."
 384   `(make-array-type ,(expand-c-type-spec sub)
 385                     (list ,@(or dims '(nil)))))
 386 (c-type-alias [] array vec)
 387
 388 ;;;--------------------------------------------------------------------------
 389 ;;; Function types.
 390
 391 ;; Function arguments.
 392
 393 (defun arguments-lists-equal-p (list-a list-b)
 394   "Return whether LIST-A and LIST-B match.
 395
 396    They must have the same number of arguments, and each argument must have
 397    the same type, or be :ELLIPSIS.  The argument names are not inspected."
 398   (and (= (length list-a) (length list-b))
 399        (every (lambda (arg-a arg-b)
 400                 (if (eq arg-a :ellipsis)
 401                     (eq arg-b :ellipsis)
 402                     (c-type-equal-p (argument-type arg-a)
 403                                     (argument-type arg-b))))
 404               list-a list-b)))
 405
 406 ;; Class definition.
 407
 408 (export '(c-function-type c-function-arguments))
 409 (defclass c-function-type (c-type)
 410   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
 411    (arguments :initarg :arguments :type list :reader c-function-arguments))
 412   (:documentation
 413    "C function types.  The subtype is the return type, as implied by the C
 414     syntax for function declarations."))
 415
 416 ;; Constructor function.
 417
 418 (export 'make-function-type)
 419 (defun make-function-type (subtype arguments)
 420   "Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
 421   (make-instance 'c-function-type :subtype subtype :arguments arguments))
 422
 423 ;; Comparison protocol.
 424
 425 (defmethod c-type-equal-p and
 426     ((type-a c-function-type) (type-b c-function-type))
 427   (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))
 428        (arguments-lists-equal-p (c-function-arguments type-a)
 429                                 (c-function-arguments type-b))))
 430
 431 ;; C syntax output protocol.
 432
 433 (defmethod pprint-c-type ((type c-function-type) stream kernel)
 434   (pprint-c-type (c-type-subtype type) stream
 435                  (lambda (stream prio spacep)
 436                    (maybe-in-parens (stream (> prio 2))
 437                      (when spacep (c-type-space stream))
 438                      (funcall kernel stream 2 nil)
 439                      (pprint-indent :block 4 stream)
 440                      (pprint-logical-block
 441                          (stream nil :prefix "(" :suffix ")")
 442                        (let ((firstp t))
 443                          (dolist (arg (c-function-arguments type))
 444                            (if firstp
 445                                (setf firstp nil)
 446                                (format stream ", ~_"))
 447                            (if (eq arg :ellipsis)
 448                                (write-string "..." stream)
 449                                (pprint-c-type (argument-type arg)
 450                                               stream
 451                                               (argument-name arg))))))))))
 452
 453 ;; S-expression notation protocol.
 454
 455 (defmethod print-c-type
 456     (stream (type c-function-type) &optional colon atsign)
 457   (declare (ignore colon atsign))
 458   (format stream "~:@<~
 459                   FUN ~@_~:I~/sod:print-c-type/~
 460                   ~{ ~_~:<~S ~@_~/sod:print-c-type/~:>~}~
 461                   ~:>"
 462           (c-type-subtype type)
 463           (mapcar (lambda (arg)
 464                     (if (eq arg :ellipsis)
 465                         arg
 466                         (list (argument-name arg) (argument-type arg))))
 467                   (c-function-arguments type))))
 468
 469 (export '(fun function func fn))
 470 (define-c-type-syntax fun (ret &rest args)
 471   "Return the type of functions which returns RET and has arguments ARGS.
 472
 473    The ARGS are a list of arguments of the form (NAME TYPE).  The NAME can be
 474    NIL to indicate that no name was given.
 475
 476    If an entry isn't a list, it's assumed to be the start of a Lisp
 477    expression to compute the tail of the list; similarly, if the list is
 478    improper, then it's considered to be a complete expression.  The upshot of
 479    this apparently bizarre rule is that you can say
 480
 481      (c-type (fun int (\"foo\" int) . arg-tail))
 482
 483    where ARG-TAIL is (almost) any old Lisp expression and have it tack the
 484    arguments onto the end.  Of course, there don't have to be any explicit
 485    arguments at all.  The only restriction is that the head of the Lisp form
 486    can't be a list -- so ((lambda (...) ...) ...) is out, but you probably
 487    wouldn't type that anyway."
 488
 489   `(make-function-type ,(expand-c-type-spec ret)
 490                        ,(do ((args args (cdr args))
 491                              (list nil
 492                                    (cons `(make-argument ,(caar args)
 493                                                          ,(expand-c-type-spec
 494                                                            (cadar args)))
 495                                          list)))
 496                             ((or (atom args) (atom (car args)))
 497                              (cond ((and (null args) (null list)) `nil)
 498                                    ((null args) `(list ,@(nreverse list)))
 499                                    ((and (consp args)
 500                                          (eq (car args) :ellipsis))
 501                                     `(list ,@(nreverse list) :ellipsis))
 502                                    ((null list) `,args)
 503                                    (t `(list* ,@(nreverse list) ,args)))))))
 504 (c-type-alias fun function () func fn)
 505
 506 ;; Additional utilities for dealing with functions.
 507
 508 (export 'commentify-argument-names)
 509 (defun commentify-argument-names (arguments)
 510   "Return an argument list with the arguments commentified.
 511
 512    That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME."
 513   (mapcar (lambda (arg)
 514             (if (eq arg :ellipsis)
 515                 arg
 516                 (make-argument (commentify-argument-name (argument-name arg))
 517                                (argument-type arg))))
 518           arguments))
 519
 520 (export 'commentify-function-type)
 521 (defun commentify-function-type (type)
 522   "Return a type like TYPE, but with arguments commentified.
 523
 524    This doesn't recurse into the return type or argument types."
 525   (make-function-type (c-type-subtype type)
 526                       (commentify-argument-names
 527                        (c-function-arguments type))))
 528
 529 ;;;----- That's all, folks --------------------------------------------------