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