generator.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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 <attila@lendvai.name>
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 string.
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 called
62 ;; with each emitted form, and the second one once, at the end. They both may
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. Editing it by hand is not wise.~%~
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) :test 'eq)
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-char" ":unsigned-char" ":short"
100 ":unsigned-short" ":int" ":unsigned-int" ":long" ":unsigned-long"
101 ":long-long" ":unsigned-long-long" ":float" ":double" ":long-double")
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/exclusion rules must be strings.")
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 bits)" bit-size))
166 byte-size))
167
168 (defmacro assume (condition &optional format-control &rest format-arguments)
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 alist)))))
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 name)))))
211 (destructuring-bind
212 ;; using &optional would trigger a warning (on SBCL)
213 (&key (otherwise nil otherwise?))
214 args
215 `(,name
216 (json-value ,json-entry ,key ,@(when otherwise?
217 `(:otherwise ,otherwise))))))))
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 has &key &allow-other-keys for future extendability."))))
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 namespace confusion at:
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 a valid name."
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 types of a function. and
297 ;; if the function ends up *not* getting emitted, e.g. because of a missing type, then
298 ;; we wrongly record here the missing type in the *generated-names* registry.
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 *readtable*))
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 (enabled t)) &body body)
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/questions/436513/char-signed-char-char-unsigned-char
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 'equal)) ()
412 "Not all C basic types are covered! The outlier is: ~S" tag)
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 {} my_type"
430 ;; kind of inline anonymous declaration. Let's call PROCESS-C2FFI-ENTRY
431 ;; to emit it for us, and return with the generated name (first value)
432 ;; as if it was a standalone toplevel struct definition.
433 ;; TODO is it a problem that we don't invoke the CALLBACK-FACTORY stuff here?
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:defcunion))))
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-anon-entity id))
447 :enum)))
448 (find-cffi-type-or-die cffi-name :enum)
449 ;; TODO FIXME this would be the proper one, but CFFI is broken: `(:enum ,cffi-name)
450 cffi-name)))
451 ((equal tag "enum")
452 ;; "enum" is an inline "typedef enum {m1, m2} var" kind of inline declaration
453 (expected-json-keys json-entry :name :tag :id)
454 ;; TODO FIXME similarly to struct, but it would be nice to see an example
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-simplification*)
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 mentioned
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 *allow-pointer-type-simplification*)
503 (allow-skipping-struct-fields *allow-skipping-struct-fields*)
504 (assume-struct-by-value-support *assume-struct-by-value-support*)
505 ;; either a pathname or a string (will be copied as is),
506 ;; or a function that will be funcall'd with one argument
507 ;; to emit a form (i.e. OUTPUT/CODE).
508 prelude
509 (output (make-pathname :name (strcat (pathname-name c2ffi-spec-file) ".cffi-tmp")
510 :type "lisp" :defaults c2ffi-spec-file))
511 (output-encoding asdf:*default-encoding*)
512 ;; The args following this point are mirrored in the ASDF
513 ;; component on the same name.
514 (ffi-name-transformer *ffi-name-transformer*)
515 (ffi-name-export-predicate *ffi-name-export-predicate*)
516 ;; as per CFFI:DEFINE-FOREIGN-LIBRARY and CFFI:LOAD-FOREIGN-LIBRARY
517 (ffi-type-transformer *ffi-type-transformer*)
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/driver:encoding-external-format :utf-8))
538 (with-output-to-file (*c2ffi-output-stream* output :if-exists :supersede
539 :external-format (asdf/driver:encoding-external-format output-encoding))
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 neutral to READTABLE-CASE.
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-parsers*))
551 (*anon-name-counter* 0)
552 (*anon-entities* (make-hash-table))
553 (*generated-names* (mapcar (lambda (key)
554 `(,key . ,(make-hash-table :test 'equal)))
555 +name-kinds+))
556 (*allow-pointer-type-simplification* allow-pointer-type-simplification)
557 (*allow-skipping-struct-fields* allow-skipping-struct-fields)
558 (*assume-struct-by-value-support* assume-struct-by-value-support)
559 (*ffi-name-transformer* (canonicalize-transformer-hook ffi-name-transformer))
560 (*ffi-name-export-predicate* (canonicalize-transformer-hook ffi-name-export-predicate))
561 (*ffi-type-transformer* (canonicalize-transformer-hook ffi-type-transformer))
562 (*callback-factory* (canonicalize-transformer-hook callback-factory))
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 :use COMMON-LISP here,
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-library-name)))
577 (output/code `(cffi:define-foreign-library ,foreign-library-name
578 ,@foreign-library-spec))
579 ;; TODO: Unconditionally emitting a USE-FOREIGN-LIBRARY may not be smart.
580 ;; For details see: https://bugs.launchpad.net/cffi/+bug/1593635
581 (output/code `(cffi:use-foreign-library ,foreign-library-name)))
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-stream*
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 #\: location)
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 json-entry)))
609 ;;
610 ;; Call the plugin to let the user emit a form after the given
611 ;; definition
612 (when (and emitted-definition
613 form-callback)
614 (map nil 'output/code (call-hook form-callback emitted-definition)))))
615 (output/string "~&;; Skipped ~S due to filters" name)))))
616 ;;
617 ;; Call the plugin to let the user append multiple forms after the
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 symbols) #'string<)
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-name))
636 ',(hash-table-alist (cdr (assoc kind *generated-names*)))))))
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 any CFFI type. The definition is ~S"
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 because of missing type ~S"
680 json-entry (cffi::foreign-type-error/compound-name e))
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-entry-)
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-alignment :fields)
698 (with-json-values (json-entry tag (struct-name :name) fields bit-size id)
699 (assert (member tag '(":struct" "struct" ":union" "union") :test 'equal))
700 (flet ((process-field (json-entry)
701 (with-json-values (json-entry (field-name :name) bit-offset type)
702 (let ((cffi-type (with-allowed-foreign-type-errors
703 ('failed :enabled *allow-skipping-struct-fields*)
704 (json-type-to-cffi-type type `(,kind ,struct-name ,field-name)))))
705 (if (eq cffi-type 'failed)
706 (output/string "~&;; skipping field due to missing type ~S, full json entry: ~S" type json-entry)
707 `(,(json-name-to-cffi-name field-name :field)
708 ,cffi-type
709 ,@(unless (eq kind :union)
710 `(:offset ,(coerce-to-byte-size bit-offset)))))))))
711 `(,definer (,(json-name-to-cffi-name (or struct-name
712 (register-anon-entity
713 id
714 (generate-anon-name anon-base-name)))
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-struct-))
722
723 (define-processor union ()
724 (%process-struct-like -json-entry- :union 'cffi:defcunion '#:anon-union-))
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 inline variadic storage-class)
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" storage-class function-name)
737 (expected-json-keys -json-entry- :tag :name :return-type :parameters :variadic :inline :storage-class :ns)
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) type)
742 (assert (equal tag "parameter"))
743 (let* ((cffi-type (json-type-to-cffi-type type `(:function ,function-name ,argument-name)))
744 (canonicalized-type (cffi::canonicalize-foreign-type cffi-type)))
745 (when (and (consp canonicalized-type)
746 (member (first canonicalized-type) '(:struct :union)))
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 file?
762 (output/string "~&;; Skipping inline function ~S" function-name)
763 (values))
764 (t `(cffi:defcfun (,function-name ,(json-name-to-cffi-name function-name :function))
765 ,(json-type-to-cffi-type return-type `(:function ,function-name :return-type))
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/bits/confname.h:24:1) (FIELDS ((TAG . field) (NAME . _PC_LINK_MAX) (VALUE . 0)) ((TAG . field) (NAME . _PC_MAX_CANON) (VALUE . 1)) ((TAG . field) (NAME . _PC_MAX_INPUT) (VALUE . 2)) ((TAG . field) (NAME . _PC_NAME_MAX) (VALUE . 3)) ((TAG . field) (NAME . _PC_PATH_MAX) (VALUE . 4)) ((TAG . field) (NAME . _PC_PIPE_BUF) (VALUE . 5)) ((TAG . field) (NAME . _PC_CHOWN_RESTRICTED) (VALUE . 6)) ((TAG . field) (NAME . _PC_NO_TRUNC) (VALUE . 7)) ((TAG . field) (NAME . _PC_VDISABLE) (VALUE . 8)) ((TAG . field) (NAME . _PC_SYNC_IO) (VALUE . 9)) ((TAG . field) (NAME . _PC_ASYNC_IO) (VALUE . 10)) ((TAG . field) (NAME . _PC_PRIO_IO) (VALUE . 11)) ((TAG . field) (NAME . _PC_SOCK_MAXBUF) (VALUE . 12)) ((TAG . field) (NAME . _PC_FILESIZEBITS) (VALUE . 13)) ((TAG . field) (NAME . _PC_REC_INCR_XFER_SIZE) (VALUE . 14)) ((TAG . field) (NAME . _PC_REC_MAX_XFER_SIZE) (VALUE . 15)) ((TAG . field) (NAME . _PC_REC_MIN_XFER_SIZE) (VALUE . 16)) ((TAG . field) (NAME . _PC_REC_XFER_ALIGN) (VALUE . 17)) ((TAG . field) (NAME . _PC_ALLOC_SIZE_MIN) (VALUE . 18)) ((TAG . field) (NAME . _PC_SYMLINK_MAX) (VALUE . 19)) ((TAG . field) (NAME . _PC_2_SYMLINKS) (VALUE . 20))))
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-enum-)))
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 value ~S (json type is ~S)." cffi-type value type)
838 (values)))))