chiark - git - mdw - sod/blob - c-types.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Dealing with C types
   4 ;;;
   5 ;;; (c) 2008 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  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 ;;; Plain old C types.
  30
  31 ;; Class definition.
  32
  33 (defclass c-type ()
  34   ()
  35   (:documentation
  36    "Base class for C type objects."))
  37
  38 ;; Important protocol.
  39
  40 (defgeneric c-type-subtype (type)
  41   (:documentation
  42    "For compound types, return the base type."))
  43
  44 (defgeneric c-type-equal-p (type-a type-b)
  45   (:method-combination and)
  46   (:documentation
  47    "Answers whether two types TYPE-A and TYPE-B are, in fact, equal.")
  48   (:method and (type-a type-b)
  49     (eql (class-of type-a) (class-of type-b))))
  50
  51 (defgeneric pprint-c-type (type stream kernel)
  52   (:documentation
  53    "Pretty-printer for C types.
  54
  55    Print TYPE to STREAM.  In the middle of the declarator, call the function
  56    KERNEL with one argument: whether it needs a leading space.")
  57   (:method :around (type stream kernel)
  58     (typecase kernel
  59       (function (call-next-method))
  60       (null (pprint-c-type type stream
  61                            (lambda (stream prio spacep)
  62                              (declare (ignore stream prio spacep))
  63                              nil)))
  64       (t (pprint-c-type type stream
  65                         (lambda (stream prio spacep)
  66                           (declare (ignore prio))
  67                           (when spacep
  68                             (c-type-space stream))
  69                           (princ kernel stream)))))))
  70
  71 (defgeneric print-c-type (stream type &optional colon atsign)
  72   (:documentation
  73    "Print an abbreviated syntax for TYPE to the STREAM."))
  74
  75 (defmethod print-object ((object c-type) stream)
  76   (if *print-escape*
  77       (format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object)
  78       (pprint-c-type object stream nil)))
  79
  80 ;; Utility functions and macros.
  81
  82 (defun c-type-space (stream)
  83   "Print a space and a miser-mode newline to STREAM.
  84
  85    This is the right function to call in a PPRINT-C-TYPE kernel function when
  86    the SPACEP argument is true."
  87   (pprint-indent :block 2 stream)
  88   (write-char #\space stream)
  89   (pprint-newline :miser stream))
  90
  91 (defun maybe-in-parens* (stream condition thunk)
  92   "Helper function for the MAYBE-IN-PARENS macro."
  93   (pprint-logical-block
  94       (stream nil
  95               :prefix (if condition "(" "")
  96               :suffix (if condition ")" ""))
  97     (funcall thunk stream)))
  98
  99 (defmacro maybe-in-parens ((stream condition) &body body)
 100   "Evaluate BODY; if CONDITION, write parens to STREAM around it.
 101
 102    This macro is useful for implementing the PPRINT-C-TYPE method on compound
 103    types.  The BODY is evaluated in the context of a logical block printing
 104    to STREAM.  If CONDITION is non-nil, then the block will have open/close
 105    parens as its prefix and suffix; otherwise they will be empty.
 106
 107    The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol."
 108   `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
 109
 110 ;; S-expression syntax machinery.
 111
 112 (defun c-name-case (name)
 113   "Convert NAME to suitable case.
 114
 115    Strings are returned as-is; symbols are squashed to lower-case and hyphens
 116    are replaced by underscores."
 117   (typecase name
 118     (symbol (with-output-to-string (out)
 119               (loop for ch across (symbol-name name)
 120                     do (cond ((alpha-char-p ch)
 121                               (write-char (char-downcase ch) out))
 122                              ((or (digit-char-p ch)
 123                                   (char= ch #\_))
 124                               (write-char ch out))
 125                              ((char= ch #\-)
 126                               (write-char #\_ out))
 127                              (t
 128                               (error "Bad character in C name ~S." name))))))
 129     (t name)))
 130
 131 (eval-when (:compile-toplevel :load-toplevel :execute)
 132   (defgeneric expand-c-type-spec (spec)
 133     (:documentation
 134      "Expand SPEC into Lisp code to construct a C type.")
 135     (:method ((spec list))
 136       (expand-c-type-form (car spec) (cdr spec))))
 137   (defgeneric expand-c-type-form (head tail)
 138     (:documentation
 139      "Expand a C type list beginning with HEAD.")
 140     (:method ((name (eql 'lisp)) tail)
 141       `(progn ,@tail))))
 142
 143 (defmacro c-type (spec)
 144   "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC."
 145   (expand-c-type-spec spec))
 146
 147 (defmacro define-c-type-syntax (name bvl &rest body)
 148   "Define a C-type syntax function.
 149
 150    A function defined by BODY and with lambda-list BVL is associated with the
 151    NAME.  When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
 152    function with the argument list STUFF."
 153   (let ((headvar (gensym "HEAD"))
 154         (tailvar (gensym "TAIL")))
 155     `(eval-when (:compile-toplevel :load-toplevel :execute)
 156        (defmethod expand-c-type-form ((,headvar (eql ',name)) ,tailvar)
 157          (destructuring-bind ,bvl ,tailvar
 158            ,@body)))))
 159
 160 (defmacro c-type-alias (original &rest aliases)
 161   "Make ALIASES behave the same way as the ORIGINAL type."
 162   (let ((headvar (gensym "HEAD"))
 163         (tailvar (gensym "TAIL")))
 164     `(eval-when (:compile-toplevel :load-toplevel :execute)
 165        ,@(mapcar (lambda (alias)
 166                    `(defmethod expand-c-type-form
 167                         ((,headvar (eql ',alias)) ,tailvar)
 168                       (expand-c-type-form ',original ,tailvar)))
 169                  aliases))))
 170
 171 (defmacro defctype (names value)
 172   "Define NAMES all to describe the C-type VALUE.
 173
 174    NAMES can be a symbol (treated as a singleton list), or a list of symbols.
 175    The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE.  It will
 176    be expanded once at run-time."
 177   (let* ((names (if (listp names) names (list names)))
 178          (namevar (gensym "NAME"))
 179          (typevar (symbolicate 'c-type- (car names))))
 180     `(progn
 181        (defparameter ,typevar ,(expand-c-type-spec value))
 182        (eval-when (:compile-toplevel :load-toplevel :execute)
 183          ,@(mapcar (lambda (name)
 184                      `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
 185                         ',typevar))
 186                    names)))))
 187
 188 ;;;--------------------------------------------------------------------------
 189 ;;; Types which can accept qualifiers.
 190
 191 ;; Basic definitions.
 192
 193 (defclass qualifiable-c-type (c-type)
 194   ((qualifiers :initarg :qualifiers :initform nil
 195                :type list :accessor c-type-qualifiers))
 196   (:documentation
 197    "Base class for C types which can be qualified."))
 198
 199 (defun format-qualifiers (quals)
 200   "Return a string listing QUALS, with a space after each."
 201   (format nil "~{~(~A~) ~}" quals))
 202
 203 (defmethod c-type-equal-p and ((type-a qualifiable-c-type)
 204                                (type-b qualifiable-c-type))
 205   (flet ((fix (type)
 206            (sort (copy-list (c-type-qualifiers type)) #'string<)))
 207     (equal (fix type-a) (fix type-b))))
 208
 209 ;; A handy utility.
 210
 211 (let ((cache (make-hash-table :test #'equal)))
 212   (defun qualify-type (c-type qualifiers)
 213     "Returns a qualified version of C-TYPE.
 214
 215    Maintains a cache of qualified types so that we don't have to run out of
 216    memory.  This can also speed up type comparisons."
 217     (if (null qualifiers)
 218         c-type
 219         (let ((key (cons c-type qualifiers)))
 220           (unless (typep c-type 'qualifiable-c-type)
 221             (error "~A isn't qualifiable." (class-name (class-of c-type))))
 222           (or (gethash key cache)
 223               (setf (gethash key cache)
 224                     (copy-instance c-type :qualifiers qualifiers)))))))
 225
 226 ;;;--------------------------------------------------------------------------
 227 ;;; Simple C types (e.g., built-in arithmetic types).
 228
 229 (defvar *simple-type-map* (make-hash-table :test #'equal)
 230   "A hash table mapping type strings to Lisp symbols naming them.")
 231
 232 ;; Basic definitions.
 233
 234 (defclass simple-c-type (qualifiable-c-type)
 235   ((name :initarg :name :type string :reader c-type-name))
 236   (:documentation
 237    "C types with simple forms."))
 238
 239 (let ((cache (make-hash-table :test #'equal)))
 240   (defun make-simple-type (name &optional qualifiers)
 241     "Make a distinguished object for the simple type called NAME."
 242     (qualify-type (or (gethash name cache)
 243                       (setf (gethash name cache)
 244                             (make-instance 'simple-c-type :name name)))
 245                   qualifiers)))
 246
 247 (defmethod pprint-c-type ((type simple-c-type) stream kernel)
 248   (pprint-logical-block (stream nil)
 249     (format stream "~{~(~A~) ~@_~}~A"
 250             (c-type-qualifiers type)
 251             (c-type-name type))
 252     (funcall kernel stream 0 t)))
 253
 254 (defmethod c-type-equal-p and ((type-a simple-c-type)
 255                                (type-b simple-c-type))
 256   (string= (c-type-name type-a) (c-type-name type-b)))
 257
 258 (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
 259   (declare (ignore colon atsign))
 260   (let* ((name (c-type-name type))
 261          (symbol (gethash name *simple-type-map*)))
 262     (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]"
 263             (c-type-qualifiers type) (or symbol name))))
 264
 265 ;; S-expression syntax.
 266
 267 (eval-when (:compile-toplevel :load-toplevel :execute)
 268   (defmethod expand-c-type-spec ((spec string))
 269     `(make-simple-type ,spec))
 270   (defmethod expand-c-type-form ((head string) tail)
 271     `(make-simple-type ,head ,@tail)))
 272
 273 (defmacro define-simple-c-type (names type)
 274   "Define each of NAMES to be a simple type called TYPE."
 275   (let ((names (if (listp names) names (list names))))
 276     `(progn
 277        (setf (gethash ,type *simple-type-map*) ',(car names))
 278        (defctype ,names ,type)
 279        (define-c-type-syntax ,(car names) (&rest quals)
 280          `(make-simple-type ,',type (list ,@quals))))))
 281
 282 (define-simple-c-type void "void")
 283
 284 (define-simple-c-type char "char")
 285 (define-simple-c-type (unsigned-char uchar) "unsigned char")
 286 (define-simple-c-type (signed-char schar) "signed char")
 287
 288 (define-simple-c-type (int signed signed-int sint) "int")
 289 (define-simple-c-type (unsigned unsigned-int uint) "unsigned")
 290
 291 (define-simple-c-type (short signed-short short-int signed-short-int sshort)
 292   "short")
 293 (define-simple-c-type (unsigned-short unsigned-short-int ushort)
 294   "unsigned short")
 295
 296 (define-simple-c-type (long signed-long long-int signed-long-int slong)
 297   "long")
 298 (define-simple-c-type (unsigned-long unsigned-long-int ulong)
 299   "unsigned long")
 300
 301 (define-simple-c-type (long-long signed-long-long long-long-int
 302                        signed-long-long-int llong sllong)
 303   "long long")
 304 (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
 305   "unsigned long long")
 306
 307 (define-simple-c-type float "float")
 308 (define-simple-c-type double "double")
 309 (define-simple-c-type long-double "long double")
 310
 311 (define-simple-c-type va-list "va_list")
 312 (define-simple-c-type size-t "size_t")
 313 (define-simple-c-type ptrdiff-t "ptrdiff_t")
 314
 315 ;;;--------------------------------------------------------------------------
 316 ;;; Tag types (structs, unions and enums).
 317
 318 ;; Definitions.
 319
 320 (defclass tagged-c-type (qualifiable-c-type)
 321   ((tag :initarg :tag :type string :reader c-type-tag))
 322   (:documentation
 323    "C types with tags."))
 324
 325 (defgeneric c-tagged-type-kind (type)
 326   (:documentation
 327    "Return the kind of tagged type that TYPE is, as a keyword."))
 328
 329 (macrolet ((define-tagged-type (kind what)
 330              (let ((type (symbolicate 'c- kind '-type))
 331                    (constructor (symbolicate 'make- kind '-type)))
 332                `(progn
 333                   (defclass ,type (tagged-c-type) ()
 334                     (:documentation ,(format nil "C ~a types." what)))
 335                   (defmethod c-tagged-type-kind ((type ,type))
 336                     ',kind)
 337                   (let ((cache (make-hash-table :test #'equal)))
 338                     (defun ,constructor (tag &optional qualifiers)
 339                       (qualify-type (or (gethash tag cache)
 340                                         (setf (gethash tag cache)
 341                                               (make-instance ',type
 342                                                              :tag tag)))
 343                                     qualifiers)))
 344                   (define-c-type-syntax ,kind (tag &rest quals)
 345                     ,(format nil "Construct ~A type named TAG" what)
 346                     `(,',constructor ,tag (list ,@quals)))))))
 347   (define-tagged-type enum "enumerated")
 348   (define-tagged-type struct "structure")
 349   (define-tagged-type union "union"))
 350
 351 (defmethod pprint-c-type ((type tagged-c-type) stream kernel)
 352   (pprint-logical-block (stream nil)
 353     (format stream "~{~(~A~) ~@_~}~(~A~) ~A"
 354             (c-type-qualifiers type)
 355             (c-tagged-type-kind type)
 356             (c-type-tag type))
 357     (funcall kernel stream 0 t)))
 358
 359 (defmethod c-type-equal-p and ((type-a tagged-c-type)
 360                                (type-b tagged-c-type))
 361   (string= (c-type-tag type-a) (c-type-tag type-b)))
 362
 363 (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
 364   (declare (ignore colon atsign))
 365   (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>"
 366           (c-tagged-type-kind type)
 367           (c-type-tag type)
 368           (c-type-qualifiers type)))
 369
 370 ;;;--------------------------------------------------------------------------
 371 ;;; Pointer types.
 372
 373 ;; Definitions.
 374
 375 (defclass c-pointer-type (qualifiable-c-type)
 376   ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
 377   (:documentation
 378    "C pointer types."))
 379
 380 (let ((cache (make-hash-table :test #'eql)))
 381   (defun make-pointer-type (subtype &optional qualifiers)
 382     "Return a (maybe distinguished) pointer type."
 383     (qualify-type (or (gethash subtype cache)
 384                       (make-instance 'c-pointer-type :subtype subtype))
 385                   qualifiers)))
 386
 387 (defmethod pprint-c-type ((type c-pointer-type) stream kernel)
 388   (pprint-c-type (c-type-subtype type) stream
 389                  (lambda (stream prio spacep)
 390                    (when spacep (c-type-space stream))
 391                    (maybe-in-parens (stream (> prio 1))
 392                      (format stream "*~{~(~A~)~^ ~@_~}"
 393                              (c-type-qualifiers type))
 394                      (funcall kernel stream 1 (c-type-qualifiers type))))))
 395
 396 (defmethod c-type-equal-p and ((type-a c-pointer-type)
 397                                (type-b c-pointer-type))
 398   (c-type-equal-p (c-type-subtype type-a)
 399                   (c-type-subtype type-b)))
 400
 401 (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
 402   (declare (ignore colon atsign))
 403   (format stream "~:@<* ~@_~/sod::print-c-type/~{ ~_~S~}~:>"
 404           (c-type-subtype type)
 405           (c-type-qualifiers type)))
 406
 407 ;; S-expression syntax.
 408
 409 (define-c-type-syntax * (sub &rest quals)
 410   "Return the type of pointer-to-SUB."
 411   `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
 412 (c-type-alias * pointer ptr)
 413
 414 (defctype string (* char))
 415 (defctype const-string (* (char :const)))
 416
 417 ;;;--------------------------------------------------------------------------
 418 ;;; Array types.
 419
 420 ;; Definitions.
 421
 422 (defclass c-array-type (c-type)
 423   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
 424    (dimensions :initarg :dimensions :type list :reader c-array-dimensions))
 425   (:documentation
 426    "C array types."))
 427
 428 (defun make-array-type (subtype dimensions)
 429   "Return a new array of SUBTYPE with given DIMENSIONS."
 430   (make-instance 'c-array-type :subtype subtype
 431                  :dimensions (or dimensions '(nil))))
 432
 433 (defmethod pprint-c-type ((type c-array-type) stream kernel)
 434   (pprint-c-type (c-type-subtype type) stream
 435                  (lambda (stream prio spacep)
 436                    (maybe-in-parens (stream (> prio 2))
 437                      (funcall kernel stream 2 spacep)
 438                      (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
 439                              (c-array-dimensions type))))))
 440
 441 (defmethod c-type-equal-p and ((type-a c-array-type)
 442                                (type-b c-array-type))
 443   (and (c-type-equal-p (c-type-subtype type-a)
 444                        (c-type-subtype type-b))
 445        (equal (c-array-dimensions type-a)
 446               (c-array-dimensions type-b))))
 447
 448 (defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
 449   (declare (ignore colon atsign))
 450   (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~S~}~:>"
 451           (c-type-subtype type)
 452           (c-array-dimensions type)))
 453
 454 ;; S-expression syntax.
 455
 456 (define-c-type-syntax [] (sub &rest dims)
 457   "Return the type of arrays of SUB with the dimensions DIMS.
 458
 459    If the DIMS are omitted, a single unknown-length dimension is added."
 460   `(make-array-type ,(expand-c-type-spec sub)
 461                     (list ,@(or dims '(nil)))))
 462 (c-type-alias [] array vec)
 463
 464 ;;;--------------------------------------------------------------------------
 465 ;;; Function types.
 466
 467 ;; Arguments.
 468
 469 (defstruct (argument (:constructor make-argument (name type)) (:type list))
 470   "Simple list structure representing a function argument."
 471   name
 472   type)
 473
 474 (defun arguments-lists-equal-p (list-a list-b)
 475   "Return whether LIST-A and LIST-B match.
 476
 477    They must have the same number of arguments, and each argument must have
 478    the same type, or be :ELLIPSIS.  The argument names are not inspected."
 479   (and (= (length list-a) (length list-b))
 480        (every (lambda (arg-a arg-b)
 481                 (if (eq arg-a :ellipsis)
 482                     (eq arg-b :ellipsis)
 483                     (c-type-equal-p (argument-type arg-a)
 484                                     (argument-type arg-b))))
 485               list-a list-b)))
 486
 487 (defgeneric commentify-argument-name (name)
 488   (:documentation
 489    "Produce a `commentified' version of the argument.
 490
 491    The default behaviour is that temporary argument names are simply omitted
 492    (NIL is returned); otherwise, `/*...*/' markers are wrapped around the
 493    printable representation of the argument.")
 494   (:method ((name null)) nil)
 495   (:method ((name t)) (format nil "/*~A*/" name)))
 496
 497 (defun commentify-argument-names (arguments)
 498   "Return an argument list with the arguments commentified.
 499
 500    That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME."
 501   (mapcar (lambda (arg)
 502             (if (eq arg :ellipsis)
 503                 arg
 504                 (make-argument (commentify-argument-name (argument-name arg))
 505                                (argument-type arg))))
 506           arguments))
 507
 508 (defun commentify-function-type (type)
 509   "Return a type like TYPE, but with arguments commentified.
 510
 511    This doesn't recurse into the return type or argument types."
 512   (make-function-type (c-type-subtype type)
 513                       (commentify-argument-names
 514                        (c-function-arguments type))))
 515
 516 ;; Definitions.
 517
 518 (defclass c-function-type (c-type)
 519   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
 520    (arguments :initarg :arguments :type list :reader c-function-arguments))
 521   (:documentation
 522    "C function types.  The subtype is the return type, as implied by the C
 523     syntax for function declarations."))
 524
 525 (defun make-function-type (subtype arguments)
 526   "Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
 527   (make-instance 'c-function-type :subtype subtype :arguments arguments))
 528
 529 (defmethod c-type-equal-p and ((type-a c-function-type)
 530                                (type-b c-function-type))
 531   (and (c-type-equal-p (c-type-subtype type-a)
 532                        (c-type-subtype type-b))
 533        (arguments-lists-equal-p (c-function-arguments type-a)
 534                                 (c-function-arguments type-b))))
 535
 536 (defmethod print-c-type
 537     (stream (type c-function-type) &optional colon atsign)
 538   (declare (ignore colon atsign))
 539   (format stream
 540           #.(concatenate 'string
 541                          "~:@<"
 542                          "FUN ~@_~:I~/sod::print-c-type/"
 543                          "~{ ~_~:<~S ~@_~/sod::print-c-type/~:>~}"
 544                          "~:>")
 545           (c-type-subtype type)
 546           (c-function-arguments type)))
 547
 548 (defmethod pprint-c-type ((type c-function-type) stream kernel)
 549   (pprint-c-type (c-type-subtype type) stream
 550                  (lambda (stream prio spacep)
 551                    (maybe-in-parens (stream (> prio 2))
 552                      (when spacep (c-type-space stream))
 553                      (funcall kernel stream 2 nil)
 554                      (pprint-indent :block 4 stream)
 555                      ;;(pprint-newline :miser stream)
 556                      (pprint-logical-block
 557                          (stream nil :prefix "(" :suffix ")")
 558                        (let ((firstp t))
 559                          (dolist (arg (c-function-arguments type))
 560                            (if firstp
 561                                (setf firstp nil)
 562                                (format stream ", ~_"))
 563                            (if (eq arg :ellipsis)
 564                                (write-string "..." stream)
 565                                (pprint-c-type (argument-type arg)
 566                                               stream
 567                                               (argument-name arg))))))))))
 568
 569 ;; S-expression syntax.
 570
 571 (define-c-type-syntax fun (ret &rest args)
 572   "Return the type of functions which returns RET and has arguments ARGS.
 573
 574    The ARGS are a list of arguments of the form (NAME TYPE).  The NAME can be
 575    NIL to indicate that no name was given.
 576
 577    If an entry isn't a list, it's assumed to be the start of a Lisp
 578    expression to compute the tail of the list; similarly, if the list is
 579    improper, then it's considered to be a complete expression.  The upshot of
 580    this apparently bizarre rule is that you can say
 581
 582      (c-type (fun int (\"foo\" int) . arg-tail))
 583
 584    where ARG-TAIL is (almost) any old Lisp expression and have it tack the
 585    arguments onto the end.  Of course, there don't have to be any explicit
 586    arguments at all.  The only restriction is that the head of the Lisp form
 587    can't be a list -- so ((lambda (...) ...) ...) is out, but you probably
 588    wouldn't type that anyway."
 589
 590   `(make-function-type ,(expand-c-type-spec ret)
 591                        ,(do ((args args (cdr args))
 592                              (list nil
 593                                    (cons `(make-argument ,(caar args)
 594                                                          ,(expand-c-type-spec
 595                                                            (cadar args)))
 596                                          list)))
 597                             ((or (atom args) (atom (car args)))
 598                              (cond ((and (null args) (null list)) `nil)
 599                                    ((null args) `(list ,@(nreverse list)))
 600                                    ((null list) `,args)
 601                                    (t `(list* ,@(nreverse list) ,args)))))))
 602 (c-type-alias fun function () func fn)
 603
 604 ;;;----- That's all, folks --------------------------------------------------