doc/sod.sty: Allow setting the description modifier explicitly.

[sod] / src / c-types-proto.lisp

diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp
index c8aa72e..43824da 100644 (file)
--- a/src/c-types-proto.lisp
+++ b/src/c-types-proto.lisp
@@ -57,6 +57,16 @@
    The qualifiers of the returned type are the union of the requested
    QUALIFIERS and the qualifiers already applied to TYPE."))
 
    The qualifiers of the returned type are the union of the requested
    QUALIFIERS and the qualifiers already applied to TYPE."))
 

+(export 'c-qualifier-keyword)
+(defgeneric c-qualifier-keyword (qualifier)
+  (:documentation "Return the C keyword for the QUALIFIER (a Lisp keyword).")
+  (:method ((qualifier symbol)) (string-downcase qualifier)))
+
+(export 'c-type-qualifier-keywords)
+(defun c-type-qualifier-keywords (c-type)
+  "Return the type's qualifiers, as a list of C keyword names."
+  (mapcar #'c-qualifier-keyword (c-type-qualifiers c-type)))
+

 (export 'c-type-subtype)
 (defgeneric c-type-subtype (type)
   (:documentation
 (export 'c-type-subtype)
 (defgeneric c-type-subtype (type)
   (:documentation


@@ -232,19 +242,108 @@
                             ((char= ch #\-)
                              (write-char #\_ out))
                             (t
                             ((char= ch #\-)
                              (write-char #\_ out))
                             (t

-                             (error "Bad character in C name ~S." name))))))
+                             (error "Bad character in C name ~S" name))))))

     (t 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.
 
 ;;; 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)
                                                  &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)
 (define-access-wrapper argument-type argument-%type :read-only t)
 
 (export 'commentify-argument-name)