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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; C type representation implementation
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Interning types.
  30
  31 (defparameter *c-type-intern-map* (make-hash-table :test #'equal)
  32   "Hash table mapping lists describing types to their distinguished
  33    representations.")
  34
  35 (defun intern-c-type (class &rest initargs)
  36   "If the CLASS and INITARGS have already been interned, then return the
  37    existing object; otherwise make a new one."
  38   (let ((list (cons class initargs)))
  39     (or (gethash list *c-type-intern-map*)
  40         (let ((new (apply #'make-instance class initargs)))
  41           (setf (gethash new *c-type-intern-map*) t
  42                 (gethash list *c-type-intern-map*) new)))))
  43
  44 #+test
  45 (defun check-type-intern-map ()
  46   "Sanity check for the type-intern map."
  47   (let ((map (make-hash-table)))
  48
  49     ;; Pass 1: check that interned types are consistent with their keys.
  50     ;; Remember interned types.
  51     (maphash (lambda (k v)
  52                (when (listp k)
  53                  (let ((ty (apply #'make-instance k)))
  54                    (assert (c-type-equal-p ty v)))
  55                  (setf (gethash v map) t)))
  56              *c-type-intern-map*)
  57
  58     ;; Pass 2: check that the interned type indicators are correct.
  59     (maphash (lambda (k v)
  60                (declare (ignore v))
  61                (assert (gethash k *c-type-intern-map*)))
  62              map)
  63     (maphash (lambda (k v)
  64                (declare (ignore v))
  65                (when (typep k 'c-type)
  66                  (assert (gethash k map))))
  67              *c-type-intern-map*)))
  68
  69 (defmethod qualify-c-type ((type qualifiable-c-type) qualifiers)
  70   (let ((initargs (instance-initargs type)))
  71     (remf initargs :qualifiers)
  72     (apply (if (gethash type *c-type-intern-map*)
  73                #'intern-c-type #'make-instance)
  74            (class-of type)
  75            :qualifiers (canonify-qualifiers
  76                         (append qualifiers (c-type-qualifiers type)))
  77            initargs)))
  78
  79 ;;;--------------------------------------------------------------------------
  80 ;;; Simple C types.
  81
  82 ;; Class definition.
  83
  84 (export '(simple-c-type c-type-name))
  85 (defclass simple-c-type (qualifiable-c-type)
  86   ((name :initarg :name :type string :reader c-type-name))
  87   (:documentation
  88    "C types with simple forms."))
  89
  90 ;; Constructor function and interning.
  91
  92 (export 'make-simple-type)
  93 (defun make-simple-type (name &optional qualifiers)
  94   "Make a distinguished object for the simple type called NAME."
  95   (intern-c-type 'simple-c-type
  96                  :name name
  97                  :qualifiers (canonify-qualifiers qualifiers)))
  98
  99 ;; Comparison protocol.
 100
 101 (defmethod c-type-equal-p and
 102     ((type-a simple-c-type) (type-b simple-c-type))
 103   (string= (c-type-name type-a) (c-type-name type-b)))
 104
 105 ;; C syntax output protocol.
 106
 107 (defmethod pprint-c-type ((type simple-c-type) stream kernel)
 108   (pprint-logical-block (stream nil)
 109     (format stream "~{~(~A~) ~@_~}~A"
 110             (c-type-qualifiers type)
 111             (c-type-name type))
 112     (funcall kernel stream 0 t)))
 113
 114 ;; S-expression notation protocol.
 115
 116 (defparameter *simple-type-map* (make-hash-table)
 117   "Hash table mapping strings of C syntax to symbolic names.")
 118
 119 (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
 120   (declare (ignore colon atsign))
 121   (let* ((name (c-type-name type))
 122          (symbol (gethash name *simple-type-map*)))
 123     (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]"
 124             (c-type-qualifiers type) (or symbol name))))
 125
 126 (eval-when (:compile-toplevel :load-toplevel :execute)
 127   (defmethod expand-c-type-spec ((spec string))
 128     `(make-simple-type ,spec))
 129   (defmethod expand-c-type-form ((head string) tail)
 130     `(make-simple-type ,head (list ,@tail))))
 131
 132 (export 'define-simple-c-type)
 133 (defmacro define-simple-c-type (names type &key export)
 134   "Define each of NAMES to be a simple type called TYPE."
 135   (let ((names (if (listp names) names (list names))))
 136     `(progn
 137        (setf (gethash ,type *simple-type-map*) ',(car names))
 138        (defctype ,names ,type :export ,export)
 139        (define-c-type-syntax ,(car names) (&rest quals)
 140          `(make-simple-type ,',type (list ,@quals))))))
 141
 142 ;; Built-in C types.
 143
 144 (define-simple-c-type void "void" :export t)
 145
 146 (define-simple-c-type char "char" :export t)
 147 (define-simple-c-type (unsigned-char uchar) "unsigned char" :export t)
 148 (define-simple-c-type (signed-char schar) "signed char" :export t)
 149 (define-simple-c-type wchar-t "wchar-t" :export t)
 150
 151 (define-simple-c-type (int signed signed-int sint) "int" :export t)
 152 (define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t)
 153
 154 (define-simple-c-type (short signed-short short-int signed-short-int sshort)
 155   "short" :export t)
 156 (define-simple-c-type (unsigned-short unsigned-short-int ushort)
 157   "unsigned short" :export t)
 158
 159 (define-simple-c-type (long signed-long long-int signed-long-int slong)
 160   "long" :export t)
 161 (define-simple-c-type (unsigned-long unsigned-long-int ulong)
 162   "unsigned long" :export t)
 163
 164 (define-simple-c-type (long-long signed-long-long long-long-int
 165                        signed-long-long-int llong sllong)
 166   "long long" :export t)
 167 (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
 168   "unsigned long long" :export t)
 169
 170 (define-simple-c-type float "float" :export t)
 171 (define-simple-c-type double "double" :export t)
 172 (define-simple-c-type long-double "long double" :export t)
 173
 174 (define-simple-c-type bool "_Bool" :export t)
 175
 176 (define-simple-c-type float-complex "float _Complex" :export t)
 177 (define-simple-c-type double-complex "double _Complex" :export t)
 178 (define-simple-c-type long-double-complex "long double _Complex" :export t)
 179
 180 (define-simple-c-type float-imaginary "float _Imaginary" :export t)
 181 (define-simple-c-type double-imaginary "double _Imaginary" :export t)
 182 (define-simple-c-type long-double-imaginary
 183     "long double _Imaginary" :export t)
 184
 185 (define-simple-c-type va-list "va_list" :export t)
 186 (define-simple-c-type size-t "size_t" :export t)
 187 (define-simple-c-type ptrdiff-t "ptrdiff_t" :export t)
 188
 189 ;;;--------------------------------------------------------------------------
 190 ;;; Tagged types (enums, structs and unions).
 191
 192 ;; Class definition.
 193
 194 (export '(tagged-c-type c-type-tag))
 195 (defclass tagged-c-type (qualifiable-c-type)
 196   ((tag :initarg :tag :type string :reader c-type-tag))
 197   (:documentation
 198    "C types with tags."))
 199
 200 ;; Subclass definitions.
 201
 202 (export 'c-tagged-type-kind)
 203 (defgeneric c-tagged-type-kind (type)
 204   (:documentation
 205    "Return the kind of tagged type that TYPE is, as a keyword."))
 206
 207 (export 'kind-c-tagged-type)
 208 (defgeneric kind-c-tagged-type (kind)
 209   (:documentation
 210    "Given a keyword KIND, return the appropriate class name."))
 211
 212 (export 'make-c-tagged-type)
 213 (defun make-c-tagged-type (kind tag &optional qualifiers)
 214   "Return a tagged type with the given KIND (keyword) and TAG (string)."
 215   (intern-c-type (kind-c-tagged-type kind)
 216                  :tag tag
 217                  :qualifiers (canonify-qualifiers qualifiers)))
 218
 219 (macrolet ((define-tagged-type (kind what)
 220              (let* ((type (symbolicate 'c- kind '-type))
 221                     (keyword (intern (symbol-name kind) :keyword))
 222                     (constructor (symbolicate 'make- kind '-type)))
 223                `(progn
 224                   (export '(,type ,kind ,constructor))
 225                   (defclass ,type (tagged-c-type) ()
 226                     (:documentation ,(format nil "C ~a types." what)))
 227                   (defmethod c-tagged-type-kind ((type ,type))
 228                     ',keyword)
 229                   (defmethod kind-c-tagged-type ((kind (eql ',keyword)))
 230                     ',type)
 231                   (defun ,constructor (tag &optional qualifiers)
 232                     (intern-c-type ',type :tag tag
 233                                    :qualifiers (canonify-qualifiers
 234                                                 qualifiers)))
 235                   (define-c-type-syntax ,kind (tag &rest quals)
 236                     ,(format nil "Construct ~A type named TAG" what)
 237                     `(,',constructor ,tag (list ,@quals)))))))
 238   (define-tagged-type enum "enumerated")
 239   (define-tagged-type struct "structure")
 240   (define-tagged-type union "union"))
 241
 242 ;; Comparison protocol.
 243
 244 (defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type))
 245   (string= (c-type-tag type-a) (c-type-tag type-b)))
 246
 247 ;; C syntax output protocol.
 248
 249 (defmethod pprint-c-type ((type tagged-c-type) stream kernel)
 250   (pprint-logical-block (stream nil)
 251     (format stream "~{~(~A~) ~@_~}~(~A~) ~A"
 252             (c-type-qualifiers type)
 253             (c-tagged-type-kind type)
 254             (c-type-tag type))
 255     (funcall kernel stream 0 t)))
 256
 257 ;; S-expression notation protocol.
 258
 259 (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
 260   (declare (ignore colon atsign))
 261   (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>"
 262           (c-tagged-type-kind type)
 263           (c-type-tag type)
 264           (c-type-qualifiers type)))
 265
 266 ;;;--------------------------------------------------------------------------
 267 ;;; Pointer types.
 268
 269 ;; Class definition.
 270
 271 (export 'c-pointer-type)
 272 (defclass c-pointer-type (qualifiable-c-type)
 273   ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
 274   (:documentation "C pointer types."))
 275
 276 ;; Constructor function.
 277
 278 (export 'make-pointer-type)
 279 (defun make-pointer-type (subtype &optional qualifiers)
 280   "Return a (maybe distinguished) pointer type."
 281   (let ((canonical (canonify-qualifiers qualifiers)))
 282     (funcall (if (gethash subtype *c-type-intern-map*)
 283                  #'intern-c-type #'make-instance)
 284              'c-pointer-type
 285              :subtype subtype
 286              :qualifiers canonical)))
 287
 288 ;; Comparison protocol.
 289
 290 (defmethod c-type-equal-p and ((type-a c-pointer-type)
 291                                (type-b c-pointer-type))
 292   (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
 293
 294 ;; C syntax output protocol.
 295
 296 (defmethod pprint-c-type ((type c-pointer-type) stream kernel)
 297   (pprint-c-type (c-type-subtype type) stream
 298                  (lambda (stream prio spacep)
 299                    (when spacep (c-type-space stream))
 300                    (maybe-in-parens (stream (> prio 1))
 301                      (format stream "*~{~(~A~)~^ ~@_~}"
 302                              (c-type-qualifiers type))
 303                      (funcall kernel stream 1 (c-type-qualifiers type))))))
 304
 305 ;; S-expression notation protocol.
 306
 307 (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
 308   (declare (ignore colon atsign))
 309   (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
 310           (c-type-subtype type)
 311           (c-type-qualifiers type)))
 312
 313 (export '(* pointer ptr))
 314 (define-c-type-syntax * (sub &rest quals)
 315   "Return the type of pointer-to-SUB."
 316   `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
 317 (c-type-alias * pointer ptr)
 318
 319 ;; Built-in C types.
 320
 321 (export '(string const-string))
 322 (defctype string (* char))
 323 (defctype const-string (* (char :const)))
 324
 325 ;;;--------------------------------------------------------------------------
 326 ;;; Array types.
 327
 328 ;; Class definition.
 329
 330 (export '(c-array-type c-array-dimensions))
 331 (defclass c-array-type (c-type)
 332   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
 333    (dimensions :initarg :dimensions :type list :reader c-array-dimensions))
 334   (:documentation
 335    "C array types."))
 336
 337 ;; Constructor function.
 338
 339 (export 'make-array-type)
 340 (defun make-array-type (subtype dimensions)
 341   "Return a new array of SUBTYPE with given DIMENSIONS."
 342   (make-instance 'c-array-type :subtype subtype
 343                  :dimensions (or dimensions '(nil))))
 344
 345 ;; Comparison protocol.
 346
 347 (defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type))
 348
 349   ;; Messy.  C doesn't have multidimensional arrays, but we fake them for
 350   ;; convenience's sake.  But it means that we have to arrange for
 351   ;; multidimensional arrays to equal vectors of vectors -- and in general
 352   ;; for multidimensional arrays of multidimensional arrays to match each
 353   ;; other properly, even when their dimensions don't align precisely.
 354   (labels ((check (sub-a dim-a sub-b dim-b)
 355              (cond ((endp dim-a)
 356                     (cond ((endp dim-b)
 357                            (c-type-equal-p sub-a sub-b))
 358                           ((typep sub-a 'c-array-type)
 359                            (check (c-type-subtype sub-a)
 360                                   (c-array-dimensions sub-a)
 361                                   sub-b dim-b))
 362                           (t
 363                            nil)))
 364                    ((endp dim-b)
 365                     (check sub-b dim-b sub-a dim-a))
 366                    ((equal (car dim-a) (car dim-b))
 367                     (check sub-a (cdr dim-a) sub-b (cdr dim-b)))
 368                    (t
 369                     nil))))
 370     (check (c-type-subtype type-a) (c-array-dimensions type-a)
 371            (c-type-subtype type-b) (c-array-dimensions type-b))))
 372
 373 ;; C syntax output protocol.
 374
 375 (defmethod pprint-c-type ((type c-array-type) stream kernel)
 376   (pprint-c-type (c-type-subtype type) stream
 377                  (lambda (stream prio spacep)
 378                    (maybe-in-parens (stream (> prio 2))
 379                      (funcall kernel stream 2 spacep)
 380                      (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
 381                              (c-array-dimensions type))))))
 382
 383 ;; S-expression notation protocol.
 384
 385 (defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
 386   (declare (ignore colon atsign))
 387   (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>"
 388           (c-type-subtype type)
 389           (c-array-dimensions type)))
 390
 391 (export '([] array vec))
 392 (define-c-type-syntax [] (sub &rest dims)
 393   "Return the type of arrays of SUB with the dimensions DIMS.
 394
 395    If the DIMS are omitted, a single unknown-length dimension is added."
 396   `(make-array-type ,(expand-c-type-spec sub)
 397                     (list ,@(or dims '(nil)))))
 398 (c-type-alias [] array vec)
 399
 400 ;;;--------------------------------------------------------------------------
 401 ;;; Function types.
 402
 403 ;; Function arguments.
 404
 405 (defun argument-lists-equal-p (list-a list-b)
 406   "Return whether LIST-A and LIST-B match.
 407
 408    They must have the same number of arguments, and each argument must have
 409    the same type, or be `:ellipsis'.  The argument names are not inspected."
 410   (and (= (length list-a) (length list-b))
 411        (every (lambda (arg-a arg-b)
 412                 (if (eq arg-a :ellipsis)
 413                     (eq arg-b :ellipsis)
 414                     (and (argumentp arg-a) (argumentp arg-b)
 415                          (c-type-equal-p (argument-type arg-a)
 416                                          (argument-type arg-b)))))
 417               list-a list-b)))
 418
 419 (defun fix-and-check-keyword-argument-list (list)
 420   "Check the keyword argument LIST is valid; if so, fix it up and return it.
 421
 422    Check that the keyword arguments have distinct names.  Fix the list up by
 423    sorting it by keyword name."
 424
 425   (unless (every #'argumentp list)
 426     (error "(INTERNAL) not an argument value"))
 427
 428   (let ((list (sort (copy-list list) #'string< :key #'argument-name)))
 429     (do ((list (cdr list) (cdr list))
 430          (this (car list) (car list))
 431          (prev nil this))
 432         ((endp list))
 433       (when prev
 434         (let ((this-name (argument-name this))
 435               (prev-name (argument-name prev)))
 436           (when (string= this-name prev-name)
 437             (error "Duplicate keyword argument name `~A'." this-name)))))
 438     list))
 439
 440 (export 'merge-keyword-lists)
 441 (defun merge-keyword-lists (lists)
 442   "Return the union of keyword argument lists.
 443
 444    The LISTS parameter consists of pairs (ARGS . WHAT), where ARGS is a list
 445    of `argument' objects, and WHAT is either nil or a printable object
 446    describing the origin of the corresponding argument list suitable for
 447    quoting in an error message.
 448
 449    The resulting list contains exactly one argument for each distinct
 450    argument name appearing in the input lists; this argument will contain the
 451    default value corresponding to the name's earliest occurrence in the input
 452    LISTS.
 453
 454    If the same name appears in multiple input lists with different types, an
 455    error is signalled; this error will quote the origins of a representative
 456    conflicting pair of arguments."
 457
 458   ;; The easy way through all of this is with a hash table mapping argument
 459   ;; names to (ARGUMENT . WHAT) pairs.
 460
 461   (let ((argmap (make-hash-table :test #'equal)))
 462
 463     ;; Set up the table.  When we find a duplicate, check that the types
 464     ;; match.
 465     (dolist (item lists)
 466       (let ((args (car item))
 467             (what (cdr item)))
 468         (dolist (arg args)
 469           (let* ((name (argument-name arg))
 470                  (other-item (gethash name argmap)))
 471             (if (null other-item)
 472                 (setf (gethash name argmap) (cons arg what))
 473                 (let* ((type (argument-type arg))
 474                        (other (car other-item))
 475                        (other-type (argument-type other))
 476                        (other-what (cdr other-item)))
 477                   (unless (c-type-equal-p type other-type)
 478                     (error "Type mismatch for keyword argument `~A': ~
 479                             ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]."
 480                            name
 481                            type what
 482                            other-type other-what))))))))
 483
 484     ;; Now it's just a matter of picking the arguments out again.
 485     (let ((result nil))
 486       (maphash (lambda (name item)
 487                  (declare (ignore name))
 488                  (push (car item) result))
 489                argmap)
 490       (fix-and-check-keyword-argument-list result))))
 491
 492 ;; Class definition.
 493
 494 (export '(c-function-type c-function-arguments))
 495 (defclass c-function-type (c-type)
 496   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
 497    (arguments :type list :reader c-function-arguments))
 498   (:documentation
 499    "C function types.  The subtype is the return type, as implied by the C
 500     syntax for function declarations."))
 501
 502 (defmethod shared-initialize :after
 503     ((type c-function-type) slot-names &key (arguments nil argsp))
 504   (declare (ignore slot-names))
 505   (when argsp
 506     (setf (slot-value type 'arguments)
 507           (if (and arguments
 508                    (null (cdr arguments))
 509                    (not (eq (car arguments) :ellipsis))
 510                    (eq (argument-type (car arguments)) c-type-void))
 511               nil
 512               arguments))))
 513
 514 (export '(c-keyword-function-type c-function-keywords))
 515 (defclass c-keyword-function-type (c-function-type)
 516   ((keywords :initarg :keywords :type list
 517              :reader c-function-keywords))
 518   (:documentation
 519    "C function types for `functions' which take keyword arguments."))
 520
 521 (defmethod shared-initialize :after
 522     ((type c-keyword-function-type) slot-names &key (keywords nil keysp))
 523   (declare (ignore slot-names))
 524   (when keysp
 525     (setf (slot-value type 'keywords)
 526           (fix-and-check-keyword-argument-list keywords))))
 527
 528 ;; Constructor function.
 529
 530 (export 'make-function-type)
 531 (defun make-function-type (subtype arguments)
 532   "Return a new function type, returning SUBTYPE and accepting ARGUMENTS.
 533
 534    As a helper for dealing with the S-expression syntax for keyword
 535    functions, if ARGUMENTS has the form (ARGS ... :keys KEYWORDS ...)' then
 536    return a keyword function with arguments (ARGS ...) and keywords (KEYWORDS
 537    ...)."
 538   (let ((split (member :keys arguments)))
 539     (if split
 540         (make-instance 'c-keyword-function-type
 541                        :subtype subtype
 542                        :arguments (ldiff arguments split)
 543                        :keywords (cdr split))
 544         (make-instance 'c-function-type
 545                        :subtype subtype
 546                        :arguments arguments))))
 547
 548 (export 'make-keyword-function-type)
 549 (defun make-keyword-function-type (subtype arguments keywords)
 550   "Return a new keyword-function type, returning SUBTYPE and accepting
 551    ARGUMENTS and KEYWORDS."
 552   (make-instance 'c-keyword-function-type :subtype subtype
 553                  :arguments arguments :keywords keywords))
 554
 555 ;; Comparison protocol.
 556
 557 (defmethod c-type-equal-p and
 558     ((type-a c-function-type) (type-b c-function-type))
 559   (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))
 560        (argument-lists-equal-p (c-function-arguments type-a)
 561                                (c-function-arguments type-b))))
 562
 563 (defmethod c-type-equal-p and
 564     ((type-a c-keyword-function-type) (type-b c-keyword-function-type))
 565   ;; Actually, there's nothing to check here.  I'm happy as long as both
 566   ;; functions notionally accept keyword arguments.
 567   t)
 568
 569 ;; C syntax output protocol.
 570
 571 (export 'pprint-c-function-type)
 572 (defun pprint-c-function-type (return-type stream print-args print-kernel)
 573   "Common top-level printing for function types.
 574
 575    Prints RETURN-TYPE (KERNEL(ARGS)), where RETURN-TYPE is the actual return
 576    type, and ARGS and KERNEL are whatever is printed by the PRINT-ARGS and
 577    PRINT-KERNEL functions.
 578
 579    The PRINT-KERNEL function is the standard such thing for the
 580    `pprint-c-type' protocol; PRINT-ARGS accepts just an output stream."
 581   (pprint-c-type return-type stream
 582                  (lambda (stream prio spacep)
 583                    (maybe-in-parens (stream (> prio 2))
 584                      (when spacep (c-type-space stream))
 585                      (funcall print-kernel stream 2 nil)
 586                      (pprint-indent :block 4 stream)
 587                      (pprint-newline :linear stream)
 588                      (pprint-logical-block
 589                          (stream nil :prefix "(" :suffix ")")
 590                        (funcall print-args stream))))))
 591
 592 (export 'pprint-argument-list)
 593 (defun pprint-argument-list (args stream)
 594   "Print an argument list.
 595
 596    The ARGS is a list of `argument' objects, optionally containing an
 597    `:ellipsis' marker.  The output is written to STREAM.
 598
 599    Returns non-nil if any arguments were actually printed."
 600   (let ((anyp nil))
 601     (pprint-logical-block (stream nil)
 602       (dolist (arg args)
 603         (if anyp
 604             (format stream ", ~_")
 605             (setf anyp t))
 606         (etypecase arg
 607           ((member :ellipsis)
 608            (write-string "..." stream))
 609           (argument
 610            (pprint-logical-block (stream nil)
 611              (pprint-c-type (argument-type arg) stream (argument-name arg))
 612              (let ((default (argument-default arg)))
 613                (when default
 614                  (format stream " = ~2I~_~A" default))))))))
 615     anyp))
 616
 617 (let ((void-arglist (list (make-argument nil c-type-void))))
 618   (defmethod pprint-c-type ((type c-function-type) stream kernel)
 619     (let ((args (or (c-function-arguments type) void-arglist)))
 620       (pprint-c-function-type (c-type-subtype type) stream
 621                               (lambda (stream)
 622                                 (pprint-argument-list args stream))
 623                               kernel))))
 624
 625 (defmethod pprint-c-type ((type c-keyword-function-type) stream kernel)
 626   (let ((args (c-function-arguments type))
 627         (keys (c-function-keywords type)))
 628     (pprint-c-function-type  (c-type-subtype type) stream
 629                                (lambda (stream)
 630                                  (when (pprint-argument-list args stream)
 631                                    (format stream ", ~_"))
 632                                  (write-char #\? stream)
 633                                  (pprint-argument-list keys stream))
 634                                kernel)))
 635
 636 ;; S-expression notation protocol.
 637
 638 (defmethod print-c-type
 639     (stream (type c-function-type) &optional colon atsign)
 640   (declare (ignore colon atsign))
 641   (format stream "~:@<~
 642                   FUN ~@_~:I~
 643                   ~/sod:print-c-type/~:[~; ~]~:*~_~
 644                   ~<~@{~:<~S ~@_~/sod:print-c-type/~:>~^ ~_~}~:>~
 645                   ~:[~2*~; ~_~S ~@_~<~@{~:<~S ~@_~/sod:print-c-type/~
 646                     ~@[ ~@_~S~]~:>~^ ~_~}~:>~]~
 647                   ~:>"
 648           (c-type-subtype type)
 649           (mapcar (lambda (arg)
 650                     (if (eq arg :ellipsis) arg
 651                         (list (argument-name arg) (argument-type arg))))
 652                   (c-function-arguments type))
 653           (typep type 'c-keyword-function-type)
 654           :keys
 655           (and (typep type 'c-keyword-function-type)
 656                (mapcar (lambda (arg)
 657                          (list (argument-name arg)
 658                                (argument-type arg)
 659                                (argument-default arg)))
 660                        (c-function-keywords type)))))
 661
 662 (export '(fun function () func fn))
 663 (define-c-type-syntax fun (ret &rest args)
 664   "Return the type of functions which returns RET and has arguments ARGS.
 665
 666    The ARGS are a list of arguments of the form (NAME TYPE [DEFAULT]).  The
 667    NAME can be NIL to indicate that no name was given.
 668
 669    If an entry isn't a list, it's assumed to be the start of a Lisp
 670    expression to compute the tail of the list; similarly, if the list is
 671    improper, then it's considered to be a complete expression.  The upshot of
 672    this apparently bizarre rule is that you can say
 673
 674      (c-type (fun int (\"foo\" int) . arg-tail))
 675
 676    where ARG-TAIL is (almost) any old Lisp expression and have it tack the
 677    arguments onto the end.  Of course, there don't have to be any explicit
 678    arguments at all.  The only restriction is that the head of the Lisp form
 679    can't be a list -- so ((lambda (...) ...) ...) is out, but you probably
 680    wouldn't type that anyway."
 681
 682   `(make-function-type ,(expand-c-type-spec ret)
 683                        ,(do ((args args (cdr args))
 684                              (list nil
 685                                    (if (keywordp (car args))
 686                                        (cons (car args) list)
 687                                        (let* ((name (caar args))
 688                                               (type (expand-c-type-spec
 689                                                      (cadar args)))
 690                                               (default (and (cddar args)
 691                                                             (caddar args)))
 692                                               (arg `(make-argument
 693                                                      ,name ,type ,default)))
 694                                          (cons arg list)))))
 695                             ((or (atom args)
 696                                  (and (atom (car args))
 697                                       (not (keywordp (car args)))))
 698                              (cond ((and (null args) (null list)) `nil)
 699                                    ((null args) `(list ,@(nreverse list)))
 700                                    ((null list) `,args)
 701                                    (t `(list* ,@(nreverse list) ,args)))))))
 702 (c-type-alias fun function () func fn)
 703
 704 ;; Additional utilities for dealing with functions.
 705
 706 (export 'commentify-argument-names)
 707 (defun commentify-argument-names (arguments)
 708   "Return an argument list with the arguments commentified.
 709
 710    That is, with each argument name passed through
 711    `commentify-argument-name'."
 712   (mapcar (lambda (arg)
 713             (if (eq arg :ellipsis) arg
 714                 (make-argument (commentify-argument-name (argument-name arg))
 715                                (argument-type arg)
 716                                (argument-default arg))))
 717           arguments))
 718
 719 (export 'commentify-function-type)
 720 (defun commentify-function-type (type)
 721   "Return a type like TYPE, but with arguments commentified.
 722
 723    This doesn't recurse into the return type or argument types."
 724   (make-function-type (c-type-subtype type)
 725                       (commentify-argument-names
 726                        (c-function-arguments type))))
 727
 728 (export 'reify-variable-argument-tail)
 729 (defun reify-variable-argument-tail (arguments)
 730   "Replace any `:ellipsis' item in ARGUMENTS with a `va_list' argument.
 731
 732    The argument's name is taken from the variable `*sod-ap*'."
 733   (substitute (make-argument *sod-ap* c-type-va-list) :ellipsis arguments))
 734
 735 ;;;----- That's all, folks --------------------------------------------------