(assert (gethash k map))))
*c-type-intern-map*)))
+(defun make-or-intern-c-type (new-type-class base-types &rest initargs)
+ "Return a possibly-new instance of NEW-TYPE-CLASS with the given INITARGS.
+
+ If all of the BASE-TYPES are interned, then use `intern-c-type' to
+ construct the new type; otherwise just make a new one with
+ `make-instance'. BASE-TYPES may be a singleton type, or a sequence of
+ types."
+ (apply (if (if (typep base-types 'sequence)
+ (every (lambda (type)
+ (gethash type *c-type-intern-map*))
+ base-types)
+ (gethash base-types *c-type-intern-map*))
+ #'intern-c-type #'make-instance)
+ new-type-class
+ initargs))
+
+;;;--------------------------------------------------------------------------
+;;; Qualifiers.
+
+(defmethod c-qualifier-keyword ((qualifier (eql :atomic))) "_Atomic")
+
(defmethod qualify-c-type ((type qualifiable-c-type) qualifiers)
(let ((initargs (instance-initargs type)))
(remf initargs :qualifiers)
- (apply (if (gethash type *c-type-intern-map*)
- #'intern-c-type #'make-instance)
- (class-of type)
+ (apply #'make-or-intern-c-type (class-of type) type
:qualifiers (canonify-qualifiers
(append qualifiers (c-type-qualifiers type)))
initargs)))
+;;;--------------------------------------------------------------------------
+;;; Storage specifiers.
+
+(defmethod c-type-equal-p :around
+ ((type-a c-storage-specifiers-type) (type-b c-type))
+ "Ignore storage specifiers when comparing C types."
+ (c-type-equal-p (c-type-subtype type-a) type-b))
+
+(defmethod c-type-equal-p :around
+ ((type-a c-type) (type-b c-storage-specifiers-type))
+ "Ignore storage specifiers when comparing C types."
+ (c-type-equal-p type-a (c-type-subtype type-b)))
+
+(defun make-storage-specifiers-type (subtype specifiers)
+ "Construct a type based on SUBTYPE, carrying the storage SPECIFIERS."
+ (if (null specifiers) subtype
+ (make-or-intern-c-type 'c-storage-specifiers-type subtype
+ :specifiers specifiers
+ :subtype subtype)))
+
+(defmethod pprint-c-type ((type c-storage-specifiers-type) stream kernel)
+ (dolist (spec (c-type-specifiers type))
+ (pprint-c-storage-specifier spec stream)
+ (write-char #\space stream)
+ (pprint-newline :miser stream))
+ (pprint-c-type (c-type-subtype type) stream kernel))
+
+(defmethod print-c-type
+ (stream (type c-storage-specifiers-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream "~:@<SPECS ~@_~:I~/sod:print-c-type/~
+ ~{ ~_~/sod:print-c-storage-specifier/~}~:>"
+ (c-type-subtype type) (c-type-specifiers type)))
+
+(export 'specs)
+(define-c-type-syntax specs (subtype &rest specifiers)
+ `(make-storage-specifiers-type
+ ,(expand-c-type-spec subtype)
+ (list ,@(mapcar #'expand-c-storage-specifier specifiers))))
+
+;;;--------------------------------------------------------------------------
+;;; Some storage specifiers.
+
+(export 'alignas-storage-specifier)
+(defclass alignas-storage-specifier ()
+ ((alignment :initarg :alignment :reader spec-alignment)))
+
+(export 'alignas)
+(define-c-storage-specifier-syntax alignas (alignment)
+ `(make-instance 'alignas-storage-specifier :alignment ,alignment))
+
+(defmethod print-c-storage-specifier
+ (stream (spec alignas-storage-specifier) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream "~:@<~S ~_~S~:>" 'alignas (spec-alignment spec)))
+
+(defmethod pprint-c-storage-specifier
+ ((spec alignas-storage-specifier) stream)
+ (format stream "_Alignas(~A)" (spec-alignment spec)))
+
;;;--------------------------------------------------------------------------
;;; Simple C types.
(defmethod pprint-c-type ((type simple-c-type) stream kernel)
(pprint-logical-block (stream nil)
- (format stream "~{~(~A~) ~@_~}~A"
- (c-type-qualifiers type)
+ (format stream "~{~A ~@_~}~A"
+ (c-type-qualifier-keywords type)
(c-type-name type))
(funcall kernel stream 0 t)))
(define-simple-c-type char "char" :export t)
(define-simple-c-type (unsigned-char uchar) "unsigned char" :export t)
(define-simple-c-type (signed-char schar) "signed char" :export t)
-(define-simple-c-type wchar-t "wchar-t" :export t)
+(define-simple-c-type wchar-t "wchar_t" :export t)
(define-simple-c-type (int signed signed-int sint) "int" :export t)
(define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t)
(defmethod pprint-c-type ((type tagged-c-type) stream kernel)
(pprint-logical-block (stream nil)
- (format stream "~{~(~A~) ~@_~}~(~A~) ~A"
- (c-type-qualifiers type)
+ (format stream "~{~A ~@_~}~(~A~) ~A"
+ (c-type-qualifier-keywords type)
(c-tagged-type-kind type)
(c-type-tag type))
(funcall kernel stream 0 t)))
(c-type-tag type)
(c-type-qualifiers type)))
+;;;--------------------------------------------------------------------------
+;;; Atomic types.
+
+;; Class definition.
+
+(export 'c-atomic-type)
+(defclass c-atomic-type (qualifiable-c-type)
+ ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
+ (:documentation "C atomic types."))
+
+;; Constructor function.
+
+(export 'make-atomic-type)
+(defun make-atomic-type (subtype &optional qualifiers)
+ "Return a (maybe distinguished) atomic type."
+ (make-or-intern-c-type 'c-atomic-type subtype
+ :subtype subtype
+ :qualifiers (canonify-qualifiers qualifiers)))
+
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and ((type-a c-atomic-type) (type-b c-atomic-type))
+ (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
+
+;; C-syntax output protocol.
+
+(defmethod pprint-c-type ((type c-atomic-type) stream kernel)
+ (pprint-logical-block (stream nil)
+ (format stream "~{~A ~@_~}" (c-type-qualifier-keywords type))
+ (write-string "_Atomic(" stream)
+ (pprint-indent :current 0 stream)
+ (pprint-c-type (c-type-subtype type) stream
+ (lambda (stream prio spacep)
+ (declare (ignore stream prio spacep))))
+ (write-char #\) stream)))
+
+;; S-expression notation protocol.
+
+(defmethod print-c-type (stream (type c-atomic-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream "~:@<ATOMIC ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
+ (c-type-subtype type)
+ (c-type-qualifiers type)))
+
+(export 'atomic)
+(define-c-type-syntax atomic (sub &rest quals)
+ "Return the type of atomic SUB."
+ `(make-atomic-type ,(expand-c-type-spec sub) (list ,@quals)))
+
;;;--------------------------------------------------------------------------
;;; Pointer types.
(export 'make-pointer-type)
(defun make-pointer-type (subtype &optional qualifiers)
"Return a (maybe distinguished) pointer type."
- (let ((canonical (canonify-qualifiers qualifiers)))
- (funcall (if (gethash subtype *c-type-intern-map*)
- #'intern-c-type #'make-instance)
- 'c-pointer-type
- :subtype subtype
- :qualifiers canonical)))
+ (make-or-intern-c-type 'c-pointer-type subtype
+ :subtype subtype
+ :qualifiers (canonify-qualifiers qualifiers)))
;; Comparison protocol.
(lambda (stream prio spacep)
(when spacep (c-type-space stream))
(maybe-in-parens (stream (> prio 1))
- (format stream "*~{~(~A~)~^ ~@_~}"
- (c-type-qualifiers type))
+ (format stream "*~{~A~^ ~@_~}"
+ (c-type-qualifier-keywords type))
(funcall kernel stream 1 (c-type-qualifiers type))))))
;; S-expression notation protocol.
(argument-type arg-b)))))
list-a list-b)))
+(defun fix-and-check-keyword-argument-list (list)
+ "Check the keyword argument LIST is valid; if so, fix it up and return it.
+
+ Check that the keyword arguments have distinct names. Fix the list up by
+ sorting it by keyword name."
+
+ (unless (every #'argumentp list)
+ (error "(INTERNAL) not an argument value"))
+
+ (let ((list (sort (copy-list list) #'string< :key #'argument-name)))
+ (do ((list (cdr list) (cdr list))
+ (this (car list) (car list))
+ (prev nil this))
+ ((endp list))
+ (when prev
+ (let ((this-name (argument-name this))
+ (prev-name (argument-name prev)))
+ (when (string= this-name prev-name)
+ (error "Duplicate keyword argument name `~A'." this-name)))))
+ list))
+
+(export 'merge-keyword-lists)
+(defun merge-keyword-lists (lists)
+ "Return the union of keyword argument lists.
+
+ The LISTS parameter consists of pairs (ARGS . WHAT), where ARGS is a list
+ of `argument' objects, and WHAT is either nil or a printable object
+ describing the origin of the corresponding argument list suitable for
+ quoting in an error message.
+
+ The resulting list contains exactly one argument for each distinct
+ argument name appearing in the input lists; this argument will contain the
+ default value corresponding to the name's earliest occurrence in the input
+ LISTS.
+
+ If the same name appears in multiple input lists with different types, an
+ error is signalled; this error will quote the origins of a representative
+ conflicting pair of arguments."
+
+ ;; The easy way through all of this is with a hash table mapping argument
+ ;; names to (ARGUMENT . WHAT) pairs.
+
+ (let ((argmap (make-hash-table :test #'equal)))
+
+ ;; Set up the table. When we find a duplicate, check that the types
+ ;; match.
+ (dolist (item lists)
+ (let ((args (car item))
+ (what (cdr item)))
+ (dolist (arg args)
+ (let* ((name (argument-name arg))
+ (other-item (gethash name argmap)))
+ (if (null other-item)
+ (setf (gethash name argmap) (cons arg what))
+ (let* ((type (argument-type arg))
+ (other (car other-item))
+ (other-type (argument-type other))
+ (other-what (cdr other-item)))
+ (unless (c-type-equal-p type other-type)
+ (error "Type mismatch for keyword argument `~A': ~
+ ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]."
+ name
+ type what
+ other-type other-what))))))))
+
+ ;; Now it's just a matter of picking the arguments out again.
+ (let ((result nil))
+ (maphash (lambda (name item)
+ (declare (ignore name))
+ (push (car item) result))
+ argmap)
+ (fix-and-check-keyword-argument-list result))))
+
;; Class definition.
(export '(c-function-type c-function-arguments))
nil
arguments))))
+(export '(c-keyword-function-type c-function-keywords))
+(defclass c-keyword-function-type (c-function-type)
+ ((keywords :initarg :keywords :type list
+ :reader c-function-keywords))
+ (:documentation
+ "C function types for `functions' which take keyword arguments."))
+
+(defmethod shared-initialize :after
+ ((type c-keyword-function-type) slot-names &key (keywords nil keysp))
+ (declare (ignore slot-names))
+ (when keysp
+ (setf (slot-value type 'keywords)
+ (fix-and-check-keyword-argument-list keywords))))
+
;; Constructor function.
(export 'make-function-type)
(defun make-function-type (subtype arguments)
- "Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
- (make-instance 'c-function-type :subtype subtype
- :arguments arguments))
+ "Return a new function type, returning SUBTYPE and accepting ARGUMENTS.
+
+ As a helper for dealing with the S-expression syntax for keyword
+ functions, if ARGUMENTS has the form (ARGS ... :keys KEYWORDS ...)' then
+ return a keyword function with arguments (ARGS ...) and keywords (KEYWORDS
+ ...)."
+ (let ((split (member :keys arguments)))
+ (if split
+ (make-instance 'c-keyword-function-type
+ :subtype subtype
+ :arguments (ldiff arguments split)
+ :keywords (cdr split))
+ (make-instance 'c-function-type
+ :subtype subtype
+ :arguments arguments))))
+
+(export 'make-keyword-function-type)
+(defun make-keyword-function-type (subtype arguments keywords)
+ "Return a new keyword-function type, returning SUBTYPE and accepting
+ ARGUMENTS and KEYWORDS."
+ (make-instance 'c-keyword-function-type :subtype subtype
+ :arguments arguments :keywords keywords))
;; Comparison protocol.
(argument-lists-equal-p (c-function-arguments type-a)
(c-function-arguments type-b))))
+(defmethod c-type-equal-p and
+ ((type-a c-keyword-function-type) (type-b c-keyword-function-type))
+ ;; Actually, there's nothing to check here. I'm happy as long as both
+ ;; functions notionally accept keyword arguments.
+ t)
+
;; C syntax output protocol.
+(export 'pprint-c-function-type)
+(defun pprint-c-function-type (return-type stream print-args print-kernel)
+ "Common top-level printing for function types.
+
+ Prints RETURN-TYPE (KERNEL(ARGS)), where RETURN-TYPE is the actual return
+ type, and ARGS and KERNEL are whatever is printed by the PRINT-ARGS and
+ PRINT-KERNEL functions.
+
+ The PRINT-KERNEL function is the standard such thing for the
+ `pprint-c-type' protocol; PRINT-ARGS accepts just an output stream."
+ (pprint-c-type return-type stream
+ (lambda (stream prio spacep)
+ (maybe-in-parens (stream (> prio 2))
+ (when spacep (c-type-space stream))
+ (funcall print-kernel stream 2 nil)
+ (pprint-indent :block 4 stream)
+ (pprint-newline :linear stream)
+ (pprint-logical-block
+ (stream nil :prefix "(" :suffix ")")
+ (funcall print-args stream))))))
+
+(export 'pprint-argument-list)
+(defun pprint-argument-list (args stream)
+ "Print an argument list.
+
+ The ARGS is a list of `argument' objects, optionally containing an
+ `:ellipsis' marker. The output is written to STREAM.
+
+ Returns non-nil if any arguments were actually printed."
+ (let ((anyp nil))
+ (pprint-logical-block (stream nil)
+ (dolist (arg args)
+ (if anyp
+ (format stream ", ~_")
+ (setf anyp t))
+ (etypecase arg
+ ((member :ellipsis)
+ (write-string "..." stream))
+ (argument
+ (pprint-logical-block (stream nil)
+ (pprint-c-type (argument-type arg) stream (argument-name arg))
+ (let ((default (argument-default arg)))
+ (when default
+ (format stream " = ~2I~_~A" default))))))))
+ anyp))
+
(let ((void-arglist (list (make-argument nil c-type-void))))
(defmethod pprint-c-type ((type c-function-type) stream kernel)
- (pprint-c-type (c-type-subtype type) stream
- (lambda (stream prio spacep)
- (maybe-in-parens (stream (> prio 2))
- (when spacep (c-type-space stream))
- (funcall kernel stream 2 nil)
- (pprint-indent :block 4 stream)
- (pprint-logical-block
- (stream nil :prefix "(" :suffix ")")
- (let ((firstp t))
- (dolist (arg (or (c-function-arguments type)
- void-arglist))
- (if firstp
- (setf firstp nil)
- (format stream ", ~_"))
- (if (eq arg :ellipsis)
- (write-string "..." stream)
- (pprint-c-type (argument-type arg)
- stream
- (argument-name arg)))))))))))
+ (let ((args (or (c-function-arguments type) void-arglist)))
+ (pprint-c-function-type (c-type-subtype type) stream
+ (lambda (stream)
+ (pprint-argument-list args stream))
+ kernel))))
+
+(defmethod pprint-c-type ((type c-keyword-function-type) stream kernel)
+ (let ((args (c-function-arguments type))
+ (keys (c-function-keywords type)))
+ (pprint-c-function-type (c-type-subtype type) stream
+ (lambda (stream)
+ (when (pprint-argument-list args stream)
+ (format stream ", ~_"))
+ (write-char #\? stream)
+ (pprint-argument-list keys stream))
+ kernel)))
;; S-expression notation protocol.
(stream (type c-function-type) &optional colon atsign)
(declare (ignore colon atsign))
(format stream "~:@<~
- FUN ~@_~:I~/sod:print-c-type/~
- ~{ ~_~:<~S ~@_~/sod:print-c-type/~:>~}~
+ FUN ~@_~:I~
+ ~/sod:print-c-type/~:[~; ~]~:*~_~
+ ~<~@{~:<~S ~@_~/sod:print-c-type/~:>~^ ~_~}~:>~
+ ~:[~2*~; ~_~S ~@_~<~@{~:<~S ~@_~/sod:print-c-type/~
+ ~@[ ~@_~S~]~:>~^ ~_~}~:>~]~
~:>"
(c-type-subtype type)
(mapcar (lambda (arg)
(if (eq arg :ellipsis) arg
(list (argument-name arg) (argument-type arg))))
- (c-function-arguments type))))
+ (c-function-arguments type))
+ (typep type 'c-keyword-function-type)
+ :keys
+ (and (typep type 'c-keyword-function-type)
+ (mapcar (lambda (arg)
+ (list (argument-name arg)
+ (argument-type arg)
+ (argument-default arg)))
+ (c-function-keywords type)))))
(export '(fun function () func fn))
(define-c-type-syntax fun (ret &rest args)
"Return the type of functions which returns RET and has arguments ARGS.
- The ARGS are a list of arguments of the form (NAME TYPE). The NAME can be
- NIL to indicate that no name was given.
+ The ARGS are a list of arguments of the form (NAME TYPE [DEFAULT]). The
+ NAME can be NIL to indicate that no name was given.
If an entry isn't a list, it's assumed to be the start of a Lisp
expression to compute the tail of the list; similarly, if the list is
`(make-function-type ,(expand-c-type-spec ret)
,(do ((args args (cdr args))
(list nil
- (cons `(make-argument ,(caar args)
- ,(expand-c-type-spec
- (cadar args)))
- list)))
- ((or (atom args) (atom (car args)))
+ (if (keywordp (car args))
+ (cons (car args) list)
+ (let* ((name (caar args))
+ (type (expand-c-type-spec
+ (cadar args)))
+ (default (and (cddar args)
+ (caddar args)))
+ (arg `(make-argument
+ ,name ,type ,default)))
+ (cons arg list)))))
+ ((or (atom args)
+ (and (atom (car args))
+ (not (keywordp (car args)))))
(cond ((and (null args) (null list)) `nil)
((null args) `(list ,@(nreverse list)))
- ((and (consp args)
- (eq (car args) :ellipsis))
- `(list ,@(nreverse list) :ellipsis))
((null list) `,args)
(t `(list* ,@(nreverse list) ,args)))))))
(c-type-alias fun function () func fn)
(mapcar (lambda (arg)
(if (eq arg :ellipsis) arg
(make-argument (commentify-argument-name (argument-name arg))
- (argument-type arg))))
+ (argument-type arg)
+ (argument-default arg))))
arguments))
(export 'commentify-function-type)
(commentify-argument-names
(c-function-arguments type))))
+(export 'reify-variable-argument-tail)
+(defun reify-variable-argument-tail (arguments)
+ "Replace any `:ellipsis' item in ARGUMENTS with a `va_list' argument.
+
+ The argument's name is taken from the variable `*sod-ap*'."
+ (substitute (make-argument *sod-ap* c-type-va-list) :ellipsis arguments))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff