3 ;;; C type representation implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
31 (defparameter *c-type-intern-map* (make-hash-table :test #'equal)
32 "Hash table mapping lists describing types to their distinguished
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))
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.
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))
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)))))
60 (defun check-type-intern-map ()
61 "Sanity check for the type-intern map."
62 (let ((map (make-hash-table)))
64 ;; Pass 1: check that interned types are consistent with their keys.
65 ;; Remember interned types.
66 (maphash (lambda (k v)
68 (let ((ty (apply #'make-instance k)))
69 (assert (c-type-equal-p ty v)))
70 (setf (gethash v map) t)))
73 ;; Pass 2: check that the interned type indicators are correct.
74 (maphash (lambda (k v)
76 (assert (gethash k *c-type-intern-map*)))
78 (maphash (lambda (k v)
80 (when (typep k 'c-type)
81 (assert (gethash k map))))
82 *c-type-intern-map*)))
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.
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
91 (apply (if (if (typep base-types 'sequence)
93 (gethash type *c-type-intern-map*))
95 (gethash base-types *c-type-intern-map*))
96 #'intern-c-type #'make-instance)
100 ;;;--------------------------------------------------------------------------
103 (defmethod c-qualifier-keyword ((qualifier (eql :atomic))) "_Atomic")
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)))
113 ;;;--------------------------------------------------------------------------
114 ;;; Storage specifiers.
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))
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)))
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
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))
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)))
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))))
153 ;;;--------------------------------------------------------------------------
154 ;;; Some storage specifiers.
156 (export 'alignas-storage-specifier)
157 (defclass alignas-storage-specifier ()
158 ((alignment :initarg :alignment :reader spec-alignment)))
161 (define-c-storage-specifier-syntax alignas (alignment)
162 `(make-instance 'alignas-storage-specifier :alignment ,alignment))
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)))
169 (defmethod pprint-c-storage-specifier
170 ((spec alignas-storage-specifier) stream)
171 (format stream "_Alignas(~A)" (spec-alignment spec)))
173 ;;;--------------------------------------------------------------------------
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))
182 "C types with simple forms."))
184 ;; Constructor function and interning.
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
191 :qualifiers (canonify-qualifiers qualifiers)))
193 ;; Comparison protocol.
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)))
199 ;; C syntax output protocol.
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)
206 (funcall kernel stream 0 t)))
208 ;; S-expression notation protocol.
210 (defparameter *simple-type-map* (make-hash-table :test #'equal)
211 "Hash table mapping strings of C syntax to symbolic names.")
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))))
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))))
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)
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 ,(format nil "Return a possibly-qualified `~A' type." (car types))
240 `(make-simple-type ,',(car types) (list ,@quals)))))))
242 (export 'find-simple-c-type)
243 (defun find-simple-c-type (name)
244 "Return the `simple-c-type' with the given NAME, or nil."
245 (aand (gethash name *simple-type-map*)
246 (make-simple-type (gethash it *simple-type-map*))))
250 (define-simple-c-type void "void" :export t)
252 (define-simple-c-type char "char" :export t)
253 (define-simple-c-type (unsigned-char uchar) "unsigned char" :export t)
254 (define-simple-c-type (signed-char schar) "signed char" :export t)
255 (define-simple-c-type wchar-t "wchar_t" :export t)
257 (define-simple-c-type (int signed signed-int sint)
258 ("int" "signed") :export t)
259 (define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t)
261 (define-simple-c-type (short signed-short short-int signed-short-int sshort)
263 (define-simple-c-type (unsigned-short unsigned-short-int ushort)
264 "unsigned short" :export t)
266 (define-simple-c-type (long signed-long long-int signed-long-int slong)
268 (define-simple-c-type (unsigned-long unsigned-long-int ulong)
269 "unsigned long" :export t)
271 (define-simple-c-type (long-long signed-long-long long-long-int
272 signed-long-long-int llong sllong)
273 "long long" :export t)
274 (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
275 "unsigned long long" :export t)
277 (define-simple-c-type float "float" :export t)
278 (define-simple-c-type double "double" :export t)
279 (define-simple-c-type long-double "long double" :export t)
281 (define-simple-c-type bool ("_Bool" "bool") :export t)
283 (define-simple-c-type float-complex "float _Complex" :export t)
284 (define-simple-c-type double-complex "double _Complex" :export t)
285 (define-simple-c-type long-double-complex "long double _Complex" :export t)
287 (define-simple-c-type float-imaginary "float _Imaginary" :export t)
288 (define-simple-c-type double-imaginary "double _Imaginary" :export t)
289 (define-simple-c-type long-double-imaginary
290 "long double _Imaginary" :export t)
292 (define-simple-c-type va-list "va_list" :export t)
293 (define-simple-c-type size-t "size_t" :export t)
294 (define-simple-c-type ptrdiff-t "ptrdiff_t" :export t)
296 (macrolet ((define-cross-product-types (&rest pieces)
298 ,@(mapcar (lambda (row)
299 (let* ((c-name (apply #'concatenate 'string row))
301 (frob-identifier c-name))))
302 `(define-simple-c-type ,lisp-name ,c-name
304 (apply #'cross-product pieces)))))
305 (define-cross-product-types ("int" "uint") ("" "_least" "_fast")
306 ("8" "16" "32" "64") "_t")
307 (define-cross-product-types ("int" "uint") ("ptr" "max") "_t"))
309 ;;;--------------------------------------------------------------------------
310 ;;; Tagged types (enums, structs and unions).
314 (export '(tagged-c-type c-type-tag))
315 (defclass tagged-c-type (qualifiable-c-type)
316 ((tag :initarg :tag :type string :reader c-type-tag))
318 "C types with tags."))
320 ;; Subclass definitions.
322 (export 'c-tagged-type-kind)
323 (defgeneric c-tagged-type-kind (type)
325 "Return the kind of tagged type that TYPE is, as a keyword."))
327 (export 'kind-c-tagged-type)
328 (defgeneric kind-c-tagged-type (kind)
330 "Given a keyword KIND, return the appropriate class name."))
332 (export 'make-c-tagged-type)
333 (defun make-c-tagged-type (kind tag &optional qualifiers)
334 "Return a tagged type with the given KIND (keyword) and TAG (string)."
335 (intern-c-type (kind-c-tagged-type kind)
337 :qualifiers (canonify-qualifiers qualifiers)))
339 (macrolet ((define-tagged-type (kind what)
340 (let* ((type (symbolicate 'c- kind '-type))
341 (keyword (intern (symbol-name kind) :keyword))
342 (constructor (symbolicate 'make- kind '-type)))
344 (export '(,type ,kind ,constructor))
345 (defclass ,type (tagged-c-type) ()
346 (:documentation ,(format nil "C ~A types." what)))
347 (defmethod c-tagged-type-kind ((type ,type))
349 (defmethod kind-c-tagged-type ((kind (eql ',keyword)))
351 (defun ,constructor (tag &optional qualifiers)
352 (intern-c-type ',type :tag tag
353 :qualifiers (canonify-qualifiers
355 (define-c-type-syntax ,kind (tag &rest quals)
356 ,(format nil "Construct ~A type named TAG" what)
357 `(,',constructor ,tag (list ,@quals)))))))
358 (define-tagged-type enum "enumerated")
359 (define-tagged-type struct "structure")
360 (define-tagged-type union "union"))
362 ;; Comparison protocol.
364 (defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type))
365 (string= (c-type-tag type-a) (c-type-tag type-b)))
367 ;; C syntax output protocol.
369 (defmethod pprint-c-type ((type tagged-c-type) stream kernel)
370 (pprint-logical-block (stream nil)
371 (format stream "~{~A ~@_~}~(~A~) ~A"
372 (c-type-qualifier-keywords type)
373 (c-tagged-type-kind type)
375 (funcall kernel stream 0 t)))
377 ;; S-expression notation protocol.
379 (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
380 (declare (ignore colon atsign))
381 (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>"
382 (c-tagged-type-kind type)
384 (c-type-qualifiers type)))
386 ;;;--------------------------------------------------------------------------
391 (export 'c-atomic-type)
392 (defclass c-atomic-type (qualifiable-c-type)
393 ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
394 (:documentation "C atomic types."))
396 ;; Constructor function.
398 (export 'make-atomic-type)
399 (defun make-atomic-type (subtype &optional qualifiers)
400 "Return a (maybe distinguished) atomic type."
401 (make-or-intern-c-type 'c-atomic-type subtype
403 :qualifiers (canonify-qualifiers qualifiers)))
405 ;; Comparison protocol.
407 (defmethod c-type-equal-p and ((type-a c-atomic-type) (type-b c-atomic-type))
408 (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
410 ;; C-syntax output protocol.
412 (defmethod pprint-c-type ((type c-atomic-type) stream kernel)
413 (pprint-logical-block (stream nil)
414 (format stream "~{~A ~@_~}" (c-type-qualifier-keywords type))
415 (write-string "_Atomic(" stream)
416 (pprint-indent :current 0 stream)
417 (pprint-c-type (c-type-subtype type) stream
418 (lambda (stream prio spacep)
419 (declare (ignore stream prio spacep))))
420 (write-char #\) stream)))
422 ;; S-expression notation protocol.
424 (defmethod print-c-type (stream (type c-atomic-type) &optional colon atsign)
425 (declare (ignore colon atsign))
426 (format stream "~:@<ATOMIC ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
427 (c-type-subtype type)
428 (c-type-qualifiers type)))
431 (define-c-type-syntax atomic (sub &rest quals)
432 "Return the type of atomic SUB."
433 `(make-atomic-type ,(expand-c-type-spec sub) (list ,@quals)))
435 ;;;--------------------------------------------------------------------------
440 (export 'c-pointer-type)
441 (defclass c-pointer-type (qualifiable-c-type)
442 ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
443 (:documentation "C pointer types."))
445 ;; Constructor function.
447 (export 'make-pointer-type)
448 (defun make-pointer-type (subtype &optional qualifiers)
449 "Return a (maybe distinguished) pointer type."
450 (make-or-intern-c-type 'c-pointer-type subtype
452 :qualifiers (canonify-qualifiers qualifiers)))
454 ;; Comparison protocol.
456 (defmethod c-type-equal-p and ((type-a c-pointer-type)
457 (type-b c-pointer-type))
458 (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
460 ;; C syntax output protocol.
462 (defmethod pprint-c-type ((type c-pointer-type) stream kernel)
463 (pprint-c-type (c-type-subtype type) stream
464 (lambda (stream prio spacep)
465 (when spacep (c-type-space stream))
466 (maybe-in-parens (stream (> prio 1))
467 (format stream "*~{~A~^ ~@_~}"
468 (c-type-qualifier-keywords type))
469 (funcall kernel stream 1 (c-type-qualifiers type))))))
471 ;; S-expression notation protocol.
473 (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
474 (declare (ignore colon atsign))
475 (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
476 (c-type-subtype type)
477 (c-type-qualifiers type)))
479 (export '(* pointer ptr))
480 (define-c-type-syntax * (sub &rest quals)
481 "Return the type of pointer-to-SUB."
482 `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
483 (c-type-alias * pointer ptr)
487 (export '(string const-string))
488 (defctype string (* char))
489 (defctype const-string (* (char :const)))
491 ;;;--------------------------------------------------------------------------
496 (export '(c-array-type c-array-dimensions))
497 (defclass c-array-type (c-type)
498 ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
499 (dimensions :initarg :dimensions :type list :reader c-array-dimensions))
503 ;; Constructor function.
505 (export 'make-array-type)
506 (defun make-array-type (subtype dimensions)
507 "Return a new array of SUBTYPE with given DIMENSIONS."
508 (make-instance 'c-array-type :subtype subtype
509 :dimensions (or dimensions '(nil))))
511 ;; Comparison protocol.
513 (defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type))
515 ;; Messy. C doesn't have multidimensional arrays, but we fake them for
516 ;; convenience's sake. But it means that we have to arrange for
517 ;; multidimensional arrays to equal vectors of vectors -- and in general
518 ;; for multidimensional arrays of multidimensional arrays to match each
519 ;; other properly, even when their dimensions don't align precisely.
520 (labels ((check (sub-a dim-a sub-b dim-b)
523 (c-type-equal-p sub-a sub-b))
524 ((typep sub-a 'c-array-type)
525 (check (c-type-subtype sub-a)
526 (c-array-dimensions sub-a)
531 (check sub-b dim-b sub-a dim-a))
532 ((equal (car dim-a) (car dim-b))
533 (check sub-a (cdr dim-a) sub-b (cdr dim-b)))
536 (check (c-type-subtype type-a) (c-array-dimensions type-a)
537 (c-type-subtype type-b) (c-array-dimensions type-b))))
539 ;; C syntax output protocol.
541 (defmethod pprint-c-type ((type c-array-type) stream kernel)
542 (pprint-c-type (c-type-subtype type) stream
543 (lambda (stream prio spacep)
544 (maybe-in-parens (stream (> prio 2))
545 (funcall kernel stream 2 spacep)
546 (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
547 (c-array-dimensions type))))))
549 ;; S-expression notation protocol.
551 (defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
552 (declare (ignore colon atsign))
553 (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>"
554 (c-type-subtype type)
555 (c-array-dimensions type)))
557 (export '([] array vec))
558 (define-c-type-syntax [] (sub &rest dims)
559 "Return the type of arrays of SUB with the dimensions DIMS.
561 If the DIMS are omitted, a single unknown-length dimension is added."
562 `(make-array-type ,(expand-c-type-spec sub)
563 (list ,@(or dims '(nil)))))
564 (c-type-alias [] array vec)
566 ;;;--------------------------------------------------------------------------
569 ;; Function arguments.
571 (defun argument-lists-equal-p (list-a list-b)
572 "Return whether LIST-A and LIST-B match.
574 They must have the same number of arguments, and each argument must have
575 the same type, or be `:ellipsis'. The argument names are not inspected."
576 (and (= (length list-a) (length list-b))
577 (every (lambda (arg-a arg-b)
578 (if (eq arg-a :ellipsis)
580 (and (argumentp arg-a) (argumentp arg-b)
581 (c-type-equal-p (argument-type arg-a)
582 (argument-type arg-b)))))
585 (defun fix-and-check-keyword-argument-list (list)
586 "Check the keyword argument LIST is valid; if so, fix it up and return it.
588 Check that the keyword arguments have distinct names. Fix the list up by
589 sorting it by keyword name."
591 (unless (every #'argumentp list)
592 (error "(INTERNAL) not an argument value"))
594 (let ((list (sort (copy-list list) #'string< :key #'argument-name)))
595 (do ((list (cdr list) (cdr list))
596 (this (car list) (car list))
600 (let ((this-name (argument-name this))
601 (prev-name (argument-name prev)))
602 (when (string= this-name prev-name)
603 (error "Duplicate keyword argument name `~A'" this-name)))))
606 (export 'merge-keyword-lists)
607 (defun merge-keyword-lists (whatfn lists)
608 "Return the union of keyword argument lists.
610 The WHATFN is either nil or a designator for a function (see below).
612 The LISTS parameter consists of pairs (REPORTFN . ARGS), where REPORTFN is
613 either nil or a designator for a function (see below); and and ARGS is a
614 list of `argument' objects.
616 The resulting list contains exactly one argument for each distinct
617 argument name appearing in the input lists; this argument will contain the
618 default value corresponding to the name's earliest occurrence in the input
621 If the same name appears in multiple input lists with different types, a
622 continuable error is signalled.
624 The WHATFN function is given no arguments, and is expected to return a
625 file location (or other object convertible with `file-location'), and a
626 string (or other printable object) describing the site at which the
627 keyword argument lists are being merged or nil; a mismatch error will be
628 reported as being at the location returned by WHATFN, and the description
629 will be included in the error message. A nil WHATFN is equivalent to a
630 function which returns a nil location and description, though this is
631 considered poor practice.
633 The REPORTFN is given a single argument ARG, which is one of the
634 conflicting `argument' objects found in the REPORTFN's corresponding
635 argument list: the REPORTFN is expected to issue additional `info'
636 messages to help the user diagnose the problem. The (common) name of the
637 argument has already been reported. A nil REPORTFN is equivalent to one
638 which does nothing, though this is considered poor practice."
640 ;; The easy way through all of this is with a hash table mapping argument
641 ;; names to (WHAT . ARG) pairs.
643 (let ((argmap (make-hash-table :test #'equal)))
645 ;; Set up the table. When we find a duplicate, check that the types
648 (let ((reportfn (car item))
651 (let* ((name (argument-name arg))
652 (other-item (gethash name argmap)))
653 (if (null other-item)
654 (setf (gethash name argmap) (cons reportfn arg))
655 (let* ((type (argument-type arg))
656 (other-reportfn (car other-item))
657 (other (cdr other-item))
658 (other-type (argument-type other)))
659 (unless (c-type-equal-p type other-type)
660 (multiple-value-bind (floc desc)
661 (if whatfn (funcall whatfn) (values nil nil))
662 (cerror*-with-location floc
663 "Type mismatch for keyword ~
664 argument `~A'~@[ in ~A~]"
667 (funcall reportfn arg))
669 (funcall other-reportfn other))))))))))
671 ;; Now it's just a matter of picking the arguments out again.
673 (maphash (lambda (name item)
674 (declare (ignore name))
675 (push (cdr item) result))
677 (fix-and-check-keyword-argument-list result))))
681 (export '(c-function-type c-function-arguments))
682 (defclass c-function-type (c-type)
683 ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
684 (arguments :type list :reader c-function-arguments))
686 "C function types. The subtype is the return type, as implied by the C
687 syntax for function declarations."))
689 (defmethod shared-initialize :after
690 ((type c-function-type) slot-names &key (arguments nil argsp))
691 (declare (ignore slot-names))
693 (setf (slot-value type 'arguments)
695 (null (cdr arguments))
696 (not (eq (car arguments) :ellipsis))
697 (eq (argument-type (car arguments)) c-type-void))
701 (export '(c-keyword-function-type c-function-keywords))
702 (defclass c-keyword-function-type (c-function-type)
703 ((keywords :initarg :keywords :type list
704 :reader c-function-keywords))
706 "C function types for `functions' which take keyword arguments."))
708 (defmethod shared-initialize :after
709 ((type c-keyword-function-type) slot-names &key (keywords nil keysp))
710 (declare (ignore slot-names))
712 (setf (slot-value type 'keywords)
713 (fix-and-check-keyword-argument-list keywords))))
715 ;; Constructor function.
717 (export 'make-function-type)
718 (defun make-function-type (subtype arguments)
719 "Return a new function type, returning SUBTYPE and accepting ARGUMENTS.
721 As a helper for dealing with the S-expression syntax for keyword
722 functions, if ARGUMENTS has the form (ARGS ... :keys KEYWORDS ...)' then
723 return a keyword function with arguments (ARGS ...) and keywords (KEYWORDS
725 (let ((split (member :keys arguments)))
727 (make-instance 'c-keyword-function-type
729 :arguments (ldiff arguments split)
730 :keywords (cdr split))
731 (make-instance 'c-function-type
733 :arguments arguments))))
735 (export 'make-keyword-function-type)
736 (defun make-keyword-function-type (subtype arguments keywords)
737 "Return a new keyword-function type, returning SUBTYPE and accepting
738 ARGUMENTS and KEYWORDS."
739 (make-instance 'c-keyword-function-type :subtype subtype
740 :arguments arguments :keywords keywords))
742 ;; Comparison protocol.
744 (defmethod c-type-equal-p and
745 ((type-a c-function-type) (type-b c-function-type))
746 (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))
747 (argument-lists-equal-p (c-function-arguments type-a)
748 (c-function-arguments type-b))))
750 (defmethod c-type-equal-p and
751 ((type-a c-keyword-function-type) (type-b c-keyword-function-type))
752 ;; Actually, there's nothing to check here. I'm happy as long as both
753 ;; functions notionally accept keyword arguments.
756 ;; C syntax output protocol.
758 (export 'pprint-c-function-type)
759 (defun pprint-c-function-type (return-type stream print-args print-kernel)
760 "Common top-level printing for function types.
762 Prints RETURN-TYPE (KERNEL(ARGS)), where RETURN-TYPE is the actual return
763 type, and ARGS and KERNEL are whatever is printed by the PRINT-ARGS and
764 PRINT-KERNEL functions.
766 The PRINT-KERNEL function is the standard such thing for the
767 `pprint-c-type' protocol; PRINT-ARGS accepts just an output stream."
768 (pprint-c-type return-type stream
769 (lambda (stream prio spacep)
770 (maybe-in-parens (stream (> prio 2))
771 (when spacep (c-type-space stream))
772 (funcall print-kernel stream 2 nil)
773 (pprint-indent :block 4 stream)
774 (pprint-newline :linear stream)
775 (pprint-logical-block
776 (stream nil :prefix "(" :suffix ")")
777 (funcall print-args stream))))))
779 (export 'pprint-argument-list)
780 (defun pprint-argument-list (args stream)
781 "Print an argument list.
783 The ARGS is a list of `argument' objects, optionally containing an
784 `:ellipsis' marker. The output is written to STREAM.
786 Returns non-nil if any arguments were actually printed."
788 (pprint-logical-block (stream nil)
791 (format stream ", ~_")
795 (write-string "..." stream))
797 (pprint-logical-block (stream nil)
798 (pprint-c-type (argument-type arg) stream (argument-name arg))
799 (let ((default (argument-default arg)))
801 (format stream " = ~2I~_~A" default))))))))
804 (let ((void-arglist (list (make-argument nil c-type-void))))
805 (defmethod pprint-c-type ((type c-function-type) stream kernel)
806 (let ((args (or (c-function-arguments type) void-arglist)))
807 (pprint-c-function-type (c-type-subtype type) stream
809 (pprint-argument-list args stream))
812 (defmethod pprint-c-type ((type c-keyword-function-type) stream kernel)
813 (let ((args (c-function-arguments type))
814 (keys (c-function-keywords type)))
815 (pprint-c-function-type (c-type-subtype type) stream
817 (when (pprint-argument-list args stream)
818 (format stream ", ~_"))
819 (write-char #\? stream)
820 (pprint-argument-list keys stream))
823 ;; S-expression notation protocol.
825 (defmethod print-c-type
826 (stream (type c-function-type) &optional colon atsign)
827 (declare (ignore colon atsign))
828 (format stream "~:@<~
830 ~/sod:print-c-type/~:[~; ~]~:*~_~
831 ~<~@{~:<~S ~@_~/sod:print-c-type/~:>~^ ~_~}~:>~
832 ~:[~2*~; ~_~S ~@_~<~@{~:<~S ~@_~/sod:print-c-type/~
833 ~@[ ~@_~S~]~:>~^ ~_~}~:>~]~
835 (c-type-subtype type)
836 (mapcar (lambda (arg)
837 (if (eq arg :ellipsis) arg
838 (list (argument-name arg) (argument-type arg))))
839 (c-function-arguments type))
840 (typep type 'c-keyword-function-type)
842 (and (typep type 'c-keyword-function-type)
843 (mapcar (lambda (arg)
844 (list (argument-name arg)
846 (argument-default arg)))
847 (c-function-keywords type)))))
849 (export '(fun function () func fn))
850 (define-c-type-syntax fun (ret &rest args)
851 "Return the type of functions which returns RET and has arguments ARGS.
853 The ARGS are a list of arguments of the form (NAME TYPE [DEFAULT]). The
854 NAME can be NIL to indicate that no name was given.
856 If an entry isn't a list, it's assumed to be the start of a Lisp
857 expression to compute the tail of the list; similarly, if the list is
858 improper, then it's considered to be a complete expression. The upshot of
859 this apparently bizarre rule is that you can say
861 (c-type (fun int (\"foo\" int) . arg-tail))
863 where ARG-TAIL is (almost) any old Lisp expression and have it tack the
864 arguments onto the end. Of course, there don't have to be any explicit
865 arguments at all. The only restriction is that the head of the Lisp form
866 can't be a list -- so ((lambda (...) ...) ...) is out, but you probably
867 wouldn't type that anyway."
869 `(make-function-type ,(expand-c-type-spec ret)
870 ,(do ((args args (cdr args))
872 (if (keywordp (car args))
873 (cons (car args) list)
874 (let* ((name (caar args))
875 (type (expand-c-type-spec
877 (default (and (cddar args)
880 ,name ,type ,default)))
883 (and (atom (car args))
884 (not (keywordp (car args)))))
885 (cond ((and (null args) (null list)) `nil)
886 ((null args) `(list ,@(nreverse list)))
888 (t `(list* ,@(nreverse list) ,args)))))))
889 (c-type-alias fun function () func fn)
891 ;; Additional utilities for dealing with functions.
893 (export 'commentify-argument-names)
894 (defun commentify-argument-names (arguments)
895 "Return an argument list with the arguments commentified.
897 That is, with each argument name passed through
898 `commentify-argument-name'."
899 (mapcar (lambda (arg)
900 (if (eq arg :ellipsis) arg
901 (make-argument (commentify-argument-name (argument-name arg))
903 (argument-default arg))))
906 (export 'commentify-function-type)
907 (defun commentify-function-type (type)
908 "Return a type like TYPE, but with arguments commentified.
910 This doesn't recurse into the return type or argument types."
911 (make-function-type (c-type-subtype type)
912 (commentify-argument-names
913 (c-function-arguments type))))
915 (export 'reify-variable-argument-tail)
916 (defun reify-variable-argument-tail (arguments)
917 "Replace any `:ellipsis' item in ARGUMENTS with a `va_list' argument.
919 The argument's name is taken from the variable `*sod-ap*'."
920 (substitute (make-argument *sod-ap* c-type-va-list) :ellipsis arguments))
922 ;;;----- That's all, folks --------------------------------------------------