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