mdw@git.distorted.org.uk Git - sod/blob - cutting-room-floor.lisp

   1 ;;;--------------------------------------------------------------------------
   2 ;;; C types stuff.
   3
   4 (cl:defpackage #:c-types
   5   (:use #:common-lisp
   6         #+sbcl #:sb-mop
   7         #+(or cmu clisp) #:mop
   8         #+ecl #:clos)
   9   (:export #:c-type
  10            #:c-declarator-priority #:maybe-parenthesize
  11            #:pprint-c-type
  12            #:c-type-subtype #:compount-type-declaration
  13            #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
  14            #:simple-c-type #:c-type-name
  15            #:c-pointer-type
  16            #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
  17            #:tagged-c-type-kind
  18            #:c-array-type #:c-array-dimensions
  19            #:make-argument #:argument-name #:argument-type
  20            #:c-function-type #:c-function-arguments
  21
  22            #:define-c-type-syntax #:c-type-alias #:defctype
  23            #:print-c-type
  24            #:qualifier #:declare-qualifier
  25            #:define-simple-c-type
  26
  27            #:const #:volatile #:static #:restrict
  28            #:char #:unsigned-char #:uchar #:signed-char #:schar
  29            #:int #:signed #:signed-int #:sint
  30            #:unsigned #:unsigned-int #:uint
  31            #:short #:signed-short #:short-int #:signed-short-int #:sshort
  32            #:unsigned-short #:unsigned-short-int #:ushort
  33            #:long #:signed-long #:long-int #:signed-long-int #:slong
  34            #:unsigned-long #:unsigned-long-int #:ulong
  35            #:float #:double #:long-double
  36            #:pointer #:ptr
  37            #:[] #:vec
  38            #:fun #:func #:fn))
  39
  40
  41 ;;;--------------------------------------------------------------------------
  42 ;;; Convenient syntax for C types.
  43
  44 ;; Basic machinery.
  45
  46 ;; Qualifiers.  They have hairy syntax and need to be implemented by hand.
  47
  48 ;; Simple types.
  49
  50 ;; Pointers.
  51
  52 ;; Tagged types.
  53
  54 ;; Arrays.
  55
  56 ;; Functions.
  57
  58
  59 (progn
  60   (defconstant q-byte (byte 3 0))
  61   (defconstant q-const 1)
  62   (defconstant q-volatile 2)
  63   (defconstant q-restrict 4)
  64
  65   (defconstant z-byte (byte 3 3))
  66   (defconstant z-unspec 0)
  67   (defconstant z-short 1)
  68   (defconstant z-long 2)
  69   (defconstant z-long-long 3)
  70   (defconstant z-double 4)
  71   (defconstant z-long-double 5)
  72
  73   (defconstant s-byte (byte 2 6))
  74   (defconstant s-unspec 0)
  75   (defconstant s-signed 1)
  76   (defconstant s-unsigned 2)
  77
  78   (defconstant t-byte (byte 3 8))
  79   (defconstant t-unspec 0)
  80   (defconstant t-int 1)
  81   (defconstant t-char 2)
  82   (defconstant t-float 3)
  83   (defconstant t-user 4))
  84
  85 (defun make-type-flags (size sign type &rest quals)
  86   (let ((flags 0))
  87     (dolist (qual quals)
  88       (setf flags (logior flags qual)))
  89     (setf (ldb z-byte flags) size
  90           (ldb s-byte flags) sign
  91           (ldb t-byte flags) type)
  92     flags))
  93
  94
  95 (defun expand-c-type (spec)
  96   "Parse SPEC as a C type and return the result.
  97
  98    The SPEC can be one of the following.
  99
 100      * A C-TYPE object, which is returned immediately.
 101
 102      * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
 103        function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
 104        or some other means is invoked on the ARGUMENTS, and the result is
 105        returned.
 106
 107      * A symbol, which is treated the same way as a singleton list would be."
 108
 109   (flet ((interp (sym)
 110            (or (get sym 'c-type)
 111                (error "Unknown C type operator ~S." sym))))
 112     (etypecase spec
 113       (c-type spec)
 114       (symbol (funcall (interp spec)))
 115       (list (apply (interp (car spec)) (cdr spec))))))
 116
 117 (defmacro c-type (spec)
 118   "Evaluates to the type that EXPAND-C-TYPE would return.
 119
 120    Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime.  Maybe
 121    later it will do something more clever."
 122   `(expand-c-type ',spec))
 123
 124 ;; S-expression machinery.  Qualifiers have hairy syntax and need to be
 125 ;; implemented by hand.
 126
 127 (defun qualifier (qual &rest args)
 128   "Parse a qualified C type.
 129
 130    The ARGS consist of a number of qualifiers and exactly one C-type
 131    S-expression.  The result is a qualified version of this type, with the
 132    given qualifiers attached."
 133   (if (null args)
 134       qual
 135       (let* ((things (mapcar #'expand-c-type args))
 136              (quals (delete-duplicates
 137                      (sort (cons qual (remove-if-not #'keywordp things))
 138                            #'string<)))
 139              (types (remove-if-not (lambda (thing) (typep thing 'c-type))
 140                                    things)))
 141         (when (or (null types)
 142                   (not (null (cdr types))))
 143           (error "Only one proper type expected in ~S." args))
 144         (qualify-type (car types) quals))))
 145 (setf (get 'qualifier 'c-type) #'qualifier)
 146
 147 (defun declare-qualifier (qual)
 148   "Defines QUAL as being a type qualifier.
 149
 150    When used as a C-type operator, it applies that qualifier to the type that
 151    is its argument."
 152   (let ((kw (intern (string qual) :keyword)))
 153     (setf (get qual 'c-type)
 154           (lambda (&rest args)
 155             (apply #'qualifier kw args)))))
 156
 157 ;; Define some initial qualifiers.
 158 (dolist (qual '(const volatile restrict))
 159   (declare-qualifier qual))
 160
 161
 162 (define-c-type-syntax simple-c-type (name)
 163   "Constructs a simple C type called NAME (a string or symbol)."
 164   (make-simple-type (c-name-case name)))
 165
 166 (defmethod print-c-type :around
 167     (stream (type qualifiable-c-type) &optional colon atsign)
 168   (if (c-type-qualifiers type)
 169       (pprint-logical-block (stream nil :prefix "(" :suffix ")")
 170         (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
 171                 (c-type-qualifiers type))
 172         (call-next-method stream type colon atsign))
 173       (call-next-method)))
 174 ;; S-expression syntax.
 175
 176
 177 (define-c-type-syntax enum (tag)
 178   "Construct an enumeration type named TAG."
 179   (make-instance 'c-enum-type :tag (c-name-case tag)))
 180 (define-c-type-syntax struct (tag)
 181   "Construct a structure type named TAG."
 182   (make-instance 'c-struct-type :tag (c-name-case tag)))
 183 (define-c-type-syntax union (tag)
 184   "Construct a union type named TAG."
 185   (make-instance 'c-union-type :tag (c-name-case tag)))
 186
 187 (defgeneric make-me-argument (message class)
 188   (:documentation
 189    "Return an ARGUMENT object for the `me' argument to MESSAGE, as
 190    specialized to CLASS."))
 191
 192 (defmethod make-me-argument
 193     ((message basic-message) (class sod-class))
 194   (make-argument "me" (make-instance 'c-pointer-type
 195                                      :subtype (sod-class-type class))))