mdw@git.distorted.org.uk Git - 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 :test #'equal)
 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         (types (if (listp type) type (list type))))
 231     (with-gensyms (type name)
 232       `(progn
 233          (dolist (,type ',types)
 234            (setf (gethash ,type *simple-type-map*) ',(car names)))
 235          (dolist (,name ',names)
 236            (setf (gethash ,name *simple-type-map*) ,(car types)))
 237          (defctype ,names ,(car types) :export ,export)
 238          (define-c-type-syntax ,(car names) (&rest quals)
 239            `(make-simple-type ,',(car types) (list ,@quals)))))))
 240
 241 (export 'find-simple-c-type)
 242 (defun find-simple-c-type (name)
 243   "Return the `simple-c-type' with the given NAME, or nil."
 244   (aand (gethash name *simple-type-map*)
 245         (make-simple-type (gethash it *simple-type-map*))))
 246
 247 ;; Built-in C types.
 248
 249 (define-simple-c-type void "void" :export t)
 250
 251 (define-simple-c-type char "char" :export t)
 252 (define-simple-c-type (unsigned-char uchar) "unsigned char" :export t)
 253 (define-simple-c-type (signed-char schar) "signed char" :export t)
 254 (define-simple-c-type wchar-t "wchar_t" :export t)
 255
 256 (define-simple-c-type (int signed signed-int sint)
 257   ("int" "signed") :export t)
 258 (define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t)
 259
 260 (define-simple-c-type (short signed-short short-int signed-short-int sshort)
 261   "short" :export t)
 262 (define-simple-c-type (unsigned-short unsigned-short-int ushort)
 263   "unsigned short" :export t)
 264
 265 (define-simple-c-type (long signed-long long-int signed-long-int slong)
 266   "long" :export t)
 267 (define-simple-c-type (unsigned-long unsigned-long-int ulong)
 268   "unsigned long" :export t)
 269
 270 (define-simple-c-type (long-long signed-long-long long-long-int
 271                        signed-long-long-int llong sllong)
 272   "long long" :export t)
 273 (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
 274   "unsigned long long" :export t)
 275
 276 (define-simple-c-type float "float" :export t)
 277 (define-simple-c-type double "double" :export t)
 278 (define-simple-c-type long-double "long double" :export t)
 279
 280 (define-simple-c-type bool ("_Bool" "bool") :export t)
 281
 282 (define-simple-c-type float-complex "float _Complex" :export t)
 283 (define-simple-c-type double-complex "double _Complex" :export t)
 284 (define-simple-c-type long-double-complex "long double _Complex" :export t)
 285
 286 (define-simple-c-type float-imaginary "float _Imaginary" :export t)
 287 (define-simple-c-type double-imaginary "double _Imaginary" :export t)
 288 (define-simple-c-type long-double-imaginary
 289     "long double _Imaginary" :export t)
 290
 291 (define-simple-c-type va-list "va_list" :export t)
 292 (define-simple-c-type size-t "size_t" :export t)
 293 (define-simple-c-type ptrdiff-t "ptrdiff_t" :export t)
 294
 295 (macrolet ((define-cross-product-types (&rest pieces)
 296              `(progn
 297                 ,@(mapcar (lambda (row)
 298                             (let* ((c-name (apply #'concatenate 'string row))
 299                                    (lisp-name (intern
 300                                                (frob-identifier c-name))))
 301                               `(define-simple-c-type ,lisp-name ,c-name
 302                                                      :export t)))
 303                           (apply #'cross-product pieces)))))
 304   (define-cross-product-types ("int" "uint") ("" "_least" "_fast")
 305                               ("8" "16" "32" "64") "_t")
 306   (define-cross-product-types ("int" "uint") ("ptr" "max") "_t"))
 307
 308 ;;;--------------------------------------------------------------------------
 309 ;;; Tagged types (enums, structs and unions).
 310
 311 ;; Class definition.
 312
 313 (export '(tagged-c-type c-type-tag))
 314 (defclass tagged-c-type (qualifiable-c-type)
 315   ((tag :initarg :tag :type string :reader c-type-tag))
 316   (:documentation
 317    "C types with tags."))
 318
 319 ;; Subclass definitions.
 320
 321 (export 'c-tagged-type-kind)
 322 (defgeneric c-tagged-type-kind (type)
 323   (:documentation
 324    "Return the kind of tagged type that TYPE is, as a keyword."))
 325
 326 (export 'kind-c-tagged-type)
 327 (defgeneric kind-c-tagged-type (kind)
 328   (:documentation
 329    "Given a keyword KIND, return the appropriate class name."))
 330
 331 (export 'make-c-tagged-type)
 332 (defun make-c-tagged-type (kind tag &optional qualifiers)
 333   "Return a tagged type with the given KIND (keyword) and TAG (string)."
 334   (intern-c-type (kind-c-tagged-type kind)
 335                  :tag tag
 336                  :qualifiers (canonify-qualifiers qualifiers)))
 337
 338 (macrolet ((define-tagged-type (kind what)
 339              (let* ((type (symbolicate 'c- kind '-type))
 340                     (keyword (intern (symbol-name kind) :keyword))
 341                     (constructor (symbolicate 'make- kind '-type)))
 342                `(progn
 343                   (export '(,type ,kind ,constructor))
 344                   (defclass ,type (tagged-c-type) ()
 345                     (:documentation ,(format nil "C ~A types." what)))
 346                   (defmethod c-tagged-type-kind ((type ,type))
 347                     ',keyword)
 348                   (defmethod kind-c-tagged-type ((kind (eql ',keyword)))
 349                     ',type)
 350                   (defun ,constructor (tag &optional qualifiers)
 351                     (intern-c-type ',type :tag tag
 352                                    :qualifiers (canonify-qualifiers
 353                                                 qualifiers)))
 354                   (define-c-type-syntax ,kind (tag &rest quals)
 355                     ,(format nil "Construct ~A type named TAG" what)
 356                     `(,',constructor ,tag (list ,@quals)))))))
 357   (define-tagged-type enum "enumerated")
 358   (define-tagged-type struct "structure")
 359   (define-tagged-type union "union"))
 360
 361 ;; Comparison protocol.
 362
 363 (defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type))
 364   (string= (c-type-tag type-a) (c-type-tag type-b)))
 365
 366 ;; C syntax output protocol.
 367
 368 (defmethod pprint-c-type ((type tagged-c-type) stream kernel)
 369   (pprint-logical-block (stream nil)
 370     (format stream "~{~A ~@_~}~(~A~) ~A"
 371             (c-type-qualifier-keywords type)
 372             (c-tagged-type-kind type)
 373             (c-type-tag type))
 374     (funcall kernel stream 0 t)))
 375
 376 ;; S-expression notation protocol.
 377
 378 (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
 379   (declare (ignore colon atsign))
 380   (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>"
 381           (c-tagged-type-kind type)
 382           (c-type-tag type)
 383           (c-type-qualifiers type)))
 384
 385 ;;;--------------------------------------------------------------------------
 386 ;;; Atomic types.
 387
 388 ;; Class definition.
 389
 390 (export 'c-atomic-type)
 391 (defclass c-atomic-type (qualifiable-c-type)
 392   ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
 393   (:documentation "C atomic types."))
 394
 395 ;; Constructor function.
 396
 397 (export 'make-atomic-type)
 398 (defun make-atomic-type (subtype &optional qualifiers)
 399   "Return a (maybe distinguished) atomic type."
 400   (make-or-intern-c-type 'c-atomic-type subtype
 401                          :subtype subtype
 402                          :qualifiers (canonify-qualifiers qualifiers)))
 403
 404 ;; Comparison protocol.
 405
 406 (defmethod c-type-equal-p and ((type-a c-atomic-type) (type-b c-atomic-type))
 407   (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
 408
 409 ;; C-syntax output protocol.
 410
 411 (defmethod pprint-c-type ((type c-atomic-type) stream kernel)
 412   (pprint-logical-block (stream nil)
 413     (format stream "~{~A ~@_~}" (c-type-qualifier-keywords type))
 414     (write-string "_Atomic(" stream)
 415     (pprint-indent :current 0 stream)
 416     (pprint-c-type (c-type-subtype type) stream
 417                    (lambda (stream prio spacep)
 418                      (declare (ignore stream prio spacep))))
 419     (write-char #\) stream)))
 420
 421 ;; S-expression notation protocol.
 422
 423 (defmethod print-c-type (stream (type c-atomic-type) &optional colon atsign)
 424   (declare (ignore colon atsign))
 425   (format stream "~:@<ATOMIC ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
 426           (c-type-subtype type)
 427           (c-type-qualifiers type)))
 428
 429 (export 'atomic)
 430 (define-c-type-syntax atomic (sub &rest quals)
 431   "Return the type of atomic SUB."
 432   `(make-atomic-type ,(expand-c-type-spec sub) (list ,@quals)))
 433
 434 ;;;--------------------------------------------------------------------------
 435 ;;; Pointer types.
 436
 437 ;; Class definition.
 438
 439 (export 'c-pointer-type)
 440 (defclass c-pointer-type (qualifiable-c-type)
 441   ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
 442   (:documentation "C pointer types."))
 443
 444 ;; Constructor function.
 445
 446 (export 'make-pointer-type)
 447 (defun make-pointer-type (subtype &optional qualifiers)
 448   "Return a (maybe distinguished) pointer type."
 449   (make-or-intern-c-type 'c-pointer-type subtype
 450                          :subtype subtype
 451                          :qualifiers (canonify-qualifiers qualifiers)))
 452
 453 ;; Comparison protocol.
 454
 455 (defmethod c-type-equal-p and ((type-a c-pointer-type)
 456                                (type-b c-pointer-type))
 457   (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
 458
 459 ;; C syntax output protocol.
 460
 461 (defmethod pprint-c-type ((type c-pointer-type) stream kernel)
 462   (pprint-c-type (c-type-subtype type) stream
 463                  (lambda (stream prio spacep)
 464                    (when spacep (c-type-space stream))
 465                    (maybe-in-parens (stream (> prio 1))
 466                      (format stream "*~{~A~^ ~@_~}"
 467                              (c-type-qualifier-keywords type))
 468                      (funcall kernel stream 1 (c-type-qualifiers type))))))
 469
 470 ;; S-expression notation protocol.
 471
 472 (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
 473   (declare (ignore colon atsign))
 474   (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
 475           (c-type-subtype type)
 476           (c-type-qualifiers type)))
 477
 478 (export '(* pointer ptr))
 479 (define-c-type-syntax * (sub &rest quals)
 480   "Return the type of pointer-to-SUB."
 481   `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
 482 (c-type-alias * pointer ptr)
 483
 484 ;; Built-in C types.
 485
 486 (export '(string const-string))
 487 (defctype string (* char))
 488 (defctype const-string (* (char :const)))
 489
 490 ;;;--------------------------------------------------------------------------
 491 ;;; Array types.
 492
 493 ;; Class definition.
 494
 495 (export '(c-array-type c-array-dimensions))
 496 (defclass c-array-type (c-type)
 497   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
 498    (dimensions :initarg :dimensions :type list :reader c-array-dimensions))
 499   (:documentation
 500    "C array types."))
 501
 502 ;; Constructor function.
 503
 504 (export 'make-array-type)
 505 (defun make-array-type (subtype dimensions)
 506   "Return a new array of SUBTYPE with given DIMENSIONS."
 507   (make-instance 'c-array-type :subtype subtype
 508                  :dimensions (or dimensions '(nil))))
 509
 510 ;; Comparison protocol.
 511
 512 (defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type))
 513
 514   ;; Messy.  C doesn't have multidimensional arrays, but we fake them for
 515   ;; convenience's sake.  But it means that we have to arrange for
 516   ;; multidimensional arrays to equal vectors of vectors -- and in general
 517   ;; for multidimensional arrays of multidimensional arrays to match each
 518   ;; other properly, even when their dimensions don't align precisely.
 519   (labels ((check (sub-a dim-a sub-b dim-b)
 520              (cond ((endp dim-a)
 521                     (cond ((endp dim-b)
 522                            (c-type-equal-p sub-a sub-b))
 523                           ((typep sub-a 'c-array-type)
 524                            (check (c-type-subtype sub-a)
 525                                   (c-array-dimensions sub-a)
 526                                   sub-b dim-b))
 527                           (t
 528                            nil)))
 529                    ((endp dim-b)
 530                     (check sub-b dim-b sub-a dim-a))
 531                    ((equal (car dim-a) (car dim-b))
 532                     (check sub-a (cdr dim-a) sub-b (cdr dim-b)))
 533                    (t
 534                     nil))))
 535     (check (c-type-subtype type-a) (c-array-dimensions type-a)
 536            (c-type-subtype type-b) (c-array-dimensions type-b))))
 537
 538 ;; C syntax output protocol.
 539
 540 (defmethod pprint-c-type ((type c-array-type) stream kernel)
 541   (pprint-c-type (c-type-subtype type) stream
 542                  (lambda (stream prio spacep)
 543                    (maybe-in-parens (stream (> prio 2))
 544                      (funcall kernel stream 2 spacep)
 545                      (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
 546                              (c-array-dimensions type))))))
 547
 548 ;; S-expression notation protocol.
 549
 550 (defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
 551   (declare (ignore colon atsign))
 552   (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>"
 553           (c-type-subtype type)
 554           (c-array-dimensions type)))
 555
 556 (export '([] array vec))
 557 (define-c-type-syntax [] (sub &rest dims)
 558   "Return the type of arrays of SUB with the dimensions DIMS.
 559
 560    If the DIMS are omitted, a single unknown-length dimension is added."
 561   `(make-array-type ,(expand-c-type-spec sub)
 562                     (list ,@(or dims '(nil)))))
 563 (c-type-alias [] array vec)
 564
 565 ;;;--------------------------------------------------------------------------
 566 ;;; Function types.
 567
 568 ;; Function arguments.
 569
 570 (defun argument-lists-equal-p (list-a list-b)
 571   "Return whether LIST-A and LIST-B match.
 572
 573    They must have the same number of arguments, and each argument must have
 574    the same type, or be `:ellipsis'.  The argument names are not inspected."
 575   (and (= (length list-a) (length list-b))
 576        (every (lambda (arg-a arg-b)
 577                 (if (eq arg-a :ellipsis)
 578                     (eq arg-b :ellipsis)
 579                     (and (argumentp arg-a) (argumentp arg-b)
 580                          (c-type-equal-p (argument-type arg-a)
 581                                          (argument-type arg-b)))))
 582               list-a list-b)))
 583
 584 (defun fix-and-check-keyword-argument-list (list)
 585   "Check the keyword argument LIST is valid; if so, fix it up and return it.
 586
 587    Check that the keyword arguments have distinct names.  Fix the list up by
 588    sorting it by keyword name."
 589
 590   (unless (every #'argumentp list)
 591     (error "(INTERNAL) not an argument value"))
 592
 593   (let ((list (sort (copy-list list) #'string< :key #'argument-name)))
 594     (do ((list (cdr list) (cdr list))
 595          (this (car list) (car list))
 596          (prev nil this))
 597         ((endp list))
 598       (when prev
 599         (let ((this-name (argument-name this))
 600               (prev-name (argument-name prev)))
 601           (when (string= this-name prev-name)
 602             (error "Duplicate keyword argument name `~A'" this-name)))))
 603     list))
 604
 605 (export 'merge-keyword-lists)
 606 (defun merge-keyword-lists (whatfn lists)
 607   "Return the union of keyword argument lists.
 608
 609    The WHATFN is either nil or a designator for a function (see below).
 610
 611    The LISTS parameter consists of pairs (REPORTFN . ARGS), where REPORTFN is
 612    either nil or a designator for a function (see below); and and ARGS is a
 613    list of `argument' objects.
 614
 615    The resulting list contains exactly one argument for each distinct
 616    argument name appearing in the input lists; this argument will contain the
 617    default value corresponding to the name's earliest occurrence in the input
 618    LISTS.
 619
 620    If the same name appears in multiple input lists with different types, a
 621    continuable error is signalled.
 622
 623    The WHATFN function is given no arguments, and is expected to return a
 624    file location (or other object convertible with `file-location'), and a
 625    string (or other printable object) describing the site at which the
 626    keyword argument lists are being merged or nil; a mismatch error will be
 627    reported as being at the location returned by WHATFN, and the description
 628    will be included in the error message.  A nil WHATFN is equivalent to a
 629    function which returns a nil location and description, though this is
 630    considered poor practice.
 631
 632    The REPORTFN is given a single argument ARG, which is one of the
 633    conflicting `argument' objects found in the REPORTFN's corresponding
 634    argument list: the REPORTFN is expected to issue additional `info'
 635    messages to help the user diagnose the problem.  The (common) name of the
 636    argument has already been reported.  A nil REPORTFN is equivalent to one
 637    which does nothing, though this is considered poor practice."
 638
 639   ;; The easy way through all of this is with a hash table mapping argument
 640   ;; names to (WHAT . ARG) pairs.
 641
 642   (let ((argmap (make-hash-table :test #'equal)))
 643
 644     ;; Set up the table.  When we find a duplicate, check that the types
 645     ;; match.
 646     (dolist (item lists)
 647       (let ((reportfn (car item))
 648             (args (cdr item)))
 649         (dolist (arg args)
 650           (let* ((name (argument-name arg))
 651                  (other-item (gethash name argmap)))
 652             (if (null other-item)
 653                 (setf (gethash name argmap) (cons reportfn arg))
 654                 (let* ((type (argument-type arg))
 655                        (other-reportfn (car other-item))
 656                        (other (cdr other-item))
 657                        (other-type (argument-type other)))
 658                   (unless (c-type-equal-p type other-type)
 659                     (multiple-value-bind (floc desc)
 660                         (if whatfn (funcall whatfn) (values nil nil))
 661                       (cerror*-with-location floc
 662                                              "Type mismatch for keyword ~
 663                                               argument `~A'~@[ in ~A~]"
 664                                              name desc)
 665                       (when reportfn
 666                         (funcall reportfn arg))
 667                       (when other-reportfn
 668                         (funcall other-reportfn other))))))))))
 669
 670     ;; Now it's just a matter of picking the arguments out again.
 671     (let ((result nil))
 672       (maphash (lambda (name item)
 673                  (declare (ignore name))
 674                  (push (cdr item) result))
 675                argmap)
 676       (fix-and-check-keyword-argument-list result))))
 677
 678 ;; Class definition.
 679
 680 (export '(c-function-type c-function-arguments))
 681 (defclass c-function-type (c-type)
 682   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
 683    (arguments :type list :reader c-function-arguments))
 684   (:documentation
 685    "C function types.  The subtype is the return type, as implied by the C
 686     syntax for function declarations."))
 687
 688 (defmethod shared-initialize :after
 689     ((type c-function-type) slot-names &key (arguments nil argsp))
 690   (declare (ignore slot-names))
 691   (when argsp
 692     (setf (slot-value type 'arguments)
 693           (if (and arguments
 694                    (null (cdr arguments))
 695                    (not (eq (car arguments) :ellipsis))
 696                    (eq (argument-type (car arguments)) c-type-void))
 697               nil
 698               arguments))))
 699
 700 (export '(c-keyword-function-type c-function-keywords))
 701 (defclass c-keyword-function-type (c-function-type)
 702   ((keywords :initarg :keywords :type list
 703              :reader c-function-keywords))
 704   (:documentation
 705    "C function types for `functions' which take keyword arguments."))
 706
 707 (defmethod shared-initialize :after
 708     ((type c-keyword-function-type) slot-names &key (keywords nil keysp))
 709   (declare (ignore slot-names))
 710   (when keysp
 711     (setf (slot-value type 'keywords)
 712           (fix-and-check-keyword-argument-list keywords))))
 713
 714 ;; Constructor function.
 715
 716 (export 'make-function-type)
 717 (defun make-function-type (subtype arguments)
 718   "Return a new function type, returning SUBTYPE and accepting ARGUMENTS.
 719
 720    As a helper for dealing with the S-expression syntax for keyword
 721    functions, if ARGUMENTS has the form (ARGS ... :keys KEYWORDS ...)' then
 722    return a keyword function with arguments (ARGS ...) and keywords (KEYWORDS
 723    ...)."
 724   (let ((split (member :keys arguments)))
 725     (if split
 726         (make-instance 'c-keyword-function-type
 727                        :subtype subtype
 728                        :arguments (ldiff arguments split)
 729                        :keywords (cdr split))
 730         (make-instance 'c-function-type
 731                        :subtype subtype
 732                        :arguments arguments))))
 733
 734 (export 'make-keyword-function-type)
 735 (defun make-keyword-function-type (subtype arguments keywords)
 736   "Return a new keyword-function type, returning SUBTYPE and accepting
 737    ARGUMENTS and KEYWORDS."
 738   (make-instance 'c-keyword-function-type :subtype subtype
 739                  :arguments arguments :keywords keywords))
 740
 741 ;; Comparison protocol.
 742
 743 (defmethod c-type-equal-p and
 744     ((type-a c-function-type) (type-b c-function-type))
 745   (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))
 746        (argument-lists-equal-p (c-function-arguments type-a)
 747                                (c-function-arguments type-b))))
 748
 749 (defmethod c-type-equal-p and
 750     ((type-a c-keyword-function-type) (type-b c-keyword-function-type))
 751   ;; Actually, there's nothing to check here.  I'm happy as long as both
 752   ;; functions notionally accept keyword arguments.
 753   t)
 754
 755 ;; C syntax output protocol.
 756
 757 (export 'pprint-c-function-type)
 758 (defun pprint-c-function-type (return-type stream print-args print-kernel)
 759   "Common top-level printing for function types.
 760
 761    Prints RETURN-TYPE (KERNEL(ARGS)), where RETURN-TYPE is the actual return
 762    type, and ARGS and KERNEL are whatever is printed by the PRINT-ARGS and
 763    PRINT-KERNEL functions.
 764
 765    The PRINT-KERNEL function is the standard such thing for the
 766    `pprint-c-type' protocol; PRINT-ARGS accepts just an output stream."
 767   (pprint-c-type return-type stream
 768                  (lambda (stream prio spacep)
 769                    (maybe-in-parens (stream (> prio 2))
 770                      (when spacep (c-type-space stream))
 771                      (funcall print-kernel stream 2 nil)
 772                      (pprint-indent :block 4 stream)
 773                      (pprint-newline :linear stream)
 774                      (pprint-logical-block
 775                          (stream nil :prefix "(" :suffix ")")
 776                        (funcall print-args stream))))))
 777
 778 (export 'pprint-argument-list)
 779 (defun pprint-argument-list (args stream)
 780   "Print an argument list.
 781
 782    The ARGS is a list of `argument' objects, optionally containing an
 783    `:ellipsis' marker.  The output is written to STREAM.
 784
 785    Returns non-nil if any arguments were actually printed."
 786   (let ((anyp nil))
 787     (pprint-logical-block (stream nil)
 788       (dolist (arg args)
 789         (if anyp
 790             (format stream ", ~_")
 791             (setf anyp t))
 792         (etypecase arg
 793           ((member :ellipsis)
 794            (write-string "..." stream))
 795           (argument
 796            (pprint-logical-block (stream nil)
 797              (pprint-c-type (argument-type arg) stream (argument-name arg))
 798              (let ((default (argument-default arg)))
 799                (when default
 800                  (format stream " = ~2I~_~A" default))))))))
 801     anyp))
 802
 803 (let ((void-arglist (list (make-argument nil c-type-void))))
 804   (defmethod pprint-c-type ((type c-function-type) stream kernel)
 805     (let ((args (or (c-function-arguments type) void-arglist)))
 806       (pprint-c-function-type (c-type-subtype type) stream
 807                               (lambda (stream)
 808                                 (pprint-argument-list args stream))
 809                               kernel))))
 810
 811 (defmethod pprint-c-type ((type c-keyword-function-type) stream kernel)
 812   (let ((args (c-function-arguments type))
 813         (keys (c-function-keywords type)))
 814     (pprint-c-function-type  (c-type-subtype type) stream
 815                                (lambda (stream)
 816                                  (when (pprint-argument-list args stream)
 817                                    (format stream ", ~_"))
 818                                  (write-char #\? stream)
 819                                  (pprint-argument-list keys stream))
 820                                kernel)))
 821
 822 ;; S-expression notation protocol.
 823
 824 (defmethod print-c-type
 825     (stream (type c-function-type) &optional colon atsign)
 826   (declare (ignore colon atsign))
 827   (format stream "~:@<~
 828                   FUN ~@_~:I~
 829                   ~/sod:print-c-type/~:[~; ~]~:*~_~
 830                   ~<~@{~:<~S ~@_~/sod:print-c-type/~:>~^ ~_~}~:>~
 831                   ~:[~2*~; ~_~S ~@_~<~@{~:<~S ~@_~/sod:print-c-type/~
 832                     ~@[ ~@_~S~]~:>~^ ~_~}~:>~]~
 833                   ~:>"
 834           (c-type-subtype type)
 835           (mapcar (lambda (arg)
 836                     (if (eq arg :ellipsis) arg
 837                         (list (argument-name arg) (argument-type arg))))
 838                   (c-function-arguments type))
 839           (typep type 'c-keyword-function-type)
 840           :keys
 841           (and (typep type 'c-keyword-function-type)
 842                (mapcar (lambda (arg)
 843                          (list (argument-name arg)
 844                                (argument-type arg)
 845                                (argument-default arg)))
 846                        (c-function-keywords type)))))
 847
 848 (export '(fun function () func fn))
 849 (define-c-type-syntax fun (ret &rest args)
 850   "Return the type of functions which returns RET and has arguments ARGS.
 851
 852    The ARGS are a list of arguments of the form (NAME TYPE [DEFAULT]).  The
 853    NAME can be NIL to indicate that no name was given.
 854
 855    If an entry isn't a list, it's assumed to be the start of a Lisp
 856    expression to compute the tail of the list; similarly, if the list is
 857    improper, then it's considered to be a complete expression.  The upshot of
 858    this apparently bizarre rule is that you can say
 859
 860      (c-type (fun int (\"foo\" int) . arg-tail))
 861
 862    where ARG-TAIL is (almost) any old Lisp expression and have it tack the
 863    arguments onto the end.  Of course, there don't have to be any explicit
 864    arguments at all.  The only restriction is that the head of the Lisp form
 865    can't be a list -- so ((lambda (...) ...) ...) is out, but you probably
 866    wouldn't type that anyway."
 867
 868   `(make-function-type ,(expand-c-type-spec ret)
 869                        ,(do ((args args (cdr args))
 870                              (list nil
 871                                    (if (keywordp (car args))
 872                                        (cons (car args) list)
 873                                        (let* ((name (caar args))
 874                                               (type (expand-c-type-spec
 875                                                      (cadar args)))
 876                                               (default (and (cddar args)
 877                                                             (caddar args)))
 878                                               (arg `(make-argument
 879                                                      ,name ,type ,default)))
 880                                          (cons arg list)))))
 881                             ((or (atom args)
 882                                  (and (atom (car args))
 883                                       (not (keywordp (car args)))))
 884                              (cond ((and (null args) (null list)) `nil)
 885                                    ((null args) `(list ,@(nreverse list)))
 886                                    ((null list) `,args)
 887                                    (t `(list* ,@(nreverse list) ,args)))))))
 888 (c-type-alias fun function () func fn)
 889
 890 ;; Additional utilities for dealing with functions.
 891
 892 (export 'commentify-argument-names)
 893 (defun commentify-argument-names (arguments)
 894   "Return an argument list with the arguments commentified.
 895
 896    That is, with each argument name passed through
 897    `commentify-argument-name'."
 898   (mapcar (lambda (arg)
 899             (if (eq arg :ellipsis) arg
 900                 (make-argument (commentify-argument-name (argument-name arg))
 901                                (argument-type arg)
 902                                (argument-default arg))))
 903           arguments))
 904
 905 (export 'commentify-function-type)
 906 (defun commentify-function-type (type)
 907   "Return a type like TYPE, but with arguments commentified.
 908
 909    This doesn't recurse into the return type or argument types."
 910   (make-function-type (c-type-subtype type)
 911                       (commentify-argument-names
 912                        (c-function-arguments type))))
 913
 914 (export 'reify-variable-argument-tail)
 915 (defun reify-variable-argument-tail (arguments)
 916   "Replace any `:ellipsis' item in ARGUMENTS with a `va_list' argument.
 917
 918    The argument's name is taken from the variable `*sod-ap*'."
 919   (substitute (make-argument *sod-ap* c-type-va-list) :ellipsis arguments))
 920
 921 ;;;----- That's all, folks --------------------------------------------------