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