X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/7d21069e791a4d164c1eb1fc4f1ae661fe08ffbe..8f33dc2a5d924fc6747d32d047b8c52ab753331c:/pre-reorg/cutting-room-floor.lisp?ds=inline diff --git a/pre-reorg/cutting-room-floor.lisp b/pre-reorg/cutting-room-floor.lisp deleted file mode 100644 index 294e5b6..0000000 --- a/pre-reorg/cutting-room-floor.lisp +++ /dev/null @@ -1,491 +0,0 @@ -;;;-------------------------------------------------------------------------- -;;; 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