GopherProxy

	tgenerator.lisp - clic - Clic is an command line interactive client for gopher …
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tgenerator.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)))))