Commit | Line | Data |
---|---|---|
abdf50aa MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
dea4d055 | 3 | ;;; C type representation implementation |
abdf50aa | 4 | ;;; |
dea4d055 | 5 | ;;; (c) 2009 Straylight/Edgeware |
abdf50aa MW |
6 | ;;; |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
abdf50aa MW |
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 | ;;;-------------------------------------------------------------------------- | |
dea4d055 MW |
29 | ;;; Interning types. |
30 | ||
31 | (defparameter *c-type-intern-map* (make-hash-table :test #'equal) | |
32 | "Hash table mapping lists describing types to their distinguished | |
33 | representations.") | |
34 | ||
35 | (defun intern-c-type (class &rest initargs) | |
36 | "If the CLASS and INITARGS have already been interned, then return the | |
37 | existing object; otherwise make a new one." | |
38 | (let ((list (cons class initargs))) | |
39 | (or (gethash list *c-type-intern-map*) | |
40 | (let ((new (apply #'make-instance class initargs))) | |
41 | (setf (gethash new *c-type-intern-map*) t | |
42 | (gethash list *c-type-intern-map*) new))))) | |
43 | ||
44 | #+test | |
45 | (defun check-type-intern-map () | |
46 | "Sanity check for the type-intern map." | |
47 | (let ((map (make-hash-table))) | |
48 | ||
49 | ;; Pass 1: check that interned types are consistent with their keys. | |
50 | ;; Remember interned types. | |
51 | (maphash (lambda (k v) | |
52 | (when (listp k) | |
53 | (let ((ty (apply #'make-instance k))) | |
54 | (assert (c-type-equal-p ty v))) | |
55 | (setf (gethash v map) t))) | |
56 | *c-type-intern-map*) | |
57 | ||
58 | ;; Pass 2: check that the interned type indicators are correct. | |
59 | (maphash (lambda (k v) | |
60 | (declare (ignore v)) | |
61 | (assert (gethash k *c-type-intern-map*))) | |
62 | map) | |
63 | (maphash (lambda (k v) | |
64 | (declare (ignore v)) | |
65 | (when (typep k 'c-type) | |
66 | (assert (gethash k map)))) | |
67 | *c-type-intern-map*))) | |
abdf50aa | 68 | |
2b2252cc MW |
69 | (defun make-or-intern-c-type (new-type-class base-types &rest initargs) |
70 | "Return a possibly-new instance of NEW-TYPE-CLASS with the given INITARGS. | |
71 | ||
72 | If all of the BASE-TYPES are interned, then use `intern-c-type' to | |
73 | construct the new type; otherwise just make a new one with | |
74 | `make-instance'. BASE-TYPES may be a singleton type, or a sequence of | |
75 | types." | |
76 | (apply (if (if (typep base-types 'sequence) | |
77 | (every (lambda (type) | |
78 | (gethash type *c-type-intern-map*)) | |
79 | base-types) | |
80 | (gethash base-types *c-type-intern-map*)) | |
81 | #'intern-c-type #'make-instance) | |
82 | new-type-class | |
83 | initargs)) | |
84 | ||
bf090e02 MW |
85 | (defmethod qualify-c-type ((type qualifiable-c-type) qualifiers) |
86 | (let ((initargs (instance-initargs type))) | |
87 | (remf initargs :qualifiers) | |
2b2252cc | 88 | (apply #'make-or-intern-c-type (class-of type) type |
bf090e02 MW |
89 | :qualifiers (canonify-qualifiers |
90 | (append qualifiers (c-type-qualifiers type))) | |
91 | initargs))) | |
92 | ||
abdf50aa | 93 | ;;;-------------------------------------------------------------------------- |
dea4d055 | 94 | ;;; Simple C types. |
abdf50aa | 95 | |
dea4d055 | 96 | ;; Class definition. |
abdf50aa | 97 | |
dea4d055 MW |
98 | (export '(simple-c-type c-type-name)) |
99 | (defclass simple-c-type (qualifiable-c-type) | |
100 | ((name :initarg :name :type string :reader c-type-name)) | |
abdf50aa | 101 | (:documentation |
dea4d055 | 102 | "C types with simple forms.")) |
abdf50aa | 103 | |
dea4d055 | 104 | ;; Constructor function and interning. |
abdf50aa | 105 | |
dea4d055 MW |
106 | (export 'make-simple-type) |
107 | (defun make-simple-type (name &optional qualifiers) | |
108 | "Make a distinguished object for the simple type called NAME." | |
109 | (intern-c-type 'simple-c-type | |
110 | :name name | |
111 | :qualifiers (canonify-qualifiers qualifiers))) | |
abdf50aa | 112 | |
dea4d055 | 113 | ;; Comparison protocol. |
abdf50aa | 114 | |
dea4d055 MW |
115 | (defmethod c-type-equal-p and |
116 | ((type-a simple-c-type) (type-b simple-c-type)) | |
117 | (string= (c-type-name type-a) (c-type-name type-b))) | |
abdf50aa | 118 | |
dea4d055 | 119 | ;; C syntax output protocol. |
1f1d88f5 MW |
120 | |
121 | (defmethod pprint-c-type ((type simple-c-type) stream kernel) | |
122 | (pprint-logical-block (stream nil) | |
ff4e398b MW |
123 | (format stream "~{~A ~@_~}~A" |
124 | (c-type-qualifier-keywords type) | |
1f1d88f5 MW |
125 | (c-type-name type)) |
126 | (funcall kernel stream 0 t))) | |
abdf50aa | 127 | |
dea4d055 MW |
128 | ;; S-expression notation protocol. |
129 | ||
130 | (defparameter *simple-type-map* (make-hash-table) | |
131 | "Hash table mapping strings of C syntax to symbolic names.") | |
abdf50aa MW |
132 | |
133 | (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign) | |
134 | (declare (ignore colon atsign)) | |
135 | (let* ((name (c-type-name type)) | |
136 | (symbol (gethash name *simple-type-map*))) | |
1f1d88f5 MW |
137 | (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]" |
138 | (c-type-qualifiers type) (or symbol name)))) | |
abdf50aa | 139 | |
1f1d88f5 MW |
140 | (eval-when (:compile-toplevel :load-toplevel :execute) |
141 | (defmethod expand-c-type-spec ((spec string)) | |
142 | `(make-simple-type ,spec)) | |
143 | (defmethod expand-c-type-form ((head string) tail) | |
dea4d055 | 144 | `(make-simple-type ,head (list ,@tail)))) |
abdf50aa | 145 | |
dea4d055 | 146 | (export 'define-simple-c-type) |
e43d3532 | 147 | (defmacro define-simple-c-type (names type &key export) |
abdf50aa | 148 | "Define each of NAMES to be a simple type called TYPE." |
1f1d88f5 MW |
149 | (let ((names (if (listp names) names (list names)))) |
150 | `(progn | |
151 | (setf (gethash ,type *simple-type-map*) ',(car names)) | |
e43d3532 | 152 | (defctype ,names ,type :export ,export) |
1f1d88f5 MW |
153 | (define-c-type-syntax ,(car names) (&rest quals) |
154 | `(make-simple-type ,',type (list ,@quals)))))) | |
abdf50aa | 155 | |
dea4d055 MW |
156 | ;; Built-in C types. |
157 | ||
e43d3532 MW |
158 | (define-simple-c-type void "void" :export t) |
159 | ||
160 | (define-simple-c-type char "char" :export t) | |
161 | (define-simple-c-type (unsigned-char uchar) "unsigned char" :export t) | |
162 | (define-simple-c-type (signed-char schar) "signed char" :export t) | |
163 | (define-simple-c-type wchar-t "wchar-t" :export t) | |
164 | ||
165 | (define-simple-c-type (int signed signed-int sint) "int" :export t) | |
166 | (define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t) | |
abdf50aa MW |
167 | |
168 | (define-simple-c-type (short signed-short short-int signed-short-int sshort) | |
e43d3532 | 169 | "short" :export t) |
abdf50aa | 170 | (define-simple-c-type (unsigned-short unsigned-short-int ushort) |
e43d3532 | 171 | "unsigned short" :export t) |
abdf50aa MW |
172 | |
173 | (define-simple-c-type (long signed-long long-int signed-long-int slong) | |
e43d3532 | 174 | "long" :export t) |
abdf50aa | 175 | (define-simple-c-type (unsigned-long unsigned-long-int ulong) |
e43d3532 | 176 | "unsigned long" :export t) |
abdf50aa MW |
177 | |
178 | (define-simple-c-type (long-long signed-long-long long-long-int | |
179 | signed-long-long-int llong sllong) | |
e43d3532 | 180 | "long long" :export t) |
abdf50aa | 181 | (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong) |
e43d3532 | 182 | "unsigned long long" :export t) |
abdf50aa | 183 | |
e43d3532 MW |
184 | (define-simple-c-type float "float" :export t) |
185 | (define-simple-c-type double "double" :export t) | |
186 | (define-simple-c-type long-double "long double" :export t) | |
abdf50aa | 187 | |
e43d3532 | 188 | (define-simple-c-type bool "_Bool" :export t) |
0e7cdea0 | 189 | |
e43d3532 MW |
190 | (define-simple-c-type float-complex "float _Complex" :export t) |
191 | (define-simple-c-type double-complex "double _Complex" :export t) | |
192 | (define-simple-c-type long-double-complex "long double _Complex" :export t) | |
0e7cdea0 | 193 | |
e43d3532 MW |
194 | (define-simple-c-type float-imaginary "float _Imaginary" :export t) |
195 | (define-simple-c-type double-imaginary "double _Imaginary" :export t) | |
196 | (define-simple-c-type long-double-imaginary | |
197 | "long double _Imaginary" :export t) | |
0e7cdea0 | 198 | |
e43d3532 MW |
199 | (define-simple-c-type va-list "va_list" :export t) |
200 | (define-simple-c-type size-t "size_t" :export t) | |
201 | (define-simple-c-type ptrdiff-t "ptrdiff_t" :export t) | |
abdf50aa MW |
202 | |
203 | ;;;-------------------------------------------------------------------------- | |
dea4d055 | 204 | ;;; Tagged types (enums, structs and unions). |
abdf50aa | 205 | |
dea4d055 | 206 | ;; Class definition. |
abdf50aa | 207 | |
dea4d055 | 208 | (export '(tagged-c-type c-type-tag)) |
abdf50aa | 209 | (defclass tagged-c-type (qualifiable-c-type) |
77027cca | 210 | ((tag :initarg :tag :type string :reader c-type-tag)) |
abdf50aa MW |
211 | (:documentation |
212 | "C types with tags.")) | |
213 | ||
dea4d055 MW |
214 | ;; Subclass definitions. |
215 | ||
216 | (export 'c-tagged-type-kind) | |
abdf50aa MW |
217 | (defgeneric c-tagged-type-kind (type) |
218 | (:documentation | |
219 | "Return the kind of tagged type that TYPE is, as a keyword.")) | |
220 | ||
dea4d055 MW |
221 | (export 'kind-c-tagged-type) |
222 | (defgeneric kind-c-tagged-type (kind) | |
223 | (:documentation | |
224 | "Given a keyword KIND, return the appropriate class name.")) | |
225 | ||
226 | (export 'make-c-tagged-type) | |
227 | (defun make-c-tagged-type (kind tag &optional qualifiers) | |
228 | "Return a tagged type with the given KIND (keyword) and TAG (string)." | |
229 | (intern-c-type (kind-c-tagged-type kind) | |
230 | :tag tag | |
231 | :qualifiers (canonify-qualifiers qualifiers))) | |
232 | ||
abdf50aa | 233 | (macrolet ((define-tagged-type (kind what) |
dea4d055 MW |
234 | (let* ((type (symbolicate 'c- kind '-type)) |
235 | (keyword (intern (symbol-name kind) :keyword)) | |
236 | (constructor (symbolicate 'make- kind '-type))) | |
abdf50aa | 237 | `(progn |
bf090e02 | 238 | (export '(,type ,kind ,constructor)) |
abdf50aa MW |
239 | (defclass ,type (tagged-c-type) () |
240 | (:documentation ,(format nil "C ~a types." what))) | |
241 | (defmethod c-tagged-type-kind ((type ,type)) | |
dea4d055 MW |
242 | ',keyword) |
243 | (defmethod kind-c-tagged-type ((kind (eql ',keyword))) | |
244 | ',type) | |
245 | (defun ,constructor (tag &optional qualifiers) | |
246 | (intern-c-type ',type :tag tag | |
247 | :qualifiers (canonify-qualifiers | |
248 | qualifiers))) | |
1f1d88f5 MW |
249 | (define-c-type-syntax ,kind (tag &rest quals) |
250 | ,(format nil "Construct ~A type named TAG" what) | |
251 | `(,',constructor ,tag (list ,@quals))))))) | |
252 | (define-tagged-type enum "enumerated") | |
253 | (define-tagged-type struct "structure") | |
254 | (define-tagged-type union "union")) | |
255 | ||
dea4d055 MW |
256 | ;; Comparison protocol. |
257 | ||
258 | (defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type)) | |
259 | (string= (c-type-tag type-a) (c-type-tag type-b))) | |
260 | ||
261 | ;; C syntax output protocol. | |
262 | ||
1f1d88f5 MW |
263 | (defmethod pprint-c-type ((type tagged-c-type) stream kernel) |
264 | (pprint-logical-block (stream nil) | |
ff4e398b MW |
265 | (format stream "~{~A ~@_~}~(~A~) ~A" |
266 | (c-type-qualifier-keywords type) | |
1f1d88f5 MW |
267 | (c-tagged-type-kind type) |
268 | (c-type-tag type)) | |
269 | (funcall kernel stream 0 t))) | |
abdf50aa | 270 | |
dea4d055 | 271 | ;; S-expression notation protocol. |
abdf50aa MW |
272 | |
273 | (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign) | |
274 | (declare (ignore colon atsign)) | |
1f1d88f5 | 275 | (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>" |
abdf50aa | 276 | (c-tagged-type-kind type) |
1f1d88f5 MW |
277 | (c-type-tag type) |
278 | (c-type-qualifiers type))) | |
abdf50aa MW |
279 | |
280 | ;;;-------------------------------------------------------------------------- | |
281 | ;;; Pointer types. | |
282 | ||
dea4d055 | 283 | ;; Class definition. |
abdf50aa | 284 | |
dea4d055 | 285 | (export 'c-pointer-type) |
abdf50aa | 286 | (defclass c-pointer-type (qualifiable-c-type) |
77027cca | 287 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype)) |
dea4d055 | 288 | (:documentation "C pointer types.")) |
abdf50aa | 289 | |
dea4d055 MW |
290 | ;; Constructor function. |
291 | ||
292 | (export 'make-pointer-type) | |
293 | (defun make-pointer-type (subtype &optional qualifiers) | |
294 | "Return a (maybe distinguished) pointer type." | |
2b2252cc MW |
295 | (make-or-intern-c-type 'c-pointer-type subtype |
296 | :subtype subtype | |
297 | :qualifiers (canonify-qualifiers qualifiers))) | |
dea4d055 MW |
298 | |
299 | ;; Comparison protocol. | |
300 | ||
301 | (defmethod c-type-equal-p and ((type-a c-pointer-type) | |
302 | (type-b c-pointer-type)) | |
303 | (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))) | |
304 | ||
305 | ;; C syntax output protocol. | |
1f1d88f5 MW |
306 | |
307 | (defmethod pprint-c-type ((type c-pointer-type) stream kernel) | |
308 | (pprint-c-type (c-type-subtype type) stream | |
309 | (lambda (stream prio spacep) | |
310 | (when spacep (c-type-space stream)) | |
311 | (maybe-in-parens (stream (> prio 1)) | |
ff4e398b MW |
312 | (format stream "*~{~A~^ ~@_~}" |
313 | (c-type-qualifier-keywords type)) | |
1f1d88f5 | 314 | (funcall kernel stream 1 (c-type-qualifiers type)))))) |
abdf50aa | 315 | |
dea4d055 | 316 | ;; S-expression notation protocol. |
abdf50aa MW |
317 | |
318 | (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign) | |
319 | (declare (ignore colon atsign)) | |
dea4d055 | 320 | (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>" |
1f1d88f5 MW |
321 | (c-type-subtype type) |
322 | (c-type-qualifiers type))) | |
abdf50aa | 323 | |
dea4d055 | 324 | (export '(* pointer ptr)) |
1f1d88f5 | 325 | (define-c-type-syntax * (sub &rest quals) |
abdf50aa | 326 | "Return the type of pointer-to-SUB." |
1f1d88f5 MW |
327 | `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals))) |
328 | (c-type-alias * pointer ptr) | |
abdf50aa | 329 | |
dea4d055 MW |
330 | ;; Built-in C types. |
331 | ||
332 | (export '(string const-string)) | |
abdf50aa | 333 | (defctype string (* char)) |
1f1d88f5 | 334 | (defctype const-string (* (char :const))) |
abdf50aa MW |
335 | |
336 | ;;;-------------------------------------------------------------------------- | |
337 | ;;; Array types. | |
338 | ||
dea4d055 | 339 | ;; Class definition. |
abdf50aa | 340 | |
dea4d055 | 341 | (export '(c-array-type c-array-dimensions)) |
abdf50aa | 342 | (defclass c-array-type (c-type) |
77027cca MW |
343 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype) |
344 | (dimensions :initarg :dimensions :type list :reader c-array-dimensions)) | |
abdf50aa MW |
345 | (:documentation |
346 | "C array types.")) | |
347 | ||
dea4d055 MW |
348 | ;; Constructor function. |
349 | ||
350 | (export 'make-array-type) | |
1f1d88f5 MW |
351 | (defun make-array-type (subtype dimensions) |
352 | "Return a new array of SUBTYPE with given DIMENSIONS." | |
353 | (make-instance 'c-array-type :subtype subtype | |
354 | :dimensions (or dimensions '(nil)))) | |
abdf50aa | 355 | |
dea4d055 MW |
356 | ;; Comparison protocol. |
357 | ||
358 | (defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type)) | |
359 | ||
360 | ;; Messy. C doesn't have multidimensional arrays, but we fake them for | |
361 | ;; convenience's sake. But it means that we have to arrange for | |
362 | ;; multidimensional arrays to equal vectors of vectors -- and in general | |
363 | ;; for multidimensional arrays of multidimensional arrays to match each | |
364 | ;; other properly, even when their dimensions don't align precisely. | |
365 | (labels ((check (sub-a dim-a sub-b dim-b) | |
366 | (cond ((endp dim-a) | |
367 | (cond ((endp dim-b) | |
368 | (c-type-equal-p sub-a sub-b)) | |
369 | ((typep sub-a 'c-array-type) | |
370 | (check (c-type-subtype sub-a) | |
371 | (c-array-dimensions sub-a) | |
372 | sub-b dim-b)) | |
373 | (t | |
374 | nil))) | |
375 | ((endp dim-b) | |
376 | (check sub-b dim-b sub-a dim-a)) | |
377 | ((equal (car dim-a) (car dim-b)) | |
378 | (check sub-a (cdr dim-a) sub-b (cdr dim-b))) | |
379 | (t | |
380 | nil)))) | |
381 | (check (c-type-subtype type-a) (c-array-dimensions type-a) | |
382 | (c-type-subtype type-b) (c-array-dimensions type-b)))) | |
383 | ||
384 | ;; C syntax output protocol. | |
385 | ||
1f1d88f5 MW |
386 | (defmethod pprint-c-type ((type c-array-type) stream kernel) |
387 | (pprint-c-type (c-type-subtype type) stream | |
388 | (lambda (stream prio spacep) | |
389 | (maybe-in-parens (stream (> prio 2)) | |
390 | (funcall kernel stream 2 spacep) | |
391 | (format stream "~@<~{[~@[~A~]]~^~_~}~:>" | |
392 | (c-array-dimensions type)))))) | |
abdf50aa | 393 | |
dea4d055 | 394 | ;; S-expression notation protocol. |
abdf50aa MW |
395 | |
396 | (defmethod print-c-type (stream (type c-array-type) &optional colon atsign) | |
397 | (declare (ignore colon atsign)) | |
dea4d055 | 398 | (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>" |
abdf50aa MW |
399 | (c-type-subtype type) |
400 | (c-array-dimensions type))) | |
401 | ||
dea4d055 | 402 | (export '([] array vec)) |
1f1d88f5 | 403 | (define-c-type-syntax [] (sub &rest dims) |
abdf50aa MW |
404 | "Return the type of arrays of SUB with the dimensions DIMS. |
405 | ||
406 | If the DIMS are omitted, a single unknown-length dimension is added." | |
1f1d88f5 MW |
407 | `(make-array-type ,(expand-c-type-spec sub) |
408 | (list ,@(or dims '(nil))))) | |
409 | (c-type-alias [] array vec) | |
abdf50aa MW |
410 | |
411 | ;;;-------------------------------------------------------------------------- | |
412 | ;;; Function types. | |
413 | ||
dea4d055 | 414 | ;; Function arguments. |
abdf50aa | 415 | |
933bbda6 | 416 | (defun argument-lists-equal-p (list-a list-b) |
1f1d88f5 MW |
417 | "Return whether LIST-A and LIST-B match. |
418 | ||
419 | They must have the same number of arguments, and each argument must have | |
3109662a | 420 | the same type, or be `:ellipsis'. The argument names are not inspected." |
abdf50aa MW |
421 | (and (= (length list-a) (length list-b)) |
422 | (every (lambda (arg-a arg-b) | |
423 | (if (eq arg-a :ellipsis) | |
424 | (eq arg-b :ellipsis) | |
b4aab8d4 MW |
425 | (and (argumentp arg-a) (argumentp arg-b) |
426 | (c-type-equal-p (argument-type arg-a) | |
427 | (argument-type arg-b))))) | |
abdf50aa MW |
428 | list-a list-b))) |
429 | ||
dea4d055 | 430 | ;; Class definition. |
1f1d88f5 | 431 | |
dea4d055 | 432 | (export '(c-function-type c-function-arguments)) |
1f1d88f5 | 433 | (defclass c-function-type (c-type) |
77027cca | 434 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype) |
8e36de0e | 435 | (arguments :type list :reader c-function-arguments)) |
1f1d88f5 MW |
436 | (:documentation |
437 | "C function types. The subtype is the return type, as implied by the C | |
438 | syntax for function declarations.")) | |
439 | ||
8e36de0e MW |
440 | (defmethod shared-initialize :after |
441 | ((type c-function-type) slot-names &key (arguments nil argsp)) | |
442 | (declare (ignore slot-names)) | |
443 | (when argsp | |
444 | (setf (slot-value type 'arguments) | |
445 | (if (and arguments | |
446 | (null (cdr arguments)) | |
447 | (not (eq (car arguments) :ellipsis)) | |
448 | (eq (argument-type (car arguments)) c-type-void)) | |
449 | nil | |
450 | arguments)))) | |
451 | ||
dea4d055 MW |
452 | ;; Constructor function. |
453 | ||
454 | (export 'make-function-type) | |
1f1d88f5 MW |
455 | (defun make-function-type (subtype arguments) |
456 | "Return a new function type, returning SUBTYPE and accepting ARGUMENTS." | |
4d89d941 | 457 | (make-instance 'c-function-type :subtype subtype |
8e36de0e | 458 | :arguments arguments)) |
1f1d88f5 | 459 | |
dea4d055 MW |
460 | ;; Comparison protocol. |
461 | ||
462 | (defmethod c-type-equal-p and | |
463 | ((type-a c-function-type) (type-b c-function-type)) | |
464 | (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)) | |
933bbda6 MW |
465 | (argument-lists-equal-p (c-function-arguments type-a) |
466 | (c-function-arguments type-b)))) | |
abdf50aa | 467 | |
dea4d055 | 468 | ;; C syntax output protocol. |
abdf50aa | 469 | |
4d89d941 MW |
470 | (let ((void-arglist (list (make-argument nil c-type-void)))) |
471 | (defmethod pprint-c-type ((type c-function-type) stream kernel) | |
472 | (pprint-c-type (c-type-subtype type) stream | |
473 | (lambda (stream prio spacep) | |
474 | (maybe-in-parens (stream (> prio 2)) | |
475 | (when spacep (c-type-space stream)) | |
476 | (funcall kernel stream 2 nil) | |
477 | (pprint-indent :block 4 stream) | |
478 | (pprint-logical-block | |
479 | (stream nil :prefix "(" :suffix ")") | |
480 | (let ((firstp t)) | |
481 | (dolist (arg (or (c-function-arguments type) | |
482 | void-arglist)) | |
483 | (if firstp | |
484 | (setf firstp nil) | |
485 | (format stream ", ~_")) | |
486 | (if (eq arg :ellipsis) | |
487 | (write-string "..." stream) | |
488 | (pprint-c-type (argument-type arg) | |
489 | stream | |
490 | (argument-name arg))))))))))) | |
1f1d88f5 | 491 | |
dea4d055 MW |
492 | ;; S-expression notation protocol. |
493 | ||
494 | (defmethod print-c-type | |
495 | (stream (type c-function-type) &optional colon atsign) | |
496 | (declare (ignore colon atsign)) | |
497 | (format stream "~:@<~ | |
498 | FUN ~@_~:I~/sod:print-c-type/~ | |
499 | ~{ ~_~:<~S ~@_~/sod:print-c-type/~:>~}~ | |
500 | ~:>" | |
501 | (c-type-subtype type) | |
502 | (mapcar (lambda (arg) | |
1224dfb0 | 503 | (if (eq arg :ellipsis) arg |
dea4d055 MW |
504 | (list (argument-name arg) (argument-type arg)))) |
505 | (c-function-arguments type)))) | |
abdf50aa | 506 | |
93348ae9 | 507 | (export '(fun function () func fn)) |
1f1d88f5 | 508 | (define-c-type-syntax fun (ret &rest args) |
abdf50aa MW |
509 | "Return the type of functions which returns RET and has arguments ARGS. |
510 | ||
1f1d88f5 MW |
511 | The ARGS are a list of arguments of the form (NAME TYPE). The NAME can be |
512 | NIL to indicate that no name was given. | |
513 | ||
514 | If an entry isn't a list, it's assumed to be the start of a Lisp | |
515 | expression to compute the tail of the list; similarly, if the list is | |
516 | improper, then it's considered to be a complete expression. The upshot of | |
517 | this apparently bizarre rule is that you can say | |
518 | ||
519 | (c-type (fun int (\"foo\" int) . arg-tail)) | |
520 | ||
521 | where ARG-TAIL is (almost) any old Lisp expression and have it tack the | |
522 | arguments onto the end. Of course, there don't have to be any explicit | |
523 | arguments at all. The only restriction is that the head of the Lisp form | |
524 | can't be a list -- so ((lambda (...) ...) ...) is out, but you probably | |
525 | wouldn't type that anyway." | |
526 | ||
527 | `(make-function-type ,(expand-c-type-spec ret) | |
528 | ,(do ((args args (cdr args)) | |
529 | (list nil | |
530 | (cons `(make-argument ,(caar args) | |
531 | ,(expand-c-type-spec | |
532 | (cadar args))) | |
533 | list))) | |
534 | ((or (atom args) (atom (car args))) | |
535 | (cond ((and (null args) (null list)) `nil) | |
536 | ((null args) `(list ,@(nreverse list))) | |
dea4d055 MW |
537 | ((and (consp args) |
538 | (eq (car args) :ellipsis)) | |
539 | `(list ,@(nreverse list) :ellipsis)) | |
1f1d88f5 MW |
540 | ((null list) `,args) |
541 | (t `(list* ,@(nreverse list) ,args))))))) | |
542 | (c-type-alias fun function () func fn) | |
abdf50aa | 543 | |
dea4d055 MW |
544 | ;; Additional utilities for dealing with functions. |
545 | ||
546 | (export 'commentify-argument-names) | |
547 | (defun commentify-argument-names (arguments) | |
548 | "Return an argument list with the arguments commentified. | |
549 | ||
3109662a MW |
550 | That is, with each argument name passed through |
551 | `commentify-argument-name'." | |
dea4d055 | 552 | (mapcar (lambda (arg) |
1224dfb0 | 553 | (if (eq arg :ellipsis) arg |
dea4d055 MW |
554 | (make-argument (commentify-argument-name (argument-name arg)) |
555 | (argument-type arg)))) | |
556 | arguments)) | |
557 | ||
558 | (export 'commentify-function-type) | |
559 | (defun commentify-function-type (type) | |
560 | "Return a type like TYPE, but with arguments commentified. | |
561 | ||
562 | This doesn't recurse into the return type or argument types." | |
563 | (make-function-type (c-type-subtype type) | |
564 | (commentify-argument-names | |
565 | (c-function-arguments type)))) | |
566 | ||
abdf50aa | 567 | ;;;----- That's all, folks -------------------------------------------------- |