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