1 ;;;--------------------------------------------------------------------------
4 (cl:defpackage #:c-types
10 #:c-declarator-priority #:maybe-parenthesize
12 #:c-type-subtype #:compount-type-declaration
13 #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
14 #:simple-c-type #:c-type-name
16 #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
18 #:c-array-type #:c-array-dimensions
19 #:make-argument #:argument-name #:argument-type
20 #:c-function-type #:c-function-arguments
22 #:define-c-type-syntax #:c-type-alias #:defctype
24 #:qualifier #:declare-qualifier
25 #:define-simple-c-type
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
41 ;;;--------------------------------------------------------------------------
42 ;;; Convenient syntax for C types.
46 ;; Qualifiers. They have hairy syntax and need to be implemented by hand.
60 (defconstant q-byte (byte 3 0))
61 (defconstant q-const 1)
62 (defconstant q-volatile 2)
63 (defconstant q-restrict 4)
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)
73 (defconstant s-byte (byte 2 6))
74 (defconstant s-unspec 0)
75 (defconstant s-signed 1)
76 (defconstant s-unsigned 2)
78 (defconstant t-byte (byte 3 8))
79 (defconstant t-unspec 0)
81 (defconstant t-char 2)
82 (defconstant t-float 3)
83 (defconstant t-user 4))
85 (defun make-type-flags (size sign type &rest 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)
95 (defun expand-c-type (spec)
96 "Parse SPEC as a C type and return the result.
98 The SPEC can be one of the following.
100 * A C-TYPE object, which is returned immediately.
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
107 * A symbol, which is treated the same way as a singleton list would be."
110 (or (get sym 'c-type)
111 (error "Unknown C type operator ~S." sym))))
114 (symbol (funcall (interp spec)))
115 (list (apply (interp (car spec)) (cdr spec))))))
117 (defmacro c-type (spec)
118 "Evaluates to the type that EXPAND-C-TYPE would return.
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))
124 ;; S-expression machinery. Qualifiers have hairy syntax and need to be
125 ;; implemented by hand.
127 (defun qualifier (qual &rest args)
128 "Parse a qualified C type.
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."
135 (let* ((things (mapcar #'expand-c-type args))
136 (quals (delete-duplicates
137 (sort (cons qual (remove-if-not #'keywordp things))
139 (types (remove-if-not (lambda (thing) (typep thing 'c-type))
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)
147 (defun declare-qualifier (qual)
148 "Defines QUAL as being a type qualifier.
150 When used as a C-type operator, it applies that qualifier to the type that
152 (let ((kw (intern (string qual) :keyword)))
153 (setf (get qual 'c-type)
155 (apply #'qualifier kw args)))))
157 ;; Define some initial qualifiers.
158 (dolist (qual '(const volatile restrict))
159 (declare-qualifier qual))
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)))
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))
174 ;; S-expression syntax.
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)))
187 (defgeneric make-me-argument (message class)
189 "Return an ARGUMENT object for the `me' argument to MESSAGE, as
190 specialized to CLASS."))
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))))
197 ;;;--------------------------------------------------------------------------
198 ;;; Keyword arguments and lambda lists.
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.
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.
207 The behaviour is that
209 * the presence of non-listed keyword arguments is permitted, as if
210 &ALLOW-OTHER-KEYS had been provided, and
212 * a list of the keyword arguments other than the ones explicitly listed
213 is stored in the VAR.
215 The return value is a replacement BVL which binds the &OTHER-KEYS variable
216 as an &AUX parameter if necessary.
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."
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.
234 (let ((item (pop tail)))
237 (&rest (when (endp tail)
238 (error "Missing &REST argument name"))
239 (setf rest-var (pop tail))
240 (push rest-var new-bvl))
242 (&key (unless rest-var
243 (setf rest-var (gensym "REST"))
244 (setf new-bvl (nconc (list '&key rest-var '&rest)
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.
256 (let ((item (pop tail)))
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)))
265 (intern (symbol-name var) :keyword)
267 (push keyword keywords))
271 ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var.
274 (error "Missing &OTHER-KEYS argument name"))
275 (setf other-keys-var (pop tail))
276 (push '&allow-other-keys new-bvl)
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))
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)
294 (cons (cadr ,keys-var)
295 (cons (car ,keys-var)
300 (return (nreconc new-bvl tail))
303 ;; Nothing to do. Return the unmolested lambda-list.
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))
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))
314 (defmacro defmethod-otherkeys (name &rest stuff)
315 "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
317 (stuff stuff (cdr stuff)))
319 `(defmethod ,name ,@(nreverse quals)
320 ,(transform-otherkeys-lambda-list (car stuff))
322 (push (car stuff) quals)))
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.
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.
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.
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.
349 Note that `many' cannot fail if MIN is zero."
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)))))
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))))
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))))
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.
379 `((multiple-value-bind (,value ,win ,cp)
381 (when ,cp (setf ,consumedp t))
385 ((and (numberp min) (plusp min))
387 (values ,value nil ,consumedp)))
391 (values ,value nil, consumedp))
393 ,@(and acc `((,up ,value))))
394 ,@(and counterp `((incf ,i)))))
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
404 `((when (and ,@(and (not (constantp max))
406 ,@(and (not (constantp commitp))
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
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))
421 ,(if (and (numberp min) (<= min 1))
426 (values ,value nil ,consumedp))))))
428 ;; If we're not committing then now is the time to
429 ;; check for hitting the maximum number of
431 ,@(and max (or (not commitp)
432 (not (constantp commitp)))
433 `((when (and ,@(and (not (constantp max))
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)
449 (when ,cp (setf ,consumedp t))
451 ,(cond ((and (constantp commitp) commitp)
453 (values ,value nil ,consumedp)))
455 (if (and (numberp min) (<= min 1))
462 ((and (numberp min) (<= min 1))
465 (values ,value nil ,consumedp))
468 `(if (or ,commitp (< ,i ,min))
470 (values ,value nil ,consumedp))
472 ,@(and acc `((,up ,value)))))
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)
478 ,@(and (eql min 0) (null acc)
479 `((declare (ignore ,value))))
480 (when ,cp (setf ,consumedp t))
487 (values ,value nil ,consumedp)))))
488 ,@(and acc `((,up ,value))))))
490 ;; Done. Update the counter and go round again.
491 ,@(and counterp `((incf ,i)))))))))))