+++ /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))))
-
-;;;--------------------------------------------------------------------------
-;;; Keyword arguments and lambda lists.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun transform-otherkeys-lambda-list (bvl)
- "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
-
- &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
- (which must also be present); &ALLOW-OTHER-KEYS must not be present.
-
- The behaviour is that
-
- * the presence of non-listed keyword arguments is permitted, as if
- &ALLOW-OTHER-KEYS had been provided, and
-
- * a list of the keyword arguments other than the ones explicitly listed
- is stored in the VAR.
-
- The return value is a replacement BVL which binds the &OTHER-KEYS variable
- as an &AUX parameter if necessary.
-
- At least for now, fancy things like destructuring lambda-lists aren't
- supported. I suspect you'll get away with a specializing lambda-list."
-
- (prog ((new-bvl nil)
- (rest-var nil)
- (keywords nil)
- (other-keys-var nil)
- (tail bvl))
-
- find-rest
- ;; Scan forwards until we find &REST or &KEY. If we find the former,
- ;; then remember the variable name. If we find the latter first then
- ;; there can't be a &REST argument, so we should invent one. If we
- ;; find neither then there's nothing to do.
- (when (endp tail)
- (go ignore))
- (let ((item (pop tail)))
- (push item new-bvl)
- (case item
- (&rest (when (endp tail)
- (error "Missing &REST argument name"))
- (setf rest-var (pop tail))
- (push rest-var new-bvl))
- (&aux (go ignore))
- (&key (unless rest-var
- (setf rest-var (gensym "REST"))
- (setf new-bvl (nconc (list '&key rest-var '&rest)
- (cdr new-bvl))))
- (go scan-keywords)))
- (go find-rest))
-
- scan-keywords
- ;; Read keyword argument specs one-by-one. For each one, stash it on
- ;; the NEW-BVL list, and also parse it to extract the keyword, which
- ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's
- ;; nothing for us to do.
- (when (endp tail)
- (go ignore))
- (let ((item (pop tail)))
- (push item new-bvl)
- (case item
- ((&aux &allow-other-keys) (go ignore))
- (&other-keys (go fix-tail)))
- (let ((keyword (if (symbolp item)
- (intern (symbol-name item) :keyword)
- (let ((var (car item)))
- (if (symbolp var)
- (intern (symbol-name var) :keyword)
- (car var))))))
- (push keyword keywords))
- (go scan-keywords))
-
- fix-tail
- ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var.
- (pop new-bvl)
- (when (endp tail)
- (error "Missing &OTHER-KEYS argument name"))
- (setf other-keys-var (pop tail))
- (push '&allow-other-keys new-bvl)
-
- ;; There should be an &AUX next. If there isn't, assume there isn't
- ;; one and provide our own. (This is safe as long as nobody else is
- ;; expecting to plumb in lambda keywords too.)
- (when (and (not (endp tail)) (eq (car tail) '&aux))
- (pop tail))
- (push '&aux new-bvl)
-
- ;; Add our shiny new &AUX argument.
- (let ((keys-var (gensym "KEYS"))
- (list-var (gensym "LIST")))
- (push `(,other-keys-var (do ((,list-var nil)
- (,keys-var ,rest-var (cddr ,keys-var)))
- ((endp ,keys-var) (nreverse ,list-var))
- (unless (member (car ,keys-var)
- ',keywords)
- (setf ,list-var
- (cons (cadr ,keys-var)
- (cons (car ,keys-var)
- ,list-var))))))
- new-bvl))
-
- ;; Done.
- (return (nreconc new-bvl tail))
-
- ignore
- ;; Nothing to do. Return the unmolested lambda-list.
- (return bvl))))
-
-(defmacro lambda-otherkeys (bvl &body body)
- "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
- `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
-
-(defmacro defun-otherkeys (name bvl &body body)
- "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
- `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
-
-(defmacro defmethod-otherkeys (name &rest stuff)
- "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
- (do ((quals nil)
- (stuff stuff (cdr stuff)))
- ((listp (car stuff))
- `(defmethod ,name ,@(nreverse quals)
- ,(transform-otherkeys-lambda-list (car stuff))
- ,@(cdr stuff)))
- (push (car stuff) quals)))
-
-
-(defparse many ((acc init update
- &key (new 'it) (final acc) (min nil minp) max (commitp t))
- parser &optional (sep nil sepp))
- "Parse a sequence of homogeneous items.
-
- The behaviour is similar to `do'. Initially an accumulator ACC is
- established, and bound to the value of INIT. The PARSER is then evaluated
- repeatedly. Each time it succeeds, UPDATE is evaluated with NEW (defaults
- to `it') bound to the result of the parse, and the value returned by
- UPDATE is stored back into ACC. If the PARSER fails, then the parse ends.
-
- If a SEP parser is provided, then the behaviour changes as follows.
- Before each attempt to parse a new item using PARSER, the parser SEP is
- invoked. If SEP fails then the parse ends; if SEP succeeds, then the
- PARSER must also succeed or the overall parse will fail.
-
- If MAX (which will be evaluated) is not nil, then it must be a number: the
- parse ends automatically after PARSER has succeeded MAX times. When the
- parse has ended, if the PARSER succeeded fewer than MIN (which will be
- evaluated) times then the parse fails. Otherwise, the FINAL form (which
- defaults to simply returning ACC) is evaluated and its value becomes the
- result of the parse. MAX defaults to nil -- i.e., no maximum; MIN
- defaults to 1 if a SEP parser is given, or 0 if not.
-
- Note that `many' cannot fail if MIN is zero."
-
- (unless minp (setf min (if sepp 1 0)))
- (with-gensyms (block value win consumedp cp i up done)
- (once-only (init min max commitp)
- (let ((counterp (or max (not (numberp min)) (> min (if sepp 1 0)))))
- `(block ,block
-
- ;; Keep track of variables. We only need an accumulator if it's
- ;; not nil, and we don't need a counter if (a) there's no maximum,
- ;; and either (b) the minimum is zero, or (c) the minimum is one
- ;; and there's a separator. In case (c), we can keep track of how
- ;; much has been seen using control flow.
- (let ((,consumedp nil)
- ,@(and acc `((,acc ,init)))
- ,@(and counterp `((,i 0))))
-
- ;; Some handy functions. `up' will update the accumulator.
- ;; `done' will return the necessary final value.
- (flet (,@(and acc `((,up (,new)
- (declare (ignorable ,new))
- (setf ,acc ,update))))
- (,done () (return-from ,block
- (values ,final t ,consumedp))))
-
- ;; If there's a separator, prime the pump by parsing a first
- ;; item. This makes the loop easy: it just parses a separator
- ;; and an item each time. And it means we don't need a
- ;; counter in the case of a minimum of 1.
- ,@(and sepp
- `((multiple-value-bind (,value ,win ,cp)
- (parse ,parser)
- (when ,cp (setf ,consumedp t))
- (unless ,win
- ,(cond ((eql min 0)
- `(,done))
- ((and (numberp min) (plusp min))
- `(return-from ,block
- (values ,value nil ,consumedp)))
- (t
- `(if (< 0 ,min)
- (return-from ,block
- (values ,value nil, consumedp))
- (,done)))))
- ,@(and acc `((,up ,value))))
- ,@(and counterp `((incf ,i)))))
-
- ;; The main loop...
- (loop
-
- ;; If we've hit the maximum then stop. But, attention, if
- ;; we have a separator and we're not committing to parsing
- ;; items, then check after scanning the separator, not
- ;; before.
- ,@(and max commitp
- `((when (and ,@(and (not (constantp max))
- `(,max))
- ,@(and (not (constantp commitp))
- `(,commitp))
- (>= ,i ,max))
- (,done))))
-
- ,@(if sepp
- ;; We're expecting a separator. If this fails and
- ;; we're below minimum then we've failed altogether.
- ;; If it succeeds then we should go on to parse an
- ;; item.
- `((multiple-value-bind (,value ,win ,cp) (parse ,sep)
- ,@(and (numberp min) (<= min 1)
- `((declare (ignore ,value))))
- (when ,cp (setf ,consumedp t))
- (unless ,win
- ,(if (and (numberp min) (<= min 1))
- `(,done)
- `(if (>= ,i ,min)
- (return ,final)
- (return-from ,block
- (values ,value nil ,consumedp))))))
-
- ;; If we're not committing then now is the time to
- ;; check for hitting the maximum number of
- ;; repetitions.
- ,@(and max (or (not commitp)
- (not (constantp commitp)))
- `((when (and ,@(and (not (constantp max))
- `(,max))
- ,@(and commitp
- `((not ,commitp)))
- (>= ,i ,max))
- (,done))))
-
- ;; Now parse an item. If this fails and we're
- ;; committed then we've blown the whole parse. If
- ;; it fails and we've not committed then we need to
- ;; check the minimum. It's getting very tempting to
- ;; write a compiler for optimizing these
- ;; conditionals. (If we don't do this, we get
- ;; annoying warnings.)
- (multiple-value-bind (,value ,win ,cp)
- (parse ,parser)
- (when ,cp (setf ,consumedp t))
- (unless ,win
- ,(cond ((and (constantp commitp) commitp)
- `(return-from ,block
- (values ,value nil ,consumedp)))
- ((not commitp)
- (if (and (numberp min) (<= min 1))
- `(,done)
- `(if (>= ,i ,min)
- (,done)
- (return-from ,block
- (values ,value nil
- ,consumedp)))))
- ((and (numberp min) (<= min 1))
- `(if ,commitp
- (return-from ,block
- (values ,value nil ,consumedp))
- (,done)))
- (t
- `(if (or ,commitp (< ,i ,min))
- (return-from ,block
- (values ,value nil ,consumedp))
- (,done)))))
- ,@(and acc `((,up ,value)))))
-
- ;; No separator. Just parse the value. If it fails,
- ;; check that we've met the minimum.
- `((multiple-value-bind (,value ,win ,cp)
- (parse ,parser)
- ,@(and (eql min 0) (null acc)
- `((declare (ignore ,value))))
- (when ,cp (setf ,consumedp t))
- (unless ,win
- ,(if (eql min 0)
- `(,done)
- `(if (>= ,i ,min)
- (,done)
- (return-from ,block
- (values ,value nil ,consumedp)))))
- ,@(and acc `((,up ,value))))))
-
- ;; Done. Update the counter and go round again.
- ,@(and counterp `((incf ,i)))))))))))
\ No newline at end of file
~mdw / sod / blobdiff