X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/aa14a4cddcb96b681d5c19a2ec8bad382f43b264..2c6153373f927d948a74b283ebb16330af8ee49a:/src/c-types-proto.lisp diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp index bc36b2e..0ce2cf3 100644 --- a/src/c-types-proto.lisp +++ b/src/c-types-proto.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 @@ -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) @@ -57,6 +60,16 @@ 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 @@ -109,14 +122,14 @@ (defun c-type-space (stream) "Print a space and a miser-mode newline to STREAM. - This is the right function to call in a PPRINT-C-TYPE kernel function when - the SPACEP argument is true." + This is the right function to call in a `pprint-c-type' kernel function + when the SPACEP argument is true." (pprint-indent :block 2 stream) (write-char #\space stream) (pprint-newline :miser stream)) (defun maybe-in-parens* (stream condition thunk) - "Helper function for the MAYBE-IN-PARENS macro." + "Helper function for the `maybe-in-parens' macro." (multiple-value-bind (prefix suffix) (if condition (values "(" ")") (values "" "")) (pprint-logical-block (stream nil :prefix prefix :suffix suffix) @@ -126,12 +139,12 @@ (defmacro maybe-in-parens ((stream condition) &body body) "Evaluate BODY; if CONDITION, write parens to STREAM around it. - This macro is useful for implementing the PPRINT-C-TYPE method on compound - types. The BODY is evaluated in the context of a logical block printing - to STREAM. If CONDITION is non-nil, then the block will have open/close - parens as its prefix and suffix; otherwise they will be empty. + This macro is useful for implementing the `pprint-c-type' method on + compound types. The BODY is evaluated in the context of a logical block + printing to STREAM. If CONDITION is non-nil, then the block will have + open/close parens as its prefix and suffix; otherwise they will be empty. - The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol." + The STREAM is passed to `pprint-logical-block', so it must be a symbol." `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body))) (export 'format-qualifiers) @@ -147,33 +160,31 @@ (:documentation "Print an abbreviated syntax for TYPE to the STREAM. - This function is suitable for use in FORMAT's ~/.../ command.")) + This function is suitable for use in `format's ~/.../ command.")) -(export 'expand-c-type-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) - (: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)))) (export 'c-type) (defmacro c-type (spec) - "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC." + "Expands to code to construct a C type, using `expand-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) @@ -181,7 +192,7 @@ ,@doc (destructuring-bind ,bvl ,tail ,@decls - ,@body)) + (block ,name ,@body))) ',name)))) (export 'c-type-alias) @@ -197,16 +208,18 @@ ',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) @@ -232,18 +245,109 @@ ((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 - type) + (name nil :type t :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) (defgeneric commentify-argument-name (name) @@ -251,7 +355,7 @@ "Produce a `commentified' version of the argument. The default behaviour is that temporary argument names are simply omitted - (NIL is returned); otherwise, `/*...*/' markers are wrapped around the + (nil is returned); otherwise, `/*...*/' markers are wrapped around the printable representation of the argument.") (:method ((name null)) nil) (:method ((name t)) (format nil "/*~A*/" name)))