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." | |
175d7ea7 MW |
38 | (let ((list (cons (typecase class |
39 | ;; Canonify the class object; we'd prefer a name. | |
40 | (standard-class (class-name class)) | |
41 | (t class)) | |
42 | (let ((alist nil) (plist initargs)) | |
43 | ;; Canonify the initargs. Arrange for them to be in | |
44 | ;; ascending order by name. This is annoying because | |
45 | ;; a plist isn't a readily sortable sequence. | |
46 | (loop | |
47 | (when (null plist) (return)) | |
48 | (let ((name (pop plist)) (value (pop plist))) | |
49 | (push (cons name value) alist))) | |
50 | (dolist (assoc (sort alist #'string> :key #'car)) | |
51 | (push (cdr assoc) plist) | |
52 | (push (car assoc) plist)) | |
53 | plist)))) | |
dea4d055 MW |
54 | (or (gethash list *c-type-intern-map*) |
55 | (let ((new (apply #'make-instance class initargs))) | |
56 | (setf (gethash new *c-type-intern-map*) t | |
57 | (gethash list *c-type-intern-map*) new))))) | |
58 | ||
59 | #+test | |
60 | (defun check-type-intern-map () | |
61 | "Sanity check for the type-intern map." | |
62 | (let ((map (make-hash-table))) | |
63 | ||
64 | ;; Pass 1: check that interned types are consistent with their keys. | |
65 | ;; Remember interned types. | |
66 | (maphash (lambda (k v) | |
67 | (when (listp k) | |
68 | (let ((ty (apply #'make-instance k))) | |
69 | (assert (c-type-equal-p ty v))) | |
70 | (setf (gethash v map) t))) | |
71 | *c-type-intern-map*) | |
72 | ||
73 | ;; Pass 2: check that the interned type indicators are correct. | |
74 | (maphash (lambda (k v) | |
75 | (declare (ignore v)) | |
76 | (assert (gethash k *c-type-intern-map*))) | |
77 | map) | |
78 | (maphash (lambda (k v) | |
79 | (declare (ignore v)) | |
80 | (when (typep k 'c-type) | |
81 | (assert (gethash k map)))) | |
82 | *c-type-intern-map*))) | |
abdf50aa | 83 | |
2b2252cc MW |
84 | (defun make-or-intern-c-type (new-type-class base-types &rest initargs) |
85 | "Return a possibly-new instance of NEW-TYPE-CLASS with the given INITARGS. | |
86 | ||
87 | If all of the BASE-TYPES are interned, then use `intern-c-type' to | |
88 | construct the new type; otherwise just make a new one with | |
89 | `make-instance'. BASE-TYPES may be a singleton type, or a sequence of | |
90 | types." | |
91 | (apply (if (if (typep base-types 'sequence) | |
92 | (every (lambda (type) | |
93 | (gethash type *c-type-intern-map*)) | |
94 | base-types) | |
95 | (gethash base-types *c-type-intern-map*)) | |
96 | #'intern-c-type #'make-instance) | |
97 | new-type-class | |
98 | initargs)) | |
99 | ||
b5c8ba34 MW |
100 | ;;;-------------------------------------------------------------------------- |
101 | ;;; Qualifiers. | |
102 | ||
103 | (defmethod c-qualifier-keyword ((qualifier (eql :atomic))) "_Atomic") | |
104 | ||
bf090e02 MW |
105 | (defmethod qualify-c-type ((type qualifiable-c-type) qualifiers) |
106 | (let ((initargs (instance-initargs type))) | |
107 | (remf initargs :qualifiers) | |
2b2252cc | 108 | (apply #'make-or-intern-c-type (class-of type) type |
bf090e02 MW |
109 | :qualifiers (canonify-qualifiers |
110 | (append qualifiers (c-type-qualifiers type))) | |
111 | initargs))) | |
112 | ||
abdf50aa | 113 | ;;;-------------------------------------------------------------------------- |
b7fcf941 MW |
114 | ;;; Storage specifiers. |
115 | ||
116 | (defmethod c-type-equal-p :around | |
117 | ((type-a c-storage-specifiers-type) (type-b c-type)) | |
118 | "Ignore storage specifiers when comparing C types." | |
119 | (c-type-equal-p (c-type-subtype type-a) type-b)) | |
120 | ||
121 | (defmethod c-type-equal-p :around | |
122 | ((type-a c-type) (type-b c-storage-specifiers-type)) | |
123 | "Ignore storage specifiers when comparing C types." | |
124 | (c-type-equal-p type-a (c-type-subtype type-b))) | |
125 | ||
126 | (defun make-storage-specifiers-type (subtype specifiers) | |
127 | "Construct a type based on SUBTYPE, carrying the storage SPECIFIERS." | |
128 | (if (null specifiers) subtype | |
129 | (make-or-intern-c-type 'c-storage-specifiers-type subtype | |
130 | :specifiers specifiers | |
131 | :subtype subtype))) | |
132 | ||
133 | (defmethod pprint-c-type ((type c-storage-specifiers-type) stream kernel) | |
134 | (dolist (spec (c-type-specifiers type)) | |
135 | (pprint-c-storage-specifier spec stream) | |
136 | (write-char #\space stream) | |
137 | (pprint-newline :miser stream)) | |
138 | (pprint-c-type (c-type-subtype type) stream kernel)) | |
139 | ||
140 | (defmethod print-c-type | |
141 | (stream (type c-storage-specifiers-type) &optional colon atsign) | |
142 | (declare (ignore colon atsign)) | |
143 | (format stream "~:@<SPECS ~@_~:I~/sod:print-c-type/~ | |
144 | ~{ ~_~/sod:print-c-storage-specifier/~}~:>" | |
145 | (c-type-subtype type) (c-type-specifiers type))) | |
146 | ||
147 | (export 'specs) | |
148 | (define-c-type-syntax specs (subtype &rest specifiers) | |
149 | `(make-storage-specifiers-type | |
150 | ,(expand-c-type-spec subtype) | |
151 | (list ,@(mapcar #'expand-c-storage-specifier specifiers)))) | |
152 | ||
153 | ;;;-------------------------------------------------------------------------- | |
db56b1d3 MW |
154 | ;;; Some storage specifiers. |
155 | ||
156 | (export 'alignas-storage-specifier) | |
157 | (defclass alignas-storage-specifier () | |
158 | ((alignment :initarg :alignment :reader spec-alignment))) | |
159 | ||
160 | (export 'alignas) | |
161 | (define-c-storage-specifier-syntax alignas (alignment) | |
162 | `(make-instance 'alignas-storage-specifier :alignment ,alignment)) | |
163 | ||
164 | (defmethod print-c-storage-specifier | |
165 | (stream (spec alignas-storage-specifier) &optional colon atsign) | |
166 | (declare (ignore colon atsign)) | |
167 | (format stream "~:@<~S ~_~S~:>" 'alignas (spec-alignment spec))) | |
168 | ||
169 | (defmethod pprint-c-storage-specifier | |
170 | ((spec alignas-storage-specifier) stream) | |
171 | (format stream "_Alignas(~A)" (spec-alignment spec))) | |
172 | ||
173 | ;;;-------------------------------------------------------------------------- | |
dea4d055 | 174 | ;;; Simple C types. |
abdf50aa | 175 | |
dea4d055 | 176 | ;; Class definition. |
abdf50aa | 177 | |
dea4d055 MW |
178 | (export '(simple-c-type c-type-name)) |
179 | (defclass simple-c-type (qualifiable-c-type) | |
180 | ((name :initarg :name :type string :reader c-type-name)) | |
abdf50aa | 181 | (:documentation |
dea4d055 | 182 | "C types with simple forms.")) |
abdf50aa | 183 | |
dea4d055 | 184 | ;; Constructor function and interning. |
abdf50aa | 185 | |
dea4d055 MW |
186 | (export 'make-simple-type) |
187 | (defun make-simple-type (name &optional qualifiers) | |
188 | "Make a distinguished object for the simple type called NAME." | |
189 | (intern-c-type 'simple-c-type | |
190 | :name name | |
191 | :qualifiers (canonify-qualifiers qualifiers))) | |
abdf50aa | 192 | |
dea4d055 | 193 | ;; Comparison protocol. |
abdf50aa | 194 | |
dea4d055 MW |
195 | (defmethod c-type-equal-p and |
196 | ((type-a simple-c-type) (type-b simple-c-type)) | |
197 | (string= (c-type-name type-a) (c-type-name type-b))) | |
abdf50aa | 198 | |
dea4d055 | 199 | ;; C syntax output protocol. |
1f1d88f5 MW |
200 | |
201 | (defmethod pprint-c-type ((type simple-c-type) stream kernel) | |
202 | (pprint-logical-block (stream nil) | |
ff4e398b MW |
203 | (format stream "~{~A ~@_~}~A" |
204 | (c-type-qualifier-keywords type) | |
1f1d88f5 MW |
205 | (c-type-name type)) |
206 | (funcall kernel stream 0 t))) | |
abdf50aa | 207 | |
dea4d055 MW |
208 | ;; S-expression notation protocol. |
209 | ||
b6f84c57 | 210 | (defparameter *simple-type-map* (make-hash-table :test #'equal) |
dea4d055 | 211 | "Hash table mapping strings of C syntax to symbolic names.") |
abdf50aa MW |
212 | |
213 | (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign) | |
214 | (declare (ignore colon atsign)) | |
215 | (let* ((name (c-type-name type)) | |
216 | (symbol (gethash name *simple-type-map*))) | |
1f1d88f5 MW |
217 | (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]" |
218 | (c-type-qualifiers type) (or symbol name)))) | |
abdf50aa | 219 | |
1f1d88f5 MW |
220 | (eval-when (:compile-toplevel :load-toplevel :execute) |
221 | (defmethod expand-c-type-spec ((spec string)) | |
222 | `(make-simple-type ,spec)) | |
223 | (defmethod expand-c-type-form ((head string) tail) | |
dea4d055 | 224 | `(make-simple-type ,head (list ,@tail)))) |
abdf50aa | 225 | |
dea4d055 | 226 | (export 'define-simple-c-type) |
e43d3532 | 227 | (defmacro define-simple-c-type (names type &key export) |
abdf50aa | 228 | "Define each of NAMES to be a simple type called TYPE." |
14adef2f MW |
229 | (let ((names (if (listp names) names (list names))) |
230 | (types (if (listp type) type (list type)))) | |
231 | (with-gensyms (type name) | |
232 | `(progn | |
233 | (dolist (,type ',types) | |
234 | (setf (gethash ,type *simple-type-map*) ',(car names))) | |
235 | (dolist (,name ',names) | |
236 | (setf (gethash ,name *simple-type-map*) ,(car types))) | |
237 | (defctype ,names ,(car types) :export ,export) | |
238 | (define-c-type-syntax ,(car names) (&rest quals) | |
239 | `(make-simple-type ,',(car types) (list ,@quals))))))) | |
240 | ||
241 | (export 'find-simple-c-type) | |
242 | (defun find-simple-c-type (name) | |
243 | "Return the `simple-c-type' with the given NAME, or nil." | |
244 | (aand (gethash name *simple-type-map*) | |
245 | (make-simple-type (gethash it *simple-type-map*)))) | |
abdf50aa | 246 | |
dea4d055 MW |
247 | ;; Built-in C types. |
248 | ||
e43d3532 MW |
249 | (define-simple-c-type void "void" :export t) |
250 | ||
251 | (define-simple-c-type char "char" :export t) | |
252 | (define-simple-c-type (unsigned-char uchar) "unsigned char" :export t) | |
253 | (define-simple-c-type (signed-char schar) "signed char" :export t) | |
be2410a0 | 254 | (define-simple-c-type wchar-t "wchar_t" :export t) |
e43d3532 | 255 | |
7aa55c11 MW |
256 | (define-simple-c-type (int signed signed-int sint) |
257 | ("int" "signed") :export t) | |
e43d3532 | 258 | (define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t) |
abdf50aa MW |
259 | |
260 | (define-simple-c-type (short signed-short short-int signed-short-int sshort) | |
e43d3532 | 261 | "short" :export t) |
abdf50aa | 262 | (define-simple-c-type (unsigned-short unsigned-short-int ushort) |
e43d3532 | 263 | "unsigned short" :export t) |
abdf50aa MW |
264 | |
265 | (define-simple-c-type (long signed-long long-int signed-long-int slong) | |
e43d3532 | 266 | "long" :export t) |
abdf50aa | 267 | (define-simple-c-type (unsigned-long unsigned-long-int ulong) |
e43d3532 | 268 | "unsigned long" :export t) |
abdf50aa MW |
269 | |
270 | (define-simple-c-type (long-long signed-long-long long-long-int | |
271 | signed-long-long-int llong sllong) | |
e43d3532 | 272 | "long long" :export t) |
abdf50aa | 273 | (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong) |
e43d3532 | 274 | "unsigned long long" :export t) |
abdf50aa | 275 | |
e43d3532 MW |
276 | (define-simple-c-type float "float" :export t) |
277 | (define-simple-c-type double "double" :export t) | |
278 | (define-simple-c-type long-double "long double" :export t) | |
abdf50aa | 279 | |
26d71c7a | 280 | (define-simple-c-type bool ("_Bool" "bool") :export t) |
0e7cdea0 | 281 | |
e43d3532 MW |
282 | (define-simple-c-type float-complex "float _Complex" :export t) |
283 | (define-simple-c-type double-complex "double _Complex" :export t) | |
284 | (define-simple-c-type long-double-complex "long double _Complex" :export t) | |
0e7cdea0 | 285 | |
e43d3532 MW |
286 | (define-simple-c-type float-imaginary "float _Imaginary" :export t) |
287 | (define-simple-c-type double-imaginary "double _Imaginary" :export t) | |
288 | (define-simple-c-type long-double-imaginary | |
289 | "long double _Imaginary" :export t) | |
0e7cdea0 | 290 | |
e43d3532 MW |
291 | (define-simple-c-type va-list "va_list" :export t) |
292 | (define-simple-c-type size-t "size_t" :export t) | |
293 | (define-simple-c-type ptrdiff-t "ptrdiff_t" :export t) | |
abdf50aa | 294 | |
0a8f78ec MW |
295 | (macrolet ((define-cross-product-types (&rest pieces) |
296 | `(progn | |
297 | ,@(mapcar (lambda (row) | |
298 | (let* ((c-name (apply #'concatenate 'string row)) | |
299 | (lisp-name (intern | |
300 | (frob-identifier c-name)))) | |
301 | `(define-simple-c-type ,lisp-name ,c-name | |
302 | :export t))) | |
303 | (apply #'cross-product pieces))))) | |
304 | (define-cross-product-types ("int" "uint") ("" "_least" "_fast") | |
305 | ("8" "16" "32" "64") "_t") | |
306 | (define-cross-product-types ("int" "uint") ("ptr" "max") "_t")) | |
307 | ||
abdf50aa | 308 | ;;;-------------------------------------------------------------------------- |
dea4d055 | 309 | ;;; Tagged types (enums, structs and unions). |
abdf50aa | 310 | |
dea4d055 | 311 | ;; Class definition. |
abdf50aa | 312 | |
dea4d055 | 313 | (export '(tagged-c-type c-type-tag)) |
abdf50aa | 314 | (defclass tagged-c-type (qualifiable-c-type) |
77027cca | 315 | ((tag :initarg :tag :type string :reader c-type-tag)) |
abdf50aa MW |
316 | (:documentation |
317 | "C types with tags.")) | |
318 | ||
dea4d055 MW |
319 | ;; Subclass definitions. |
320 | ||
321 | (export 'c-tagged-type-kind) | |
abdf50aa MW |
322 | (defgeneric c-tagged-type-kind (type) |
323 | (:documentation | |
324 | "Return the kind of tagged type that TYPE is, as a keyword.")) | |
325 | ||
dea4d055 MW |
326 | (export 'kind-c-tagged-type) |
327 | (defgeneric kind-c-tagged-type (kind) | |
328 | (:documentation | |
329 | "Given a keyword KIND, return the appropriate class name.")) | |
330 | ||
331 | (export 'make-c-tagged-type) | |
332 | (defun make-c-tagged-type (kind tag &optional qualifiers) | |
333 | "Return a tagged type with the given KIND (keyword) and TAG (string)." | |
334 | (intern-c-type (kind-c-tagged-type kind) | |
335 | :tag tag | |
336 | :qualifiers (canonify-qualifiers qualifiers))) | |
337 | ||
abdf50aa | 338 | (macrolet ((define-tagged-type (kind what) |
dea4d055 MW |
339 | (let* ((type (symbolicate 'c- kind '-type)) |
340 | (keyword (intern (symbol-name kind) :keyword)) | |
341 | (constructor (symbolicate 'make- kind '-type))) | |
abdf50aa | 342 | `(progn |
bf090e02 | 343 | (export '(,type ,kind ,constructor)) |
abdf50aa | 344 | (defclass ,type (tagged-c-type) () |
a1985b3c | 345 | (:documentation ,(format nil "C ~A types." what))) |
abdf50aa | 346 | (defmethod c-tagged-type-kind ((type ,type)) |
dea4d055 MW |
347 | ',keyword) |
348 | (defmethod kind-c-tagged-type ((kind (eql ',keyword))) | |
349 | ',type) | |
350 | (defun ,constructor (tag &optional qualifiers) | |
351 | (intern-c-type ',type :tag tag | |
352 | :qualifiers (canonify-qualifiers | |
353 | qualifiers))) | |
1f1d88f5 MW |
354 | (define-c-type-syntax ,kind (tag &rest quals) |
355 | ,(format nil "Construct ~A type named TAG" what) | |
356 | `(,',constructor ,tag (list ,@quals))))))) | |
357 | (define-tagged-type enum "enumerated") | |
358 | (define-tagged-type struct "structure") | |
359 | (define-tagged-type union "union")) | |
360 | ||
dea4d055 MW |
361 | ;; Comparison protocol. |
362 | ||
363 | (defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type)) | |
364 | (string= (c-type-tag type-a) (c-type-tag type-b))) | |
365 | ||
366 | ;; C syntax output protocol. | |
367 | ||
1f1d88f5 MW |
368 | (defmethod pprint-c-type ((type tagged-c-type) stream kernel) |
369 | (pprint-logical-block (stream nil) | |
ff4e398b MW |
370 | (format stream "~{~A ~@_~}~(~A~) ~A" |
371 | (c-type-qualifier-keywords type) | |
1f1d88f5 MW |
372 | (c-tagged-type-kind type) |
373 | (c-type-tag type)) | |
374 | (funcall kernel stream 0 t))) | |
abdf50aa | 375 | |
dea4d055 | 376 | ;; S-expression notation protocol. |
abdf50aa MW |
377 | |
378 | (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign) | |
379 | (declare (ignore colon atsign)) | |
1f1d88f5 | 380 | (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>" |
abdf50aa | 381 | (c-tagged-type-kind type) |
1f1d88f5 MW |
382 | (c-type-tag type) |
383 | (c-type-qualifiers type))) | |
abdf50aa MW |
384 | |
385 | ;;;-------------------------------------------------------------------------- | |
ae0f15ee MW |
386 | ;;; Atomic types. |
387 | ||
388 | ;; Class definition. | |
389 | ||
390 | (export 'c-atomic-type) | |
391 | (defclass c-atomic-type (qualifiable-c-type) | |
392 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype)) | |
393 | (:documentation "C atomic types.")) | |
394 | ||
395 | ;; Constructor function. | |
396 | ||
397 | (export 'make-atomic-type) | |
398 | (defun make-atomic-type (subtype &optional qualifiers) | |
399 | "Return a (maybe distinguished) atomic type." | |
400 | (make-or-intern-c-type 'c-atomic-type subtype | |
401 | :subtype subtype | |
402 | :qualifiers (canonify-qualifiers qualifiers))) | |
403 | ||
404 | ;; Comparison protocol. | |
405 | ||
406 | (defmethod c-type-equal-p and ((type-a c-atomic-type) (type-b c-atomic-type)) | |
407 | (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))) | |
408 | ||
409 | ;; C-syntax output protocol. | |
410 | ||
411 | (defmethod pprint-c-type ((type c-atomic-type) stream kernel) | |
412 | (pprint-logical-block (stream nil) | |
413 | (format stream "~{~A ~@_~}" (c-type-qualifier-keywords type)) | |
414 | (write-string "_Atomic(" stream) | |
415 | (pprint-indent :current 0 stream) | |
416 | (pprint-c-type (c-type-subtype type) stream | |
417 | (lambda (stream prio spacep) | |
418 | (declare (ignore stream prio spacep)))) | |
419 | (write-char #\) stream))) | |
420 | ||
421 | ;; S-expression notation protocol. | |
422 | ||
423 | (defmethod print-c-type (stream (type c-atomic-type) &optional colon atsign) | |
424 | (declare (ignore colon atsign)) | |
425 | (format stream "~:@<ATOMIC ~@_~/sod:print-c-type/~{ ~_~S~}~:>" | |
426 | (c-type-subtype type) | |
427 | (c-type-qualifiers type))) | |
428 | ||
429 | (export 'atomic) | |
430 | (define-c-type-syntax atomic (sub &rest quals) | |
431 | "Return the type of atomic SUB." | |
432 | `(make-atomic-type ,(expand-c-type-spec sub) (list ,@quals))) | |
433 | ||
434 | ;;;-------------------------------------------------------------------------- | |
abdf50aa MW |
435 | ;;; Pointer types. |
436 | ||
dea4d055 | 437 | ;; Class definition. |
abdf50aa | 438 | |
dea4d055 | 439 | (export 'c-pointer-type) |
abdf50aa | 440 | (defclass c-pointer-type (qualifiable-c-type) |
77027cca | 441 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype)) |
dea4d055 | 442 | (:documentation "C pointer types.")) |
abdf50aa | 443 | |
dea4d055 MW |
444 | ;; Constructor function. |
445 | ||
446 | (export 'make-pointer-type) | |
447 | (defun make-pointer-type (subtype &optional qualifiers) | |
448 | "Return a (maybe distinguished) pointer type." | |
2b2252cc MW |
449 | (make-or-intern-c-type 'c-pointer-type subtype |
450 | :subtype subtype | |
451 | :qualifiers (canonify-qualifiers qualifiers))) | |
dea4d055 MW |
452 | |
453 | ;; Comparison protocol. | |
454 | ||
455 | (defmethod c-type-equal-p and ((type-a c-pointer-type) | |
456 | (type-b c-pointer-type)) | |
457 | (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))) | |
458 | ||
459 | ;; C syntax output protocol. | |
1f1d88f5 MW |
460 | |
461 | (defmethod pprint-c-type ((type c-pointer-type) stream kernel) | |
462 | (pprint-c-type (c-type-subtype type) stream | |
463 | (lambda (stream prio spacep) | |
464 | (when spacep (c-type-space stream)) | |
465 | (maybe-in-parens (stream (> prio 1)) | |
ff4e398b MW |
466 | (format stream "*~{~A~^ ~@_~}" |
467 | (c-type-qualifier-keywords type)) | |
1f1d88f5 | 468 | (funcall kernel stream 1 (c-type-qualifiers type)))))) |
abdf50aa | 469 | |
dea4d055 | 470 | ;; S-expression notation protocol. |
abdf50aa MW |
471 | |
472 | (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign) | |
473 | (declare (ignore colon atsign)) | |
dea4d055 | 474 | (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>" |
1f1d88f5 MW |
475 | (c-type-subtype type) |
476 | (c-type-qualifiers type))) | |
abdf50aa | 477 | |
dea4d055 | 478 | (export '(* pointer ptr)) |
1f1d88f5 | 479 | (define-c-type-syntax * (sub &rest quals) |
abdf50aa | 480 | "Return the type of pointer-to-SUB." |
1f1d88f5 MW |
481 | `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals))) |
482 | (c-type-alias * pointer ptr) | |
abdf50aa | 483 | |
dea4d055 MW |
484 | ;; Built-in C types. |
485 | ||
486 | (export '(string const-string)) | |
abdf50aa | 487 | (defctype string (* char)) |
1f1d88f5 | 488 | (defctype const-string (* (char :const))) |
abdf50aa MW |
489 | |
490 | ;;;-------------------------------------------------------------------------- | |
491 | ;;; Array types. | |
492 | ||
dea4d055 | 493 | ;; Class definition. |
abdf50aa | 494 | |
dea4d055 | 495 | (export '(c-array-type c-array-dimensions)) |
abdf50aa | 496 | (defclass c-array-type (c-type) |
77027cca MW |
497 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype) |
498 | (dimensions :initarg :dimensions :type list :reader c-array-dimensions)) | |
abdf50aa MW |
499 | (:documentation |
500 | "C array types.")) | |
501 | ||
dea4d055 MW |
502 | ;; Constructor function. |
503 | ||
504 | (export 'make-array-type) | |
1f1d88f5 MW |
505 | (defun make-array-type (subtype dimensions) |
506 | "Return a new array of SUBTYPE with given DIMENSIONS." | |
507 | (make-instance 'c-array-type :subtype subtype | |
508 | :dimensions (or dimensions '(nil)))) | |
abdf50aa | 509 | |
dea4d055 MW |
510 | ;; Comparison protocol. |
511 | ||
512 | (defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type)) | |
513 | ||
514 | ;; Messy. C doesn't have multidimensional arrays, but we fake them for | |
515 | ;; convenience's sake. But it means that we have to arrange for | |
516 | ;; multidimensional arrays to equal vectors of vectors -- and in general | |
517 | ;; for multidimensional arrays of multidimensional arrays to match each | |
518 | ;; other properly, even when their dimensions don't align precisely. | |
519 | (labels ((check (sub-a dim-a sub-b dim-b) | |
520 | (cond ((endp dim-a) | |
521 | (cond ((endp dim-b) | |
522 | (c-type-equal-p sub-a sub-b)) | |
523 | ((typep sub-a 'c-array-type) | |
524 | (check (c-type-subtype sub-a) | |
525 | (c-array-dimensions sub-a) | |
526 | sub-b dim-b)) | |
527 | (t | |
528 | nil))) | |
529 | ((endp dim-b) | |
530 | (check sub-b dim-b sub-a dim-a)) | |
531 | ((equal (car dim-a) (car dim-b)) | |
532 | (check sub-a (cdr dim-a) sub-b (cdr dim-b))) | |
533 | (t | |
534 | nil)))) | |
535 | (check (c-type-subtype type-a) (c-array-dimensions type-a) | |
536 | (c-type-subtype type-b) (c-array-dimensions type-b)))) | |
537 | ||
538 | ;; C syntax output protocol. | |
539 | ||
1f1d88f5 MW |
540 | (defmethod pprint-c-type ((type c-array-type) stream kernel) |
541 | (pprint-c-type (c-type-subtype type) stream | |
542 | (lambda (stream prio spacep) | |
543 | (maybe-in-parens (stream (> prio 2)) | |
544 | (funcall kernel stream 2 spacep) | |
545 | (format stream "~@<~{[~@[~A~]]~^~_~}~:>" | |
546 | (c-array-dimensions type)))))) | |
abdf50aa | 547 | |
dea4d055 | 548 | ;; S-expression notation protocol. |
abdf50aa MW |
549 | |
550 | (defmethod print-c-type (stream (type c-array-type) &optional colon atsign) | |
551 | (declare (ignore colon atsign)) | |
dea4d055 | 552 | (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>" |
abdf50aa MW |
553 | (c-type-subtype type) |
554 | (c-array-dimensions type))) | |
555 | ||
dea4d055 | 556 | (export '([] array vec)) |
1f1d88f5 | 557 | (define-c-type-syntax [] (sub &rest dims) |
abdf50aa MW |
558 | "Return the type of arrays of SUB with the dimensions DIMS. |
559 | ||
560 | If the DIMS are omitted, a single unknown-length dimension is added." | |
1f1d88f5 MW |
561 | `(make-array-type ,(expand-c-type-spec sub) |
562 | (list ,@(or dims '(nil))))) | |
563 | (c-type-alias [] array vec) | |
abdf50aa MW |
564 | |
565 | ;;;-------------------------------------------------------------------------- | |
566 | ;;; Function types. | |
567 | ||
dea4d055 | 568 | ;; Function arguments. |
abdf50aa | 569 | |
933bbda6 | 570 | (defun argument-lists-equal-p (list-a list-b) |
1f1d88f5 MW |
571 | "Return whether LIST-A and LIST-B match. |
572 | ||
573 | They must have the same number of arguments, and each argument must have | |
3109662a | 574 | the same type, or be `:ellipsis'. The argument names are not inspected." |
abdf50aa MW |
575 | (and (= (length list-a) (length list-b)) |
576 | (every (lambda (arg-a arg-b) | |
577 | (if (eq arg-a :ellipsis) | |
578 | (eq arg-b :ellipsis) | |
b4aab8d4 MW |
579 | (and (argumentp arg-a) (argumentp arg-b) |
580 | (c-type-equal-p (argument-type arg-a) | |
581 | (argument-type arg-b))))) | |
abdf50aa MW |
582 | list-a list-b))) |
583 | ||
ced609b8 MW |
584 | (defun fix-and-check-keyword-argument-list (list) |
585 | "Check the keyword argument LIST is valid; if so, fix it up and return it. | |
586 | ||
587 | Check that the keyword arguments have distinct names. Fix the list up by | |
588 | sorting it by keyword name." | |
589 | ||
590 | (unless (every #'argumentp list) | |
591 | (error "(INTERNAL) not an argument value")) | |
592 | ||
593 | (let ((list (sort (copy-list list) #'string< :key #'argument-name))) | |
594 | (do ((list (cdr list) (cdr list)) | |
595 | (this (car list) (car list)) | |
596 | (prev nil this)) | |
597 | ((endp list)) | |
598 | (when prev | |
599 | (let ((this-name (argument-name this)) | |
600 | (prev-name (argument-name prev))) | |
601 | (when (string= this-name prev-name) | |
a1985b3c | 602 | (error "Duplicate keyword argument name `~A'" this-name))))) |
ced609b8 MW |
603 | list)) |
604 | ||
605 | (export 'merge-keyword-lists) | |
84b9d17a | 606 | (defun merge-keyword-lists (whatfn lists) |
ced609b8 MW |
607 | "Return the union of keyword argument lists. |
608 | ||
84b9d17a MW |
609 | The WHATFN is either nil or a designator for a function (see below). |
610 | ||
611 | The LISTS parameter consists of pairs (REPORTFN . ARGS), where REPORTFN is | |
612 | either nil or a designator for a function (see below); and and ARGS is a | |
613 | list of `argument' objects. | |
ced609b8 MW |
614 | |
615 | The resulting list contains exactly one argument for each distinct | |
616 | argument name appearing in the input lists; this argument will contain the | |
617 | default value corresponding to the name's earliest occurrence in the input | |
618 | LISTS. | |
619 | ||
84b9d17a MW |
620 | If the same name appears in multiple input lists with different types, a |
621 | continuable error is signalled. | |
622 | ||
623 | The WHATFN function is given no arguments, and is expected to return a | |
624 | file location (or other object convertible with `file-location'), and a | |
625 | string (or other printable object) describing the site at which the | |
626 | keyword argument lists are being merged or nil; a mismatch error will be | |
627 | reported as being at the location returned by WHATFN, and the description | |
628 | will be included in the error message. A nil WHATFN is equivalent to a | |
629 | function which returns a nil location and description, though this is | |
630 | considered poor practice. | |
631 | ||
632 | The REPORTFN is given a single argument ARG, which is one of the | |
633 | conflicting `argument' objects found in the REPORTFN's corresponding | |
634 | argument list: the REPORTFN is expected to issue additional `info' | |
635 | messages to help the user diagnose the problem. The (common) name of the | |
636 | argument has already been reported. A nil REPORTFN is equivalent to one | |
637 | which does nothing, though this is considered poor practice." | |
ced609b8 MW |
638 | |
639 | ;; The easy way through all of this is with a hash table mapping argument | |
01778b39 | 640 | ;; names to (WHAT . ARG) pairs. |
ced609b8 MW |
641 | |
642 | (let ((argmap (make-hash-table :test #'equal))) | |
643 | ||
644 | ;; Set up the table. When we find a duplicate, check that the types | |
645 | ;; match. | |
646 | (dolist (item lists) | |
84b9d17a | 647 | (let ((reportfn (car item)) |
01778b39 | 648 | (args (cdr item))) |
ced609b8 MW |
649 | (dolist (arg args) |
650 | (let* ((name (argument-name arg)) | |
651 | (other-item (gethash name argmap))) | |
652 | (if (null other-item) | |
84b9d17a | 653 | (setf (gethash name argmap) (cons reportfn arg)) |
ced609b8 | 654 | (let* ((type (argument-type arg)) |
84b9d17a | 655 | (other-reportfn (car other-item)) |
01778b39 MW |
656 | (other (cdr other-item)) |
657 | (other-type (argument-type other))) | |
ced609b8 | 658 | (unless (c-type-equal-p type other-type) |
84b9d17a MW |
659 | (multiple-value-bind (floc desc) |
660 | (if whatfn (funcall whatfn) (values nil nil)) | |
661 | (cerror*-with-location floc | |
662 | "Type mismatch for keyword ~ | |
663 | argument `~A'~@[ in ~A~]" | |
664 | name desc) | |
665 | (when reportfn | |
666 | (funcall reportfn arg)) | |
667 | (when other-reportfn | |
668 | (funcall other-reportfn other)))))))))) | |
ced609b8 MW |
669 | |
670 | ;; Now it's just a matter of picking the arguments out again. | |
671 | (let ((result nil)) | |
672 | (maphash (lambda (name item) | |
673 | (declare (ignore name)) | |
01778b39 | 674 | (push (cdr item) result)) |
ced609b8 MW |
675 | argmap) |
676 | (fix-and-check-keyword-argument-list result)))) | |
677 | ||
dea4d055 | 678 | ;; Class definition. |
1f1d88f5 | 679 | |
dea4d055 | 680 | (export '(c-function-type c-function-arguments)) |
1f1d88f5 | 681 | (defclass c-function-type (c-type) |
77027cca | 682 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype) |
8e36de0e | 683 | (arguments :type list :reader c-function-arguments)) |
1f1d88f5 MW |
684 | (:documentation |
685 | "C function types. The subtype is the return type, as implied by the C | |
686 | syntax for function declarations.")) | |
687 | ||
8e36de0e MW |
688 | (defmethod shared-initialize :after |
689 | ((type c-function-type) slot-names &key (arguments nil argsp)) | |
690 | (declare (ignore slot-names)) | |
691 | (when argsp | |
692 | (setf (slot-value type 'arguments) | |
693 | (if (and arguments | |
694 | (null (cdr arguments)) | |
695 | (not (eq (car arguments) :ellipsis)) | |
696 | (eq (argument-type (car arguments)) c-type-void)) | |
697 | nil | |
698 | arguments)))) | |
699 | ||
ced609b8 MW |
700 | (export '(c-keyword-function-type c-function-keywords)) |
701 | (defclass c-keyword-function-type (c-function-type) | |
702 | ((keywords :initarg :keywords :type list | |
703 | :reader c-function-keywords)) | |
704 | (:documentation | |
705 | "C function types for `functions' which take keyword arguments.")) | |
706 | ||
707 | (defmethod shared-initialize :after | |
708 | ((type c-keyword-function-type) slot-names &key (keywords nil keysp)) | |
709 | (declare (ignore slot-names)) | |
710 | (when keysp | |
711 | (setf (slot-value type 'keywords) | |
712 | (fix-and-check-keyword-argument-list keywords)))) | |
713 | ||
dea4d055 MW |
714 | ;; Constructor function. |
715 | ||
716 | (export 'make-function-type) | |
1f1d88f5 | 717 | (defun make-function-type (subtype arguments) |
ced609b8 MW |
718 | "Return a new function type, returning SUBTYPE and accepting ARGUMENTS. |
719 | ||
720 | As a helper for dealing with the S-expression syntax for keyword | |
721 | functions, if ARGUMENTS has the form (ARGS ... :keys KEYWORDS ...)' then | |
722 | return a keyword function with arguments (ARGS ...) and keywords (KEYWORDS | |
723 | ...)." | |
724 | (let ((split (member :keys arguments))) | |
725 | (if split | |
726 | (make-instance 'c-keyword-function-type | |
727 | :subtype subtype | |
728 | :arguments (ldiff arguments split) | |
729 | :keywords (cdr split)) | |
730 | (make-instance 'c-function-type | |
731 | :subtype subtype | |
732 | :arguments arguments)))) | |
733 | ||
734 | (export 'make-keyword-function-type) | |
735 | (defun make-keyword-function-type (subtype arguments keywords) | |
736 | "Return a new keyword-function type, returning SUBTYPE and accepting | |
737 | ARGUMENTS and KEYWORDS." | |
738 | (make-instance 'c-keyword-function-type :subtype subtype | |
739 | :arguments arguments :keywords keywords)) | |
1f1d88f5 | 740 | |
dea4d055 MW |
741 | ;; Comparison protocol. |
742 | ||
743 | (defmethod c-type-equal-p and | |
744 | ((type-a c-function-type) (type-b c-function-type)) | |
745 | (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)) | |
933bbda6 MW |
746 | (argument-lists-equal-p (c-function-arguments type-a) |
747 | (c-function-arguments type-b)))) | |
abdf50aa | 748 | |
ced609b8 MW |
749 | (defmethod c-type-equal-p and |
750 | ((type-a c-keyword-function-type) (type-b c-keyword-function-type)) | |
751 | ;; Actually, there's nothing to check here. I'm happy as long as both | |
752 | ;; functions notionally accept keyword arguments. | |
753 | t) | |
754 | ||
dea4d055 | 755 | ;; C syntax output protocol. |
abdf50aa | 756 | |
678b6c0f MW |
757 | (export 'pprint-c-function-type) |
758 | (defun pprint-c-function-type (return-type stream print-args print-kernel) | |
759 | "Common top-level printing for function types. | |
760 | ||
761 | Prints RETURN-TYPE (KERNEL(ARGS)), where RETURN-TYPE is the actual return | |
762 | type, and ARGS and KERNEL are whatever is printed by the PRINT-ARGS and | |
763 | PRINT-KERNEL functions. | |
764 | ||
765 | The PRINT-KERNEL function is the standard such thing for the | |
766 | `pprint-c-type' protocol; PRINT-ARGS accepts just an output stream." | |
767 | (pprint-c-type return-type stream | |
768 | (lambda (stream prio spacep) | |
769 | (maybe-in-parens (stream (> prio 2)) | |
770 | (when spacep (c-type-space stream)) | |
771 | (funcall print-kernel stream 2 nil) | |
772 | (pprint-indent :block 4 stream) | |
243cffbf | 773 | (pprint-newline :linear stream) |
678b6c0f MW |
774 | (pprint-logical-block |
775 | (stream nil :prefix "(" :suffix ")") | |
776 | (funcall print-args stream)))))) | |
777 | ||
778 | (export 'pprint-argument-list) | |
779 | (defun pprint-argument-list (args stream) | |
780 | "Print an argument list. | |
781 | ||
782 | The ARGS is a list of `argument' objects, optionally containing an | |
783 | `:ellipsis' marker. The output is written to STREAM. | |
784 | ||
785 | Returns non-nil if any arguments were actually printed." | |
786 | (let ((anyp nil)) | |
787 | (pprint-logical-block (stream nil) | |
788 | (dolist (arg args) | |
789 | (if anyp | |
790 | (format stream ", ~_") | |
791 | (setf anyp t)) | |
792 | (etypecase arg | |
793 | ((member :ellipsis) | |
794 | (write-string "..." stream)) | |
795 | (argument | |
796 | (pprint-logical-block (stream nil) | |
ced609b8 MW |
797 | (pprint-c-type (argument-type arg) stream (argument-name arg)) |
798 | (let ((default (argument-default arg))) | |
799 | (when default | |
800 | (format stream " = ~2I~_~A" default)))))))) | |
678b6c0f MW |
801 | anyp)) |
802 | ||
4d89d941 MW |
803 | (let ((void-arglist (list (make-argument nil c-type-void)))) |
804 | (defmethod pprint-c-type ((type c-function-type) stream kernel) | |
678b6c0f MW |
805 | (let ((args (or (c-function-arguments type) void-arglist))) |
806 | (pprint-c-function-type (c-type-subtype type) stream | |
807 | (lambda (stream) | |
808 | (pprint-argument-list args stream)) | |
809 | kernel)))) | |
1f1d88f5 | 810 | |
ced609b8 MW |
811 | (defmethod pprint-c-type ((type c-keyword-function-type) stream kernel) |
812 | (let ((args (c-function-arguments type)) | |
813 | (keys (c-function-keywords type))) | |
814 | (pprint-c-function-type (c-type-subtype type) stream | |
815 | (lambda (stream) | |
816 | (when (pprint-argument-list args stream) | |
817 | (format stream ", ~_")) | |
818 | (write-char #\? stream) | |
819 | (pprint-argument-list keys stream)) | |
820 | kernel))) | |
821 | ||
dea4d055 MW |
822 | ;; S-expression notation protocol. |
823 | ||
824 | (defmethod print-c-type | |
825 | (stream (type c-function-type) &optional colon atsign) | |
826 | (declare (ignore colon atsign)) | |
827 | (format stream "~:@<~ | |
243cffbf MW |
828 | FUN ~@_~:I~ |
829 | ~/sod:print-c-type/~:[~; ~]~:*~_~ | |
830 | ~<~@{~:<~S ~@_~/sod:print-c-type/~:>~^ ~_~}~:>~ | |
ced609b8 MW |
831 | ~:[~2*~; ~_~S ~@_~<~@{~:<~S ~@_~/sod:print-c-type/~ |
832 | ~@[ ~@_~S~]~:>~^ ~_~}~:>~]~ | |
dea4d055 MW |
833 | ~:>" |
834 | (c-type-subtype type) | |
835 | (mapcar (lambda (arg) | |
1224dfb0 | 836 | (if (eq arg :ellipsis) arg |
dea4d055 | 837 | (list (argument-name arg) (argument-type arg)))) |
ced609b8 MW |
838 | (c-function-arguments type)) |
839 | (typep type 'c-keyword-function-type) | |
840 | :keys | |
841 | (and (typep type 'c-keyword-function-type) | |
842 | (mapcar (lambda (arg) | |
843 | (list (argument-name arg) | |
844 | (argument-type arg) | |
845 | (argument-default arg))) | |
846 | (c-function-keywords type))))) | |
abdf50aa | 847 | |
93348ae9 | 848 | (export '(fun function () func fn)) |
1f1d88f5 | 849 | (define-c-type-syntax fun (ret &rest args) |
abdf50aa MW |
850 | "Return the type of functions which returns RET and has arguments ARGS. |
851 | ||
ced609b8 MW |
852 | The ARGS are a list of arguments of the form (NAME TYPE [DEFAULT]). The |
853 | NAME can be NIL to indicate that no name was given. | |
1f1d88f5 MW |
854 | |
855 | If an entry isn't a list, it's assumed to be the start of a Lisp | |
856 | expression to compute the tail of the list; similarly, if the list is | |
857 | improper, then it's considered to be a complete expression. The upshot of | |
858 | this apparently bizarre rule is that you can say | |
859 | ||
860 | (c-type (fun int (\"foo\" int) . arg-tail)) | |
861 | ||
862 | where ARG-TAIL is (almost) any old Lisp expression and have it tack the | |
863 | arguments onto the end. Of course, there don't have to be any explicit | |
864 | arguments at all. The only restriction is that the head of the Lisp form | |
865 | can't be a list -- so ((lambda (...) ...) ...) is out, but you probably | |
866 | wouldn't type that anyway." | |
867 | ||
868 | `(make-function-type ,(expand-c-type-spec ret) | |
869 | ,(do ((args args (cdr args)) | |
870 | (list nil | |
ced609b8 MW |
871 | (if (keywordp (car args)) |
872 | (cons (car args) list) | |
873 | (let* ((name (caar args)) | |
874 | (type (expand-c-type-spec | |
875 | (cadar args))) | |
876 | (default (and (cddar args) | |
877 | (caddar args))) | |
878 | (arg `(make-argument | |
879 | ,name ,type ,default))) | |
880 | (cons arg list))))) | |
881 | ((or (atom args) | |
882 | (and (atom (car args)) | |
883 | (not (keywordp (car args))))) | |
1f1d88f5 MW |
884 | (cond ((and (null args) (null list)) `nil) |
885 | ((null args) `(list ,@(nreverse list))) | |
886 | ((null list) `,args) | |
887 | (t `(list* ,@(nreverse list) ,args))))))) | |
888 | (c-type-alias fun function () func fn) | |
abdf50aa | 889 | |
dea4d055 MW |
890 | ;; Additional utilities for dealing with functions. |
891 | ||
892 | (export 'commentify-argument-names) | |
893 | (defun commentify-argument-names (arguments) | |
894 | "Return an argument list with the arguments commentified. | |
895 | ||
3109662a MW |
896 | That is, with each argument name passed through |
897 | `commentify-argument-name'." | |
dea4d055 | 898 | (mapcar (lambda (arg) |
1224dfb0 | 899 | (if (eq arg :ellipsis) arg |
dea4d055 | 900 | (make-argument (commentify-argument-name (argument-name arg)) |
ced609b8 MW |
901 | (argument-type arg) |
902 | (argument-default arg)))) | |
dea4d055 MW |
903 | arguments)) |
904 | ||
905 | (export 'commentify-function-type) | |
906 | (defun commentify-function-type (type) | |
907 | "Return a type like TYPE, but with arguments commentified. | |
908 | ||
909 | This doesn't recurse into the return type or argument types." | |
910 | (make-function-type (c-type-subtype type) | |
911 | (commentify-argument-names | |
912 | (c-function-arguments type)))) | |
913 | ||
074650bc MW |
914 | (export 'reify-variable-argument-tail) |
915 | (defun reify-variable-argument-tail (arguments) | |
916 | "Replace any `:ellipsis' item in ARGUMENTS with a `va_list' argument. | |
917 | ||
918 | The argument's name is taken from the variable `*sod-ap*'." | |
919 | (substitute (make-argument *sod-ap* c-type-va-list) :ellipsis arguments)) | |
920 | ||
abdf50aa | 921 | ;;;----- That's all, folks -------------------------------------------------- |