X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa..dea4d05507e59ab779ed4bb209e05971d87e260c:/cutting-room-floor.lisp?ds=sidebyside diff --git a/cutting-room-floor.lisp b/cutting-room-floor.lisp deleted file mode 100644 index 2f82c65..0000000 --- a/cutting-room-floor.lisp +++ /dev/null @@ -1,195 +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))))