;;;----- 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
(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)
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
(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)
(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)
(: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)
,@doc
(destructuring-bind ,bvl ,tail
,@decls
- ,@body))
+ (block ,name ,@body)))
',name))))
(export 'c-type-alias)
',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)
((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)
"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)))
~mdw / sod / blobdiff