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