;; Important protocol.
-(defgeneric c-declaration (type decl)
- (:documentation
- "Computes a declaration for a C type.
-
- Returns two strings, a type and a declarator, suitable for declaring an
- object with the inner declarator DECL."))
-
(defgeneric c-type-subtype (type)
(:documentation
"For compound types, return the base type."))
(:method and (type-a type-b)
(eql (class-of type-a) (class-of type-b))))
-(defgeneric c-declarator-priority (type)
+(defgeneric pprint-c-type (type stream kernel)
(:documentation
- "Returns the priority for the declarator of TYPE.
-
- Used to decide when to insert parentheses into the C representation.")
-
- (:method ((type c-type))
- 0))
+ "Pretty-printer for C types.
+
+ Print TYPE to STREAM. In the middle of the declarator, call the function
+ KERNEL with one argument: whether it needs a leading space.")
+ (:method :around (type stream kernel)
+ (typecase kernel
+ (function (call-next-method))
+ (null (pprint-c-type type stream
+ (lambda (stream prio spacep)
+ (declare (ignore stream prio spacep))
+ nil)))
+ (t (pprint-c-type type stream
+ (lambda (stream prio spacep)
+ (declare (ignore prio))
+ (when spacep
+ (c-type-space stream))
+ (princ kernel stream)))))))
(defgeneric print-c-type (stream type &optional colon atsign)
(:documentation
(defmethod print-object ((object c-type) stream)
(if *print-escape*
(format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object)
- (multiple-value-bind (base decl) (c-declaration object "")
- (format stream "~A~:[~; ~A~]" base (plusp (length decl)) decl))))
+ (pprint-c-type object stream nil)))
-;; Utility functions.
+;; Utility functions and macros.
-(defun maybe-parenthesize (decl me him)
- "Wrap parens around DECL, maybe, according to priorities of ME and HIM.
+(defun c-type-space (stream)
+ "Print a space and a miser-mode newline to STREAM.
- If the declarator for HIM has a higher priority than that of ME (as C
- types) then return DECL with parens wrapped around it; otherwise just
- return DECL."
- (if (<= (c-declarator-priority him)
- (c-declarator-priority me))
- decl
- (format nil "(~A)" decl)))
+ 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 compound-type-declaration (type format-control &rest format-args)
- "Convenience function for implementating compound types.
+(defun maybe-in-parens* (stream condition thunk)
+ "Helper function for the MAYBE-IN-PARENS macro."
+ (pprint-logical-block
+ (stream nil
+ :prefix (if condition "(" "")
+ :suffix (if condition ")" ""))
+ (funcall thunk stream)))
- The declaration is formed from the type's subtype and by processing the
- given format string."
- (let ((subty (c-type-subtype type))
- (subdecl (format nil "~?" format-control format-args)))
- (c-declaration subty (maybe-parenthesize subdecl type subty))))
+(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.
+
+ The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol."
+ `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
;; S-expression syntax machinery.
(error "Bad character in C name ~S." name))))))
(t name)))
-(defun expand-c-type (spec)
- "Parse SPEC as a C type and return the result.
-
- The SPEC can be one of the following.
-
- * A C-TYPE object, which is returned immediately.
-
- * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
- function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
- or some other means is invoked on the ARGUMENTS, and the result is
- returned.
-
- * A symbol, which is treated the same way as a singleton list would be."
-
- (flet ((interp (sym)
- (or (get sym 'c-type)
- (error "Unknown C type operator ~S." sym))))
- (etypecase spec
- (c-type spec)
- (symbol (funcall (interp spec)))
- (list (apply (interp (car spec)) (cdr spec))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defgeneric expand-c-type-spec (spec)
+ (: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.")
+ (:method ((name (eql 'lisp)) tail)
+ `(progn ,@tail))))
(defmacro c-type (spec)
- "Evaluates to the type that EXPAND-C-TYPE would return.
-
- Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime. Maybe
- later it will do something more clever."
- `(expand-c-type ',spec))
+ "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC."
+ (expand-c-type-spec spec))
(defmacro define-c-type-syntax (name bvl &rest 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."
- `(progn
- (setf (get ',name 'c-type) (lambda ,bvl ,@body))
- ',name))
+ (let ((headvar (gensym "HEAD"))
+ (tailvar (gensym "TAIL")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmethod expand-c-type-form ((,headvar (eql ',name)) ,tailvar)
+ (destructuring-bind ,bvl ,tailvar
+ ,@body)))))
(defmacro c-type-alias (original &rest aliases)
"Make ALIASES behave the same way as the ORIGINAL type."
- (let ((i (gensym)) (orig (gensym)))
- `(let ((,orig (get ',original 'c-type)))
- (dolist (,i ',aliases)
- (setf (get ,i 'c-type) ,orig)))))
+ (let ((headvar (gensym "HEAD"))
+ (tailvar (gensym "TAIL")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(mapcar (lambda (alias)
+ `(defmethod expand-c-type-form
+ ((,headvar (eql ',alias)) ,tailvar)
+ (expand-c-type-form ',original ,tailvar)))
+ aliases))))
(defmacro defctype (names value)
"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."
- (unless (listp names)
- (setf names (list names)))
- (let ((ty (gensym)))
- `(let ((,ty (expand-c-type ',value)))
- (setf (get ',(car names) 'c-type) (lambda () ,ty))
- ,@(and (cdr names)
- `((c-type-alias ,(car names) ,@(cdr names)))))))
+ (let* ((names (if (listp names) names (list names)))
+ (namevar (gensym "NAME"))
+ (typevar (symbolicate 'c-type- (car names))))
+ `(progn
+ (defparameter ,typevar ,(expand-c-type-spec value))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(mapcar (lambda (name)
+ `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
+ ',typevar))
+ names)))))
;;;--------------------------------------------------------------------------
;;; Types which can accept qualifiers.
(sort (copy-list (c-type-qualifiers type)) #'string<)))
(equal (fix type-a) (fix type-b))))
-(defmethod print-c-type :around
- (stream (type qualifiable-c-type) &optional colon atsign)
- (if (c-type-qualifiers type)
- (pprint-logical-block (stream nil :prefix "(" :suffix ")")
- (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
- (c-type-qualifiers type))
- (call-next-method stream type colon atsign))
- (call-next-method)))
-
;; A handy utility.
(let ((cache (make-hash-table :test #'equal)))
(setf (gethash key cache)
(copy-instance c-type :qualifiers qualifiers)))))))
-;; S-expression machinery. Qualifiers have hairy syntax and need to be
-;; implemented by hand.
-
-(defun qualifier (qual &rest args)
- "Parse a qualified C type.
-
- The ARGS consist of a number of qualifiers and exactly one C-type
- S-expression. The result is a qualified version of this type, with the
- given qualifiers attached."
- (if (null args)
- qual
- (let* ((things (mapcar #'expand-c-type args))
- (quals (delete-duplicates
- (sort (cons qual (remove-if-not #'keywordp things))
- #'string<)))
- (types (remove-if-not (lambda (thing) (typep thing 'c-type))
- things)))
- (when (or (null types)
- (not (null (cdr types))))
- (error "Only one proper type expected in ~S." args))
- (qualify-type (car types) quals))))
-(setf (get 'qualifier 'c-type) #'qualifier)
-
-(defun declare-qualifier (qual)
- "Defines QUAL as being a type qualifier.
-
- When used as a C-type operator, it applies that qualifier to the type that
- is its argument."
- (let ((kw (intern (string qual) :keyword)))
- (setf (get qual 'c-type)
- (lambda (&rest args)
- (apply #'qualifier kw args)))))
-
-;; Define some initial qualifiers.
-(dolist (qual '(const volatile restrict))
- (declare-qualifier qual))
-
;;;--------------------------------------------------------------------------
;;; Simple C types (e.g., built-in arithmetic types).
"C types with simple forms."))
(let ((cache (make-hash-table :test #'equal)))
- (defun make-simple-type (name)
+ (defun make-simple-type (name &optional qualifiers)
"Make a distinguished object for the simple type called NAME."
- (or (gethash name cache)
- (setf (gethash name cache)
- (make-instance 'simple-c-type :name name)))))
-
-(defmethod c-declaration ((type simple-c-type) decl)
- (values (concatenate 'string
- (format-qualifiers (c-type-qualifiers type))
- (c-type-name type))
- decl))
+ (qualify-type (or (gethash name cache)
+ (setf (gethash name cache)
+ (make-instance 'simple-c-type :name name)))
+ qualifiers)))
+
+(defmethod pprint-c-type ((type simple-c-type) stream kernel)
+ (pprint-logical-block (stream nil)
+ (format stream "~{~(~A~) ~@_~}~A"
+ (c-type-qualifiers type)
+ (c-type-name type))
+ (funcall kernel stream 0 t)))
(defmethod c-type-equal-p and ((type-a simple-c-type)
(type-b simple-c-type))
(declare (ignore colon atsign))
(let* ((name (c-type-name type))
(symbol (gethash name *simple-type-map*)))
- (if symbol
- (princ symbol stream)
- (format stream "~:@<SIMPLE-C-TYPE ~@_~S~:>" name))))
+ (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]"
+ (c-type-qualifiers type) (or symbol name))))
;; S-expression syntax.
-(define-c-type-syntax simple-c-type (name)
- "Constructs a simple C type called NAME (a string or symbol)."
- (make-simple-type (c-name-case name)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmethod expand-c-type-spec ((spec string))
+ `(make-simple-type ,spec))
+ (defmethod expand-c-type-form ((head string) tail)
+ `(make-simple-type ,head ,@tail)))
(defmacro define-simple-c-type (names type)
"Define each of NAMES to be a simple type called TYPE."
- `(progn
- (setf (gethash ,type *simple-type-map*)
- ',(if (listp names) (car names) names))
- (defctype ,names (simple-c-type ,type))))
+ (let ((names (if (listp names) names (list names))))
+ `(progn
+ (setf (gethash ,type *simple-type-map*) ',(car names))
+ (defctype ,names ,type)
+ (define-c-type-syntax ,(car names) (&rest quals)
+ `(make-simple-type ,',type (list ,@quals))))))
(define-simple-c-type void "void")
"Return the kind of tagged type that TYPE is, as a keyword."))
(macrolet ((define-tagged-type (kind what)
- (let ((type (intern (format nil "C-~A-TYPE" (string kind))))
- (constructor (intern (format nil "MAKE-~A-TYPE"
- (string kind)))))
+ (let ((type (symbolicate 'c- kind '-type))
+ (constructor (symbolicate 'make- kind '-type)))
`(progn
(defclass ,type (tagged-c-type) ()
(:documentation ,(format nil "C ~a types." what)))
(defmethod c-tagged-type-kind ((type ,type))
- ,kind)
+ ',kind)
(let ((cache (make-hash-table :test #'equal)))
- (defun ,constructor (tag)
- (or (gethash tag cache)
- (setf (gethash tag cache)
- (make-instance ',type :tag tag)))))
- (define-c-type-syntax ,(intern (string kind)) (tag)
- ,(format nil "Construct ~A type named TAG" what)
- (,constructor tag))))))
- (define-tagged-type :enum "enumerated")
- (define-tagged-type :struct "structure")
- (define-tagged-type :union "union"))
-
-(defclass c-enum-type (tagged-c-type)
- ()
- (:documentation
- "C enumeration types."))
-(defclass c-struct-type (tagged-c-type)
- ()
- (:documentation
- "C structure types."))
-(defclass c-union-type (tagged-c-type)
- ()
- (:documentation
- "C union types."))
-
-(defmethod c-declaration ((type tagged-c-type) decl)
- (values (concatenate 'string
- (format-qualifiers (c-type-qualifiers type))
- (string-downcase (c-tagged-type-kind type))
- " "
- (c-type-tag type))
- decl))
+ (defun ,constructor (tag &optional qualifiers)
+ (qualify-type (or (gethash tag cache)
+ (setf (gethash tag cache)
+ (make-instance ',type
+ :tag tag)))
+ qualifiers)))
+ (define-c-type-syntax ,kind (tag &rest quals)
+ ,(format nil "Construct ~A type named TAG" what)
+ `(,',constructor ,tag (list ,@quals)))))))
+ (define-tagged-type enum "enumerated")
+ (define-tagged-type struct "structure")
+ (define-tagged-type union "union"))
+
+(defmethod pprint-c-type ((type tagged-c-type) stream kernel)
+ (pprint-logical-block (stream nil)
+ (format stream "~{~(~A~) ~@_~}~(~A~) ~A"
+ (c-type-qualifiers type)
+ (c-tagged-type-kind type)
+ (c-type-tag type))
+ (funcall kernel stream 0 t)))
(defmethod c-type-equal-p and ((type-a tagged-c-type)
(type-b tagged-c-type))
(defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<~A ~A~:>"
+ (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>"
(c-tagged-type-kind type)
- (c-type-tag type)))
-
-;; S-expression syntax.
-
-(define-c-type-syntax enum (tag)
- "Construct an enumeration type named TAG."
- (make-instance 'c-enum-type :tag (c-name-case tag)))
-(define-c-type-syntax struct (tag)
- "Construct a structure type named TAG."
- (make-instance 'c-struct-type :tag (c-name-case tag)))
-(define-c-type-syntax union (tag)
- "Construct a union type named TAG."
- (make-instance 'c-union-type :tag (c-name-case tag)))
+ (c-type-tag type)
+ (c-type-qualifiers type)))
;;;--------------------------------------------------------------------------
;;; Pointer types.
(:documentation
"C pointer types."))
-(defmethod c-declarator-priority ((type c-pointer-type)) 1)
-
-(defmethod c-declaration ((type c-pointer-type) decl)
- (compound-type-declaration type
- "*~A~A"
- (format-qualifiers (c-type-qualifiers type))
- decl))
+(let ((cache (make-hash-table :test #'eql)))
+ (defun make-pointer-type (subtype &optional qualifiers)
+ "Return a (maybe distinguished) pointer type."
+ (qualify-type (or (gethash subtype cache)
+ (make-instance 'c-pointer-type :subtype subtype))
+ qualifiers)))
+
+(defmethod pprint-c-type ((type c-pointer-type) stream kernel)
+ (pprint-c-type (c-type-subtype type) stream
+ (lambda (stream prio spacep)
+ (when spacep (c-type-space stream))
+ (maybe-in-parens (stream (> prio 1))
+ (format stream "*~{~(~A~)~^ ~@_~}"
+ (c-type-qualifiers type))
+ (funcall kernel stream 1 (c-type-qualifiers type))))))
(defmethod c-type-equal-p and ((type-a c-pointer-type)
(type-b c-pointer-type))
(defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<* ~@_~/sod::print-c-type/~:>"
- (c-type-subtype type)))
+ (format stream "~:@<* ~@_~/sod::print-c-type/~{ ~_~S~}~:>"
+ (c-type-subtype type)
+ (c-type-qualifiers type)))
;; S-expression syntax.
-(define-c-type-syntax pointer (sub)
+(define-c-type-syntax * (sub &rest quals)
"Return the type of pointer-to-SUB."
- (make-instance 'c-pointer-type :subtype (expand-c-type sub)))
-(c-type-alias pointer * ptr)
+ `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
+(c-type-alias * pointer ptr)
(defctype string (* char))
+(defctype const-string (* (char :const)))
;;;--------------------------------------------------------------------------
;;; Array types.
(:documentation
"C array types."))
-(defmethod c-declarator-priority ((type c-array-type)) 2)
+(defun make-array-type (subtype dimensions)
+ "Return a new array of SUBTYPE with given DIMENSIONS."
+ (make-instance 'c-array-type :subtype subtype
+ :dimensions (or dimensions '(nil))))
-(defmethod c-declaration ((type c-array-type) decl)
- (compound-type-declaration type
- "~A~{[~@[~A~]]~}"
- decl
- (c-array-dimensions type)))
+(defmethod pprint-c-type ((type c-array-type) stream kernel)
+ (pprint-c-type (c-type-subtype type) stream
+ (lambda (stream prio spacep)
+ (maybe-in-parens (stream (> prio 2))
+ (funcall kernel stream 2 spacep)
+ (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
+ (c-array-dimensions type))))))
(defmethod c-type-equal-p and ((type-a c-array-type)
(type-b c-array-type))
(defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~A~}~:>"
+ (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~S~}~:>"
(c-type-subtype type)
(c-array-dimensions type)))
;; S-expression syntax.
-(define-c-type-syntax array (sub &rest dims)
+(define-c-type-syntax [] (sub &rest dims)
"Return the type of arrays of SUB with the dimensions DIMS.
If the DIMS are omitted, a single unknown-length dimension is added."
- (make-instance 'c-array-type
- :subtype (expand-c-type sub)
- :dimensions (or dims '(nil))))
-(c-type-alias array [] vec)
+ `(make-array-type ,(expand-c-type-spec sub)
+ (list ,@(or dims '(nil)))))
+(c-type-alias [] array vec)
;;;--------------------------------------------------------------------------
;;; Function types.
-;; Definitions.
-
-(defclass c-function-type (c-type)
- ((subtype :initarg :subtype
- :type c-type
- :reader c-type-subtype)
- (arguments :initarg :arguments
- :type list
- :reader c-function-arguments))
- (:documentation
- "C function types. The subtype is the return type, as implied by the C
- syntax for function declarations."))
-
-(defmethod c-declarator-priority ((type c-function-type)) 2)
+;; Arguments.
(defstruct (argument (:constructor make-argument (name type)) (:type list))
"Simple list structure representing a function argument."
name
type)
-(defmethod c-declaration ((type c-function-type) decl)
- (compound-type-declaration type
- "~A(~:[void~;~:*~{~A~^, ~}~])"
- decl
- (mapcar (lambda (arg)
- (if (eq arg :ellipsis)
- "..."
- (multiple-value-bind
- (typestr declstr)
- (c-declaration
- (argument-type arg)
- (or (argument-name arg) ""))
- (format nil "~A~:[~; ~A~]"
- typestr
- (plusp (length declstr))
- declstr))))
- (c-function-arguments type))))
-
(defun arguments-lists-equal-p (list-a list-b)
+ "Return whether LIST-A and LIST-B match.
+
+ They must have the same number of arguments, and each argument must have
+ the same type, or be :ELLIPSIS. The argument names are not inspected."
(and (= (length list-a) (length list-b))
(every (lambda (arg-a arg-b)
(if (eq arg-a :ellipsis)
(argument-type arg-b))))
list-a list-b)))
+(defgeneric commentify-argument-name (name)
+ (:documentation
+ "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
+ printable representation of the argument.")
+ (:method ((name null)) nil)
+ (:method ((name t)) (format nil "/*~A*/" name)))
+
+(defun commentify-argument-names (arguments)
+ "Return an argument list with the arguments commentified.
+
+ That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME."
+ (mapcar (lambda (arg)
+ (if (eq arg :ellipsis)
+ arg
+ (make-argument (commentify-argument-name (argument-name arg))
+ (argument-type arg))))
+ arguments))
+
+(defun commentify-function-type (type)
+ "Return a type like TYPE, but with arguments commentified.
+
+ This doesn't recurse into the return type or argument types."
+ (make-function-type (c-type-subtype type)
+ (commentify-argument-names
+ (c-function-arguments type))))
+
+;; Definitions.
+
+(defclass c-function-type (c-type)
+ ((subtype :initarg :subtype
+ :type c-type
+ :reader c-type-subtype)
+ (arguments :initarg :arguments
+ :type list
+ :reader c-function-arguments))
+ (:documentation
+ "C function types. The subtype is the return type, as implied by the C
+ syntax for function declarations."))
+
+(defun make-function-type (subtype arguments)
+ "Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
+ (make-instance 'c-function-type :subtype subtype :arguments arguments))
+
(defmethod c-type-equal-p and ((type-a c-function-type)
(type-b c-function-type))
(and (c-type-equal-p (c-type-subtype type-a)
#.(concatenate 'string
"~:@<"
"FUN ~@_~:I~/sod::print-c-type/"
- "~{ ~_~:<~A ~@_~/sod::print-c-type/~:>~}"
+ "~{ ~_~:<~S ~@_~/sod::print-c-type/~:>~}"
"~:>")
(c-type-subtype type)
(c-function-arguments type)))
+(defmethod pprint-c-type ((type c-function-type) stream kernel)
+ (pprint-c-type (c-type-subtype type) stream
+ (lambda (stream prio spacep)
+ (maybe-in-parens (stream (> prio 2))
+ (when spacep (c-type-space stream))
+ (funcall kernel stream 2 nil)
+ (pprint-indent :block 4 stream)
+ ;;(pprint-newline :miser stream)
+ (pprint-logical-block
+ (stream nil :prefix "(" :suffix ")")
+ (let ((firstp t))
+ (dolist (arg (c-function-arguments type))
+ (if firstp
+ (setf firstp nil)
+ (format stream ", ~_"))
+ (if (eq arg :ellipsis)
+ (write-string "..." stream)
+ (pprint-c-type (argument-type arg)
+ stream
+ (argument-name arg))))))))))
+
;; S-expression syntax.
-(define-c-type-syntax function (ret &rest args)
+(define-c-type-syntax fun (ret &rest args)
"Return the type of functions which returns RET and has arguments ARGS.
- The ARGS are a list (NAME TYPE). The NAME can be NIL to indicate that no
- name was given."
- (make-instance 'c-function-type
- :subtype (expand-c-type ret)
- :arguments (mapcar (lambda (arg)
- (make-argument (car arg)
- (expand-c-type
- (cadr arg))))
- args)))
-(c-type-alias function () func fun fn)
+ The ARGS are a list of arguments of the form (NAME TYPE). The NAME can be
+ NIL to indicate that no name was given.
+
+ If an entry isn't a list, it's assumed to be the start of a Lisp
+ expression to compute the tail of the list; similarly, if the list is
+ improper, then it's considered to be a complete expression. The upshot of
+ this apparently bizarre rule is that you can say
+
+ (c-type (fun int (\"foo\" int) . arg-tail))
+
+ where ARG-TAIL is (almost) any old Lisp expression and have it tack the
+ arguments onto the end. Of course, there don't have to be any explicit
+ arguments at all. The only restriction is that the head of the Lisp form
+ can't be a list -- so ((lambda (...) ...) ...) is out, but you probably
+ wouldn't type that anyway."
+
+ `(make-function-type ,(expand-c-type-spec ret)
+ ,(do ((args args (cdr args))
+ (list nil
+ (cons `(make-argument ,(caar args)
+ ,(expand-c-type-spec
+ (cadar args)))
+ list)))
+ ((or (atom args) (atom (car args)))
+ (cond ((and (null args) (null list)) `nil)
+ ((null args) `(list ,@(nreverse list)))
+ ((null list) `,args)
+ (t `(list* ,@(nreverse list) ,args)))))))
+(c-type-alias fun function () func fn)
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff