Commit | Line | Data |
---|---|---|
abdf50aa MW |
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 | |
1f1d88f5 | 11 | #:pprint-c-type |
abdf50aa MW |
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 | ||
1f1d88f5 MW |
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)))) |