Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Dealing with C types | |
4 | ;;; | |
5 | ;;; (c) 2008 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
11 | ;;; | |
12 | ;;; SOD is free software; you can redistribute it and/or modify | |
13 | ;;; it under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 2 of the License, or | |
15 | ;;; (at your option) any later version. | |
16 | ;;; | |
17 | ;;; SOD is distributed in the hope that it will be useful, | |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with SOD; if not, write to the Free Software Foundation, | |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
25 | ||
26 | (cl:in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Plain old C types. | |
30 | ||
31 | ;; Class definition. | |
32 | ||
33 | (defclass c-type () | |
34 | () | |
35 | (:documentation | |
36 | "Base class for C type objects.")) | |
37 | ||
38 | ;; Important protocol. | |
39 | ||
abdf50aa MW |
40 | (defgeneric c-type-subtype (type) |
41 | (:documentation | |
42 | "For compound types, return the base type.")) | |
43 | ||
44 | (defgeneric c-type-equal-p (type-a type-b) | |
45 | (:method-combination and) | |
46 | (:documentation | |
47 | "Answers whether two types TYPE-A and TYPE-B are, in fact, equal.") | |
48 | (:method and (type-a type-b) | |
49 | (eql (class-of type-a) (class-of type-b)))) | |
50 | ||
1f1d88f5 | 51 | (defgeneric pprint-c-type (type stream kernel) |
abdf50aa | 52 | (:documentation |
1f1d88f5 MW |
53 | "Pretty-printer for C types. |
54 | ||
55 | Print TYPE to STREAM. In the middle of the declarator, call the function | |
56 | KERNEL with one argument: whether it needs a leading space.") | |
57 | (:method :around (type stream kernel) | |
58 | (typecase kernel | |
59 | (function (call-next-method)) | |
60 | (null (pprint-c-type type stream | |
61 | (lambda (stream prio spacep) | |
62 | (declare (ignore stream prio spacep)) | |
63 | nil))) | |
64 | (t (pprint-c-type type stream | |
65 | (lambda (stream prio spacep) | |
66 | (declare (ignore prio)) | |
67 | (when spacep | |
68 | (c-type-space stream)) | |
69 | (princ kernel stream))))))) | |
abdf50aa MW |
70 | |
71 | (defgeneric print-c-type (stream type &optional colon atsign) | |
72 | (:documentation | |
73 | "Print an abbreviated syntax for TYPE to the STREAM.")) | |
74 | ||
75 | (defmethod print-object ((object c-type) stream) | |
76 | (if *print-escape* | |
77 | (format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object) | |
1f1d88f5 | 78 | (pprint-c-type object stream nil))) |
abdf50aa | 79 | |
1f1d88f5 | 80 | ;; Utility functions and macros. |
abdf50aa | 81 | |
1f1d88f5 MW |
82 | (defun c-type-space (stream) |
83 | "Print a space and a miser-mode newline to STREAM. | |
abdf50aa | 84 | |
1f1d88f5 MW |
85 | This is the right function to call in a PPRINT-C-TYPE kernel function when |
86 | the SPACEP argument is true." | |
87 | (pprint-indent :block 2 stream) | |
88 | (write-char #\space stream) | |
89 | (pprint-newline :miser stream)) | |
abdf50aa | 90 | |
1f1d88f5 MW |
91 | (defun maybe-in-parens* (stream condition thunk) |
92 | "Helper function for the MAYBE-IN-PARENS macro." | |
93 | (pprint-logical-block | |
94 | (stream nil | |
95 | :prefix (if condition "(" "") | |
96 | :suffix (if condition ")" "")) | |
97 | (funcall thunk stream))) | |
abdf50aa | 98 | |
1f1d88f5 MW |
99 | (defmacro maybe-in-parens ((stream condition) &body body) |
100 | "Evaluate BODY; if CONDITION, write parens to STREAM around it. | |
101 | ||
102 | This macro is useful for implementing the PPRINT-C-TYPE method on compound | |
103 | types. The BODY is evaluated in the context of a logical block printing | |
104 | to STREAM. If CONDITION is non-nil, then the block will have open/close | |
105 | parens as its prefix and suffix; otherwise they will be empty. | |
106 | ||
107 | The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol." | |
108 | `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body))) | |
abdf50aa MW |
109 | |
110 | ;; S-expression syntax machinery. | |
111 | ||
112 | (defun c-name-case (name) | |
113 | "Convert NAME to suitable case. | |
114 | ||
115 | Strings are returned as-is; symbols are squashed to lower-case and hyphens | |
116 | are replaced by underscores." | |
117 | (typecase name | |
118 | (symbol (with-output-to-string (out) | |
119 | (loop for ch across (symbol-name name) | |
120 | do (cond ((alpha-char-p ch) | |
121 | (write-char (char-downcase ch) out)) | |
122 | ((or (digit-char-p ch) | |
123 | (char= ch #\_)) | |
124 | (write-char ch out)) | |
125 | ((char= ch #\-) | |
126 | (write-char #\_ out)) | |
127 | (t | |
128 | (error "Bad character in C name ~S." name)))))) | |
129 | (t name))) | |
130 | ||
1f1d88f5 MW |
131 | (eval-when (:compile-toplevel :load-toplevel :execute) |
132 | (defgeneric expand-c-type-spec (spec) | |
133 | (:documentation | |
134 | "Expand SPEC into Lisp code to construct a C type.") | |
135 | (:method ((spec list)) | |
136 | (expand-c-type-form (car spec) (cdr spec)))) | |
137 | (defgeneric expand-c-type-form (head tail) | |
138 | (:documentation | |
139 | "Expand a C type list beginning with HEAD.") | |
140 | (:method ((name (eql 'lisp)) tail) | |
141 | `(progn ,@tail)))) | |
abdf50aa MW |
142 | |
143 | (defmacro c-type (spec) | |
1f1d88f5 MW |
144 | "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC." |
145 | (expand-c-type-spec spec)) | |
abdf50aa MW |
146 | |
147 | (defmacro define-c-type-syntax (name bvl &rest body) | |
148 | "Define a C-type syntax function. | |
149 | ||
150 | A function defined by BODY and with lambda-list BVL is associated with the | |
151 | NAME. When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this | |
152 | function with the argument list STUFF." | |
1f1d88f5 MW |
153 | (let ((headvar (gensym "HEAD")) |
154 | (tailvar (gensym "TAIL"))) | |
155 | `(eval-when (:compile-toplevel :load-toplevel :execute) | |
156 | (defmethod expand-c-type-form ((,headvar (eql ',name)) ,tailvar) | |
157 | (destructuring-bind ,bvl ,tailvar | |
158 | ,@body))))) | |
abdf50aa MW |
159 | |
160 | (defmacro c-type-alias (original &rest aliases) | |
161 | "Make ALIASES behave the same way as the ORIGINAL type." | |
1f1d88f5 MW |
162 | (let ((headvar (gensym "HEAD")) |
163 | (tailvar (gensym "TAIL"))) | |
164 | `(eval-when (:compile-toplevel :load-toplevel :execute) | |
165 | ,@(mapcar (lambda (alias) | |
166 | `(defmethod expand-c-type-form | |
167 | ((,headvar (eql ',alias)) ,tailvar) | |
168 | (expand-c-type-form ',original ,tailvar))) | |
169 | aliases)))) | |
abdf50aa MW |
170 | |
171 | (defmacro defctype (names value) | |
172 | "Define NAMES all to describe the C-type VALUE. | |
173 | ||
174 | NAMES can be a symbol (treated as a singleton list), or a list of symbols. | |
175 | The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE. It will | |
176 | be expanded once at run-time." | |
1f1d88f5 MW |
177 | (let* ((names (if (listp names) names (list names))) |
178 | (namevar (gensym "NAME")) | |
179 | (typevar (symbolicate 'c-type- (car names)))) | |
180 | `(progn | |
181 | (defparameter ,typevar ,(expand-c-type-spec value)) | |
182 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
183 | ,@(mapcar (lambda (name) | |
184 | `(defmethod expand-c-type-spec ((,namevar (eql ',name))) | |
185 | ',typevar)) | |
186 | names))))) | |
abdf50aa MW |
187 | |
188 | ;;;-------------------------------------------------------------------------- | |
189 | ;;; Types which can accept qualifiers. | |
190 | ||
191 | ;; Basic definitions. | |
192 | ||
193 | (defclass qualifiable-c-type (c-type) | |
77027cca MW |
194 | ((qualifiers :initarg :qualifiers :initform nil |
195 | :type list :accessor c-type-qualifiers)) | |
abdf50aa MW |
196 | (:documentation |
197 | "Base class for C types which can be qualified.")) | |
198 | ||
199 | (defun format-qualifiers (quals) | |
200 | "Return a string listing QUALS, with a space after each." | |
201 | (format nil "~{~(~A~) ~}" quals)) | |
202 | ||
203 | (defmethod c-type-equal-p and ((type-a qualifiable-c-type) | |
204 | (type-b qualifiable-c-type)) | |
205 | (flet ((fix (type) | |
206 | (sort (copy-list (c-type-qualifiers type)) #'string<))) | |
207 | (equal (fix type-a) (fix type-b)))) | |
208 | ||
abdf50aa MW |
209 | ;; A handy utility. |
210 | ||
211 | (let ((cache (make-hash-table :test #'equal))) | |
212 | (defun qualify-type (c-type qualifiers) | |
213 | "Returns a qualified version of C-TYPE. | |
214 | ||
215 | Maintains a cache of qualified types so that we don't have to run out of | |
216 | memory. This can also speed up type comparisons." | |
217 | (if (null qualifiers) | |
218 | c-type | |
219 | (let ((key (cons c-type qualifiers))) | |
220 | (unless (typep c-type 'qualifiable-c-type) | |
221 | (error "~A isn't qualifiable." (class-name (class-of c-type)))) | |
222 | (or (gethash key cache) | |
223 | (setf (gethash key cache) | |
224 | (copy-instance c-type :qualifiers qualifiers))))))) | |
225 | ||
abdf50aa MW |
226 | ;;;-------------------------------------------------------------------------- |
227 | ;;; Simple C types (e.g., built-in arithmetic types). | |
228 | ||
229 | (defvar *simple-type-map* (make-hash-table :test #'equal) | |
230 | "A hash table mapping type strings to Lisp symbols naming them.") | |
231 | ||
232 | ;; Basic definitions. | |
233 | ||
234 | (defclass simple-c-type (qualifiable-c-type) | |
77027cca | 235 | ((name :initarg :name :type string :reader c-type-name)) |
abdf50aa MW |
236 | (:documentation |
237 | "C types with simple forms.")) | |
238 | ||
239 | (let ((cache (make-hash-table :test #'equal))) | |
1f1d88f5 | 240 | (defun make-simple-type (name &optional qualifiers) |
abdf50aa | 241 | "Make a distinguished object for the simple type called NAME." |
1f1d88f5 MW |
242 | (qualify-type (or (gethash name cache) |
243 | (setf (gethash name cache) | |
244 | (make-instance 'simple-c-type :name name))) | |
245 | qualifiers))) | |
246 | ||
247 | (defmethod pprint-c-type ((type simple-c-type) stream kernel) | |
248 | (pprint-logical-block (stream nil) | |
249 | (format stream "~{~(~A~) ~@_~}~A" | |
250 | (c-type-qualifiers type) | |
251 | (c-type-name type)) | |
252 | (funcall kernel stream 0 t))) | |
abdf50aa MW |
253 | |
254 | (defmethod c-type-equal-p and ((type-a simple-c-type) | |
255 | (type-b simple-c-type)) | |
256 | (string= (c-type-name type-a) (c-type-name type-b))) | |
257 | ||
258 | (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign) | |
259 | (declare (ignore colon atsign)) | |
260 | (let* ((name (c-type-name type)) | |
261 | (symbol (gethash name *simple-type-map*))) | |
1f1d88f5 MW |
262 | (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]" |
263 | (c-type-qualifiers type) (or symbol name)))) | |
abdf50aa MW |
264 | |
265 | ;; S-expression syntax. | |
266 | ||
1f1d88f5 MW |
267 | (eval-when (:compile-toplevel :load-toplevel :execute) |
268 | (defmethod expand-c-type-spec ((spec string)) | |
269 | `(make-simple-type ,spec)) | |
270 | (defmethod expand-c-type-form ((head string) tail) | |
271 | `(make-simple-type ,head ,@tail))) | |
abdf50aa MW |
272 | |
273 | (defmacro define-simple-c-type (names type) | |
274 | "Define each of NAMES to be a simple type called TYPE." | |
1f1d88f5 MW |
275 | (let ((names (if (listp names) names (list names)))) |
276 | `(progn | |
277 | (setf (gethash ,type *simple-type-map*) ',(car names)) | |
278 | (defctype ,names ,type) | |
279 | (define-c-type-syntax ,(car names) (&rest quals) | |
280 | `(make-simple-type ,',type (list ,@quals)))))) | |
abdf50aa MW |
281 | |
282 | (define-simple-c-type void "void") | |
283 | ||
284 | (define-simple-c-type char "char") | |
285 | (define-simple-c-type (unsigned-char uchar) "unsigned char") | |
286 | (define-simple-c-type (signed-char schar) "signed char") | |
287 | ||
288 | (define-simple-c-type (int signed signed-int sint) "int") | |
289 | (define-simple-c-type (unsigned unsigned-int uint) "unsigned") | |
290 | ||
291 | (define-simple-c-type (short signed-short short-int signed-short-int sshort) | |
292 | "short") | |
293 | (define-simple-c-type (unsigned-short unsigned-short-int ushort) | |
294 | "unsigned short") | |
295 | ||
296 | (define-simple-c-type (long signed-long long-int signed-long-int slong) | |
297 | "long") | |
298 | (define-simple-c-type (unsigned-long unsigned-long-int ulong) | |
299 | "unsigned long") | |
300 | ||
301 | (define-simple-c-type (long-long signed-long-long long-long-int | |
302 | signed-long-long-int llong sllong) | |
303 | "long long") | |
304 | (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong) | |
305 | "unsigned long long") | |
306 | ||
307 | (define-simple-c-type float "float") | |
308 | (define-simple-c-type double "double") | |
309 | (define-simple-c-type long-double "long double") | |
310 | ||
311 | (define-simple-c-type va-list "va_list") | |
312 | (define-simple-c-type size-t "size_t") | |
313 | (define-simple-c-type ptrdiff-t "ptrdiff_t") | |
314 | ||
315 | ;;;-------------------------------------------------------------------------- | |
316 | ;;; Tag types (structs, unions and enums). | |
317 | ||
318 | ;; Definitions. | |
319 | ||
320 | (defclass tagged-c-type (qualifiable-c-type) | |
77027cca | 321 | ((tag :initarg :tag :type string :reader c-type-tag)) |
abdf50aa MW |
322 | (:documentation |
323 | "C types with tags.")) | |
324 | ||
325 | (defgeneric c-tagged-type-kind (type) | |
326 | (:documentation | |
327 | "Return the kind of tagged type that TYPE is, as a keyword.")) | |
328 | ||
329 | (macrolet ((define-tagged-type (kind what) | |
1f1d88f5 MW |
330 | (let ((type (symbolicate 'c- kind '-type)) |
331 | (constructor (symbolicate 'make- kind '-type))) | |
abdf50aa MW |
332 | `(progn |
333 | (defclass ,type (tagged-c-type) () | |
334 | (:documentation ,(format nil "C ~a types." what))) | |
335 | (defmethod c-tagged-type-kind ((type ,type)) | |
1f1d88f5 | 336 | ',kind) |
abdf50aa | 337 | (let ((cache (make-hash-table :test #'equal))) |
1f1d88f5 MW |
338 | (defun ,constructor (tag &optional qualifiers) |
339 | (qualify-type (or (gethash tag cache) | |
340 | (setf (gethash tag cache) | |
341 | (make-instance ',type | |
342 | :tag tag))) | |
343 | qualifiers))) | |
344 | (define-c-type-syntax ,kind (tag &rest quals) | |
345 | ,(format nil "Construct ~A type named TAG" what) | |
346 | `(,',constructor ,tag (list ,@quals))))))) | |
347 | (define-tagged-type enum "enumerated") | |
348 | (define-tagged-type struct "structure") | |
349 | (define-tagged-type union "union")) | |
350 | ||
351 | (defmethod pprint-c-type ((type tagged-c-type) stream kernel) | |
352 | (pprint-logical-block (stream nil) | |
353 | (format stream "~{~(~A~) ~@_~}~(~A~) ~A" | |
354 | (c-type-qualifiers type) | |
355 | (c-tagged-type-kind type) | |
356 | (c-type-tag type)) | |
357 | (funcall kernel stream 0 t))) | |
abdf50aa MW |
358 | |
359 | (defmethod c-type-equal-p and ((type-a tagged-c-type) | |
360 | (type-b tagged-c-type)) | |
361 | (string= (c-type-tag type-a) (c-type-tag type-b))) | |
362 | ||
363 | (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign) | |
364 | (declare (ignore colon atsign)) | |
1f1d88f5 | 365 | (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>" |
abdf50aa | 366 | (c-tagged-type-kind type) |
1f1d88f5 MW |
367 | (c-type-tag type) |
368 | (c-type-qualifiers type))) | |
abdf50aa MW |
369 | |
370 | ;;;-------------------------------------------------------------------------- | |
371 | ;;; Pointer types. | |
372 | ||
373 | ;; Definitions. | |
374 | ||
375 | (defclass c-pointer-type (qualifiable-c-type) | |
77027cca | 376 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype)) |
abdf50aa MW |
377 | (:documentation |
378 | "C pointer types.")) | |
379 | ||
1f1d88f5 MW |
380 | (let ((cache (make-hash-table :test #'eql))) |
381 | (defun make-pointer-type (subtype &optional qualifiers) | |
382 | "Return a (maybe distinguished) pointer type." | |
383 | (qualify-type (or (gethash subtype cache) | |
384 | (make-instance 'c-pointer-type :subtype subtype)) | |
385 | qualifiers))) | |
386 | ||
387 | (defmethod pprint-c-type ((type c-pointer-type) stream kernel) | |
388 | (pprint-c-type (c-type-subtype type) stream | |
389 | (lambda (stream prio spacep) | |
390 | (when spacep (c-type-space stream)) | |
391 | (maybe-in-parens (stream (> prio 1)) | |
392 | (format stream "*~{~(~A~)~^ ~@_~}" | |
393 | (c-type-qualifiers type)) | |
394 | (funcall kernel stream 1 (c-type-qualifiers type)))))) | |
abdf50aa MW |
395 | |
396 | (defmethod c-type-equal-p and ((type-a c-pointer-type) | |
397 | (type-b c-pointer-type)) | |
398 | (c-type-equal-p (c-type-subtype type-a) | |
399 | (c-type-subtype type-b))) | |
400 | ||
401 | (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign) | |
402 | (declare (ignore colon atsign)) | |
1f1d88f5 MW |
403 | (format stream "~:@<* ~@_~/sod::print-c-type/~{ ~_~S~}~:>" |
404 | (c-type-subtype type) | |
405 | (c-type-qualifiers type))) | |
abdf50aa MW |
406 | |
407 | ;; S-expression syntax. | |
408 | ||
1f1d88f5 | 409 | (define-c-type-syntax * (sub &rest quals) |
abdf50aa | 410 | "Return the type of pointer-to-SUB." |
1f1d88f5 MW |
411 | `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals))) |
412 | (c-type-alias * pointer ptr) | |
abdf50aa MW |
413 | |
414 | (defctype string (* char)) | |
1f1d88f5 | 415 | (defctype const-string (* (char :const))) |
abdf50aa MW |
416 | |
417 | ;;;-------------------------------------------------------------------------- | |
418 | ;;; Array types. | |
419 | ||
420 | ;; Definitions. | |
421 | ||
422 | (defclass c-array-type (c-type) | |
77027cca MW |
423 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype) |
424 | (dimensions :initarg :dimensions :type list :reader c-array-dimensions)) | |
abdf50aa MW |
425 | (:documentation |
426 | "C array types.")) | |
427 | ||
1f1d88f5 MW |
428 | (defun make-array-type (subtype dimensions) |
429 | "Return a new array of SUBTYPE with given DIMENSIONS." | |
430 | (make-instance 'c-array-type :subtype subtype | |
431 | :dimensions (or dimensions '(nil)))) | |
abdf50aa | 432 | |
1f1d88f5 MW |
433 | (defmethod pprint-c-type ((type c-array-type) stream kernel) |
434 | (pprint-c-type (c-type-subtype type) stream | |
435 | (lambda (stream prio spacep) | |
436 | (maybe-in-parens (stream (> prio 2)) | |
437 | (funcall kernel stream 2 spacep) | |
438 | (format stream "~@<~{[~@[~A~]]~^~_~}~:>" | |
439 | (c-array-dimensions type)))))) | |
abdf50aa MW |
440 | |
441 | (defmethod c-type-equal-p and ((type-a c-array-type) | |
442 | (type-b c-array-type)) | |
443 | (and (c-type-equal-p (c-type-subtype type-a) | |
444 | (c-type-subtype type-b)) | |
445 | (equal (c-array-dimensions type-a) | |
446 | (c-array-dimensions type-b)))) | |
447 | ||
448 | (defmethod print-c-type (stream (type c-array-type) &optional colon atsign) | |
449 | (declare (ignore colon atsign)) | |
1f1d88f5 | 450 | (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~S~}~:>" |
abdf50aa MW |
451 | (c-type-subtype type) |
452 | (c-array-dimensions type))) | |
453 | ||
454 | ;; S-expression syntax. | |
455 | ||
1f1d88f5 | 456 | (define-c-type-syntax [] (sub &rest dims) |
abdf50aa MW |
457 | "Return the type of arrays of SUB with the dimensions DIMS. |
458 | ||
459 | If the DIMS are omitted, a single unknown-length dimension is added." | |
1f1d88f5 MW |
460 | `(make-array-type ,(expand-c-type-spec sub) |
461 | (list ,@(or dims '(nil))))) | |
462 | (c-type-alias [] array vec) | |
abdf50aa MW |
463 | |
464 | ;;;-------------------------------------------------------------------------- | |
465 | ;;; Function types. | |
466 | ||
1f1d88f5 | 467 | ;; Arguments. |
abdf50aa MW |
468 | |
469 | (defstruct (argument (:constructor make-argument (name type)) (:type list)) | |
470 | "Simple list structure representing a function argument." | |
471 | name | |
472 | type) | |
473 | ||
abdf50aa | 474 | (defun arguments-lists-equal-p (list-a list-b) |
1f1d88f5 MW |
475 | "Return whether LIST-A and LIST-B match. |
476 | ||
477 | They must have the same number of arguments, and each argument must have | |
478 | the same type, or be :ELLIPSIS. The argument names are not inspected." | |
abdf50aa MW |
479 | (and (= (length list-a) (length list-b)) |
480 | (every (lambda (arg-a arg-b) | |
481 | (if (eq arg-a :ellipsis) | |
482 | (eq arg-b :ellipsis) | |
483 | (c-type-equal-p (argument-type arg-a) | |
484 | (argument-type arg-b)))) | |
485 | list-a list-b))) | |
486 | ||
1f1d88f5 MW |
487 | (defgeneric commentify-argument-name (name) |
488 | (:documentation | |
489 | "Produce a `commentified' version of the argument. | |
490 | ||
491 | The default behaviour is that temporary argument names are simply omitted | |
492 | (NIL is returned); otherwise, `/*...*/' markers are wrapped around the | |
493 | printable representation of the argument.") | |
494 | (:method ((name null)) nil) | |
495 | (:method ((name t)) (format nil "/*~A*/" name))) | |
496 | ||
497 | (defun commentify-argument-names (arguments) | |
498 | "Return an argument list with the arguments commentified. | |
499 | ||
500 | That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME." | |
501 | (mapcar (lambda (arg) | |
502 | (if (eq arg :ellipsis) | |
503 | arg | |
504 | (make-argument (commentify-argument-name (argument-name arg)) | |
505 | (argument-type arg)))) | |
506 | arguments)) | |
507 | ||
508 | (defun commentify-function-type (type) | |
509 | "Return a type like TYPE, but with arguments commentified. | |
510 | ||
511 | This doesn't recurse into the return type or argument types." | |
512 | (make-function-type (c-type-subtype type) | |
513 | (commentify-argument-names | |
514 | (c-function-arguments type)))) | |
515 | ||
516 | ;; Definitions. | |
517 | ||
518 | (defclass c-function-type (c-type) | |
77027cca MW |
519 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype) |
520 | (arguments :initarg :arguments :type list :reader c-function-arguments)) | |
1f1d88f5 MW |
521 | (:documentation |
522 | "C function types. The subtype is the return type, as implied by the C | |
523 | syntax for function declarations.")) | |
524 | ||
525 | (defun make-function-type (subtype arguments) | |
526 | "Return a new function type, returning SUBTYPE and accepting ARGUMENTS." | |
527 | (make-instance 'c-function-type :subtype subtype :arguments arguments)) | |
528 | ||
abdf50aa MW |
529 | (defmethod c-type-equal-p and ((type-a c-function-type) |
530 | (type-b c-function-type)) | |
531 | (and (c-type-equal-p (c-type-subtype type-a) | |
532 | (c-type-subtype type-b)) | |
533 | (arguments-lists-equal-p (c-function-arguments type-a) | |
534 | (c-function-arguments type-b)))) | |
535 | ||
536 | (defmethod print-c-type | |
537 | (stream (type c-function-type) &optional colon atsign) | |
538 | (declare (ignore colon atsign)) | |
539 | (format stream | |
540 | #.(concatenate 'string | |
541 | "~:@<" | |
542 | "FUN ~@_~:I~/sod::print-c-type/" | |
1f1d88f5 | 543 | "~{ ~_~:<~S ~@_~/sod::print-c-type/~:>~}" |
abdf50aa MW |
544 | "~:>") |
545 | (c-type-subtype type) | |
546 | (c-function-arguments type))) | |
547 | ||
1f1d88f5 MW |
548 | (defmethod pprint-c-type ((type c-function-type) stream kernel) |
549 | (pprint-c-type (c-type-subtype type) stream | |
550 | (lambda (stream prio spacep) | |
551 | (maybe-in-parens (stream (> prio 2)) | |
552 | (when spacep (c-type-space stream)) | |
553 | (funcall kernel stream 2 nil) | |
554 | (pprint-indent :block 4 stream) | |
555 | ;;(pprint-newline :miser stream) | |
556 | (pprint-logical-block | |
557 | (stream nil :prefix "(" :suffix ")") | |
558 | (let ((firstp t)) | |
559 | (dolist (arg (c-function-arguments type)) | |
560 | (if firstp | |
561 | (setf firstp nil) | |
562 | (format stream ", ~_")) | |
563 | (if (eq arg :ellipsis) | |
564 | (write-string "..." stream) | |
565 | (pprint-c-type (argument-type arg) | |
566 | stream | |
567 | (argument-name arg)))))))))) | |
568 | ||
abdf50aa MW |
569 | ;; S-expression syntax. |
570 | ||
1f1d88f5 | 571 | (define-c-type-syntax fun (ret &rest args) |
abdf50aa MW |
572 | "Return the type of functions which returns RET and has arguments ARGS. |
573 | ||
1f1d88f5 MW |
574 | The ARGS are a list of arguments of the form (NAME TYPE). The NAME can be |
575 | NIL to indicate that no name was given. | |
576 | ||
577 | If an entry isn't a list, it's assumed to be the start of a Lisp | |
578 | expression to compute the tail of the list; similarly, if the list is | |
579 | improper, then it's considered to be a complete expression. The upshot of | |
580 | this apparently bizarre rule is that you can say | |
581 | ||
582 | (c-type (fun int (\"foo\" int) . arg-tail)) | |
583 | ||
584 | where ARG-TAIL is (almost) any old Lisp expression and have it tack the | |
585 | arguments onto the end. Of course, there don't have to be any explicit | |
586 | arguments at all. The only restriction is that the head of the Lisp form | |
587 | can't be a list -- so ((lambda (...) ...) ...) is out, but you probably | |
588 | wouldn't type that anyway." | |
589 | ||
590 | `(make-function-type ,(expand-c-type-spec ret) | |
591 | ,(do ((args args (cdr args)) | |
592 | (list nil | |
593 | (cons `(make-argument ,(caar args) | |
594 | ,(expand-c-type-spec | |
595 | (cadar args))) | |
596 | list))) | |
597 | ((or (atom args) (atom (car args))) | |
598 | (cond ((and (null args) (null list)) `nil) | |
599 | ((null args) `(list ,@(nreverse list))) | |
600 | ((null list) `,args) | |
601 | (t `(list* ,@(nreverse list) ,args))))))) | |
602 | (c-type-alias fun function () func fn) | |
abdf50aa MW |
603 | |
604 | ;;;----- That's all, folks -------------------------------------------------- |