+++ /dev/null
-;;;--------------------------------------------------------------------------
-;;; C types stuff.
-
-(cl:defpackage #:c-types
- (:use #:common-lisp
- #+sbcl #:sb-mop
- #+(or cmu clisp) #:mop
- #+ecl #:clos)
- (:export #:c-type
- #:c-declarator-priority #:maybe-parenthesize
- #:pprint-c-type
- #:c-type-subtype #:compount-type-declaration
- #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
- #:simple-c-type #:c-type-name
- #:c-pointer-type
- #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
- #:tagged-c-type-kind
- #:c-array-type #:c-array-dimensions
- #:make-argument #:argument-name #:argument-type
- #:c-function-type #:c-function-arguments
-
- #:define-c-type-syntax #:c-type-alias #:defctype
- #:print-c-type
- #:qualifier #:declare-qualifier
- #:define-simple-c-type
-
- #:const #:volatile #:static #:restrict
- #:char #:unsigned-char #:uchar #:signed-char #:schar
- #:int #:signed #:signed-int #:sint
- #:unsigned #:unsigned-int #:uint
- #:short #:signed-short #:short-int #:signed-short-int #:sshort
- #:unsigned-short #:unsigned-short-int #:ushort
- #:long #:signed-long #:long-int #:signed-long-int #:slong
- #:unsigned-long #:unsigned-long-int #:ulong
- #:float #:double #:long-double
- #:pointer #:ptr
- #:[] #:vec
- #:fun #:func #:fn))
-
-
-;;;--------------------------------------------------------------------------
-;;; Convenient syntax for C types.
-
-;; Basic machinery.
-
-;; Qualifiers. They have hairy syntax and need to be implemented by hand.
-
-;; Simple types.
-
-;; Pointers.
-
-;; Tagged types.
-
-;; Arrays.
-
-;; Functions.
-
-
-(progn
- (defconstant q-byte (byte 3 0))
- (defconstant q-const 1)
- (defconstant q-volatile 2)
- (defconstant q-restrict 4)
-
- (defconstant z-byte (byte 3 3))
- (defconstant z-unspec 0)
- (defconstant z-short 1)
- (defconstant z-long 2)
- (defconstant z-long-long 3)
- (defconstant z-double 4)
- (defconstant z-long-double 5)
-
- (defconstant s-byte (byte 2 6))
- (defconstant s-unspec 0)
- (defconstant s-signed 1)
- (defconstant s-unsigned 2)
-
- (defconstant t-byte (byte 3 8))
- (defconstant t-unspec 0)
- (defconstant t-int 1)
- (defconstant t-char 2)
- (defconstant t-float 3)
- (defconstant t-user 4))
-
-(defun make-type-flags (size sign type &rest quals)
- (let ((flags 0))
- (dolist (qual quals)
- (setf flags (logior flags qual)))
- (setf (ldb z-byte flags) size
- (ldb s-byte flags) sign
- (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