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