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