src/method-impl.lisp: Initialize `suppliedp' flags properly.

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

diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp
index a13be4cba0f4ba3ae4395c04db3400ece7e01ace..f8e758999b216e91442ead0d806e7f085508d98b 100644 (file)
--- a/src/c-types-proto.lisp
+++ b/src/c-types-proto.lisp
@@ -57,6 +57,16 @@ (defgeneric qualify-c-type (type qualifiers)
    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


@@ -152,13 +162,11 @@ (defgeneric print-c-type (stream type &optional colon atsign)
 (export '(expand-c-type-spec expand-c-type-form))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defgeneric expand-c-type-spec (spec)
 (export '(expand-c-type-spec expand-c-type-form))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defgeneric expand-c-type-spec (spec)

-    (:documentation
-     "Expand SPEC into Lisp code to construct a C type.")
+    (:documentation "Expand SPEC into Lisp code to construct a C type.")

     (:method ((spec list))
       (expand-c-type-form (car spec) (cdr spec))))
   (defgeneric expand-c-type-form (head tail)
     (:method ((spec list))
       (expand-c-type-form (car spec) (cdr spec))))
   (defgeneric expand-c-type-form (head tail)

-    (:documentation
-     "Expand a C type list beginning with HEAD.")
+    (:documentation "Expand a C type list beginning with HEAD.")

     (:method ((name (eql 'lisp)) tail)
       `(progn ,@tail))))
 
     (:method ((name (eql 'lisp)) tail)
       `(progn ,@tail))))
 


@@ -168,12 +176,12 @@ (defmacro c-type (spec)
   (expand-c-type-spec spec))
 
 (export 'define-c-type-syntax)
   (expand-c-type-spec spec))
 
 (export 'define-c-type-syntax)

-(defmacro define-c-type-syntax (name bvl &rest body)
+(defmacro define-c-type-syntax (name bvl &body body)

   "Define a C-type syntax function.
 
    A function defined by BODY and with lambda-list BVL is associated with the
   "Define a C-type syntax function.
 
    A function defined by BODY and with lambda-list BVL is associated with the

-   NAME.  When `expand-c-type' sees a list (NAME . STUFF), it will call this
-   function with the argument list STUFF."
+   NAME.  When `expand-c-type-spec' 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)
   (with-gensyms (head tail)
     (multiple-value-bind (doc decls body) (parse-body body)
       `(eval-when (:compile-toplevel :load-toplevel :execute)


@@ -197,16 +205,18 @@ (defmacro c-type-alias (original &rest aliases)
        ',aliases)))
 
 (export 'defctype)
        ',aliases)))
 
 (export 'defctype)

-(defmacro defctype (names value)
+(defmacro defctype (names value &key export)

   "Define NAMES all to describe the C-type VALUE.
 
    NAMES can be a symbol (treated as a singleton list), or a list of symbols.
   "Define NAMES all to describe the C-type VALUE.
 
    NAMES can be a symbol (treated as a singleton list), or a list of symbols.

-   The VALUE is a C type S-expression, acceptable to `expand-c-type'.  It
-   will be expanded once at run-time."
+   The VALUE is a C type S-expression, acceptable to `expand-c-type-spec'.
+   It will be expanded once at run-time."

   (let* ((names (if (listp names) names (list names)))
         (namevar (gensym "NAME"))
         (typevar (symbolicate 'c-type- (car names))))
     `(progn
   (let* ((names (if (listp names) names (list names)))
         (namevar (gensym "NAME"))
         (typevar (symbolicate 'c-type- (car names))))
     `(progn

+       ,@(and export
+             `((export '(,typevar ,@names))))

        (defparameter ,typevar ,(expand-c-type-spec value))
        (eval-when (:compile-toplevel :load-toplevel :execute)
         ,@(mapcar (lambda (name)
        (defparameter ,typevar ,(expand-c-type-spec value))
        (eval-when (:compile-toplevel :load-toplevel :execute)
         ,@(mapcar (lambda (name)


@@ -235,16 +245,105 @@ (defun c-name-case (name)
                              (error "Bad character in C name ~S." name))))))
     (t 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.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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)