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

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