X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/e0808c472145fc81e52898bc9ac289e10c4f4f41..3b2ec4790da6b3f64189a58896957ac63169dd5e:/src/c-types-proto.lisp diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp index a13be4c..f8e7589 100644 --- 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.")) +(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 @@ -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) - (: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) - (: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)))) @@ -168,12 +176,12 @@ (defmacro c-type (spec) (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 - 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) @@ -197,16 +205,18 @@ (defmacro c-type-alias (original &rest aliases) ',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. - 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 + ,@(and export + `((export '(,typevar ,@names)))) (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))) +;;;-------------------------------------------------------------------------- +;;; 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)