Commit | Line | Data |
---|---|---|
dea4d055 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 | |
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)))) | |
196 | ||
197 | ;;;-------------------------------------------------------------------------- | |
198 | ;;; Keyword arguments and lambda lists. | |
199 | ||
200 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
201 | (defun transform-otherkeys-lambda-list (bvl) | |
202 | "Process a simple lambda-list BVL which might contain &OTHER-KEYS. | |
203 | ||
204 | &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments | |
205 | (which must also be present); &ALLOW-OTHER-KEYS must not be present. | |
206 | ||
207 | The behaviour is that | |
208 | ||
209 | * the presence of non-listed keyword arguments is permitted, as if | |
210 | &ALLOW-OTHER-KEYS had been provided, and | |
211 | ||
212 | * a list of the keyword arguments other than the ones explicitly listed | |
213 | is stored in the VAR. | |
214 | ||
215 | The return value is a replacement BVL which binds the &OTHER-KEYS variable | |
216 | as an &AUX parameter if necessary. | |
217 | ||
218 | At least for now, fancy things like destructuring lambda-lists aren't | |
219 | supported. I suspect you'll get away with a specializing lambda-list." | |
220 | ||
221 | (prog ((new-bvl nil) | |
222 | (rest-var nil) | |
223 | (keywords nil) | |
224 | (other-keys-var nil) | |
225 | (tail bvl)) | |
226 | ||
227 | find-rest | |
228 | ;; Scan forwards until we find &REST or &KEY. If we find the former, | |
229 | ;; then remember the variable name. If we find the latter first then | |
230 | ;; there can't be a &REST argument, so we should invent one. If we | |
231 | ;; find neither then there's nothing to do. | |
232 | (when (endp tail) | |
233 | (go ignore)) | |
234 | (let ((item (pop tail))) | |
235 | (push item new-bvl) | |
236 | (case item | |
237 | (&rest (when (endp tail) | |
238 | (error "Missing &REST argument name")) | |
239 | (setf rest-var (pop tail)) | |
240 | (push rest-var new-bvl)) | |
241 | (&aux (go ignore)) | |
242 | (&key (unless rest-var | |
243 | (setf rest-var (gensym "REST")) | |
244 | (setf new-bvl (nconc (list '&key rest-var '&rest) | |
245 | (cdr new-bvl)))) | |
246 | (go scan-keywords))) | |
247 | (go find-rest)) | |
248 | ||
249 | scan-keywords | |
250 | ;; Read keyword argument specs one-by-one. For each one, stash it on | |
251 | ;; the NEW-BVL list, and also parse it to extract the keyword, which | |
252 | ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's | |
253 | ;; nothing for us to do. | |
254 | (when (endp tail) | |
255 | (go ignore)) | |
256 | (let ((item (pop tail))) | |
257 | (push item new-bvl) | |
258 | (case item | |
259 | ((&aux &allow-other-keys) (go ignore)) | |
260 | (&other-keys (go fix-tail))) | |
261 | (let ((keyword (if (symbolp item) | |
262 | (intern (symbol-name item) :keyword) | |
263 | (let ((var (car item))) | |
264 | (if (symbolp var) | |
265 | (intern (symbol-name var) :keyword) | |
266 | (car var)))))) | |
267 | (push keyword keywords)) | |
268 | (go scan-keywords)) | |
269 | ||
270 | fix-tail | |
271 | ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var. | |
272 | (pop new-bvl) | |
273 | (when (endp tail) | |
274 | (error "Missing &OTHER-KEYS argument name")) | |
275 | (setf other-keys-var (pop tail)) | |
276 | (push '&allow-other-keys new-bvl) | |
277 | ||
278 | ;; There should be an &AUX next. If there isn't, assume there isn't | |
279 | ;; one and provide our own. (This is safe as long as nobody else is | |
280 | ;; expecting to plumb in lambda keywords too.) | |
281 | (when (and (not (endp tail)) (eq (car tail) '&aux)) | |
282 | (pop tail)) | |
283 | (push '&aux new-bvl) | |
284 | ||
285 | ;; Add our shiny new &AUX argument. | |
286 | (let ((keys-var (gensym "KEYS")) | |
287 | (list-var (gensym "LIST"))) | |
288 | (push `(,other-keys-var (do ((,list-var nil) | |
289 | (,keys-var ,rest-var (cddr ,keys-var))) | |
290 | ((endp ,keys-var) (nreverse ,list-var)) | |
291 | (unless (member (car ,keys-var) | |
292 | ',keywords) | |
293 | (setf ,list-var | |
294 | (cons (cadr ,keys-var) | |
295 | (cons (car ,keys-var) | |
296 | ,list-var)))))) | |
297 | new-bvl)) | |
298 | ||
299 | ;; Done. | |
300 | (return (nreconc new-bvl tail)) | |
301 | ||
302 | ignore | |
303 | ;; Nothing to do. Return the unmolested lambda-list. | |
304 | (return bvl)))) | |
305 | ||
306 | (defmacro lambda-otherkeys (bvl &body body) | |
307 | "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword." | |
308 | `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body)) | |
309 | ||
310 | (defmacro defun-otherkeys (name bvl &body body) | |
311 | "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword." | |
312 | `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body)) | |
313 | ||
314 | (defmacro defmethod-otherkeys (name &rest stuff) | |
315 | "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword." | |
316 | (do ((quals nil) | |
317 | (stuff stuff (cdr stuff))) | |
318 | ((listp (car stuff)) | |
319 | `(defmethod ,name ,@(nreverse quals) | |
320 | ,(transform-otherkeys-lambda-list (car stuff)) | |
321 | ,@(cdr stuff))) | |
322 | (push (car stuff) quals))) | |
323 | ||
324 | ||
325 | (defparse many ((acc init update | |
326 | &key (new 'it) (final acc) (min nil minp) max (commitp t)) | |
327 | parser &optional (sep nil sepp)) | |
328 | "Parse a sequence of homogeneous items. | |
329 | ||
330 | The behaviour is similar to `do'. Initially an accumulator ACC is | |
331 | established, and bound to the value of INIT. The PARSER is then evaluated | |
332 | repeatedly. Each time it succeeds, UPDATE is evaluated with NEW (defaults | |
333 | to `it') bound to the result of the parse, and the value returned by | |
334 | UPDATE is stored back into ACC. If the PARSER fails, then the parse ends. | |
335 | ||
336 | If a SEP parser is provided, then the behaviour changes as follows. | |
337 | Before each attempt to parse a new item using PARSER, the parser SEP is | |
338 | invoked. If SEP fails then the parse ends; if SEP succeeds, then the | |
339 | PARSER must also succeed or the overall parse will fail. | |
340 | ||
341 | If MAX (which will be evaluated) is not nil, then it must be a number: the | |
342 | parse ends automatically after PARSER has succeeded MAX times. When the | |
343 | parse has ended, if the PARSER succeeded fewer than MIN (which will be | |
344 | evaluated) times then the parse fails. Otherwise, the FINAL form (which | |
345 | defaults to simply returning ACC) is evaluated and its value becomes the | |
346 | result of the parse. MAX defaults to nil -- i.e., no maximum; MIN | |
347 | defaults to 1 if a SEP parser is given, or 0 if not. | |
348 | ||
349 | Note that `many' cannot fail if MIN is zero." | |
350 | ||
351 | (unless minp (setf min (if sepp 1 0))) | |
352 | (with-gensyms (block value win consumedp cp i up done) | |
353 | (once-only (init min max commitp) | |
354 | (let ((counterp (or max (not (numberp min)) (> min (if sepp 1 0))))) | |
355 | `(block ,block | |
356 | ||
357 | ;; Keep track of variables. We only need an accumulator if it's | |
358 | ;; not nil, and we don't need a counter if (a) there's no maximum, | |
359 | ;; and either (b) the minimum is zero, or (c) the minimum is one | |
360 | ;; and there's a separator. In case (c), we can keep track of how | |
361 | ;; much has been seen using control flow. | |
362 | (let ((,consumedp nil) | |
363 | ,@(and acc `((,acc ,init))) | |
364 | ,@(and counterp `((,i 0)))) | |
365 | ||
366 | ;; Some handy functions. `up' will update the accumulator. | |
367 | ;; `done' will return the necessary final value. | |
368 | (flet (,@(and acc `((,up (,new) | |
369 | (declare (ignorable ,new)) | |
370 | (setf ,acc ,update)))) | |
371 | (,done () (return-from ,block | |
372 | (values ,final t ,consumedp)))) | |
373 | ||
374 | ;; If there's a separator, prime the pump by parsing a first | |
375 | ;; item. This makes the loop easy: it just parses a separator | |
376 | ;; and an item each time. And it means we don't need a | |
377 | ;; counter in the case of a minimum of 1. | |
378 | ,@(and sepp | |
379 | `((multiple-value-bind (,value ,win ,cp) | |
380 | (parse ,parser) | |
381 | (when ,cp (setf ,consumedp t)) | |
382 | (unless ,win | |
383 | ,(cond ((eql min 0) | |
384 | `(,done)) | |
385 | ((and (numberp min) (plusp min)) | |
386 | `(return-from ,block | |
387 | (values ,value nil ,consumedp))) | |
388 | (t | |
389 | `(if (< 0 ,min) | |
390 | (return-from ,block | |
391 | (values ,value nil, consumedp)) | |
392 | (,done))))) | |
393 | ,@(and acc `((,up ,value)))) | |
394 | ,@(and counterp `((incf ,i))))) | |
395 | ||
396 | ;; The main loop... | |
397 | (loop | |
398 | ||
399 | ;; If we've hit the maximum then stop. But, attention, if | |
400 | ;; we have a separator and we're not committing to parsing | |
401 | ;; items, then check after scanning the separator, not | |
402 | ;; before. | |
403 | ,@(and max commitp | |
404 | `((when (and ,@(and (not (constantp max)) | |
405 | `(,max)) | |
406 | ,@(and (not (constantp commitp)) | |
407 | `(,commitp)) | |
408 | (>= ,i ,max)) | |
409 | (,done)))) | |
410 | ||
411 | ,@(if sepp | |
412 | ;; We're expecting a separator. If this fails and | |
413 | ;; we're below minimum then we've failed altogether. | |
414 | ;; If it succeeds then we should go on to parse an | |
415 | ;; item. | |
416 | `((multiple-value-bind (,value ,win ,cp) (parse ,sep) | |
417 | ,@(and (numberp min) (<= min 1) | |
418 | `((declare (ignore ,value)))) | |
419 | (when ,cp (setf ,consumedp t)) | |
420 | (unless ,win | |
421 | ,(if (and (numberp min) (<= min 1)) | |
422 | `(,done) | |
423 | `(if (>= ,i ,min) | |
424 | (return ,final) | |
425 | (return-from ,block | |
426 | (values ,value nil ,consumedp)))))) | |
427 | ||
428 | ;; If we're not committing then now is the time to | |
429 | ;; check for hitting the maximum number of | |
430 | ;; repetitions. | |
431 | ,@(and max (or (not commitp) | |
432 | (not (constantp commitp))) | |
433 | `((when (and ,@(and (not (constantp max)) | |
434 | `(,max)) | |
435 | ,@(and commitp | |
436 | `((not ,commitp))) | |
437 | (>= ,i ,max)) | |
438 | (,done)))) | |
439 | ||
440 | ;; Now parse an item. If this fails and we're | |
441 | ;; committed then we've blown the whole parse. If | |
442 | ;; it fails and we've not committed then we need to | |
443 | ;; check the minimum. It's getting very tempting to | |
444 | ;; write a compiler for optimizing these | |
445 | ;; conditionals. (If we don't do this, we get | |
446 | ;; annoying warnings.) | |
447 | (multiple-value-bind (,value ,win ,cp) | |
448 | (parse ,parser) | |
449 | (when ,cp (setf ,consumedp t)) | |
450 | (unless ,win | |
451 | ,(cond ((and (constantp commitp) commitp) | |
452 | `(return-from ,block | |
453 | (values ,value nil ,consumedp))) | |
454 | ((not commitp) | |
455 | (if (and (numberp min) (<= min 1)) | |
456 | `(,done) | |
457 | `(if (>= ,i ,min) | |
458 | (,done) | |
459 | (return-from ,block | |
460 | (values ,value nil | |
461 | ,consumedp))))) | |
462 | ((and (numberp min) (<= min 1)) | |
463 | `(if ,commitp | |
464 | (return-from ,block | |
465 | (values ,value nil ,consumedp)) | |
466 | (,done))) | |
467 | (t | |
468 | `(if (or ,commitp (< ,i ,min)) | |
469 | (return-from ,block | |
470 | (values ,value nil ,consumedp)) | |
471 | (,done))))) | |
472 | ,@(and acc `((,up ,value))))) | |
473 | ||
474 | ;; No separator. Just parse the value. If it fails, | |
475 | ;; check that we've met the minimum. | |
476 | `((multiple-value-bind (,value ,win ,cp) | |
477 | (parse ,parser) | |
478 | ,@(and (eql min 0) (null acc) | |
479 | `((declare (ignore ,value)))) | |
480 | (when ,cp (setf ,consumedp t)) | |
481 | (unless ,win | |
482 | ,(if (eql min 0) | |
483 | `(,done) | |
484 | `(if (>= ,i ,min) | |
485 | (,done) | |
486 | (return-from ,block | |
487 | (values ,value nil ,consumedp))))) | |
488 | ,@(and acc `((,up ,value)))))) | |
489 | ||
490 | ;; Done. Update the counter and go round again. | |
491 | ,@(and counterp `((incf ,i))))))))))) |