#+ecl #:clos)
(:export #:c-type
#:c-declarator-priority #:maybe-parenthesize
- #:c-declaration
+ #:pprint-c-type
#:c-type-subtype #:compount-type-declaration
#:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
#:simple-c-type #:c-type-name
(ldb t-byte flags) type)
flags))
+
+(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))))))
+
+(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))
+
+;; 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))
+
+
+(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)))
+
+(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)))
+;; 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)))
+
+(defgeneric make-me-argument (message class)
+ (:documentation
+ "Return an ARGUMENT object for the `me' argument to MESSAGE, as
+ specialized to CLASS."))
+
+(defmethod make-me-argument
+ ((message basic-message) (class sod-class))
+ (make-argument "me" (make-instance 'c-pointer-type
+ :subtype (sod-class-type class))))
~mdw / sod / blobdiff