X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3109662aca9c06495ac22c5c58b46e1c036aca5c..ff344fb7a4598447cd6527c84f01d658f3fc9f11:/src/c-types-impl.lisp

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index 7dd7b84..a27b30f 100644
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -66,17 +66,96 @@
 		 (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.
 
 ;; Class definition.
@@ -106,8 +185,8 @@
 
 (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)))
 
@@ -130,59 +209,61 @@
     `(make-simple-type ,head (list ,@tail))))
 
 (export 'define-simple-c-type)
-(defmacro define-simple-c-type (names type)
+(defmacro define-simple-c-type (names type &key export)
   "Define each of NAMES to be a simple type called TYPE."
   (let ((names (if (listp names) names (list names))))
     `(progn
        (setf (gethash ,type *simple-type-map*) ',(car names))
-       (defctype ,names ,type)
+       (defctype ,names ,type :export ,export)
        (define-c-type-syntax ,(car names) (&rest quals)
 	 `(make-simple-type ,',type (list ,@quals))))))
 
 ;; Built-in C types.
 
-(export '(void float double long-double va-list size-t ptrdiff-t
-	  char unsigned-char uchar signed-char schar
-	  int signed signed-int sint unsigned unsigned-int uint
-	  short signed-short short-int signed-short-int sshort
-	  unsigned-short unsigned-short-int ushort
-	  long signed-long long-int signed-long-int slong
-	  unsigned-long unsigned-long-int ulong
-	  long-long signed-long-long long-long-int signed-long-long-int
-	  unsigned-long-long unsigned-long-long-int llong sllong ullong))
-
-(define-simple-c-type void "void")
+(define-simple-c-type void "void" :export t)
 
-(define-simple-c-type char "char")
-(define-simple-c-type (unsigned-char uchar) "unsigned char")
-(define-simple-c-type (signed-char schar) "signed char")
+(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 (int signed signed-int sint) "int")
-(define-simple-c-type (unsigned unsigned-int uint) "unsigned")
+(define-simple-c-type (int signed signed-int sint) "int" :export t)
+(define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t)
 
 (define-simple-c-type (short signed-short short-int signed-short-int sshort)
-  "short")
+  "short" :export t)
 (define-simple-c-type (unsigned-short unsigned-short-int ushort)
-  "unsigned short")
+  "unsigned short" :export t)
 
 (define-simple-c-type (long signed-long long-int signed-long-int slong)
-  "long")
+  "long" :export t)
 (define-simple-c-type (unsigned-long unsigned-long-int ulong)
-  "unsigned long")
+  "unsigned long" :export t)
 
 (define-simple-c-type (long-long signed-long-long long-long-int
 		       signed-long-long-int llong sllong)
-  "long long")
+  "long long" :export t)
 (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
-  "unsigned long long")
+  "unsigned long long" :export t)
+
+(define-simple-c-type float "float" :export t)
+(define-simple-c-type double "double" :export t)
+(define-simple-c-type long-double "long double" :export t)
+
+(define-simple-c-type bool "_Bool" :export t)
+
+(define-simple-c-type float-complex "float _Complex" :export t)
+(define-simple-c-type double-complex "double _Complex" :export t)
+(define-simple-c-type long-double-complex "long double _Complex" :export t)
 
-(define-simple-c-type float "float")
-(define-simple-c-type double "double")
-(define-simple-c-type long-double "long double")
+(define-simple-c-type float-imaginary "float _Imaginary" :export t)
+(define-simple-c-type double-imaginary "double _Imaginary" :export t)
+(define-simple-c-type long-double-imaginary
+    "long double _Imaginary" :export t)
 
-(define-simple-c-type va-list "va_list")
-(define-simple-c-type size-t "size_t")
-(define-simple-c-type ptrdiff-t "ptrdiff_t")
+(define-simple-c-type va-list "va_list" :export t)
+(define-simple-c-type size-t "size_t" :export t)
+(define-simple-c-type ptrdiff-t "ptrdiff_t" :export t)
 
 ;;;--------------------------------------------------------------------------
 ;;; Tagged types (enums, structs and unions).
@@ -246,8 +327,8 @@
 
 (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)))
@@ -262,6 +343,55 @@
 	  (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.
 
 ;; Class definition.
@@ -276,12 +406,9 @@
 (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.
 
@@ -296,8 +423,8 @@
 		 (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.
@@ -400,7 +527,7 @@
 
 ;; Function arguments.
 
-(defun arguments-lists-equal-p (list-a list-b)
+(defun argument-lists-equal-p (list-a list-b)
   "Return whether LIST-A and LIST-B match.
 
    They must have the same number of arguments, and each argument must have
@@ -409,56 +536,227 @@
        (every (lambda (arg-a arg-b)
 		(if (eq arg-a :ellipsis)
 		    (eq arg-b :ellipsis)
-		    (c-type-equal-p (argument-type arg-a)
-				    (argument-type arg-b))))
+		    (and (argumentp arg-a) (argumentp arg-b)
+			 (c-type-equal-p (argument-type arg-a)
+					 (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))
 (defclass c-function-type (c-type)
   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
-   (arguments :initarg :arguments :type list :reader c-function-arguments))
+   (arguments :type list :reader c-function-arguments))
   (:documentation
    "C function types.  The subtype is the return type, as implied by the C
     syntax for function declarations."))
 
+(defmethod shared-initialize :after
+    ((type c-function-type) slot-names &key (arguments nil argsp))
+  (declare (ignore slot-names))
+  (when argsp
+    (setf (slot-value type 'arguments)
+	  (if (and arguments
+		   (null (cdr arguments))
+		   (not (eq (car arguments) :ellipsis))
+		   (eq (argument-type (car arguments)) c-type-void))
+	      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.
 
 (defmethod c-type-equal-p and
     ((type-a c-function-type) (type-b c-function-type))
   (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))
-       (arguments-lists-equal-p (c-function-arguments type-a)
-				(c-function-arguments type-b))))
+       (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.
 
-(defmethod pprint-c-type ((type c-function-type) stream kernel)
-  (pprint-c-type (c-type-subtype type) stream
+(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 kernel stream 2 nil)
+		     (funcall print-kernel stream 2 nil)
 		     (pprint-indent :block 4 stream)
+		     (pprint-newline :linear stream)
 		     (pprint-logical-block
 			 (stream nil :prefix "(" :suffix ")")
-		       (let ((firstp t))
-			 (dolist (arg (c-function-arguments type))
-			   (if firstp
-			       (setf firstp nil)
-			       (format stream ", ~_"))
-			   (if (eq arg :ellipsis)
-			       (write-string "..." stream)
-			       (pprint-c-type (argument-type arg)
-					      stream
-					      (argument-name arg))))))))))
+		       (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)
+    (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.
 
@@ -466,22 +764,32 @@
     (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
+		    (if (eq arg :ellipsis) arg
 			(list (argument-name arg) (argument-type arg))))
-		  (c-function-arguments type))))
-
-(export '(fun function func fn))
+		  (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
@@ -499,16 +807,21 @@
   `(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)
@@ -522,10 +835,10 @@
    That is, with each argument name passed through
    `commentify-argument-name'."
   (mapcar (lambda (arg)
-	    (if (eq arg :ellipsis)
-		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)
@@ -537,4 +850,11 @@
 		      (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 --------------------------------------------------