generator.lisp - clic - Clic is an command line interactive client for gopher w… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
generator.lisp (38985B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; generator.lisp --- Generate CFFI bindings for a c2ffi output. | |
4 ;;; | |
5 ;;; Copyright (C) 2015, Attila Lendvai <[email protected]> | |
6 ;;; | |
7 ;;; Permission is hereby granted, free of charge, to any person | |
8 ;;; obtaining a copy of this software and associated documentation | |
9 ;;; files (the "Software"), to deal in the Software without | |
10 ;;; restriction, including without limitation the rights to use, copy, | |
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies | |
12 ;;; of the Software, and to permit persons to whom the Software is | |
13 ;;; furnished to do so, subject to the following conditions: | |
14 ;;; | |
15 ;;; The above copyright notice and this permission notice shall be | |
16 ;;; included in all copies or substantial portions of the Software. | |
17 ;;; | |
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND | |
21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT | |
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, | |
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, | |
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER | |
25 ;;; DEALINGS IN THE SOFTWARE. | |
26 ;;; | |
27 | |
28 (in-package #:cffi/c2ffi) | |
29 | |
30 ;;; Output generation happens in one phase, straight into the output | |
31 ;;; stream. There's minimal look-ahead (for source-location and name) | |
32 ;;; which is needed to apply user specified filters in time. | |
33 ;;; | |
34 ;;; Each CFFI form is also EVAL'd during generation because the CFFI | |
35 ;;; type lookup/parsing mechanism is used while generating the output. | |
36 ;;; | |
37 ;;; Nomenclature: | |
38 ;;; | |
39 ;;; - variable names in this file are to be interpreted in the | |
40 ;;; C,c2ffi,json context, and 'cffi' is added to names that denote | |
41 ;;; the cffi name. | |
42 ;;; | |
43 ;;; Possible improvments: | |
44 ;;; | |
45 ;;; - generate an additional grovel file for C inline function | |
46 ;;; declarations found in header files | |
47 ;;; | |
48 ;;; - generate struct-by-value DEFCFUN's into a separate file so that | |
49 ;;; users can decide whether to depend on libffi, or they can make do | |
50 ;;; without those definitions | |
51 | |
52 (defvar *allow-pointer-type-simplification* t) | |
53 (defvar *allow-skipping-struct-fields* t) | |
54 (defvar *assume-struct-by-value-support* t) | |
55 ;; Called on the json name and may return a symbol to be used, or a stri… | |
56 (defvar *ffi-name-transformer* 'default-ffi-name-transformer) | |
57 ;; Called on the already transformed name to decide whether to export it | |
58 (defvar *ffi-name-export-predicate* 'default-ffi-name-export-predicate) | |
59 ;; Called on the CFFI type, e.g. to turn (:pointer :char) into a :string. | |
60 (defvar *ffi-type-transformer* 'default-ffi-type-transformer) | |
61 ;; May return up to two closures using VALUES. The first one will be cal… | |
62 ;; with each emitted form, and the second one once, at the end. They bot… | |
63 ;; return a list of forms that will be emitted using OUTPUT/CODE. | |
64 (defvar *callback-factory* 'default-callback-factory) | |
65 | |
66 (define-constant +generated-file-header+ | |
67 ";;; -*- Mode: lisp -*-~%~ | |
68 ;;;~%~ | |
69 ;;; This file has been automatically generated by cffi/c2ffi. Editi… | |
70 ;;;~%~%" | |
71 :test 'equal) | |
72 | |
73 (defvar *c2ffi-output-stream*) | |
74 | |
75 (defun output/export (names package) | |
76 (let ((names (uiop:ensure-list names))) | |
77 ;; Make sure we have something PRINT-READABLY as a package name, | |
78 ;; i.e. not a SIMPLE-BASE-STRING on SBCL. | |
79 (output/code `(export ',names ',(make-symbol (package-name package))… | |
80 | |
81 (defun output/code (form) | |
82 (check-type form cons) | |
83 (format *c2ffi-output-stream* "~&") | |
84 (write form | |
85 :stream *c2ffi-output-stream* | |
86 :circle t | |
87 :pretty t | |
88 :escape t | |
89 :readably t) | |
90 (format *c2ffi-output-stream* "~%~%") | |
91 (unless (member (first form) '(cffi:defcfun alexandria:define-constant… | |
92 (eval form))) | |
93 | |
94 (defun output/string (message-control &rest message-arguments) | |
95 (apply 'format *c2ffi-output-stream* message-control message-arguments… | |
96 | |
97 ;; NOTE: as per c2ffi json output. A notable difference to | |
98 ;; CFFI::*BUILT-IN-FOREIGN-TYPES* is the presence of :SIGNED-CHAR. | |
99 (define-constant +c-builtin-types+ '(":void" ":_Bool" ":char" ":signed-c… | |
100 ":unsigned-short" ":int" ":unsigned… | |
101 ":long-long" ":unsigned-long-long" … | |
102 :test 'equal) | |
103 | |
104 (define-condition unsupported-type (cffi::foreign-type-error) | |
105 ((json-definition :initarg :json-definition | |
106 :accessor json-definition-of))) | |
107 | |
108 (defun unsupported-type (json-entry) | |
109 (error 'unsupported-type :type-name nil :json-definition json-entry)) | |
110 | |
111 ;;;;;; | |
112 ;;; Utilities | |
113 | |
114 (defun compile-rules (rules) | |
115 (case rules | |
116 (:all rules) | |
117 (t (mapcar (lambda (pattern) | |
118 (check-type pattern string "Patterns in the inclusion/e… | |
119 (let ((scanner (cl-ppcre:create-scanner pattern))) | |
120 (named-lambda cffi/c2ffi/cl-ppcre-rule-matcher | |
121 (string) | |
122 (funcall scanner string 0 (length string))))) | |
123 rules)))) | |
124 | |
125 (defun include-definition? (name source-location | |
126 include-definitions exclude-definitions | |
127 include-sources exclude-sources) | |
128 (labels | |
129 ((covered-by-a-rule? (name rules) | |
130 (or (eq rules :all) | |
131 (not (null (some (rcurry #'funcall name) rules))))) | |
132 (weak? (rules) | |
133 (eq :all rules)) | |
134 (strong? (name rules) | |
135 (and name | |
136 (not (weak? rules)) | |
137 (covered-by-a-rule? name rules)))) | |
138 (let* ((excl-def/weak (weak? exclude-definitions)) | |
139 (excl-def/strong (strong? name exclude-definitions)) | |
140 (incl-def/weak (weak? include-definitions)) | |
141 (incl-def/strong (strong? name include-definitions)) | |
142 (excl-src/weak (weak? exclude-sources)) | |
143 (excl-src/strong (strong? source-location exclude-sources)) | |
144 (incl-src/weak (weak? include-sources)) | |
145 (incl-src/strong (strong? source-location include-sources)) | |
146 (incl/strong (or incl-def/strong | |
147 incl-src/strong)) | |
148 (excl/strong (or excl-def/strong | |
149 excl-src/strong)) | |
150 (incl/weak (or incl-def/weak | |
151 incl-src/weak)) | |
152 (excl/weak (or excl-def/weak | |
153 excl-src/weak))) | |
154 (or incl-def/strong | |
155 (and (not excl/strong) | |
156 (or incl/strong | |
157 (and incl/weak | |
158 ;; we want src exclude rules to be stronger | |
159 (not excl-src/weak)) | |
160 (not excl/weak))))))) | |
161 | |
162 (defun coerce-to-byte-size (bit-size) | |
163 (let ((byte-size (/ bit-size 8))) | |
164 (unless (integerp byte-size) | |
165 (error "Non-byte size encountered where it wasn't expected (~A bit… | |
166 byte-size)) | |
167 | |
168 (defmacro assume (condition &optional format-control &rest format-argume… | |
169 "Similar to ASSERT, but WARN's only." | |
170 `(unless ,condition | |
171 ,(if format-control | |
172 `(warn ,format-control ,@format-arguments) | |
173 `(warn "ASSUME failed: ~S" ',condition)))) | |
174 | |
175 (defun canonicalize-transformer-hook (hook) | |
176 (etypecase hook | |
177 ((and (or function symbol) | |
178 (not null)) | |
179 hook) | |
180 (string | |
181 (the symbol (safe-read-from-string hook))))) | |
182 | |
183 ;;;;;; | |
184 ;;; Json access | |
185 | |
186 (defun json-value (alist key &key (otherwise nil otherwise?)) | |
187 (check-type alist list) | |
188 (check-type key (and symbol (not null))) | |
189 (let* ((entry (assoc key alist)) | |
190 (result (cond | |
191 (entry | |
192 (cdr entry)) | |
193 (otherwise? | |
194 otherwise) | |
195 (t (error "Key ~S not found in json entry ~S." key al… | |
196 (if (equal result "") | |
197 nil | |
198 result))) | |
199 | |
200 (defmacro with-json-values ((json-entry &rest args) &body body) | |
201 (if (null args) | |
202 `(progn | |
203 ,@body) | |
204 (once-only (json-entry) | |
205 `(let (,@(loop | |
206 :for entry :in args | |
207 :collect (let* ((args (ensure-list entry)) | |
208 (name (pop args)) | |
209 (key (or (pop args) | |
210 (make-keyword (symbol-name n… | |
211 (destructuring-bind | |
212 ;; using &optional would trigger a w… | |
213 (&key (otherwise nil otherwise?)) | |
214 args | |
215 `(,name | |
216 (json-value ,json-entry ,key ,@(when o… | |
217 `… | |
218 ,@body)))) | |
219 | |
220 (defun expected-json-keys (alist &rest keys) | |
221 (let* ((keys (list* :location keys)) | |
222 (outliers (remove-if (lambda (el) | |
223 (member (car el) keys :test 'eq)) | |
224 alist))) | |
225 (when outliers | |
226 (warn "Unexpected key(s) in json entry ~S: ~S" alist outliers)))) | |
227 | |
228 ;;;;;; | |
229 ;;; Namespaces, names and conversions | |
230 | |
231 ;; an alist of (name . hashtable) | |
232 (defvar *generated-names*) | |
233 (defvar *anon-name-counter*) | |
234 (defvar *anon-entities*) | |
235 | |
236 (defun register-anon-entity (id name) | |
237 (check-type id integer) | |
238 (check-type name string) | |
239 (assert (not (zerop (length name)))) | |
240 (setf (gethash id *anon-entities*) name) | |
241 name) | |
242 | |
243 (defun lookup-anon-entity (id) | |
244 (or (gethash id *anon-entities*) | |
245 (error "Could not find anonymous entity with id ~S." id))) | |
246 | |
247 (defun generate-anon-name (base-name) | |
248 (format nil "~A" | |
249 (strcat (symbol-name base-name) | |
250 (princ-to-string (incf *anon-name-counter*))))) | |
251 | |
252 (defun valid-name-or-die (name) | |
253 ;; checks for valid json names (*not* CFFI names) | |
254 (etypecase name | |
255 (string | |
256 (assert (not (zerop (length name))))) | |
257 (cons | |
258 (assert (= 2 (length name))) | |
259 (assert (member (first name) '(:struct :union :enum))) | |
260 (valid-name-or-die (second name))))) | |
261 | |
262 (defun call-hook (hook &rest args) | |
263 (apply hook | |
264 ;; indiscriminately add one keyword arg entry to warn | |
265 (append args '(just-a-warning "Make sure your transformer hook … | |
266 | |
267 (defun find-cffi-type-or-die (type-name &optional (namespace :default)) | |
268 (when (eq namespace :enum) | |
269 ;; TODO FIXME this should be cleaned up in CFFI. more about namespac… | |
270 ;; https://bugs.launchpad.net/cffi/+bug/1527947 | |
271 (setf namespace :default)) | |
272 (cffi::find-type-parser type-name namespace)) | |
273 | |
274 (define-constant +name-kinds+ '(:struct :union :function :variable :type | |
275 :constant :field :argument :enum :member) | |
276 :test 'equal) | |
277 | |
278 (deftype ffi-name-kind () | |
279 '#.(list* 'member +name-kinds+)) | |
280 | |
281 (defun json-name-to-cffi-name (name kind &optional anonymous) | |
282 (check-type name string) | |
283 (check-type kind ffi-name-kind) | |
284 (when *ffi-name-transformer* | |
285 (setf name (call-hook *ffi-name-transformer* name kind)) | |
286 (unless (or (and (symbolp name) | |
287 (not (null name))) | |
288 (stringp name)) | |
289 (error "The FFI-NAME-TRANSFORMER ~S returned with ~S which is not … | |
290 *ffi-name-transformer* name))) | |
291 (let ((cffi-name (if (symbolp name) | |
292 name | |
293 (intern name)))) | |
294 (when (and (not anonymous) | |
295 (boundp '*generated-names*)) | |
296 ;; TODO FIXME this function also gets called for e.g. argument typ… | |
297 ;; if the function ends up *not* getting emitted, e.g. because of … | |
298 ;; we wrongly record here the missing type in the *generated-names… | |
299 (setf (gethash name (cdr (assoc kind *generated-names*))) | |
300 cffi-name)) | |
301 cffi-name)) | |
302 | |
303 (defun default-callback-factory (&key &allow-other-keys) | |
304 (values)) | |
305 | |
306 (defun default-ffi-name-transformer (name kind &key &allow-other-keys) | |
307 (check-type name string) | |
308 (case kind | |
309 #+nil | |
310 ((:constant :member) | |
311 (assert (not (symbolp name))) | |
312 (format nil "+~A+" name)) | |
313 (t name))) | |
314 | |
315 (defun change-case-to-readtable-case (name &optional (reatable *readtabl… | |
316 (ecase (readtable-case reatable) | |
317 (:upcase (string-upcase name)) | |
318 (:downcase (string-downcase name)) | |
319 (:preserve name) | |
320 ;; (:invert no, you don't) | |
321 )) | |
322 | |
323 (defun camelcased? (name) | |
324 (and (>= (length name) 3) | |
325 (let ((lower 0) | |
326 (upper 0)) | |
327 (loop | |
328 :for char :across name | |
329 :do (cond | |
330 ((upper-case-p char) | |
331 (incf upper)) | |
332 ((lower-case-p char) | |
333 (incf lower)))) | |
334 (unless (or (zerop lower) | |
335 (zerop upper)) | |
336 (let ((ratio (/ upper lower))) | |
337 (and (<= 0.05 ratio 0.5))))))) | |
338 | |
339 (defun camelcase-to-dash-separated (name) | |
340 (coerce (loop | |
341 :for char :across name | |
342 :for index :from 0 | |
343 :when (and (upper-case-p char) | |
344 (not (zerop index))) | |
345 :collect #\- | |
346 :collect (char-downcase char)) | |
347 'string)) | |
348 | |
349 (defun maybe-camelcase-to-dash-separated (name) | |
350 (if (camelcased? name) | |
351 (camelcase-to-dash-separated name) | |
352 name)) | |
353 | |
354 (defun default-ffi-name-export-predicate (symbol &key &allow-other-keys) | |
355 (declare (ignore symbol)) | |
356 nil) | |
357 | |
358 (defun default-ffi-type-transformer (type context &key &allow-other-keys) | |
359 (declare (ignore context)) | |
360 (cond | |
361 ((and (consp type) | |
362 (eq :pointer (first type))) | |
363 (let ((pointed-to-type (second type))) | |
364 (if (eq pointed-to-type :char) | |
365 :string | |
366 type))) | |
367 (t | |
368 type))) | |
369 | |
370 (defun function-pointer-type-name () | |
371 (symbolicate '#:function-pointer)) | |
372 | |
373 (defmacro with-allowed-foreign-type-errors ((on-failure-form &key (enabl… | |
374 (with-unique-names (type-block) | |
375 `(block ,type-block | |
376 (handler-bind | |
377 ((cffi::foreign-type-error | |
378 (lambda (_) | |
379 (declare (ignore _)) | |
380 (when ,enabled | |
381 (return-from ,type-block ,on-failure-form))))) | |
382 ,@body)))) | |
383 | |
384 (defun %json-type-to-cffi-type (json-entry) | |
385 (with-json-values (json-entry tag) | |
386 (let ((cffi-type | |
387 (cond | |
388 ((switch (tag :test 'equal) | |
389 (":void" :void) | |
390 (":_Bool" :bool) | |
391 ;; regarding :signed-char see https://stackoverflow.com/… | |
392 (":char" :char) | |
393 (":signed-char" :char) | |
394 (":unsigned-char" :unsigned-char) | |
395 (":short" :short) | |
396 (":unsigned-short" :unsigned-short) | |
397 (":int" :int) | |
398 (":unsigned-int" :unsigned-int) | |
399 (":long" :long) | |
400 (":unsigned-long" :unsigned-long) | |
401 (":long-long" :long-long) | |
402 (":unsigned-long-long" :unsigned-long-long) | |
403 (":float" :float) | |
404 (":double" :double) | |
405 ;; TODO FIXME | |
406 ;;(":long-double" :long-double) | |
407 ) | |
408 ;; return the result of the condition expression | |
409 ) | |
410 ((or (progn | |
411 (assert (not (member tag +c-builtin-types+ :test 'eq… | |
412 "Not all C basic types are covered! The outl… | |
413 nil) | |
414 (equal tag ":struct") | |
415 (equal tag ":union")) | |
416 ;; ":struct" is a "struct foo-struct var" kind of reference | |
417 (expected-json-keys json-entry :name :tag :id) | |
418 (with-json-values (json-entry name id) | |
419 (let* ((kind (if (equal tag ":struct") | |
420 :struct | |
421 :union)) | |
422 (cffi-name (if name | |
423 (json-name-to-cffi-name name kind) | |
424 (lookup-anon-entity id)))) | |
425 (find-cffi-type-or-die cffi-name kind) | |
426 `(,kind ,cffi-name)))) | |
427 ((or (equal tag "struct") | |
428 (equal tag "union")) | |
429 ;; "struct" denotes a "struct {} var", or "typedef struct … | |
430 ;; kind of inline anonymous declaration. Let's call PROCES… | |
431 ;; to emit it for us, and return with the generated name (… | |
432 ;; as if it was a standalone toplevel struct definition. | |
433 ;; TODO is it a problem that we don't invoke the CALLBACK-… | |
434 (let ((form (process-c2ffi-entry json-entry)) | |
435 (kind (if (equal tag "struct") | |
436 :struct | |
437 :union))) | |
438 (assert (and (consp form) | |
439 (member (first form) '(cffi:defcstruct cffi… | |
440 `(,kind ,(first (ensure-list (second form)))))) | |
441 ((equal tag ":enum") | |
442 ;; ":enum" is an "enum foo var" kind of reference | |
443 (expected-json-keys json-entry :name :tag :id) | |
444 (with-json-values (json-entry name id) | |
445 (let ((cffi-name (json-name-to-cffi-name (or name | |
446 (lookup-ano… | |
447 :enum))) | |
448 (find-cffi-type-or-die cffi-name :enum) | |
449 ;; TODO FIXME this would be the proper one, but CFFI i… | |
450 cffi-name))) | |
451 ((equal tag "enum") | |
452 ;; "enum" is an inline "typedef enum {m1, m2} var" kind of… | |
453 (expected-json-keys json-entry :name :tag :id) | |
454 ;; TODO FIXME similarly to struct, but it would be nice to… | |
455 (error "not yet implemented")) | |
456 ((equal tag ":array") | |
457 (expected-json-keys json-entry :tag :type :size) | |
458 (with-json-values (json-entry type size) | |
459 (check-type size integer) | |
460 `(:array ,(json-type-to-cffi-type type) ,size))) | |
461 ((equal tag ":pointer") | |
462 (expected-json-keys json-entry :tag :type :id) | |
463 (with-json-values (json-entry type) | |
464 `(:pointer ,(with-allowed-foreign-type-errors | |
465 (:void :enabled *allow-pointer-type-simp… | |
466 (json-type-to-cffi-type type))))) | |
467 ((equal tag ":function-pointer") | |
468 (expected-json-keys json-entry :tag) | |
469 (function-pointer-type-name)) | |
470 ((equal tag ":function") | |
471 (unsupported-type json-entry)) | |
472 (t | |
473 (assert (not (starts-with #\: tag))) | |
474 (let ((cffi-name (json-name-to-cffi-name tag :type))) | |
475 ;; TODO FIXME json-name-to-cffi-name collects the mentio… | |
476 ;; types to later emit +TYPE-NAMES+, but if this next | |
477 ;; find-cffi-type-or-die dies then the entire function is | |
478 ;; skipped. | |
479 (find-cffi-type-or-die cffi-name) | |
480 cffi-name))))) | |
481 (assert cffi-type () "Failed to map ~S to a cffi type" json-entry) | |
482 cffi-type))) | |
483 | |
484 (defun should-export-p (symbol) | |
485 (and symbol | |
486 (symbolp symbol) | |
487 (not (keywordp symbol)) | |
488 *ffi-name-export-predicate* | |
489 (call-hook *ffi-name-export-predicate* symbol))) | |
490 | |
491 (defun json-type-to-cffi-type (json-entry &optional (context nil context… | |
492 (let ((cffi-type (%json-type-to-cffi-type json-entry))) | |
493 (if context? | |
494 (call-hook *ffi-type-transformer* cffi-type context) | |
495 cffi-type))) | |
496 | |
497 ;;;;;; | |
498 ;;; Entry point, the "API" | |
499 | |
500 (defun process-c2ffi-spec-file (c2ffi-spec-file package-name | |
501 &key | |
502 (allow-pointer-type-simplification *al… | |
503 (allow-skipping-struct-fields *allow-s… | |
504 (assume-struct-by-value-support *assum… | |
505 ;; either a pathname or a string (will… | |
506 ;; or a function that will be funcall'… | |
507 ;; to emit a form (i.e. OUTPUT/CODE). | |
508 prelude | |
509 (output (make-pathname :name (strcat (… | |
510 :type "lisp" :d… | |
511 (output-encoding asdf:*default-encodin… | |
512 ;; The args following this point are m… | |
513 ;; component on the same name. | |
514 (ffi-name-transformer *ffi-name-transf… | |
515 (ffi-name-export-predicate *ffi-name-e… | |
516 ;; as per CFFI:DEFINE-FOREIGN-LIBRARY … | |
517 (ffi-type-transformer *ffi-type-transf… | |
518 (callback-factory *callback-factory*) | |
519 foreign-library-name | |
520 foreign-library-spec | |
521 (emit-generated-name-mappings t) | |
522 (include-sources :all) | |
523 exclude-sources | |
524 (include-definitions :all) | |
525 exclude-definitions) | |
526 "Generates a lisp file with CFFI definitions from C2FFI-SPEC-FILE. | |
527 PACKAGE-NAME will be overwritten, it assumes full control over the | |
528 target package." | |
529 (check-type c2ffi-spec-file (or pathname string)) | |
530 (macrolet ((@ (var) | |
531 `(setf ,var (compile-rules ,var)))) | |
532 (@ include-sources) | |
533 (@ exclude-sources) | |
534 (@ include-definitions) | |
535 (@ exclude-definitions)) | |
536 (with-standard-io-syntax | |
537 (with-input-from-file (in c2ffi-spec-file :external-format (asdf/dri… | |
538 (with-output-to-file (*c2ffi-output-stream* output :if-exists :sup… | |
539 :external-format (asdf/driver:encoding-exter… | |
540 (let* ((*package* (or (find-package package-name) | |
541 (make-package package-name))) | |
542 ;; Make sure we use an uninterned symbol, so that it's ne… | |
543 (package-name (make-symbol (package-name *package*))) | |
544 ;; Let's rebind a copy, so that when we are done with | |
545 ;; the generation (which also EVAL's the forms) then | |
546 ;; the CFFI type repository is also reverted back to | |
547 ;; the previous state. This avoids redefinition warning | |
548 ;; when the generated file gets compiled and loaded | |
549 ;; later. | |
550 (cffi::*type-parsers* (copy-hash-table cffi::*type-parser… | |
551 (*anon-name-counter* 0) | |
552 (*anon-entities* (make-hash-table)) | |
553 (*generated-names* (mapcar (lambda (key) | |
554 `(,key . ,(make-hash-table :… | |
555 +name-kinds+)) | |
556 (*allow-pointer-type-simplification* allow-pointer-type-s… | |
557 (*allow-skipping-struct-fields* allow-skipping-struct-fie… | |
558 (*assume-struct-by-value-support* assume-struct-by-value-… | |
559 (*ffi-name-transformer* (canonicalize-transformer-hook ff… | |
560 (*ffi-name-export-predicate* (canonicalize-transformer-ho… | |
561 (*ffi-type-transformer* (canonicalize-transformer-hook ff… | |
562 (*callback-factory* (canonicalize-transformer-hook callba… | |
563 (*read-default-float-format* 'double-float) | |
564 (json (json:decode-json in))) | |
565 (output/string +generated-file-header+) | |
566 ;; some forms that are always emitted | |
567 (mapc 'output/code | |
568 ;; Make sure the package exists. We don't even want to :… | |
569 ;; to avoid any possible name clashes. | |
570 `((uiop:define-package ,package-name (:use)) | |
571 (in-package ,package-name) | |
572 (cffi:defctype ,(function-pointer-type-name) :pointer)… | |
573 (when (and foreign-library-name | |
574 foreign-library-spec) | |
575 (when (stringp foreign-library-name) | |
576 (setf foreign-library-name (safe-read-from-string foreign-… | |
577 (output/code `(cffi:define-foreign-library ,foreign-library-… | |
578 ,@foreign-library-spec)) | |
579 ;; TODO: Unconditionally emitting a USE-FOREIGN-LIBRARY may … | |
580 ;; For details see: https://bugs.launchpad.net/cffi/+bug/159… | |
581 (output/code `(cffi:use-foreign-library ,foreign-library-nam… | |
582 (etypecase prelude | |
583 (null) | |
584 (string | |
585 (output/string prelude)) | |
586 (pathname | |
587 (with-input-from-file (prelude-stream prelude) | |
588 (alexandria:copy-stream prelude-stream *c2ffi-output-stre… | |
589 :element-type 'character))) | |
590 ((or symbol function) | |
591 (funcall prelude 'output/code))) | |
592 ;; | |
593 ;; Let's enumerate the entries | |
594 (multiple-value-bind (form-callback epilogue-callback) | |
595 (funcall *callback-factory*) | |
596 (dolist (json-entry json) | |
597 (with-json-values (json-entry name location) | |
598 (let ((source-location-file (subseq location | |
599 0 | |
600 (or (position #\: lo… | |
601 0)))) | |
602 (if (include-definition? | |
603 name source-location-file | |
604 include-definitions exclude-definitions | |
605 include-sources exclude-sources) | |
606 (progn | |
607 (output/string "~&~%;; ~S" location) | |
608 (let ((emitted-definition (process-c2ffi-entry j… | |
609 ;; | |
610 ;; Call the plugin to let the user emit a form… | |
611 ;; definition | |
612 (when (and emitted-definition | |
613 form-callback) | |
614 (map nil 'output/code (call-hook form-callba… | |
615 (output/string "~&;; Skipped ~S due to filters" na… | |
616 ;; | |
617 ;; Call the plugin to let the user append multiple forms aft… | |
618 ;; emitted definitions | |
619 (when epilogue-callback | |
620 (map nil 'output/code (call-hook epilogue-callback)))) | |
621 ;; | |
622 ;; emit optional exports | |
623 (maphash | |
624 (lambda (package-name symbols) | |
625 (output/export (sort (remove-if-not #'should-export-p symbo… | |
626 package-name)) | |
627 (get-all-names-by-package *generated-names*)) | |
628 | |
629 ;; | |
630 ;; emit optional mappings | |
631 (when emit-generated-name-mappings | |
632 (mapcar (lambda (entry) | |
633 (destructuring-bind (kind variable-name) entry | |
634 (output/code `(defparameter | |
635 ,(intern (symbol-name variable… | |
636 ',(hash-table-alist (cdr (assoc … | |
637 `((:function #:+function-names+) | |
638 (:struct #:+struct-names+) | |
639 (:union #:+union-names+) | |
640 (:variable #:+variable-names+) | |
641 (:type #:+type-names+) | |
642 (:constant #:+constant-names+) | |
643 (:argument #:+argument-names+) | |
644 (:field #:+field-names+)))))))) | |
645 output) | |
646 | |
647 (defun get-all-names-by-package (name-collection) | |
648 (let ((tables (mapcar #'cdr name-collection)) | |
649 all | |
650 (grouped (make-hash-table))) | |
651 (loop :for table :in tables :do | |
652 (loop :for s :being :the :hash-values :of table :do | |
653 (push s all))) | |
654 (remove-duplicates all :test #'eq) | |
655 (loop :for name :in all | |
656 :for package-name := (package-name (symbol-package name)) | |
657 :do (setf (gethash package-name grouped) | |
658 (cons name (gethash package-name grouped)))) | |
659 grouped)) | |
660 | |
661 ;;;;;; | |
662 ;;; Processors for various definitions | |
663 | |
664 (defvar *c2ffi-entry-processors* (make-hash-table :test 'equal)) | |
665 | |
666 (defun process-c2ffi-entry (json-entry) | |
667 (let* ((kind (json-value json-entry :tag)) | |
668 (processor (gethash kind *c2ffi-entry-processors*))) | |
669 (if processor | |
670 (let ((definition-form | |
671 (handler-bind | |
672 ((unsupported-type | |
673 (lambda (e) | |
674 (warn "Skip definition because cannot map ~S to a… | |
675 (json-definition-of e) json-entry) | |
676 (return-from process-c2ffi-entry (values)))) | |
677 (cffi::undefined-foreign-type-error | |
678 (lambda (e) | |
679 (output/string "~&;; Skipping definition ~S becau… | |
680 json-entry (cffi::foreign-type-err… | |
681 (return-from process-c2ffi-entry (values))))) | |
682 (funcall processor json-entry)))) | |
683 (when definition-form | |
684 (output/code definition-form) | |
685 definition-form)) | |
686 (progn | |
687 (warn "No cffi/c2ffi processor defined for ~A" json-entry) | |
688 (values))))) | |
689 | |
690 (defmacro define-processor (kind args &body body) | |
691 `(setf (gethash ,(string-downcase kind) *c2ffi-entry-processors*) | |
692 (named-lambda ,(symbolicate 'c2ffi-processor/ kind) (-json-entr… | |
693 (with-json-values (-json-entry- ,@args) | |
694 ,@body)))) | |
695 | |
696 (defun %process-struct-like (json-entry kind definer anon-base-name) | |
697 (expected-json-keys json-entry :tag :ns :name :id :bit-size :bit-align… | |
698 (with-json-values (json-entry tag (struct-name :name) fields bit-size … | |
699 (assert (member tag '(":struct" "struct" ":union" "union") :test 'eq… | |
700 (flet ((process-field (json-entry) | |
701 (with-json-values (json-entry (field-name :name) bit-offset… | |
702 (let ((cffi-type (with-allowed-foreign-type-errors | |
703 ('failed :enabled *allow-skipping-st… | |
704 (json-type-to-cffi-type type `(,kind ,… | |
705 (if (eq cffi-type 'failed) | |
706 (output/string "~&;; skipping field due to missing … | |
707 `(,(json-name-to-cffi-name field-name :field) | |
708 ,cffi-type | |
709 ,@(unless (eq kind :union) | |
710 `(:offset ,(coerce-to-byte-size bit-off… | |
711 `(,definer (,(json-name-to-cffi-name (or struct-name | |
712 (register-anon-entity | |
713 id | |
714 (generate-anon-name anon… | |
715 kind | |
716 (null struct-name)) | |
717 :size ,(coerce-to-byte-size bit-size)) | |
718 ,@(remove nil (mapcar #'process-field fields)))))) | |
719 | |
720 (define-processor struct () | |
721 (%process-struct-like -json-entry- :struct 'cffi:defcstruct '#:anon-st… | |
722 | |
723 (define-processor union () | |
724 (%process-struct-like -json-entry- :union 'cffi:defcunion '#:anon-unio… | |
725 | |
726 (define-processor typedef (name type) | |
727 (expected-json-keys -json-entry- :tag :name :ns :type) | |
728 `(cffi:defctype ,(json-name-to-cffi-name name :type) | |
729 ,(json-type-to-cffi-type type `(:typedef ,name)))) | |
730 | |
731 (define-processor function (return-type (function-name :name) parameters… | |
732 (declare (ignore storage-class)) | |
733 ;; TODO does storage-class matter for FFI accessibility? | |
734 #+nil | |
735 (assume (equal "extern" storage-class) | |
736 "Unexpected function STORAGE-CLASS: ~S for function ~S" storag… | |
737 (expected-json-keys -json-entry- :tag :name :return-type :parameters :… | |
738 (let ((uses-struct-by-value? nil)) | |
739 (flet ((process-arg (json-entry index) | |
740 (expected-json-keys json-entry :tag :name :type) | |
741 (with-json-values (json-entry tag (argument-name :name) typ… | |
742 (assert (equal tag "parameter")) | |
743 (let* ((cffi-type (json-type-to-cffi-type type `(:functio… | |
744 (canonicalized-type (cffi::canonicalize-foreign-ty… | |
745 (when (and (consp canonicalized-type) | |
746 (member (first canonicalized-type) '(:struct… | |
747 (setf uses-struct-by-value? t)) | |
748 `(,(if argument-name | |
749 (json-name-to-cffi-name argument-name :argument) | |
750 (symbolicate '#:arg (princ-to-string index))) | |
751 ,cffi-type))))) | |
752 (let ((cffi-args (loop | |
753 :for arg :in parameters | |
754 :for index :upfrom 1 | |
755 :collect (process-arg arg index)))) | |
756 (cond | |
757 ((and uses-struct-by-value? | |
758 (not *assume-struct-by-value-support*)) | |
759 (values)) | |
760 (inline | |
761 ;; TODO inline functions should go into a separate grovel fil… | |
762 (output/string "~&;; Skipping inline function ~S" function-na… | |
763 (values)) | |
764 (t `(cffi:defcfun (,function-name ,(json-name-to-cffi-name fun… | |
765 ,(json-type-to-cffi-type return-type `(:function ,func… | |
766 ,@(append cffi-args | |
767 (when variadic | |
768 '(&rest)))))))))) | |
769 | |
770 (define-processor extern (name type) | |
771 (expected-json-keys -json-entry- :tag :name :type) | |
772 `(cffi:defcvar (,name ,(json-name-to-cffi-name name :variable)) | |
773 ,(json-type-to-cffi-type type `(:variable ,name)))) | |
774 | |
775 ;; ((TAG . enum) (NS . 0) (NAME . ) (ID . 3) (LOCATION . /usr/include/bi… | |
776 (define-processor enum (name fields id) | |
777 (let ((bitmasks 0) | |
778 (non-bitmasks 0)) | |
779 (labels | |
780 ((for-bitmask-statistics (name value) | |
781 (declare (ignore name)) | |
782 (if (cffi::single-bit-p value) | |
783 (incf bitmasks) | |
784 (incf non-bitmasks))) | |
785 (for-enum-body (name value) | |
786 `(,(json-name-to-cffi-name name :member) | |
787 ,value)) | |
788 (process-fields (visitor) | |
789 (loop | |
790 :for json-entry :in fields | |
791 :do (expected-json-keys json-entry :tag :name :value) | |
792 :collect | |
793 (with-json-values (json-entry tag name value) | |
794 (assert (equal tag "field")) | |
795 (check-type value integer) | |
796 (funcall visitor name value))))) | |
797 (process-fields #'for-bitmask-statistics) | |
798 `(,(if (> (/ bitmasks | |
799 (+ non-bitmasks bitmasks)) | |
800 0.8) | |
801 'cffi:defbitfield | |
802 'cffi:defcenum) | |
803 ,(json-name-to-cffi-name (or name | |
804 (register-anon-entity | |
805 id | |
806 (generate-anon-name '#:anon-enu… | |
807 :enum | |
808 (null name)) | |
809 ,@(process-fields #'for-enum-body))))) | |
810 | |
811 (defun make-define-constant-form (name value) | |
812 (valid-name-or-die name) | |
813 (let ((test-fn (typecase value | |
814 (number) | |
815 (t 'equal)))) | |
816 `(alexandria:define-constant ,(json-name-to-cffi-name name :constant) | |
817 ,value ,@(when test-fn `(:test ',test-fn))))) | |
818 | |
819 (define-processor const (name type (value :value :otherwise nil)) | |
820 (expected-json-keys -json-entry- :tag :name :type :value :ns) | |
821 (let ((cffi-type (json-type-to-cffi-type type `(:contant ,name)))) | |
822 (cond | |
823 ((not value) | |
824 ;; #define __FOO_H and friends... just ignore them. | |
825 (values)) | |
826 ((and (member cffi-type '(:int :unsigned-int | |
827 :long :unsigned-long | |
828 :long-long :unsigned-long-long)) | |
829 (integerp value)) | |
830 (make-define-constant-form name value)) | |
831 ((and (member cffi-type '(:float :double)) | |
832 (floatp value)) | |
833 (make-define-constant-form name value)) | |
834 ((member cffi-type '(:string (:pointer :char)) :test 'equal) | |
835 (make-define-constant-form name value)) | |
836 (t | |
837 (warn "Don't know how to emit a constant of CFFI type ~S, with va… | |
838 (values))))) |