X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/ff4e398b224974d6283f71aa78daef4210371e32..12949379840101e2d65883f29c5e8f0f6de49e9c:/src/c-types-proto.lisp

diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp
index 1057321..0ce2cf3 100644
--- a/src/c-types-proto.lisp
+++ b/src/c-types-proto.lisp
@@ -46,8 +46,11 @@
 
 (export 'canonify-qualifiers)
 (defun canonify-qualifiers (qualifiers)
-  "Return a canonical list of qualifiers."
-  (delete-duplicates (sort (copy-list qualifiers) #'string<)))
+  "Return a canonical list of qualifiers.
+
+   Duplicates and `nil' entries are deleted, and the remaining entries are
+   sorted."
+  (sort (delete-duplicates (delete nil (copy-list qualifiers))) #'string<))
 
 (export 'qualify-c-type)
 (defgeneric qualify-c-type (type qualifiers)
@@ -242,19 +245,108 @@
 			     ((char= ch #\-)
 			      (write-char #\_ out))
 			     (t
-			      (error "Bad character in C name ~S." name))))))
+			      (error "Bad character in C name ~S" name))))))
     (t name)))
 
 ;;;--------------------------------------------------------------------------
+;;; Storage specifier protocol.
+
+(export 'pprint-c-storage-specifier)
+(defgeneric pprint-c-storage-specifier (spec stream)
+  (:documentation "Print the storage specifier SPEC to STREAM, as C syntax.")
+  (:method ((spec symbol) stream) (princ (string-downcase spec) stream)))
+
+(export 'print-c-storage-specifier)
+(defgeneric print-c-storage-specifier (stream spec &optional colon atsign)
+  (:documentation
+   "Print the storage specifier SPEC to STREAM, as an S-expression.
+
+   This function is suitable for use in `format's ~/.../ command.")
+  (:method (stream (spec t) &optional colon atsign)
+    (declare (ignore colon atsign))
+    (prin1 spec stream))
+  (:method (stream (spec symbol) &optional colon atsign)
+    (declare (ignore colon atsign))
+    (princ (string-downcase spec) stream)))
+
+(export '(expand-c-storage-specifier expand-c-storage-specifier-form))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defgeneric expand-c-storage-specifier (spec)
+    (:documentation
+     "Expand SPEC into Lisp code to construct a storage specifier.")
+    (:method ((spec list))
+      (expand-c-storage-specifier-form (car spec) (cdr spec)))
+    (:method ((spec symbol))
+      (if (keywordp spec) spec
+	  (expand-c-storage-specifier-form spec nil))))
+  (defgeneric expand-c-storage-specifier-form (head tail)
+    (:documentation
+     "Expand a C storage-specifier form beginning with HEAD.")
+    (:method ((name (eql 'lisp)) tail)
+      `(progn ,@tail))))
+
+(export 'define-c-storage-specifier-syntax)
+(defmacro define-c-storage-specifier-syntax (name bvl &body body)
+  "Define a C storage-specifier syntax function.
+
+   A function defined by BODY and with lambda-list BVL is associated wth the
+   NAME.  When `expand-c-storage-specifier' sees a list (NAME . STUFF), it
+   will call this function with the argument list STUFF."
+  (with-gensyms (head tail)
+    (multiple-value-bind (doc decls body) (parse-body body)
+      `(eval-when (:compile-toplevel :load-toplevel :execute)
+	 (defmethod expand-c-storage-specifier-form
+	     ((,head (eql ',name)) ,tail)
+	   ,@doc
+	   (destructuring-bind ,bvl ,tail
+	     ,@decls
+	     (block ,name ,@body)))
+	 ',name))))
+
+;;;--------------------------------------------------------------------------
+;;; A type for carrying storage specifiers.
+
+(export '(c-storage-specifiers-type c-type-specifiers))
+(defclass c-storage-specifiers-type (c-type)
+  ((specifiers :initarg :specifiers :type list :reader c-type-specifiers)
+   (subtype :initarg :subtype :type c-type :reader c-type-subtype))
+  (:documentation
+   "A type for carrying storage specifiers.
+
+   Properly, storage specifiers should only appear on an outermost type.
+   This fake C type is a handy marker for the presence of storage specifiers,
+   so that they can be hoisted properly when constructing derived types."))
+
+(export 'wrap-c-type)
+(defun wrap-c-type (wrapper-func base-type)
+  "Handle storage specifiers correctly when making a derived type.
+
+   WRAPPER-FUNC should be a function which will return some derived type of
+   BASE-TYPE.  This function differs from `funcall' only when BASE-TYPE is
+   actually a `c-storage-specifiers-type', in which case it invokes
+   WRAPPER-FUNC on the underlying type, and re-attaches the storage
+   specifiers to the derived type."
+  (if (typep base-type 'c-storage-specifiers-type)
+      (let* ((unwrapped-type (c-type-subtype base-type))
+	     (wrapped-type (funcall wrapper-func unwrapped-type))
+	     (specifiers (c-type-specifiers base-type)))
+	(make-or-intern-c-type 'c-storage-specifiers-type unwrapped-type
+			       :specifiers specifiers
+			       :subtype wrapped-type))
+      (funcall wrapper-func base-type)))
+
+;;;--------------------------------------------------------------------------
 ;;; Function arguments.
 
-(export '(argument argumentp make-argument argument-name argument-type))
-(defstruct (argument (:constructor make-argument (name type
+(export '(argument argumentp make-argument
+	  argument-name argument-type argument-default))
+(defstruct (argument (:constructor make-argument (name type &optional default
 						  &aux (%type type)))
 		     (:predicate argumentp))
   "Simple structure representing a function argument."
   (name nil :type t :read-only t)
-  (%type nil :type c-type :read-only t))
+  (%type nil :type c-type :read-only t)
+  (default nil :type t :read-only t))
 (define-access-wrapper argument-type argument-%type :read-only t)
 
 (export 'commentify-argument-name)