ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Tmux etc

Browse source
This commit is contained in:
Ian Keane 2020-02-18 14:21:14 -05:00
parent 276853ba84
commit 1cb167b597
361 changed files with 77302 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

211
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/c2ffi/asdf.lisp Normal file
View file

@ -0,0 +1,211 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; asdf.lisp --- ASDF components for cffi/c2ffi.
;;;
;;; Copyright (C) 2015, Attila Lendvai <attila@lendvai.name>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi/c2ffi)
(defclass c2ffi-file (cl-source-file)
((package :initarg :package
:initform nil
:accessor c2ffi-file/package)
(c2ffi-executable :initarg :c2ffi-executable
:accessor c2ffi-file/c2ffi-executable)
(trace-c2ffi :initarg :trace-c2ffi
:accessor c2ffi-file/trace-c2ffi)
(prelude :initform nil
:initarg :prelude
:accessor c2ffi-file/prelude)
(sys-include-paths :initarg :sys-include-paths
:initform nil
:accessor c2ffi-file/sys-include-paths)
(exclude-archs :initarg :exclude-archs
:initform nil
:accessor c2ffi-file/exclude-archs)
;; The following slots correspond to an arg of the same name for
;; the generator function. No accessors are needed, they just hold
;; the data until it gets delegated to the generator function using
;; SLOT-VALUE and a LOOP.
(ffi-name-transformer :initarg :ffi-name-transformer
:initform 'default-ffi-name-transformer)
(ffi-name-export-predicate :initarg :ffi-name-export-predicate
:initform 'default-ffi-name-export-predicate)
(ffi-type-transformer :initarg :ffi-type-transformer
:initform 'default-ffi-type-transformer)
(callback-factory :initarg :callback-factory
:initform 'default-callback-factory)
(foreign-library-name :initarg :foreign-library-name
:initform nil)
(foreign-library-spec :initarg :foreign-library-spec
:initform nil)
(emit-generated-name-mappings :initarg :emit-generated-name-mappings
:initform :t)
(include-sources :initarg :include-sources
:initform :all)
(exclude-sources :initarg :exclude-sources
:initform nil)
(include-definitions :initarg :include-definitions
:initform :all)
(exclude-definitions :initarg :exclude-definitions
:initform nil))
(:default-initargs
:type nil)
(:documentation
"The input of this ASDF component is a C header file and the configuration for
the binding generation process. This header file will define the initial scope of
the generation process, which can be further filtered by other configuration
parameters.
A clang/llvm based external program called 'c2ffi' is used to process this header
file and generate a json spec file for each supported architecture triplet. Normally
these .spec files are only (re)generated by the author of the lib and are checked into
the corresponding source repository. It needs to be done manually by invoking the
following command:
(cffi/c2ffi:generate-spec :your-system)
which is a shorthand for:
(asdf:operate 'cffi/c2ffi::generate-spec-op :your-system)
The generation of the underlying platform's json file must succeed, but the
generation for the other arch's is allowed to fail
\(see ENSURE-SPEC-FILE-IS-UP-TO-DATE for details).
During the normal build process the json file is used as the input to generate
a lisp file containing the CFFI definitions (see PROCESS-C2FFI-SPEC-FILE).
This file will be placed next to the .spec file, and will be compiled as any
other lisp file. This process requires loading the ASDF system called
\"cffi/c2ffi-generator\" that has more dependencies than CFFI itself. If you
want to avoid those extra dependencies in your project, then you can check in
these generated lisp files into your source repository, but keep in mind that
you'll need to manually force their regeneration if CFFI/C2FFI itself gets
updated (by e.g. deleting them from the filesystem) ."))
(defun input-file (operation component)
(let ((files (input-files operation component)))
(assert (length=n-p files 1))
(first files)))
(defclass generate-spec-op (downward-operation)
())
(defun generate-spec (system)
(asdf:operate 'generate-spec-op system))
(defmethod input-files ((op generate-spec-op) (c c2ffi-file))
(list (component-pathname c)))
(defmethod component-depends-on ((op generate-spec-op) (c c2ffi-file))
`((prepare-op ,c) ,@(call-next-method)))
(defmethod output-files ((op generate-spec-op) (c c2ffi-file))
(let* ((input-file (input-file op c))
(spec-file (spec-path input-file)))
(values
(list spec-file)
;; Tell ASDF not to apply output translation.
t)))
(defmethod perform ((op generate-spec-op) (c asdf:component))
(values))
(defmethod perform ((op generate-spec-op) (c c2ffi-file))
(let ((input-file (input-file op c))
(*c2ffi-executable* (if (slot-boundp c 'c2ffi-executable)
(c2ffi-file/c2ffi-executable c)
*c2ffi-executable*))
(*trace-c2ffi* (if (slot-boundp c 'trace-c2ffi)
(c2ffi-file/trace-c2ffi c)
*trace-c2ffi*)))
;; NOTE: we don't call OUTPUT-FILE here, which may be a violation
;; of the ASDF contract, that promises that OUTPUT-FILE can be
;; customized by users.
(ensure-spec-file-is-up-to-date
input-file
:exclude-archs (c2ffi-file/exclude-archs c)
:sys-include-paths (c2ffi-file/sys-include-paths c))))
(defclass generate-lisp-op (downward-operation)
())
(defmethod component-depends-on ((op generate-lisp-op) (c c2ffi-file))
`((load-op ,(find-system "cffi/c2ffi-generator"))
,@(call-next-method)))
(defmethod component-depends-on ((op compile-op) (c c2ffi-file))
`((generate-lisp-op ,c) ,@(call-next-method)))
(defmethod component-depends-on ((op load-source-op) (c c2ffi-file))
`((generate-lisp-op ,c) ,@(call-next-method)))
(defmethod input-files ((op generate-lisp-op) (c c2ffi-file))
(list (output-file 'generate-spec-op c)))
(defmethod input-files ((op compile-op) (c c2ffi-file))
(list (output-file 'generate-lisp-op c)))
(defmethod output-files ((op generate-lisp-op) (c c2ffi-file))
(let* ((spec-file (input-file op c))
(generated-lisp-file (make-pathname :type "lisp"
:defaults spec-file)))
(values
(list generated-lisp-file)
;; Tell ASDF not to apply output translation.
t)))
(defmethod perform ((op generate-lisp-op) (c c2ffi-file))
(let ((spec-file (input-file op c))
(generated-lisp-file (output-file op c)))
(with-staging-pathname (tmp-output generated-lisp-file)
(format *debug-io* "~&; CFFI/C2FFI is generating the file ~S~%" generated-lisp-file)
(apply 'process-c2ffi-spec-file
spec-file (c2ffi-file/package c)
:output tmp-output
:output-encoding (asdf:component-encoding c)
:prelude (let ((prelude (c2ffi-file/prelude c)))
(if (and (pathnamep prelude)
(not (absolute-pathname-p prelude)))
(merge-pathnames* prelude (component-pathname c))
prelude))
;; The following slots and keyword args have the same name in the ASDF
;; component and in PROCESS-C2FFI-SPEC-FILE, and this loop copies them.
(loop
:for arg :in '(ffi-name-transformer
ffi-name-export-predicate
ffi-type-transformer
callback-factory
foreign-library-name
foreign-library-spec
emit-generated-name-mappings
include-sources
exclude-sources
include-definitions
exclude-definitions)
:append (list (make-keyword arg)
(slot-value c arg)))))))
;; Allow for naked :cffi/c2ffi-file in asdf definitions.
(setf (find-class 'asdf::cffi/c2ffi-file) (find-class 'c2ffi-file))

194
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/c2ffi/c2ffi.lisp Normal file
View file

@ -0,0 +1,194 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; c2ffi.lisp --- c2ffi related code
;;;
;;; Copyright (C) 2013, Ryan Pavlik <rpavlik@gmail.com>
;;; Copyright (C) 2015, Attila Lendvai <attila@lendvai.name>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi/c2ffi)
;;; NOTE: Most of this has been taken over from cl-autowrap.
;;; Note this is rather untested and not very extensive at the moment;
;;; it should probably work on linux/win/osx though. Patches welcome.
(defun local-cpu ()
#+x86-64 "x86_64"
#+(and (not (or x86-64 freebsd)) x86) "i686"
#+(and (not x86-64) x86 freebsd) "i386"
#+arm "arm")
(defun local-vendor ()
#+(or linux windows) "-pc"
#+darwin "-apple"
#+(not (or linux windows darwin)) "-unknown")
(defun local-os ()
#+linux "-linux"
#+windows "-windows-msvc"
#+darwin "-darwin9"
#+freebsd "-freebsd")
(defun local-environment ()
#+linux "-gnu"
#-linux "")
(defun local-arch ()
(strcat (local-cpu) (local-vendor) (local-os) (local-environment)))
(defparameter *known-archs*
'("i686-pc-linux-gnu"
"x86_64-pc-linux-gnu"
"i686-pc-windows-msvc"
"x86_64-pc-windows-msvc"
"i686-apple-darwin9"
"x86_64-apple-darwin9"
"i386-unknown-freebsd"
"x86_64-unknown-freebsd"))
(defvar *c2ffi-executable* "c2ffi")
(defvar *trace-c2ffi* nil)
(defun c2ffi-executable-available? ()
;; This is a hack to determine if c2ffi exists; it assumes if it
;; doesn't exist, we will get a return code other than 0.
(zerop (nth-value 2 (uiop:run-program `(,*c2ffi-executable* "-h")
:ignore-error-status t))))
(defun run-program* (program args &key (output (if *trace-c2ffi* *standard-output* nil))
(error-output (if *trace-c2ffi* *error-output* nil))
ignore-error-status)
(when *trace-c2ffi*
(format *debug-io* "~&; Invoking: ~A~{ ~A~}~%" program args))
(zerop (nth-value 2 (uiop:run-program (list* program args) :output output
:error-output error-output
:ignore-error-status ignore-error-status))))
(defun generate-spec-with-c2ffi (input-header-file output-spec-path
&key arch sys-include-paths ignore-error-status)
"Run c2ffi on `INPUT-HEADER-FILE`, outputting to `OUTPUT-FILE` and
`MACRO-OUTPUT-FILE`, optionally specifying a target triple `ARCH`."
(uiop:with-temporary-file (:pathname tmp-macro-file
:keep *trace-c2ffi*)
nil ; workaround for an UIOP bug; delme eventually (attila, 2016-01-27).
:close-stream
(let* ((arch (when arch (list "--arch" arch)))
(sys-include-paths (loop
:for dir :in sys-include-paths
:append (list "--sys-include" dir))))
;; Invoke c2ffi to first emit C #define's into TMP-MACRO-FILE. We ask c2ffi
;; to first generate a file of C global variables that are assigned the
;; value of the corresponding #define's, so that in the second pass below
;; the C compiler evaluates for us their right hand side and thus we can
;; get hold of their value. This is a kludge and eventually we could/should
;; support generating cffi-grovel files, and in grovel mode not rely
;; on this kludge anymore.
(when (run-program* *c2ffi-executable* (list* (namestring input-header-file)
"--driver" "null"
"--macro-file" (namestring tmp-macro-file)
(append arch sys-include-paths))
:output *standard-output*
:ignore-error-status ignore-error-status)
;; Write a tmp header file that #include's the original input file and
;; the above generated macros file which will form the input for our
;; final, second pass.
(uiop:with-temporary-file (:stream tmp-include-file-stream
:pathname tmp-include-file
:keep *trace-c2ffi*)
(format tmp-include-file-stream "#include \"~A\"~%" input-header-file)
(format tmp-include-file-stream "#include \"~A\"~%" tmp-macro-file)
:close-stream
;; Invoke c2ffi again to generate the final output.
(run-program* *c2ffi-executable* (list* (namestring tmp-include-file)
"--output" (namestring output-spec-path)
(append arch sys-include-paths))
:output *standard-output*
:ignore-error-status ignore-error-status))))))
(defun spec-path (base-name &key version (arch (local-arch)))
(check-type base-name pathname)
(make-pathname :defaults base-name
:name (strcat (pathname-name base-name)
(if version
(strcat "-" version)
"")
"."
arch)
:type "spec"))
(defun find-local-spec (base-name &optional (errorp t))
(let* ((spec-path (spec-path base-name))
(probed (probe-file spec-path)))
(if probed
spec-path
(when errorp
(error "c2ffi spec file not found for base name ~S" base-name)))))
(defun ensure-spec-file-is-up-to-date (header-file-path
&key exclude-archs sys-include-paths version)
(let ((spec-path (find-local-spec header-file-path nil)))
(flet ((regenerate-spec-file ()
(let ((local-arch (local-arch)))
(unless (c2ffi-executable-available?)
(error "No spec found for ~S on arch '~A' and c2ffi not found"
header-file-path local-arch))
(generate-spec-with-c2ffi header-file-path
(spec-path header-file-path
:arch local-arch
:version version)
:arch local-arch
:sys-include-paths sys-include-paths)
;; Try to run c2ffi for other architectures, but tolerate failure
(dolist (arch *known-archs*)
(unless (or (string= local-arch arch)
(member arch exclude-archs :test #'string=))
(unless (generate-spec-with-c2ffi header-file-path
(spec-path header-file-path
:arch arch
:version version)
:arch arch
:sys-include-paths sys-include-paths
:ignore-error-status t)
(warn "Failed to generate spec for other arch: ~S" arch))))
(find-local-spec header-file-path))))
(if (and spec-path
(uiop:timestamp< (file-write-date header-file-path)
(file-write-date spec-path)))
spec-path ; it's up to date, just return it as is
(restart-case
(regenerate-spec-file)
(touch-old-copy ()
:report (lambda (stream)
(format stream "Update the modification time of the out-of-date copy ~S" spec-path))
;; Make it only be visible when the spec file exists (but it's out of date)
:test (lambda (condition)
(declare (ignore condition))
(not (null spec-path)))
;; Update the last modification time. Yes, it's convoluted and wasteful,
;; but I can't see any other way.
(with-staging-pathname (tmp-file spec-path)
(copy-file spec-path tmp-file))
;; The return value of RESTART-CASE
spec-path))))))

838
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/c2ffi/generator.lisp Normal file
View file

@ -0,0 +1,838 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; generator.lisp --- Generate CFFI bindings for a c2ffi output.
;;;
;;; Copyright (C) 2015, Attila Lendvai <attila@lendvai.name>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi/c2ffi)
;;; Output generation happens in one phase, straight into the output
;;; stream. There's minimal look-ahead (for source-location and name)
;;; which is needed to apply user specified filters in time.
;;;
;;; Each CFFI form is also EVAL'd during generation because the CFFI
;;; type lookup/parsing mechanism is used while generating the output.
;;;
;;; Nomenclature:
;;;
;;; - variable names in this file are to be interpreted in the
;;; C,c2ffi,json context, and 'cffi' is added to names that denote
;;; the cffi name.
;;;
;;; Possible improvments:
;;;
;;; - generate an additional grovel file for C inline function
;;; declarations found in header files
;;;
;;; - generate struct-by-value DEFCFUN's into a separate file so that
;;; users can decide whether to depend on libffi, or they can make do
;;; without those definitions
(defvar *allow-pointer-type-simplification* t)
(defvar *allow-skipping-struct-fields* t)
(defvar *assume-struct-by-value-support* t)
;; Called on the json name and may return a symbol to be used, or a string.
(defvar *ffi-name-transformer* 'default-ffi-name-transformer)
;; Called on the already transformed name to decide whether to export it
(defvar *ffi-name-export-predicate* 'default-ffi-name-export-predicate)
;; Called on the CFFI type, e.g. to turn (:pointer :char) into a :string.
(defvar *ffi-type-transformer* 'default-ffi-type-transformer)
;; May return up to two closures using VALUES. The first one will be called
;; with each emitted form, and the second one once, at the end. They both may
;; return a list of forms that will be emitted using OUTPUT/CODE.
(defvar *callback-factory* 'default-callback-factory)
(define-constant +generated-file-header+
";;; -*- Mode: lisp -*-~%~
;;;~%~
;;; This file has been automatically generated by cffi/c2ffi. Editing it by hand is not wise.~%~
;;;~%~%"
:test 'equal)
(defvar *c2ffi-output-stream*)
(defun output/export (names package)
(let ((names (uiop:ensure-list names)))
;; Make sure we have something PRINT-READABLY as a package name,
;; i.e. not a SIMPLE-BASE-STRING on SBCL.
(output/code `(export ',names ',(make-symbol (package-name package))))))
(defun output/code (form)
(check-type form cons)
(format *c2ffi-output-stream* "~&")
(write form
:stream *c2ffi-output-stream*
:circle t
:pretty t
:escape t
:readably t)
(format *c2ffi-output-stream* "~%~%")
(unless (member (first form) '(cffi:defcfun alexandria:define-constant) :test 'eq)
(eval form)))
(defun output/string (message-control &rest message-arguments)
(apply 'format *c2ffi-output-stream* message-control message-arguments))
;; NOTE: as per c2ffi json output. A notable difference to
;; CFFI::*BUILT-IN-FOREIGN-TYPES* is the presence of :SIGNED-CHAR.
(define-constant +c-builtin-types+ '(":void" ":_Bool" ":char" ":signed-char" ":unsigned-char" ":short"
":unsigned-short" ":int" ":unsigned-int" ":long" ":unsigned-long"
":long-long" ":unsigned-long-long" ":float" ":double" ":long-double")
:test 'equal)
(define-condition unsupported-type (cffi::foreign-type-error)
((json-definition :initarg :json-definition
:accessor json-definition-of)))
(defun unsupported-type (json-entry)
(error 'unsupported-type :type-name nil :json-definition json-entry))
;;;;;;
;;; Utilities
(defun compile-rules (rules)
(case rules
(:all rules)
(t (mapcar (lambda (pattern)
(check-type pattern string "Patterns in the inclusion/exclusion rules must be strings.")
(let ((scanner (cl-ppcre:create-scanner pattern)))
(named-lambda cffi/c2ffi/cl-ppcre-rule-matcher
(string)
(funcall scanner string 0 (length string)))))
rules))))
(defun include-definition? (name source-location
include-definitions exclude-definitions
include-sources exclude-sources)
(labels
((covered-by-a-rule? (name rules)
(or (eq rules :all)
(not (null (some (rcurry #'funcall name) rules)))))
(weak? (rules)
(eq :all rules))
(strong? (name rules)
(and name
(not (weak? rules))
(covered-by-a-rule? name rules))))
(let* ((excl-def/weak (weak? exclude-definitions))
(excl-def/strong (strong? name exclude-definitions))
(incl-def/weak (weak? include-definitions))
(incl-def/strong (strong? name include-definitions))
(excl-src/weak (weak? exclude-sources))
(excl-src/strong (strong? source-location exclude-sources))
(incl-src/weak (weak? include-sources))
(incl-src/strong (strong? source-location include-sources))
(incl/strong (or incl-def/strong
incl-src/strong))
(excl/strong (or excl-def/strong
excl-src/strong))
(incl/weak (or incl-def/weak
incl-src/weak))
(excl/weak (or excl-def/weak
excl-src/weak)))
(or incl-def/strong
(and (not excl/strong)
(or incl/strong
(and incl/weak
;; we want src exclude rules to be stronger
(not excl-src/weak))
(not excl/weak)))))))
(defun coerce-to-byte-size (bit-size)
(let ((byte-size (/ bit-size 8)))
(unless (integerp byte-size)
(error "Non-byte size encountered where it wasn't expected (~A bits)" bit-size))
byte-size))
(defmacro assume (condition &optional format-control &rest format-arguments)
"Similar to ASSERT, but WARN's only."
`(unless ,condition
,(if format-control
`(warn ,format-control ,@format-arguments)
`(warn "ASSUME failed: ~S" ',condition))))
(defun canonicalize-transformer-hook (hook)
(etypecase hook
((and (or function symbol)
(not null))
hook)
(string
(the symbol (safe-read-from-string hook)))))
;;;;;;
;;; Json access
(defun json-value (alist key &key (otherwise nil otherwise?))
(check-type alist list)
(check-type key (and symbol (not null)))
(let* ((entry (assoc key alist))
(result (cond
(entry
(cdr entry))
(otherwise?
otherwise)
(t (error "Key ~S not found in json entry ~S." key alist)))))
(if (equal result "")
nil
result)))
(defmacro with-json-values ((json-entry &rest args) &body body)
(if (null args)
`(progn
,@body)
(once-only (json-entry)
`(let (,@(loop
:for entry :in args
:collect (let* ((args (ensure-list entry))
(name (pop args))
(key (or (pop args)
(make-keyword (symbol-name name)))))
(destructuring-bind
;; using &optional would trigger a warning (on SBCL)
(&key (otherwise nil otherwise?))
args
`(,name
(json-value ,json-entry ,key ,@(when otherwise?
`(:otherwise ,otherwise))))))))
,@body))))
(defun expected-json-keys (alist &rest keys)
(let* ((keys (list* :location keys))
(outliers (remove-if (lambda (el)
(member (car el) keys :test 'eq))
alist)))
(when outliers
(warn "Unexpected key(s) in json entry ~S: ~S" alist outliers))))
;;;;;;
;;; Namespaces, names and conversions
;; an alist of (name . hashtable)
(defvar *generated-names*)
(defvar *anon-name-counter*)
(defvar *anon-entities*)
(defun register-anon-entity (id name)
(check-type id integer)
(check-type name string)
(assert (not (zerop (length name))))
(setf (gethash id *anon-entities*) name)
name)
(defun lookup-anon-entity (id)
(or (gethash id *anon-entities*)
(error "Could not find anonymous entity with id ~S." id)))
(defun generate-anon-name (base-name)
(format nil "~A"
(strcat (symbol-name base-name)
(princ-to-string (incf *anon-name-counter*)))))
(defun valid-name-or-die (name)
;; checks for valid json names (*not* CFFI names)
(etypecase name
(string
(assert (not (zerop (length name)))))
(cons
(assert (= 2 (length name)))
(assert (member (first name) '(:struct :union :enum)))
(valid-name-or-die (second name)))))
(defun call-hook (hook &rest args)
(apply hook
;; indiscriminately add one keyword arg entry to warn
(append args '(just-a-warning "Make sure your transformer hook has &key &allow-other-keys for future extendability."))))
(defun find-cffi-type-or-die (type-name &optional (namespace :default))
(when (eq namespace :enum)
;; TODO FIXME this should be cleaned up in CFFI. more about namespace confusion at:
;; https://bugs.launchpad.net/cffi/+bug/1527947
(setf namespace :default))
(cffi::find-type-parser type-name namespace))
(define-constant +name-kinds+ '(:struct :union :function :variable :type
:constant :field :argument :enum :member)
:test 'equal)
(deftype ffi-name-kind ()
'#.(list* 'member +name-kinds+))
(defun json-name-to-cffi-name (name kind &optional anonymous)
(check-type name string)
(check-type kind ffi-name-kind)
(when *ffi-name-transformer*
(setf name (call-hook *ffi-name-transformer* name kind))
(unless (or (and (symbolp name)
(not (null name)))
(stringp name))
(error "The FFI-NAME-TRANSFORMER ~S returned with ~S which is not a valid name."
*ffi-name-transformer* name)))
(let ((cffi-name (if (symbolp name)
name
(intern name))))
(when (and (not anonymous)
(boundp '*generated-names*))
;; TODO FIXME this function also gets called for e.g. argument types of a function. and
;; if the function ends up *not* getting emitted, e.g. because of a missing type, then
;; we wrongly record here the missing type in the *generated-names* registry.
(setf (gethash name (cdr (assoc kind *generated-names*)))
cffi-name))
cffi-name))
(defun default-callback-factory (&key &allow-other-keys)
(values))
(defun default-ffi-name-transformer (name kind &key &allow-other-keys)
(check-type name string)
(case kind
#+nil
((:constant :member)
(assert (not (symbolp name)))
(format nil "+~A+" name))
(t name)))
(defun change-case-to-readtable-case (name &optional (reatable *readtable*))
(ecase (readtable-case reatable)
(:upcase (string-upcase name))
(:downcase (string-downcase name))
(:preserve name)
;; (:invert no, you don't)
))
(defun camelcased? (name)
(and (>= (length name) 3)
(let ((lower 0)
(upper 0))
(loop
:for char :across name
:do (cond
((upper-case-p char)
(incf upper))
((lower-case-p char)
(incf lower))))
(unless (or (zerop lower)
(zerop upper))
(let ((ratio (/ upper lower)))
(and (<= 0.05 ratio 0.5)))))))
(defun camelcase-to-dash-separated (name)
(coerce (loop
:for char :across name
:for index :from 0
:when (and (upper-case-p char)
(not (zerop index)))
:collect #\-
:collect (char-downcase char))
'string))
(defun maybe-camelcase-to-dash-separated (name)
(if (camelcased? name)
(camelcase-to-dash-separated name)
name))
(defun default-ffi-name-export-predicate (symbol &key &allow-other-keys)
(declare (ignore symbol))
nil)
(defun default-ffi-type-transformer (type context &key &allow-other-keys)
(declare (ignore context))
(cond
((and (consp type)
(eq :pointer (first type)))
(let ((pointed-to-type (second type)))
(if (eq pointed-to-type :char)
:string
type)))
(t
type)))
(defun function-pointer-type-name ()
(symbolicate '#:function-pointer))
(defmacro with-allowed-foreign-type-errors ((on-failure-form &key (enabled t)) &body body)
(with-unique-names (type-block)
`(block ,type-block
(handler-bind
((cffi::foreign-type-error
(lambda (_)
(declare (ignore _))
(when ,enabled
(return-from ,type-block ,on-failure-form)))))
,@body))))
(defun %json-type-to-cffi-type (json-entry)
(with-json-values (json-entry tag)
(let ((cffi-type
(cond
((switch (tag :test 'equal)
(":void" :void)
(":_Bool" :bool)
;; regarding :signed-char see https://stackoverflow.com/questions/436513/char-signed-char-char-unsigned-char
(":char" :char)
(":signed-char" :char)
(":unsigned-char" :unsigned-char)
(":short" :short)
(":unsigned-short" :unsigned-short)
(":int" :int)
(":unsigned-int" :unsigned-int)
(":long" :long)
(":unsigned-long" :unsigned-long)
(":long-long" :long-long)
(":unsigned-long-long" :unsigned-long-long)
(":float" :float)
(":double" :double)
;; TODO FIXME
;;(":long-double" :long-double)
)
;; return the result of the condition expression
)
((or (progn
(assert (not (member tag +c-builtin-types+ :test 'equal)) ()
"Not all C basic types are covered! The outlier is: ~S" tag)
nil)
(equal tag ":struct")
(equal tag ":union"))
;; ":struct" is a "struct foo-struct var" kind of reference
(expected-json-keys json-entry :name :tag :id)
(with-json-values (json-entry name id)
(let* ((kind (if (equal tag ":struct")
:struct
:union))
(cffi-name (if name
(json-name-to-cffi-name name kind)
(lookup-anon-entity id))))
(find-cffi-type-or-die cffi-name kind)
`(,kind ,cffi-name))))
((or (equal tag "struct")
(equal tag "union"))
;; "struct" denotes a "struct {} var", or "typedef struct {} my_type"
;; kind of inline anonymous declaration. Let's call PROCESS-C2FFI-ENTRY
;; to emit it for us, and return with the generated name (first value)
;; as if it was a standalone toplevel struct definition.
;; TODO is it a problem that we don't invoke the CALLBACK-FACTORY stuff here?
(let ((form (process-c2ffi-entry json-entry))
(kind (if (equal tag "struct")
:struct
:union)))
(assert (and (consp form)
(member (first form) '(cffi:defcstruct cffi:defcunion))))
`(,kind ,(first (ensure-list (second form))))))
((equal tag ":enum")
;; ":enum" is an "enum foo var" kind of reference
(expected-json-keys json-entry :name :tag :id)
(with-json-values (json-entry name id)
(let ((cffi-name (json-name-to-cffi-name (or name
(lookup-anon-entity id))
:enum)))
(find-cffi-type-or-die cffi-name :enum)
;; TODO FIXME this would be the proper one, but CFFI is broken: `(:enum ,cffi-name)
cffi-name)))
((equal tag "enum")
;; "enum" is an inline "typedef enum {m1, m2} var" kind of inline declaration
(expected-json-keys json-entry :name :tag :id)
;; TODO FIXME similarly to struct, but it would be nice to see an example
(error "not yet implemented"))
((equal tag ":array")
(expected-json-keys json-entry :tag :type :size)
(with-json-values (json-entry type size)
(check-type size integer)
`(:array ,(json-type-to-cffi-type type) ,size)))
((equal tag ":pointer")
(expected-json-keys json-entry :tag :type :id)
(with-json-values (json-entry type)
`(:pointer ,(with-allowed-foreign-type-errors
(:void :enabled *allow-pointer-type-simplification*)
(json-type-to-cffi-type type)))))
((equal tag ":function-pointer")
(expected-json-keys json-entry :tag)
(function-pointer-type-name))
((equal tag ":function")
(unsupported-type json-entry))
(t
(assert (not (starts-with #\: tag)))
(let ((cffi-name (json-name-to-cffi-name tag :type)))
;; TODO FIXME json-name-to-cffi-name collects the mentioned
;; types to later emit +TYPE-NAMES+, but if this next
;; find-cffi-type-or-die dies then the entire function is
;; skipped.
(find-cffi-type-or-die cffi-name)
cffi-name)))))
(assert cffi-type () "Failed to map ~S to a cffi type" json-entry)
cffi-type)))
(defun should-export-p (symbol)
(and symbol
(symbolp symbol)
(not (keywordp symbol))
*ffi-name-export-predicate*
(call-hook *ffi-name-export-predicate* symbol)))
(defun json-type-to-cffi-type (json-entry &optional (context nil context?))
(let ((cffi-type (%json-type-to-cffi-type json-entry)))
(if context?
(call-hook *ffi-type-transformer* cffi-type context)
cffi-type)))
;;;;;;
;;; Entry point, the "API"
(defun process-c2ffi-spec-file (c2ffi-spec-file package-name
&key
(allow-pointer-type-simplification *allow-pointer-type-simplification*)
(allow-skipping-struct-fields *allow-skipping-struct-fields*)
(assume-struct-by-value-support *assume-struct-by-value-support*)
;; either a pathname or a string (will be copied as is),
;; or a function that will be funcall'd with one argument
;; to emit a form (i.e. OUTPUT/CODE).
prelude
(output (make-pathname :name (strcat (pathname-name c2ffi-spec-file) ".cffi-tmp")
:type "lisp" :defaults c2ffi-spec-file))
(output-encoding asdf:*default-encoding*)
;; The args following this point are mirrored in the ASDF
;; component on the same name.
(ffi-name-transformer *ffi-name-transformer*)
(ffi-name-export-predicate *ffi-name-export-predicate*)
;; as per CFFI:DEFINE-FOREIGN-LIBRARY and CFFI:LOAD-FOREIGN-LIBRARY
(ffi-type-transformer *ffi-type-transformer*)
(callback-factory *callback-factory*)
foreign-library-name
foreign-library-spec
(emit-generated-name-mappings t)
(include-sources :all)
exclude-sources
(include-definitions :all)
exclude-definitions)
"Generates a lisp file with CFFI definitions from C2FFI-SPEC-FILE.
PACKAGE-NAME will be overwritten, it assumes full control over the
target package."
(check-type c2ffi-spec-file (or pathname string))
(macrolet ((@ (var)
`(setf ,var (compile-rules ,var))))
(@ include-sources)
(@ exclude-sources)
(@ include-definitions)
(@ exclude-definitions))
(with-standard-io-syntax
(with-input-from-file (in c2ffi-spec-file :external-format (asdf/driver:encoding-external-format :utf-8))
(with-output-to-file (*c2ffi-output-stream* output :if-exists :supersede
:external-format (asdf/driver:encoding-external-format output-encoding))
(let* ((*package* (or (find-package package-name)
(make-package package-name)))
;; Make sure we use an uninterned symbol, so that it's neutral to READTABLE-CASE.
(package-name (make-symbol (package-name *package*)))
;; Let's rebind a copy, so that when we are done with
;; the generation (which also EVAL's the forms) then
;; the CFFI type repository is also reverted back to
;; the previous state. This avoids redefinition warning
;; when the generated file gets compiled and loaded
;; later.
(cffi::*type-parsers* (copy-hash-table cffi::*type-parsers*))
(*anon-name-counter* 0)
(*anon-entities* (make-hash-table))
(*generated-names* (mapcar (lambda (key)
`(,key . ,(make-hash-table :test 'equal)))
+name-kinds+))
(*allow-pointer-type-simplification* allow-pointer-type-simplification)
(*allow-skipping-struct-fields* allow-skipping-struct-fields)
(*assume-struct-by-value-support* assume-struct-by-value-support)
(*ffi-name-transformer* (canonicalize-transformer-hook ffi-name-transformer))
(*ffi-name-export-predicate* (canonicalize-transformer-hook ffi-name-export-predicate))
(*ffi-type-transformer* (canonicalize-transformer-hook ffi-type-transformer))
(*callback-factory* (canonicalize-transformer-hook callback-factory))
(*read-default-float-format* 'double-float)
(json (json:decode-json in)))
(output/string +generated-file-header+)
;; some forms that are always emitted
(mapc 'output/code
;; Make sure the package exists. We don't even want to :use COMMON-LISP here,
;; to avoid any possible name clashes.
`((uiop:define-package ,package-name (:use))
(in-package ,package-name)
(cffi:defctype ,(function-pointer-type-name) :pointer)))
(when (and foreign-library-name
foreign-library-spec)
(when (stringp foreign-library-name)
(setf foreign-library-name (safe-read-from-string foreign-library-name)))
(output/code `(cffi:define-foreign-library ,foreign-library-name
,@foreign-library-spec))
;; TODO: Unconditionally emitting a USE-FOREIGN-LIBRARY may not be smart.
;; For details see: https://bugs.launchpad.net/cffi/+bug/1593635
(output/code `(cffi:use-foreign-library ,foreign-library-name)))
(etypecase prelude
(null)
(string
(output/string prelude))
(pathname
(with-input-from-file (prelude-stream prelude)
(alexandria:copy-stream prelude-stream *c2ffi-output-stream*
:element-type 'character)))
((or symbol function)
(funcall prelude 'output/code)))
;;
;; Let's enumerate the entries
(multiple-value-bind (form-callback epilogue-callback)
(funcall *callback-factory*)
(dolist (json-entry json)
(with-json-values (json-entry name location)
(let ((source-location-file (subseq location
0
(or (position #\: location)
0))))
(if (include-definition?
name source-location-file
include-definitions exclude-definitions
include-sources exclude-sources)
(progn
(output/string "~&~%;; ~S" location)
(let ((emitted-definition (process-c2ffi-entry json-entry)))
;;
;; Call the plugin to let the user emit a form after the given
;; definition
(when (and emitted-definition
form-callback)
(map nil 'output/code (call-hook form-callback emitted-definition)))))
(output/string "~&;; Skipped ~S due to filters" name)))))
;;
;; Call the plugin to let the user append multiple forms after the
;; emitted definitions
(when epilogue-callback
(map nil 'output/code (call-hook epilogue-callback))))
;;
;; emit optional exports
(maphash
(lambda (package-name symbols)
(output/export (sort (remove-if-not #'should-export-p symbols) #'string<)
package-name))
(get-all-names-by-package *generated-names*))
;;
;; emit optional mappings
(when emit-generated-name-mappings
(mapcar (lambda (entry)
(destructuring-bind (kind variable-name) entry
(output/code `(defparameter
,(intern (symbol-name variable-name))
',(hash-table-alist (cdr (assoc kind *generated-names*)))))))
`((:function #:+function-names+)
(:struct #:+struct-names+)
(:union #:+union-names+)
(:variable #:+variable-names+)
(:type #:+type-names+)
(:constant #:+constant-names+)
(:argument #:+argument-names+)
(:field #:+field-names+))))))))
output)
(defun get-all-names-by-package (name-collection)
(let ((tables (mapcar #'cdr name-collection))
all
(grouped (make-hash-table)))
(loop :for table :in tables :do
(loop :for s :being :the :hash-values :of table :do
(push s all)))
(remove-duplicates all :test #'eq)
(loop :for name :in all
:for package-name := (package-name (symbol-package name))
:do (setf (gethash package-name grouped)
(cons name (gethash package-name grouped))))
grouped))
;;;;;;
;;; Processors for various definitions
(defvar *c2ffi-entry-processors* (make-hash-table :test 'equal))
(defun process-c2ffi-entry (json-entry)
(let* ((kind (json-value json-entry :tag))
(processor (gethash kind *c2ffi-entry-processors*)))
(if processor
(let ((definition-form
(handler-bind
((unsupported-type
(lambda (e)
(warn "Skip definition because cannot map ~S to any CFFI type. The definition is ~S"
(json-definition-of e) json-entry)
(return-from process-c2ffi-entry (values))))
(cffi::undefined-foreign-type-error
(lambda (e)
(output/string "~&;; Skipping definition ~S because of missing type ~S"
json-entry (cffi::foreign-type-error/compound-name e))
(return-from process-c2ffi-entry (values)))))
(funcall processor json-entry))))
(when definition-form
(output/code definition-form)
definition-form))
(progn
(warn "No cffi/c2ffi processor defined for ~A" json-entry)
(values)))))
(defmacro define-processor (kind args &body body)
`(setf (gethash ,(string-downcase kind) *c2ffi-entry-processors*)
(named-lambda ,(symbolicate 'c2ffi-processor/ kind) (-json-entry-)
(with-json-values (-json-entry- ,@args)
,@body))))
(defun %process-struct-like (json-entry kind definer anon-base-name)
(expected-json-keys json-entry :tag :ns :name :id :bit-size :bit-alignment :fields)
(with-json-values (json-entry tag (struct-name :name) fields bit-size id)
(assert (member tag '(":struct" "struct" ":union" "union") :test 'equal))
(flet ((process-field (json-entry)
(with-json-values (json-entry (field-name :name) bit-offset type)
(let ((cffi-type (with-allowed-foreign-type-errors
('failed :enabled *allow-skipping-struct-fields*)
(json-type-to-cffi-type type `(,kind ,struct-name ,field-name)))))
(if (eq cffi-type 'failed)
(output/string "~&;; skipping field due to missing type ~S, full json entry: ~S" type json-entry)
`(,(json-name-to-cffi-name field-name :field)
,cffi-type
,@(unless (eq kind :union)
`(:offset ,(coerce-to-byte-size bit-offset)))))))))
`(,definer (,(json-name-to-cffi-name (or struct-name
(register-anon-entity
id
(generate-anon-name anon-base-name)))
kind
(null struct-name))
:size ,(coerce-to-byte-size bit-size))
,@(remove nil (mapcar #'process-field fields))))))
(define-processor struct ()
(%process-struct-like -json-entry- :struct 'cffi:defcstruct '#:anon-struct-))
(define-processor union ()
(%process-struct-like -json-entry- :union 'cffi:defcunion '#:anon-union-))
(define-processor typedef (name type)
(expected-json-keys -json-entry- :tag :name :ns :type)
`(cffi:defctype ,(json-name-to-cffi-name name :type)
,(json-type-to-cffi-type type `(:typedef ,name))))
(define-processor function (return-type (function-name :name) parameters inline variadic storage-class)
(declare (ignore storage-class))
;; TODO does storage-class matter for FFI accessibility?
#+nil
(assume (equal "extern" storage-class)
"Unexpected function STORAGE-CLASS: ~S for function ~S" storage-class function-name)
(expected-json-keys -json-entry- :tag :name :return-type :parameters :variadic :inline :storage-class :ns)
(let ((uses-struct-by-value? nil))
(flet ((process-arg (json-entry index)
(expected-json-keys json-entry :tag :name :type)
(with-json-values (json-entry tag (argument-name :name) type)
(assert (equal tag "parameter"))
(let* ((cffi-type (json-type-to-cffi-type type `(:function ,function-name ,argument-name)))
(canonicalized-type (cffi::canonicalize-foreign-type cffi-type)))
(when (and (consp canonicalized-type)
(member (first canonicalized-type) '(:struct :union)))
(setf uses-struct-by-value? t))
`(,(if argument-name
(json-name-to-cffi-name argument-name :argument)
(symbolicate '#:arg (princ-to-string index)))
,cffi-type)))))
(let ((cffi-args (loop
:for arg :in parameters
:for index :upfrom 1
:collect (process-arg arg index))))
(cond
((and uses-struct-by-value?
(not *assume-struct-by-value-support*))
(values))
(inline
;; TODO inline functions should go into a separate grovel file?
(output/string "~&;; Skipping inline function ~S" function-name)
(values))
(t `(cffi:defcfun (,function-name ,(json-name-to-cffi-name function-name :function))
,(json-type-to-cffi-type return-type `(:function ,function-name :return-type))
,@(append cffi-args
(when variadic
'(&rest))))))))))
(define-processor extern (name type)
(expected-json-keys -json-entry- :tag :name :type)
`(cffi:defcvar (,name ,(json-name-to-cffi-name name :variable))
,(json-type-to-cffi-type type `(:variable ,name))))
;; ((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))))
(define-processor enum (name fields id)
(let ((bitmasks 0)
(non-bitmasks 0))
(labels
((for-bitmask-statistics (name value)
(declare (ignore name))
(if (cffi::single-bit-p value)
(incf bitmasks)
(incf non-bitmasks)))
(for-enum-body (name value)
`(,(json-name-to-cffi-name name :member)
,value))
(process-fields (visitor)
(loop
:for json-entry :in fields
:do (expected-json-keys json-entry :tag :name :value)
:collect
(with-json-values (json-entry tag name value)
(assert (equal tag "field"))
(check-type value integer)
(funcall visitor name value)))))
(process-fields #'for-bitmask-statistics)
`(,(if (> (/ bitmasks
(+ non-bitmasks bitmasks))
0.8)
'cffi:defbitfield
'cffi:defcenum)
,(json-name-to-cffi-name (or name
(register-anon-entity
id
(generate-anon-name '#:anon-enum-)))
:enum
(null name))
,@(process-fields #'for-enum-body)))))
(defun make-define-constant-form (name value)
(valid-name-or-die name)
(let ((test-fn (typecase value
(number)
(t 'equal))))
`(alexandria:define-constant ,(json-name-to-cffi-name name :constant)
,value ,@(when test-fn `(:test ',test-fn)))))
(define-processor const (name type (value :value :otherwise nil))
(expected-json-keys -json-entry- :tag :name :type :value :ns)
(let ((cffi-type (json-type-to-cffi-type type `(:contant ,name))))
(cond
((not value)
;; #define __FOO_H and friends... just ignore them.
(values))
((and (member cffi-type '(:int :unsigned-int
:long :unsigned-long
:long-long :unsigned-long-long))
(integerp value))
(make-define-constant-form name value))
((and (member cffi-type '(:float :double))
(floatp value))
(make-define-constant-form name value))
((member cffi-type '(:string (:pointer :char)) :test 'equal)
(make-define-constant-form name value))
(t
(warn "Don't know how to emit a constant of CFFI type ~S, with value ~S (json type is ~S)." cffi-type value type)
(values)))))

54
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/c2ffi/package.lisp Normal file
View file

@ -0,0 +1,54 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; Copyright (C) 2015, Attila Lendvai <attila@lendvai.name>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(uiop:define-package #:cffi/c2ffi
(:mix #:uiop
#:alexandria
#:common-lisp)
(:import-from :asdf
#:cl-source-file
#:find-system
#:output-file
#:output-files
#:input-files
#:perform
#:compile-op
#:load-op
#:load-source-op
#:prepare-op
#:component-pathname
#:component-depends-on
#:downward-operation
#:load-system
#:component-loaded-p)
(:export
#:c2ffi-file
#:camelcased?
#:camelcase-to-dash-separated
#:change-case-to-readtable-case
#:default-ffi-name-transformer
#:default-ffi-type-transformer
#:generate-spec
#:maybe-camelcase-to-dash-separated))

664
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-abcl.lisp Normal file
View file

@ -0,0 +1,664 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-abcl.lisp --- CFFI-SYS implementation for ABCL/JNA.
;;;
;;; Copyright (C) 2009, Luis Oliveira <loliveira@common-lisp.net>
;;; Copyright (C) 2012, Mark Evenson <evenson.not.org@gmail.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;; This implementation requires the Java Native Access (JNA) library.
;;; <http://jna.dev.java.net/>
;;;
;;; JNA may be automatically loaded into the current JVM process from
;;; abcl-1.1.0-dev via the contrib mechanism.
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :abcl-contrib)
(require :jna)
(require :jss))
;;; This is a preliminary version that will have to be cleaned up,
;;; optimized, etc. Nevertheless, it passes all of the relevant CFFI
;;; tests except MAKE-POINTER.HIGH. Shareable Vectors are not
;;; implemented yet.
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:cl #:java)
(:import-from #:alexandria #:hash-table-values #:length= #:format-symbol)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
;; #:make-shareable-byte-vector
;; #:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:%defcallback
#:%callback
#:with-pointer-to-vector-data
#:make-shareable-byte-vector))
(in-package #:cffi-sys)
;;;# Loading and Closing Foreign Libraries
(defparameter *loaded-libraries* (make-hash-table))
(defun %load-foreign-library (name path)
"Load a foreign library, signals a simple error on failure."
(flet ((load-and-register (name path)
(let ((lib (jstatic "getInstance" "com.sun.jna.NativeLibrary" path)))
(setf (gethash name *loaded-libraries*) lib)
lib))
(foreign-library-type-p (type)
(find type '("so" "dll" "dylib") :test #'string=))
(java-error (e)
(error (jcall (jmethod "java.lang.Exception" "getMessage")
(java-exception-cause e)))))
(handler-case
(load-and-register name path)
(java-exception (e)
;; From JNA http://jna.java.net/javadoc/com/sun/jna/NativeLibrary.html
;; ``[The name] can be short form (e.g. "c"), an explicit
;; version (e.g. "libc.so.6"), or the full path to the library
;; (e.g. "/lib/libc.so.6")''
;;
;; Try to deal with the occurance "libXXX" and "libXXX.so" as
;; "libXXX.so.6" and "XXX" should have succesfully loaded.
(let ((p (pathname path)))
(if (and (not (pathname-directory p))
(= (search "lib" (pathname-name p)) 0))
(let ((short-name (if (foreign-library-type-p (pathname-type p))
(subseq (pathname-name p) 3)
(pathname-name p))))
(handler-case
(load-and-register name short-name)
(java-exception (e) (java-error e))))
(java-error e)))))))
;;; FIXME. Should remove libraries from the hash table.
(defun %close-foreign-library (handle)
"Closes a foreign library."
#+#:ignore (setf *loaded-libraries* (remove handle *loaded-libraries*))
(jcall-raw (jmethod "com.sun.jna.NativeLibrary" "dispose") handle))
;;;
;;; FIXME! We should probably define a private-jfield-accessor that does the hard work once!
(let ((get-declared-fields-jmethod (jmethod "java.lang.Class" "getDeclaredFields")))
(defun private-jfield (class-name field-name instance)
(let ((field (find field-name
(jcall get-declared-fields-jmethod
(jclass class-name))
:key #'jfield-name
:test #'string=)))
(jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean")
field +true+)
(jcall (jmethod "java.lang.reflect.Field" "get" "java.lang.Object")
field instance))))
;;; XXX: doesn't match jmethod-arguments.
(let ((get-declared-methods-jmethod (jmethod "java.lang.Class" "getDeclaredMethods")))
(defun private-jmethod (class-name method-name)
(let ((method (find method-name
(jcall get-declared-methods-jmethod
(jclass class-name))
:key #'jmethod-name
:test #'string=)))
(jcall (jmethod "java.lang.reflect.Method" "setAccessible" "boolean")
method +true+)
method)))
(let ((get-declared-constructors-jmethod (jmethod "java.lang.Class"
"getDeclaredConstructors"))
(set-accessible-jmethod (jmethod "java.lang.reflect.Constructor" "setAccessible" "boolean")))
(defun private-jconstructor (class-name &rest params)
(let* ((param-classes (mapcar #'jclass params))
(cons (find-if (lambda (x &aux (cons-params (jconstructor-params x)))
(and (length= param-classes cons-params)
(loop for param in param-classes
and param-x across cons-params
always (string= (jclass-name param)
(jclass-name param-x)))))
(jcall get-declared-constructors-jmethod (jclass class-name)))))
(jcall set-accessible-jmethod cons +true+)
cons)))
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(string-upcase name))
;;;# Pointers
(deftype foreign-pointer ()
'(satisfies pointerp))
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(let ((jclass (jclass-of ptr)))
(when jclass
(jclass-superclass-p (jclass "com.sun.jna.Pointer") jclass))))
(let ((jconstructor (private-jconstructor "com.sun.jna.Pointer" "long")))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(jnew jconstructor address)))
(defun make-private-jfield-accessor (class-name field-name)
(let ((field (find field-name
(jcall (jmethod "java.lang.Class" "getDeclaredFields")
(jclass class-name))
:key #'jfield-name
:test #'string=)))
(jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean")
field +true+)
(let ((get-jmethod (jmethod "java.lang.reflect.Field" "get" "java.lang.Object")))
(lambda (instance)
(jcall get-jmethod field instance)))))
(let ((accessor (make-private-jfield-accessor "com.sun.jna.Pointer" "peer")))
(defun %pointer-address (pointer)
(funcall accessor pointer)))
(defun pointer-address (pointer)
"Return the address pointed to by PTR."
(let ((peer (%pointer-address pointer)))
(if (< peer 0)
(+ #.(ash 1 64) peer)
peer)))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(= (%pointer-address ptr1) (%pointer-address ptr2)))
(defun null-pointer ()
"Construct and return a null pointer."
(make-pointer 0))
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(zerop (%pointer-address ptr)))
(defun inc-pointer (ptr offset)
"Return a fresh pointer pointing OFFSET bytes past PTR."
(make-pointer (+ (%pointer-address ptr) offset)))
;;;# Allocation
(let ((malloc-jmethod (private-jmethod "com.sun.jna.Memory" "malloc")))
(defun %foreign-alloc (size)
"Allocate SIZE bytes on the heap and return a pointer."
(make-pointer
(jstatic-raw malloc-jmethod nil size))))
(let ((free-jmethod (private-jmethod "com.sun.jna.Memory" "free")))
(defun foreign-free (ptr)
"Free a PTR allocated by FOREIGN-ALLOC."
(jstatic-raw free-jmethod nil (%pointer-address ptr))
nil))
;;; TODO: stack allocation.
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The pointer
in VAR is invalid beyond the dynamic extent of BODY, and may be
stack-allocated if supported by the implementation. If SIZE-VAR is
supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
`(let* ((,size-var ,size)
(,var (%foreign-alloc ,size-var)))
(unwind-protect
(progn ,@body)
(foreign-free ,var))))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(defun jna-setter (type)
(ecase type
((:char :unsigned-char) "setByte")
(:double "setDouble")
(:float "setFloat")
((:int :unsigned-int) "setInt")
((:long :unsigned-long) "setNativeLong")
((:long-long :unsigned-long-long) "setLong")
(:pointer "setPointer")
((:short :unsigned-short) "setShort")))
(defun jna-setter-arg-type (type)
(ecase type
((:char :unsigned-char) "byte")
(:double "double")
(:float "float")
((:int :unsigned-int) "int")
((:long :unsigned-long) "com.sun.jna.NativeLong")
((:long-long :unsigned-long-long) "long")
(:pointer "com.sun.jna.Pointer")
((:short :unsigned-short) "short")))
(defun jna-getter (type)
(ecase type
((:char :unsigned-char) "getByte")
(:double "getDouble")
(:float "getFloat")
((:int :unsigned-int) "getInt")
((:long :unsigned-long) "getNativeLong")
((:long-long :unsigned-long-long) "getLong")
(:pointer "getPointer")
((:short :unsigned-short) "getShort")))
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)))
(let ((method (jmethod "com.sun.jna.Pointer"
(jna-setter :char) "long" (jna-setter-arg-type :char))))
(defun copy-to-foreign-vector (vector foreign-pointer)
(loop for i below (length vector)
do
(jcall-raw method
foreign-pointer i
(aref vector i)))))
;; hand-roll the jna-getter method instead of calling %mem-ref every time through
(let ((method (jmethod "com.sun.jna.Pointer" (jna-getter :char) "long")))
(defun copy-from-foreign-vector (vector foreign-pointer)
(loop for i below (length vector)
do (setf (aref vector i)
(java:jobject-lisp-value (jcall-raw method foreign-pointer i))))))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
(let ((vector-sym (gensym "VECTOR")))
`(let ((,vector-sym ,vector))
(with-foreign-pointer (,ptr-var (length ,vector-sym))
(copy-to-foreign-vector ,vector-sym ,ptr-var)
(unwind-protect
(progn ,@body)
(copy-from-foreign-vector ,vector-sym ,ptr-var))))))
;;;# Dereferencing
(defun foreign-type-to-java-class (type)
(jclass
(ecase type
((:int :unsigned-int) "java.lang.Integer")
((:long :unsigned-long) "com.sun.jna.NativeLong")
((:long-long :unsigned-long-long) "java.lang.Long")
(:pointer "com.sun.jna.Pointer") ;; void * is pointer?
(:float "java.lang.Float")
(:double "java.lang.Double")
((:char :unsigned-char) "java.lang.Byte")
((:short :unsigned-short) "java.lang.Short"))))
(defun %foreign-type-size (type)
"Return the size in bytes of a foreign type."
(jstatic "getNativeSize" "com.sun.jna.Native"
(foreign-type-to-java-class type)))
;;; FIXME.
(defun %foreign-type-alignment (type)
"Return the alignment in bytes of a foreign type."
(%foreign-type-size type))
(defun unsigned-type-p (type)
(case type
((:unsigned-char
:unsigned-int
:unsigned-short
:unsigned-long
:unsigned-long-long) t)
(t nil)))
(defun lispify-value (value type)
(when (and (eq type :pointer) (or (null (java:jobject-lisp-value value))
(eq +null+ (java:jobject-lisp-value value))))
(return-from lispify-value (null-pointer)))
(when (or (eq type :long) (eq type :unsigned-long))
(setq value (jcall-raw (jmethod "com.sun.jna.NativeLong" "longValue")
(java:jobject-lisp-value value))))
(let ((bit-size (* 8 (%foreign-type-size type))))
(let ((lisp-value (java:jobject-lisp-value value)))
(if (and (unsigned-type-p type)
(logbitp (1- bit-size) lisp-value))
(lognot (logxor lisp-value (1- (expt 2 bit-size))))
lisp-value))))
(defun %mem-ref (ptr type &optional (offset 0))
(lispify-value
(jcall-raw (jmethod "com.sun.jna.Pointer" (jna-getter type) "long")
ptr offset)
type))
(defun %mem-set (value ptr type &optional (offset 0))
(let* ((bit-size (* 8 (%foreign-type-size type)))
(val (if (and (unsigned-type-p type) (logbitp (1- bit-size) value))
(lognot (logxor value (1- (expt 2 bit-size))))
value)))
(jcall-raw (jmethod "com.sun.jna.Pointer"
(jna-setter type) "long" (jna-setter-arg-type type))
ptr
offset
(if (or (eq type :long) (eq type :unsigned-long))
(jnew (jconstructor "com.sun.jna.NativeLong" "long") val)
val)))
value)
;;;# Foreign Globals
(let ((get-symbol-address-jmethod (private-jmethod "com.sun.jna.NativeLibrary" "getSymbolAddress")))
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(flet ((find-it (library)
(ignore-errors
(make-pointer
(jcall-raw get-symbol-address-jmethod library name)))))
(if (eq library :default)
(or (find-it
(jstatic "getProcess" "com.sun.jna.NativeLibrary"))
;; The above should find it, but I'm not exactly sure, so
;; let's still do it manually just in case.
(loop for lib being the hash-values of *loaded-libraries*
thereis (find-it lib)))
(find-it library)))))
;;;# Calling Foreign Functions
(defun find-foreign-function (name library)
(flet ((find-it (library)
(ignore-errors
(jcall-raw (jmethod "com.sun.jna.NativeLibrary" "getFunction"
"java.lang.String")
library name))))
(if (eq library :default)
(or (find-it
(jstatic "getProcess" "com.sun.jna.NativeLibrary"))
;; The above should find it, but I'm not exactly sure, so
;; let's still do it manually just in case.
(loop for lib being the hash-values of *loaded-libraries*
thereis (find-it lib)))
(find-it (gethash library *loaded-libraries*)))))
(defun convert-calling-convention (convention)
(ecase convention
(:stdcall "ALT_CONVENTION")
(:cdecl "C_CONVENTION")))
(defparameter *jna-string-encoding* "UTF-8"
"Encoding for conversion between Java and native strings that occurs within JNA.
Used with jna-4.0.0 or later.")
;;; c.f. <http://twall.github.io/jna/4.0/javadoc/com/sun/jna/Function.html#Function%28com.sun.jna.Pointer,%20int,%20java.lang.String%29>
(defvar *jna-4.0.0-or-later-p*
(ignore-errors (private-jconstructor "com.sun.jna.Function"
"com.sun.jna.Pointer" "int" "java.lang.String")))
(let ((jconstructor
(if *jna-4.0.0-or-later-p*
(private-jconstructor "com.sun.jna.Function"
"com.sun.jna.Pointer" "int" "java.lang.String")
(private-jconstructor "com.sun.jna.Function"
"com.sun.jna.Pointer" "int"))))
(defun make-function-pointer (pointer convention)
(apply
#'jnew jconstructor pointer
(jfield "com.sun.jna.Function" (convert-calling-convention convention))
(when *jna-4.0.0-or-later-p*
(list *jna-string-encoding*)))))
(defun lisp-value-to-java (value foreign-type)
(case foreign-type
(:pointer value)
(:void nil)
(t (jnew (ecase foreign-type
((:int :unsigned-int) (jconstructor "java.lang.Integer" "int"))
((:long-long :unsigned-long-long)
(jconstructor "java.lang.Long" "long"))
((:long :unsigned-long)
(jconstructor "com.sun.jna.NativeLong" "long"))
((:short :unsigned-short) (jconstructor "java.lang.Short" "short"))
((:char :unsigned-char) (jconstructor "java.lang.Byte" "byte"))
(:float (jconstructor "java.lang.Float" "float"))
(:double (jconstructor "java.lang.Double" "double")))
value))))
(defun %%foreign-funcall (function args arg-types return-type)
(let ((jargs (jnew-array "java.lang.Object" (length args))))
(loop for arg in args and type in arg-types and i from 0
do (setf (jarray-ref jargs i)
(lisp-value-to-java arg type)))
(if (eq return-type :void)
(progn
(jcall-raw (jmethod "com.sun.jna.Function" "invoke" "[Ljava.lang.Object;")
function jargs)
(values))
(lispify-value
(jcall-raw (jmethod "com.sun.jna.Function" "invoke"
"java.lang.Class" "[Ljava.lang.Object;")
function
(foreign-type-to-java-class return-type)
jargs)
return-type))))
(defun foreign-funcall-type-and-args (args)
(let ((return-type :void))
(loop for (type arg) on args by #'cddr
if arg collect type into types
and collect arg into fargs
else do (setf return-type type)
finally (return (values types fargs return-type)))))
(defmacro %foreign-funcall (name args &key library convention)
(declare (ignore convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(%%foreign-funcall (find-foreign-function ',name ',library)
(list ,@fargs) ',types ',rettype)))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(%%foreign-funcall (make-function-pointer ,ptr ',convention)
(list ,@fargs) ',types ',rettype)))
;;;# Callbacks
(defun foreign-to-callback-type (type)
(ecase type
((:int :unsigned-int)
:int)
((:long :unsigned-long)
(jvm::make-jvm-class-name "com.sun.jna.NativeLong"))
((:long-long :unsigned-long-long)
(jvm::make-jvm-class-name "java.lang.Long"))
(:pointer
(jvm::make-jvm-class-name "com.sun.jna.Pointer"))
(:float
:float)
(:double
:double)
((:char :unsigned-char)
:byte)
((:short :unsigned-short)
:short)
(:wchar_t
:int)
(:void
:void)))
(defvar *callbacks* (make-hash-table))
(defmacro convert-args-to-lisp-values (arg-names arg-types &body body)
(let ((gensym-args (loop for name in arg-names
collect (format-symbol t '#:callback-arg-~a- name))))
`(lambda (,@gensym-args)
(let ,(loop for arg in arg-names
for type in arg-types
for gensym-arg in gensym-args
collecting `(,arg (if (typep ,gensym-arg 'java:java-object)
(lispify-value ,gensym-arg ,type)
,gensym-arg)))
,@body))))
(defmacro %defcallback (name return-type arg-names arg-types body
&key convention)
(declare (ignore convention)) ;; I'm always up for ignoring convention, but this is probably wrong.
`(setf (gethash ',name *callbacks*)
(jinterface-implementation
(ensure-callback-interface ',return-type ',arg-types)
"callback"
(convert-args-to-lisp-values ,arg-names ,arg-types (lisp-value-to-java ,body ',return-type)))))
;; (lambda (,@arg-names) ,body))))
(jvm::define-class-name +callback-object+ "com.sun.jna.Callback")
(defconstant
+dynamic-callback-package+
"org/armedbear/jna/dynamic/callbacks"
"The slash-delimited Java package in which we create classes dynamically to specify callback interfaces.")
(defun ensure-callback-interface (returns args)
"Ensure that the jvm interface for the callback exists in the current JVM.
Returns the fully dot qualified name of the interface."
(let* ((jvm-returns (foreign-to-callback-type returns))
(jvm-args (mapcar #'foreign-to-callback-type args))
(interface-name (qualified-callback-interface-classname jvm-returns jvm-args)))
(handler-case
(jss:find-java-class interface-name)
(java-exception (e)
(when (jinstance-of-p (java:java-exception-cause e)
"java.lang.ClassNotFoundException")
(let ((interface-class-bytes (%define-jna-callback-interface jvm-returns jvm-args))
(simple-interface-name (callback-interface-classname jvm-returns jvm-args)))
(load-class interface-name interface-class-bytes)))))
interface-name))
(defun qualified-callback-interface-classname (returns args)
(format nil "~A.~A"
(substitute #\. #\/ +dynamic-callback-package+)
(callback-interface-classname returns args)))
(defun callback-interface-classname (returns args)
(flet ((stringify (thing)
(typecase thing
(jvm::jvm-class-name
(substitute #\_ #\/
(jvm::class-name-internal thing)))
(t (string thing)))))
(format nil "~A__~{~A~^__~}"
(stringify returns)
(mapcar #'stringify args))))
(defun %define-jna-callback-interface (returns args)
"Returns the Java byte[] array of a class representing a Java
interface descending form +CALLBACK-OBJECT+ which contains the
single function 'callback' which takes ARGS returning RETURNS.
The fully qualified dotted name of the generated class is returned as
the second value."
(let ((name (callback-interface-classname returns args)))
(values
(define-java-interface name +dynamic-callback-package+
`(("callback" ,returns ,args))
`(,+callback-object+))
(qualified-callback-interface-classname returns args))))
(defun define-java-interface (name package methods
&optional (superinterfaces nil))
"Returns the bytes of the Java class interface called NAME in PACKAGE with METHODS.
METHODS is a list of (NAME RETURN-TYPE (ARG-TYPES)) entries. NAME is
a string. The values of RETURN-TYPE and the list of ARG-TYPES for the
defined method follow the are either references to Java objects as
created by JVM::MAKE-JVM-CLASS-NAME, or keywords representing Java
primtive types as contained in JVM::MAP-PRIMITIVE-TYPE.
SUPERINTERFACES optionally contains a list of interfaces that this
interface extends specified as fully qualifed dotted Java names."
(let* ((class-name-string (format nil "~A/~A" package name))
(class-name (jvm::make-jvm-class-name class-name-string))
(class (jvm::make-class-interface-file class-name)))
(dolist (superinterface superinterfaces)
(jvm::class-add-superinterface
class
(if (typep superinterface 'jvm::jvm-class-name)
superinterface
(jvm::make-jvm-class-name superinterface))))
(dolist (method methods)
(let ((name (first method))
(returns (second method))
(args (third method)))
(jvm::class-add-method
class
(jvm::make-jvm-method name returns args
:flags '(:public :abstract)))))
(jvm::finalize-class-file class)
(let ((s (sys::%make-byte-array-output-stream)))
(jvm::write-class-file class s)
(sys::%get-output-stream-bytes s))))
(defun load-class (name bytes)
"Load the byte[] array BYTES as a Java class called NAME."
(#"loadClassFromByteArray" java::*classloader* name bytes))
;;; Test function: unused in CFFI
(defun write-class (class-bytes pathname)
"Write the Java byte[] array CLASS-BYTES to PATHNAME."
(with-open-file (stream pathname
:direction :output
:element-type '(signed-byte 8))
(dotimes (i (jarray-length class-bytes))
(write-byte (jarray-ref class-bytes i) stream))))
(defun %callback (name)
(or (#"getFunctionPointer" 'com.sun.jna.CallbackReference
(gethash name *callbacks*))
(error "Undefined callback: ~S" name)))
(defun native-namestring (pathname)
(namestring pathname))

446
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-allegro.lisp Normal file
View file

@ -0,0 +1,446 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL.
;;;
;;; Copyright (C) 2005-2009, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp)
(:import-from #:alexandria #:if-let #:with-unique-names #:once-only)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:defcfun-helper-forms
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Mis-features
#-64bit (pushnew 'no-long-long *features*)
(pushnew 'flat-namespace *features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(if (eq excl:*current-case-mode* :case-sensitive-lower)
(string-downcase name)
(string-upcase name)))
;;;# Basic Pointer Operations
(deftype foreign-pointer ()
'ff:foreign-address)
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(ff:foreign-address-p ptr))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(eql ptr1 ptr2))
(defun null-pointer ()
"Return a null pointer."
0)
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(zerop ptr))
(defun inc-pointer (ptr offset)
"Return a pointer pointing OFFSET bytes past PTR."
(+ ptr offset))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(check-type address ff:foreign-address)
address)
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(check-type ptr ff:foreign-address)
ptr)
;;;# Allocation
;;;
;;; Functions and macros for allocating foreign memory on the stack
;;; and on the heap. The main CFFI package defines macros that wrap
;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
;;; when the memory has dynamic extent.
(defun %foreign-alloc (size)
"Allocate SIZE bytes on the heap and return a pointer."
(ff:allocate-fobject :char :c size))
(defun foreign-free (ptr)
"Free a PTR allocated by FOREIGN-ALLOC."
(ff:free-fobject ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
#+(version>= 8 1)
(when (and (constantp size) (<= (eval size) ff:*max-stack-fobject-bytes*))
(return-from with-foreign-pointer
`(let ((,size-var ,(eval size)))
(declare (ignorable ,size-var))
(ff:with-static-fobject (,var '(:array :char ,(eval size))
:allocation :foreign-static-gc)
;; (excl::stack-allocated-p var) => T
(let ((,var (ff:fslot-address ,var)))
,@body)))))
`(let* ((,size-var ,size)
(,var (ff:allocate-fobject :char :c ,size-var)))
(unwind-protect
(progn ,@body)
(ff:free-fobject ,var))))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)
:allocation :static-reclaimable))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
;; An array allocated in static-reclamable is a non-simple array in
;; the normal Lisp allocation area, pointing to a simple array in
;; the static-reclaimable allocation area. Therefore we have to get
;; out the simple-array to find the pointer to the actual contents.
(with-unique-names (simple-vec)
`(excl:with-underlying-simple-vector (,vector ,simple-vec)
(let ((,ptr-var (ff:fslot-address-typed :unsigned-char :lisp
,simple-vec)))
,@body))))
;;;# Dereferencing
(defun convert-foreign-type (type-keyword)
"Convert a CFFI type keyword to an Allegro type."
(ecase type-keyword
(:char :char)
(:unsigned-char :unsigned-char)
(:short :short)
(:unsigned-short :unsigned-short)
(:int :int)
(:unsigned-int :unsigned-int)
(:long :long)
(:unsigned-long :unsigned-long)
(:long-long
#+64bit :nat
#-64bit (error "this platform does not support :long-long."))
(:unsigned-long-long
#+64bit :unsigned-nat
#-64bit (error "this platform does not support :unsigned-long-long"))
(:float :float)
(:double :double)
(:pointer :unsigned-nat)
(:void :void)))
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference an object of TYPE at OFFSET bytes from PTR."
(unless (zerop offset)
(setf ptr (inc-pointer ptr offset)))
(ff:fslot-value-typed (convert-foreign-type type) :c ptr))
;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the
;;; CFFI type is constant. Allegro does its own transformation on the
;;; call that results in efficient code.
(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
(if (constantp type)
(let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
`(ff:fslot-value-typed ',(convert-foreign-type (eval type))
:c ,ptr-form))
form))
(defun %mem-set (value ptr type &optional (offset 0))
"Set the object of TYPE at OFFSET bytes from PTR."
(unless (zerop offset)
(setf ptr (inc-pointer ptr offset)))
(setf (ff:fslot-value-typed (convert-foreign-type type) :c ptr) value))
;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED)
;;; when the CFFI type is constant. Allegro does its own
;;; transformation on the call that results in efficient code.
(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
(if (constantp type)
(once-only (val)
(let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
`(setf (ff:fslot-value-typed ',(convert-foreign-type (eval type))
:c ,ptr-form) ,val)))
form))
;;;# Calling Foreign Functions
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(ff:sizeof-fobject (convert-foreign-type type-keyword)))
(defun %foreign-type-alignment (type-keyword)
"Returns the alignment in bytes of a foreign type."
#+(and powerpc macosx32)
(when (eq type-keyword :double)
(return-from %foreign-type-alignment 8))
;; No override necessary for the remaining types....
(ff::sized-ftype-prim-align
(ff::iforeign-type-sftype
(ff:get-foreign-type
(convert-foreign-type type-keyword)))))
(defun foreign-funcall-type-and-args (args)
"Returns a list of types, list of args and return type."
(let ((return-type :void))
(loop for (type arg) on args by #'cddr
if arg collect type into types
and collect arg into fargs
else do (setf return-type type)
finally (return (values types fargs return-type)))))
(defun convert-to-lisp-type (type)
(ecase type
((:char :short :int :long :nat)
`(signed-byte ,(* 8 (ff:sizeof-fobject type))))
((:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsigned-nat)
`(unsigned-byte ,(* 8 (ff:sizeof-fobject type))))
(:float 'single-float)
(:double 'double-float)
(:void 'null)))
(defun allegro-type-pair (cffi-type)
;; the :FOREIGN-ADDRESS pseudo-type accepts both pointers and
;; arrays. We need the latter for shareable byte vector support.
(if (eq cffi-type :pointer)
(list :foreign-address)
(let ((ftype (convert-foreign-type cffi-type)))
(list ftype (convert-to-lisp-type ftype)))))
#+ignore
(defun note-named-foreign-function (symbol name types rettype)
"Give Allegro's compiler a hint to perform a direct call."
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',symbol 'system::direct-ff-call)
(list '(,name :language :c)
t ; callback
:c ; convention
;; return type '(:c-type lisp-type)
',(allegro-type-pair rettype)
;; arg types '({(:c-type lisp-type)}*)
'(,@(mapcar #'allegro-type-pair types))
nil ; arg-checking
ff::ep-flag-never-release))))
(defmacro %foreign-funcall (name args &key convention library)
(declare (ignore convention library))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(system::ff-funcall
(load-time-value (excl::determine-foreign-address
'(,name :language :c)
#-(version>= 8 1) ff::ep-flag-never-release
#+(version>= 8 1) ff::ep-flag-always-release
nil ; method-index
))
;; arg types {'(:c-type lisp-type) argN}*
,@(mapcan (lambda (type arg)
`(',(allegro-type-pair type) ,arg))
types fargs)
;; return type '(:c-type lisp-type)
',(allegro-type-pair rettype))))
(defun defcfun-helper-forms (name lisp-name rettype args types options)
"Return 2 values for DEFCFUN. A prelude form and a caller form."
(declare (ignore options))
(let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
(values
`(ff:def-foreign-call (,ff-name ,name)
,(loop for type in types
collect (list* (gensym) (allegro-type-pair type)))
:returning ,(allegro-type-pair rettype)
;; Don't use call-direct when there are no arguments.
,@(unless (null args) '(:call-direct t))
:arg-checking nil
:strings-convert nil
#+(version>= 8 1) ,@'(:release-heap :when-ok
:release-heap-ignorable t)
#+smp ,@'(:release-heap-implies-allow-gc t))
`(,ff-name ,@args))))
;;; See doc/allegro-internals.txt for a clue about entry-vec.
(defmacro %foreign-funcall-pointer (ptr args &key convention)
(declare (ignore convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
(with-unique-names (entry-vec)
`(let ((,entry-vec (excl::make-entry-vec-boa)))
(setf (aref ,entry-vec 1) ,ptr) ; set jump address
(system::ff-funcall
,entry-vec
;; arg types {'(:c-type lisp-type) argN}*
,@(mapcan (lambda (type arg)
`(',(allegro-type-pair type) ,arg))
types fargs)
;; return type '(:c-type lisp-type)
',(allegro-type-pair rettype))))))
;;;# Callbacks
;;; The *CALLBACKS* hash table contains information about a callback
;;; for the Allegro FFI. The key is the name of the CFFI callback,
;;; and the value is a cons, the car containing the symbol the
;;; callback was defined on in the CFFI-CALLBACKS package, the cdr
;;; being an Allegro FFI pointer (a fixnum) that can be passed to C
;;; functions.
;;;
;;; These pointers must be restored when a saved Lisp image is loaded.
;;; The RESTORE-CALLBACKS function is added to *RESTART-ACTIONS* to
;;; re-register the callbacks during Lisp startup.
(defvar *callbacks* (make-hash-table))
;;; Register a callback in the *CALLBACKS* hash table.
(defun register-callback (cffi-name callback-name)
(setf (gethash cffi-name *callbacks*)
(cons callback-name (ff:register-foreign-callable
callback-name :reuse t))))
;;; Restore the saved pointers in *CALLBACKS* when loading an image.
(defun restore-callbacks ()
(maphash (lambda (key value)
(register-callback key (car value)))
*callbacks*))
;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing
;;; CFFI is restarted.
(eval-when (:load-toplevel :execute)
(pushnew 'restore-callbacks excl:*restart-actions*))
;;; Create a package to contain the symbols for callback functions.
(defpackage #:cffi-callbacks
(:use))
(defun intern-callback (name)
(intern (format nil "~A::~A"
(if-let (package (symbol-package name))
(package-name package)
"#")
(symbol-name name))
'#:cffi-callbacks))
(defun convert-calling-convention (convention)
(ecase convention
(:cdecl :c)
(:stdcall :stdcall)))
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(declare (ignore rettype))
(let ((cb-name (intern-callback name)))
`(progn
(ff:defun-foreign-callable ,cb-name
,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
arg-names arg-types)
(declare (:convention ,(convert-calling-convention convention)))
,body)
(register-callback ',name ',cb-name))))
;;; Return the saved Lisp callback pointer from *CALLBACKS* for the
;;; CFFI callback named NAME.
(defun %callback (name)
(or (cdr (gethash name *callbacks*))
(error "Undefined callback: ~S" name)))
;;;# Loading and Closing Foreign Libraries
(defun %load-foreign-library (name path)
"Load a foreign library."
;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load
;; the argument. However, previous versions do not and will only
;; foreign load the argument if its type is a member of the
;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special
;; to a list containing whatever type NAME has.
(declare (ignore name))
(let ((excl::*load-foreign-types*
(list (pathname-type (parse-namestring path)))))
(handler-case
(progn
#+(version>= 7) (load path :foreign t)
#-(version>= 7) (load path))
(file-error (fe)
(error (change-class fe 'simple-error))))
path))
(defun %close-foreign-library (name)
"Close the foreign library NAME."
(ff:unload-foreign-library name))
(defun native-namestring (pathname)
(namestring pathname))
;;;# Foreign Globals
(defun convert-external-name (name)
"Add an underscore to NAME if necessary for the ABI."
#+macosx (concatenate 'string "_" name)
#-macosx name)
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(declare (ignore library))
(prog1 (ff:get-entry-point (convert-external-name name))))

201
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-clasp.lisp Normal file
View file

@ -0,0 +1,201 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-clasp.lisp --- CFFI-SYS implementation for Clasp.
;;;
;;; Copyright (C) 2017 Frank Goenninger <frank.goenninger@goenninger.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%mem-ref
#:%mem-set
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%defcallback
#:%callback
#:%foreign-symbol-pointer))
(in-package #:cffi-sys)
;;;# Mis-features
(pushnew 'flat-namespace cl:*features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Allocation
(defun %foreign-alloc (size)
"Allocate SIZE bytes of foreign-addressable memory."
(clasp-ffi:%foreign-alloc size))
(defun foreign-free (ptr)
"Free a pointer PTR allocated by FOREIGN-ALLOC."
(clasp-ffi:%foreign-free ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
`(let* ((,size-var ,size)
(,var (%foreign-alloc ,size-var)))
(unwind-protect
(progn ,@body)
(foreign-free ,var))))
;;;# Misc. Pointer Operations
(deftype foreign-pointer ()
'clasp-ffi:foreign-data)
(defun null-pointer-p (ptr)
"Test if PTR is a null pointer."
(clasp-ffi:%null-pointer-p ptr))
(defun null-pointer ()
"Construct and return a null pointer."
(clasp-ffi:%make-nullpointer))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(clasp-ffi:%make-pointer address))
(defun inc-pointer (ptr offset)
"Return a pointer OFFSET bytes past PTR."
(clasp-ffi:%inc-pointer ptr offset))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(clasp-ffi:%foreign-data-address ptr))
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(typep ptr 'clasp-ffi:foreign-data))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(check-type ptr1 clasp-ffi:foreign-data)
(check-type ptr2 clasp-ffi:foreign-data)
(eql (pointer-address ptr1) (pointer-address ptr2)))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes that can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)))
;; frgo, 2016-07-02: TODO: Implemenent!
;; (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
;; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
;; `(let ((,ptr-var (si:make-foreign-data-from-array ,vector)))
;; ,@body))
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(clasp-ffi:%foreign-type-size type-keyword))
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(clasp-ffi:%foreign-type-alignment type-keyword))
;;;# Dereferencing
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference an object of TYPE at OFFSET bytes from PTR."
(clasp-ffi:%mem-ref ptr type offset))
(defun %mem-set (value ptr type &optional (offset 0))
"Set an object of TYPE at OFFSET bytes from PTR."
(clasp-ffi:%mem-set ptr type value offset))
(defmacro %foreign-funcall (name args &key library convention)
"Call a foreign function."
(declare (ignore library convention))
`(clasp-ffi:%foreign-funcall ,name ,@args))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
"Funcall a pointer to a foreign function."
(declare (ignore convention))
`(clasp-ffi:%foreign-funcall-pointer ,ptr ,@args))
;;;# Foreign Libraries
(defun %load-foreign-library (name path)
"Load a foreign library."
(clasp-ffi:%load-foreign-library name path))
(defun %close-foreign-library (handle)
"Close a foreign library."
(clasp-ffi:%close-foreign-library handle))
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(clasp-ffi:%foreign-symbol-pointer name library))
(defun native-namestring (pathname)
(namestring pathname))
;;;# Callbacks
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
`(clasp-ffi:%defcallback (,name ,@(when convention `(:convention ,convention)))
,rettype ,arg-names ,arg-types ,body))
(defun %callback (name)
(clasp-ffi:%get-callback name))

432
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-clisp.lisp Normal file
View file

@ -0,0 +1,432 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2005-2006, Joerg Hoehle <hoehle@users.sourceforge.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package :ffi)
(error "CFFI requires CLISP compiled with dynamic FFI support.")))
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Built-In Foreign Types
(defun convert-foreign-type (type)
"Convert a CFFI built-in type keyword to a CLisp FFI type."
(ecase type
(:char 'ffi:char)
(:unsigned-char 'ffi:uchar)
(:short 'ffi:short)
(:unsigned-short 'ffi:ushort)
(:int 'ffi:int)
(:unsigned-int 'ffi:uint)
(:long 'ffi:long)
(:unsigned-long 'ffi:ulong)
(:long-long 'ffi:sint64)
(:unsigned-long-long 'ffi:uint64)
(:float 'ffi:single-float)
(:double 'ffi:double-float)
;; Clisp's FFI:C-POINTER converts NULL to NIL. For now
;; we have a workaround in the pointer operations...
(:pointer 'ffi:c-pointer)
(:void nil)))
(defun %foreign-type-size (type)
"Return the size in bytes of objects having foreign type TYPE."
(nth-value 0 (ffi:sizeof (convert-foreign-type type))))
;; Remind me to buy a beer for whoever made getting the alignment
;; of foreign types part of the public interface in CLisp. :-)
(defun %foreign-type-alignment (type)
"Return the structure alignment in bytes of foreign TYPE."
#+(and darwin ppc)
(case type
((:double :long-long :unsigned-long-long)
(return-from %foreign-type-alignment 8)))
;; Override not necessary for the remaining types...
(nth-value 1 (ffi:sizeof (convert-foreign-type type))))
;;;# Basic Pointer Operations
(deftype foreign-pointer ()
'ffi:foreign-address)
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(typep ptr 'ffi:foreign-address))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(eql (ffi:foreign-address-unsigned ptr1)
(ffi:foreign-address-unsigned ptr2)))
(defun null-pointer ()
"Return a null foreign pointer."
(ffi:unsigned-foreign-address 0))
(defun null-pointer-p (ptr)
"Return true if PTR is a null foreign pointer."
(zerop (ffi:foreign-address-unsigned ptr)))
(defun inc-pointer (ptr offset)
"Return a pointer pointing OFFSET bytes past PTR."
(ffi:unsigned-foreign-address
(+ offset (ffi:foreign-address-unsigned ptr))))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(ffi:unsigned-foreign-address address))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(ffi:foreign-address-unsigned ptr))
;;;# Foreign Memory Allocation
(defun %foreign-alloc (size)
"Allocate SIZE bytes of foreign-addressable memory and return a
pointer to the allocated block. An implementation-specific error
is signalled if the memory cannot be allocated."
(ffi:foreign-address
(ffi:allocate-shallow 'ffi:uint8 :count (if (zerop size) 1 size))))
(defun foreign-free (ptr)
"Free a pointer PTR allocated by FOREIGN-ALLOC. The results
are undefined if PTR is used after being freed."
(ffi:foreign-free ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to a pointer to SIZE bytes of foreign-addressable
memory during BODY. Both PTR and the memory block pointed to
have dynamic extent and may be stack allocated if supported by
the implementation. If SIZE-VAR is supplied, it will be bound to
SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
(let ((obj-var (gensym)))
`(let ((,size-var ,size))
(ffi:with-foreign-object
(,obj-var `(ffi:c-array ffi:uint8 ,,size-var))
(let ((,var (ffi:foreign-address ,obj-var)))
,@body)))))
;;;# Memory Access
;;; %MEM-REF and its compiler macro work around CLISP's FFI:C-POINTER
;;; type and convert NILs back to null pointers.
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference a pointer OFFSET bytes from PTR to an object of
built-in foreign TYPE. Returns the object as a foreign pointer
or Lisp number."
(let ((value (ffi:memory-as ptr (convert-foreign-type type) offset)))
(if (eq type :pointer)
(or value (null-pointer))
value)))
(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
"Compiler macro to open-code when TYPE is constant."
(if (constantp type)
(let* ((ftype (convert-foreign-type (eval type)))
(form `(ffi:memory-as ,ptr ',ftype ,offset)))
(if (eq type :pointer)
`(or ,form (null-pointer))
form))
form))
(defun %mem-set (value ptr type &optional (offset 0))
"Set a pointer OFFSET bytes from PTR to an object of built-in
foreign TYPE to VALUE."
(setf (ffi:memory-as ptr (convert-foreign-type type) offset) value))
(define-compiler-macro %mem-set
(&whole form value ptr type &optional (offset 0))
(if (constantp type)
;; (setf (ffi:memory-as) value) is exported, but not so nice
;; w.r.t. the left to right evaluation rule
`(ffi::write-memory-as
,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
form))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(declaim (inline make-shareable-byte-vector))
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)))
(deftype shareable-byte-vector ()
`(vector (unsigned-byte 8)))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
(with-unique-names (vector-var size-var)
`(let ((,vector-var ,vector))
(check-type ,vector-var shareable-byte-vector)
(with-foreign-pointer (,ptr-var (length ,vector-var) ,size-var)
;; copy-in
(loop for i below ,size-var do
(%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i))
(unwind-protect (progn ,@body)
;; copy-out
(loop for i below ,size-var do
(setf (aref ,vector-var i)
(%mem-ref ,ptr-var :unsigned-char i))))))))
;;;# Foreign Function Calling
(defun parse-foreign-funcall-args (args)
"Return three values, a list of CLISP FFI types, a list of
values to pass to the function, and the CLISP FFI return type."
(let ((return-type nil))
(loop for (type arg) on args by #'cddr
if arg collect (list (gensym) (convert-foreign-type type)) into types
and collect arg into fargs
else do (setf return-type (convert-foreign-type type))
finally (return (values types fargs return-type)))))
(defun convert-calling-convention (convention)
(ecase convention
(:stdcall :stdc-stdcall)
(:cdecl :stdc)))
(defun c-function-type (arg-types rettype convention)
"Generate the apropriate CLISP foreign type specification. Also
takes care of converting the calling convention names."
`(ffi:c-function (:arguments ,@arg-types)
(:return-type ,rettype)
(:language ,(convert-calling-convention convention))))
;;; Quick hack around the fact that the CFFI package is not yet
;;; defined when this file is loaded. I suppose we could arrange for
;;; the CFFI package to be defined a bit earlier, though.
(defun library-handle-form (name)
(flet ((find-cffi-symbol (symbol)
(find-symbol (symbol-name symbol) '#:cffi)))
`(,(find-cffi-symbol '#:foreign-library-handle)
(,(find-cffi-symbol '#:get-foreign-library) ',name))))
(eval-when (:compile-toplevel :load-toplevel :execute)
;; version 2.40 (CVS 2006-09-03, to be more precise) added a
;; PROPERTIES argument to FFI::FOREIGN-LIBRARY-FUNCTION.
(defun post-2.40-ffi-interface-p ()
(let ((f-l-f (find-symbol (string '#:foreign-library-function) '#:ffi)))
(if (and f-l-f (= (length (ext:arglist f-l-f)) 5))
'(:and)
'(:or))))
;; FFI::FOREIGN-LIBRARY-FUNCTION and FFI::FOREIGN-LIBRARY-VARIABLE
;; were deprecated in 2.41 and removed in 2.45.
(defun post-2.45-ffi-interface-p ()
(if (find-symbol (string '#:foreign-library-function) '#:ffi)
'(:or)
'(:and))))
#+#.(cffi-sys::post-2.45-ffi-interface-p)
(defun %foreign-funcall-aux (name type library)
`(ffi::find-foreign-function ,name ,type nil ,library nil nil))
#-#.(cffi-sys::post-2.45-ffi-interface-p)
(defun %foreign-funcall-aux (name type library)
`(ffi::foreign-library-function
,name ,library nil
#+#.(cffi-sys::post-2.40-ffi-interface-p)
nil
,type))
(defmacro %foreign-funcall (name args &key library convention)
"Invoke a foreign function called NAME, taking pairs of
foreign-type/value pairs from ARGS. If a single element is left
over at the end of ARGS, it specifies the foreign return type of
the function call."
(multiple-value-bind (types fargs rettype)
(parse-foreign-funcall-args args)
(let* ((fn (%foreign-funcall-aux
name
`(ffi:parse-c-type
',(c-function-type types rettype convention))
(if (eq library :default)
:default
(library-handle-form library))))
(form `(funcall
(load-time-value
(handler-case ,fn
(error (err)
(warn "~A" err))))
,@fargs)))
(if (eq rettype 'ffi:c-pointer)
`(or ,form (null-pointer))
form))))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
"Similar to %foreign-funcall but takes a pointer instead of a string."
(multiple-value-bind (types fargs rettype)
(parse-foreign-funcall-args args)
`(funcall (ffi:foreign-function
,ptr (load-time-value
(ffi:parse-c-type ',(c-function-type
types rettype convention))))
,@fargs)))
;;;# Callbacks
;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK
;;; macro. The symbol naming the callback is the key, and the value
;;; is a list containing a Lisp function, the parsed CLISP FFI type of
;;; the callback, and a saved pointer that should not persist across
;;; saved images.
(defvar *callbacks* (make-hash-table))
;;; Return a CLISP FFI function type for a CFFI callback function
;;; given a return type and list of argument names and types.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun callback-type (rettype arg-names arg-types convention)
(ffi:parse-c-type
`(ffi:c-function
(:arguments ,@(mapcar (lambda (sym type)
(list sym (convert-foreign-type type)))
arg-names arg-types))
(:return-type ,(convert-foreign-type rettype))
(:language ,(convert-calling-convention convention))))))
;;; Register and create a callback function.
(defun register-callback (name function parsed-type)
(setf (gethash name *callbacks*)
(list function parsed-type
(ffi:with-foreign-object (ptr 'ffi:c-pointer)
;; Create callback by converting Lisp function to foreign
(setf (ffi:memory-as ptr parsed-type) function)
(ffi:foreign-value ptr)))))
;;; Restore all saved callback pointers when restarting the Lisp
;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*.
;;; Needs clisp > 2.35, bugfix 2005-09-29
(defun restore-callback-pointers ()
(maphash
(lambda (name list)
(register-callback name (first list) (second list)))
*callbacks*))
;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
;;; when an image is restarted.
(eval-when (:load-toplevel :execute)
(pushnew 'restore-callback-pointers custom:*init-hooks*))
;;; Define a callback function NAME to run BODY with arguments
;;; ARG-NAMES translated according to ARG-TYPES and the return type
;;; translated according to RETTYPE. Obtain a pointer that can be
;;; passed to C code for this callback by calling %CALLBACK.
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
`(register-callback
',name
(lambda ,arg-names
;; Work around CLISP's FFI:C-POINTER type and convert NIL values
;; back into a null pointers.
(let (,@(loop for name in arg-names
and type in arg-types
when (eq type :pointer)
collect `(,name (or ,name (null-pointer)))))
,body))
,(callback-type rettype arg-names arg-types convention)))
;;; Look up the name of a callback and return a pointer that can be
;;; passed to a C function. Signals an error if no callback is
;;; defined called NAME.
(defun %callback (name)
(multiple-value-bind (list winp) (gethash name *callbacks*)
(unless winp
(error "Undefined callback: ~S" name))
(third list)))
;;;# Loading and Closing Foreign Libraries
(defun %load-foreign-library (name path)
"Load a foreign library from PATH."
(declare (ignore name))
#+#.(cffi-sys::post-2.45-ffi-interface-p)
(ffi:open-foreign-library path)
#-#.(cffi-sys::post-2.45-ffi-interface-p)
(ffi::foreign-library path))
(defun %close-foreign-library (handle)
"Close a foreign library."
(ffi:close-foreign-library handle))
(defun native-namestring (pathname)
(namestring pathname))
;;;# Foreign Globals
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(prog1 (ignore-errors
(ffi:foreign-address
#+#.(cffi-sys::post-2.45-ffi-interface-p)
(ffi::find-foreign-variable name nil library nil nil)
#-#.(cffi-sys::post-2.45-ffi-interface-p)
(ffi::foreign-library-variable name library nil nil)))))

384
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-cmucl.lisp Normal file
View file

@ -0,0 +1,384 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-cmucl.lisp --- CFFI-SYS implementation for CMU CL.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:alien #:c-call)
(:import-from #:alexandria #:once-only #:with-unique-names #:if-let)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Misfeatures
(pushnew 'flat-namespace *features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Basic Pointer Operations
(deftype foreign-pointer ()
'sys:system-area-pointer)
(declaim (inline pointerp))
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(sys:system-area-pointer-p ptr))
(declaim (inline pointer-eq))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(sys:sap= ptr1 ptr2))
(declaim (inline null-pointer))
(defun null-pointer ()
"Construct and return a null pointer."
(sys:int-sap 0))
(declaim (inline null-pointer-p))
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(zerop (sys:sap-int ptr)))
(declaim (inline inc-pointer))
(defun inc-pointer (ptr offset)
"Return a pointer pointing OFFSET bytes past PTR."
(sys:sap+ ptr offset))
(declaim (inline make-pointer))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(sys:int-sap address))
(declaim (inline pointer-address))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(sys:sap-int ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
;; If the size is constant we can stack-allocate.
(if (constantp size)
(let ((alien-var (gensym "ALIEN")))
`(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
(let ((,size-var ,(eval size))
(,var (alien-sap ,alien-var)))
(declare (ignorable ,size-var))
,@body)))
`(let* ((,size-var ,size)
(,var (%foreign-alloc ,size-var)))
(unwind-protect
(progn ,@body)
(foreign-free ,var)))))
;;;# Allocation
;;;
;;; Functions and macros for allocating foreign memory on the stack
;;; and on the heap. The main CFFI package defines macros that wrap
;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
;;; when the memory has dynamic extent.
(defun %foreign-alloc (size)
"Allocate SIZE bytes on the heap and return a pointer."
(declare (type (unsigned-byte 32) size))
(alien-funcall
(extern-alien
"malloc"
(function system-area-pointer unsigned))
size))
(defun foreign-free (ptr)
"Free a PTR allocated by FOREIGN-ALLOC."
(declare (type system-area-pointer ptr))
(alien-funcall
(extern-alien
"free"
(function (values) system-area-pointer))
ptr))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes that can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
`(sys:without-gcing
(let ((,ptr-var (sys:vector-sap ,vector)))
,@body)))
;;;# Dereferencing
;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
;;; macros that optimize the case where the type keyword is constant
;;; at compile-time.
(defmacro define-mem-accessors (&body pairs)
`(progn
(defun %mem-ref (ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (,fn ptr offset)))))
(defun %mem-set (value ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (setf (,fn ptr offset) value)))))
(define-compiler-macro %mem-ref
(&whole form ptr type &optional (offset 0))
(if (constantp type)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(,',fn ,ptr ,offset))))
form))
(define-compiler-macro %mem-set
(&whole form value ptr type &optional (offset 0))
(if (constantp type)
(once-only (value)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(setf (,',fn ,ptr ,offset)
,value)))))
form))))
(define-mem-accessors
(:char sys:signed-sap-ref-8)
(:unsigned-char sys:sap-ref-8)
(:short sys:signed-sap-ref-16)
(:unsigned-short sys:sap-ref-16)
(:int sys:signed-sap-ref-32)
(:unsigned-int sys:sap-ref-32)
(:long sys:signed-sap-ref-32)
(:unsigned-long sys:sap-ref-32)
(:long-long sys:signed-sap-ref-64)
(:unsigned-long-long sys:sap-ref-64)
(:float sys:sap-ref-single)
(:double sys:sap-ref-double)
(:pointer sys:sap-ref-sap))
;;;# Calling Foreign Functions
(defun convert-foreign-type (type-keyword)
"Convert a CFFI type keyword to an ALIEN type."
(ecase type-keyword
(:char 'char)
(:unsigned-char 'unsigned-char)
(:short 'short)
(:unsigned-short 'unsigned-short)
(:int 'int)
(:unsigned-int 'unsigned-int)
(:long 'long)
(:unsigned-long 'unsigned-long)
(:long-long '(signed 64))
(:unsigned-long-long '(unsigned 64))
(:float 'single-float)
(:double 'double-float)
(:pointer 'system-area-pointer)
(:void 'void)))
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(/ (alien-internals:alien-type-bits
(alien-internals:parse-alien-type
(convert-foreign-type type-keyword))) 8))
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(/ (alien-internals:alien-type-alignment
(alien-internals:parse-alien-type
(convert-foreign-type type-keyword))) 8))
(defun foreign-funcall-type-and-args (args)
"Return an ALIEN function type for ARGS."
(let ((return-type nil))
(loop for (type arg) on args by #'cddr
if arg collect (convert-foreign-type type) into types
and collect arg into fargs
else do (setf return-type (convert-foreign-type type))
finally (return (values types fargs return-type)))))
(defmacro %%foreign-funcall (name types fargs rettype)
"Internal guts of %FOREIGN-FUNCALL."
`(alien-funcall
(extern-alien ,name (function ,rettype ,@types))
,@fargs))
(defmacro %foreign-funcall (name args &key library convention)
"Perform a foreign function call, document it more later."
(declare (ignore library convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(%%foreign-funcall ,name ,types ,fargs ,rettype)))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
"Funcall a pointer to a foreign function."
(declare (ignore convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
(with-unique-names (function)
`(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
(alien-funcall ,function ,@fargs)))))
;;;# Callbacks
(defvar *callbacks* (make-hash-table))
;;; Create a package to contain the symbols for callback functions. We
;;; want to redefine callbacks with the same symbol so the internal data
;;; structures are reused.
(defpackage #:cffi-callbacks
(:use))
;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
;;; callback for NAME.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun intern-callback (name)
(intern (format nil "~A::~A"
(if-let (package (symbol-package name))
(package-name package)
name)
(symbol-name name))
'#:cffi-callbacks)))
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(declare (ignore convention))
(let ((cb-name (intern-callback name)))
`(progn
(def-callback ,cb-name
(,(convert-foreign-type rettype)
,@(mapcar (lambda (sym type)
(list sym (convert-foreign-type type)))
arg-names arg-types))
,body)
(setf (gethash ',name *callbacks*) (callback ,cb-name)))))
(defun %callback (name)
(multiple-value-bind (pointer winp)
(gethash name *callbacks*)
(unless winp
(error "Undefined callback: ~S" name))
pointer))
;;; CMUCL makes new callback trampolines when it reloads, so we need
;;; to update CFFI's copies.
(defun reset-callbacks ()
(loop for k being the hash-keys of *callbacks*
do (setf (gethash k *callbacks*)
(alien::symbol-trampoline (intern-callback k)))))
;; Needs to be after cmucl's restore-callbacks, so put at the end...
(unless (member 'reset-callbacks ext:*after-save-initializations*)
(setf ext:*after-save-initializations*
(append ext:*after-save-initializations* (list 'reset-callbacks))))
;;;# Loading and Closing Foreign Libraries
;;; Work-around for compiling ffi code without loading the
;;; respective library at compile-time.
(setf c::top-level-lambda-max 0)
(defun %load-foreign-library (name path)
"Load the foreign library NAME."
;; On some platforms SYS::LOAD-OBJECT-FILE signals an error when
;; loading fails, but on others (Linux for instance) it returns
;; two values: NIL and an error string.
(declare (ignore name))
(multiple-value-bind (ret message)
(sys::load-object-file path)
(cond
;; Loading failed.
((stringp message) (error "~A" message))
;; The library was already loaded.
((null ret) (cdr (rassoc path sys::*global-table* :test #'string=)))
;; The library has been loaded, but since SYS::LOAD-OBJECT-FILE
;; returns an alist of *all* loaded libraries along with their addresses
;; we return only the handler associated with the library just loaded.
(t (cdr (rassoc path ret :test #'string=))))))
;;; XXX: doesn't work on Darwin; does not check for errors. I suppose we'd
;;; want something like SBCL's dlclose-or-lose in foreign-load.lisp:66
(defun %close-foreign-library (handler)
"Closes a foreign library."
(let ((lib (rassoc (ext:unix-namestring handler) sys::*global-table*
:test #'string=)))
(sys::dlclose (car lib))
(setf (car lib) (sys:int-sap 0))))
(defun native-namestring (pathname)
(ext:unix-namestring pathname nil))
;;;# Foreign Globals
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(declare (ignore library))
(let ((address (sys:alternate-get-global-address
(vm:extern-alien-name name))))
(if (zerop address)
nil
(sys:int-sap address))))

331
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-corman.lisp Normal file
View file

@ -0,0 +1,331 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-corman.lisp --- CFFI-SYS implementation for Corman Lisp.
;;;
;;; Copyright (C) 2005-2008, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;; This port is suffering from bitrot as of 2007-03-29. Corman Lisp
;;; is too funky with ASDF, crashes easily, makes it very painful to
;;; do any testing. -- luis
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:c-types)
(:import-from #:alexandria #:with-unique-names)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
;#:make-shareable-byte-vector
;#:with-pointer-to-vector-data
#:foreign-symbol-pointer
#:defcfun-helper-forms
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Misfeatures
(pushnew 'no-long-long *features*)
(pushnew 'no-foreign-funcall *features*)
;;;$ Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Basic Pointer Operations
(deftype foreign-pointer ()
'cl::foreign)
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(cpointerp ptr))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(cpointer= ptr1 ptr2))
(defun null-pointer ()
"Return a null pointer."
(create-foreign-ptr))
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(cpointer-null ptr))
(defun inc-pointer (ptr offset)
"Return a pointer pointing OFFSET bytes past PTR."
(let ((new-ptr (create-foreign-ptr)))
(setf (cpointer-value new-ptr)
(+ (cpointer-value ptr) offset))
new-ptr))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(int-to-foreign-ptr address))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(foreign-ptr-to-int ptr))
;;;# Allocation
;;;
;;; Functions and macros for allocating foreign memory on the stack
;;; and on the heap. The main CFFI package defines macros that wrap
;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
;;; when the memory has dynamic extent.
(defun %foreign-alloc (size)
"Allocate SIZE bytes on the heap and return a pointer."
(malloc size))
(defun foreign-free (ptr)
"Free a PTR allocated by FOREIGN-ALLOC."
(free ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
`(let* ((,size-var ,size)
(,var (malloc ,size-var)))
(unwind-protect
(progn ,@body)
(free ,var))))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
;(defun make-shareable-byte-vector (size)
; "Create a Lisp vector of SIZE bytes can passed to
;WITH-POINTER-TO-VECTOR-DATA."
; (make-array size :element-type '(unsigned-byte 8)))
;
;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
; `(sb-sys:without-gcing
; (let ((,ptr-var (sb-sys:vector-sap ,vector)))
; ,@body)))
;;;# Dereferencing
;;; According to the docs, Corman's C Function Definition Parser
;;; converts int to long, so we'll assume that.
(defun convert-foreign-type (type-keyword)
"Convert a CFFI type keyword to a CormanCL type."
(ecase type-keyword
(:char :char)
(:unsigned-char :unsigned-char)
(:short :short)
(:unsigned-short :unsigned-short)
(:int :long)
(:unsigned-int :unsigned-long)
(:long :long)
(:unsigned-long :unsigned-long)
(:float :single-float)
(:double :double-float)
(:pointer :handle)
(:void :void)))
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference an object of TYPE at OFFSET bytes from PTR."
(unless (eql offset 0)
(setq ptr (inc-pointer ptr offset)))
(ecase type
(:char (cref (:char *) ptr 0))
(:unsigned-char (cref (:unsigned-char *) ptr 0))
(:short (cref (:short *) ptr 0))
(:unsigned-short (cref (:unsigned-short *) ptr 0))
(:int (cref (:long *) ptr 0))
(:unsigned-int (cref (:unsigned-long *) ptr 0))
(:long (cref (:long *) ptr 0))
(:unsigned-long (cref (:unsigned-long *) ptr 0))
(:float (cref (:single-float *) ptr 0))
(:double (cref (:double-float *) ptr 0))
(:pointer (cref (:handle *) ptr 0))))
;(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
; (if (constantp type)
; `(cref (,(convert-foreign-type type) *) ,ptr ,offset)
; form))
(defun %mem-set (value ptr type &optional (offset 0))
"Set the object of TYPE at OFFSET bytes from PTR."
(unless (eql offset 0)
(setq ptr (inc-pointer ptr offset)))
(ecase type
(:char (setf (cref (:char *) ptr 0) value))
(:unsigned-char (setf (cref (:unsigned-char *) ptr 0) value))
(:short (setf (cref (:short *) ptr 0) value))
(:unsigned-short (setf (cref (:unsigned-short *) ptr 0) value))
(:int (setf (cref (:long *) ptr 0) value))
(:unsigned-int (setf (cref (:unsigned-long *) ptr 0) value))
(:long (setf (cref (:long *) ptr 0) value))
(:unsigned-long (setf (cref (:unsigned-long *) ptr 0) value))
(:float (setf (cref (:single-float *) ptr 0) value))
(:double (setf (cref (:double-float *) ptr 0) value))
(:pointer (setf (cref (:handle *) ptr 0) value))))
;;;# Calling Foreign Functions
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(sizeof (convert-foreign-type type-keyword)))
;;; Couldn't find anything in sys/ffi.lisp and the C declaration parser
;;; doesn't seem to care about alignment so we'll assume that it's the
;;; same as its size.
(defun %foreign-type-alignment (type-keyword)
(sizeof (convert-foreign-type type-keyword)))
(defun find-dll-containing-function (name)
"Searches for NAME in the loaded DLLs. If found, returns
the DLL's name (a string), else returns NIL."
(dolist (dll ct::*dlls-loaded*)
(when (ignore-errors
(ct::get-dll-proc-address name (ct::dll-record-handle dll)))
(return (ct::dll-record-name dll)))))
;;; This won't work at all...
#||
(defmacro %foreign-funcall (name &rest args)
(let ((sym (gensym)))
`(let (,sym)
(ct::install-dll-function ,(find-dll-containing-function name)
,name ,sym)
(funcall ,sym ,@(loop for (type arg) on args by #'cddr
if arg collect arg)))))
||#
;;; It *might* be possible to implement by copying most of the code
;;; from Corman's DEFUN-DLL. Alternatively, it could implemented the
;;; same way as Lispworks' foreign-funcall. In practice, nobody uses
;;; Corman with CFFI, apparently. :)
(defmacro %foreign-funcall (name &rest args)
"Call a foreign function NAME passing arguments ARGS."
`(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
(defun defcfun-helper-forms (name lisp-name rettype args types)
"Return 2 values for DEFCFUN. A prelude form and a caller form."
(let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name)))
;; XXX This will only work if the dll is already loaded, fix this.
(dll (find-dll-containing-function name)))
(values
`(defun-dll ,ff-name
,(mapcar (lambda (type)
(list (gensym) (convert-foreign-type type)))
types)
:return-type ,(convert-foreign-type rettype)
:library-name ,dll
:entry-name ,name
;; we want also :pascal linkage type to access
;; the win32 api for instance..
:linkage-type :c)
`(,ff-name ,@args))))
;;;# Callbacks
;;; defun-c-callback vs. defun-direct-c-callback?
;;; same issue as Allegro, no return type declaration, should we coerce?
(defmacro %defcallback (name rettype arg-names arg-types body-form)
(declare (ignore rettype))
(with-unique-names (cb-sym)
`(progn
(defun-c-callback ,cb-sym
,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
arg-names arg-types)
,body-form)
(setf (get ',name 'callback-ptr)
(get-callback-procinst ',cb-sym)))))
;;; Just continue to use the plist for now even though this really
;;; should use a *CALLBACKS* hash table and not define the callbacks
;;; as gensyms. Someone with access to Corman should update this.
(defun %callback (name)
(get name 'callback-ptr))
;;;# Loading Foreign Libraries
(defun %load-foreign-library (name)
"Load the foreign library NAME."
(ct::get-dll-record name))
(defun %close-foreign-library (name)
"Close the foreign library NAME."
(error "Not implemented."))
(defun native-namestring (pathname)
(namestring pathname)) ; TODO: confirm
;;;# Foreign Globals
;;; FFI to GetProcAddress from the Win32 API.
;;; "The GetProcAddress function retrieves the address of an exported
;;; function or variable from the specified dynamic-link library (DLL)."
(defun-dll get-proc-address
((module HMODULE)
(name LPCSTR))
:return-type FARPROC
:library-name "Kernel32.dll"
:entry-name "GetProcAddress"
:linkage-type :pascal)
(defun foreign-symbol-pointer (name)
"Returns a pointer to a foreign symbol NAME."
(let ((str (lisp-string-to-c-string name)))
(unwind-protect
(dolist (dll ct::*dlls-loaded*)
(let ((ptr (get-proc-address
(int-to-foreign-ptr (ct::dll-record-handle dll))
str)))
(when (not (cpointer-null ptr))
(return ptr))))
(free str))))

454
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-ecl.lisp Normal file
View file

@ -0,0 +1,454 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-ecl.lisp --- ECL backend for CFFI.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:alexandria)
(:import-from #:si #:null-pointer-p)
(:export
#:*cffi-ecl-method*
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%mem-ref
#:%mem-set
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-funcall-varargs
#:%foreign-funcall-pointer-varargs
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%defcallback
#:%callback
#:%foreign-symbol-pointer))
(in-package #:cffi-sys)
;;;
;;; ECL allows many ways of calling a foreign function, and also many
;;; ways of finding the pointer associated to a function name. They
;;; depend on whether the FFI relies on libffi or on the C/C++ compiler,
;;; and whether they use the shared library loader to locate symbols
;;; or they are linked by the linker.
;;;
;;; :DFFI
;;;
;;; ECL uses libffi to call foreign functions. The only way to find out
;;; foreign symbols is by loading shared libraries and using dlopen()
;;; or similar.
;;;
;;; :DLOPEN
;;;
;;; ECL compiles FFI code as C/C++ statements. The names are resolved
;;; at run time by the shared library loader every time the function
;;; is called
;;;
;;; :C/C++
;;;
;;; ECL compiles FFI code as C/C++ statements, but the name resolution
;;; happens at link time. In this case you have to tell the ECL
;;; compiler which are the right ld-flags (c:*ld-flags*) to link in
;;; the library.
;;;
(defvar *cffi-ecl-method*
#+dffi :dffi
#+(and dlopen (not dffi)) :dlopen
#-(or dffi dlopen) :c/c++
"The type of code that CFFI generates for ECL: :DFFI when using the
dynamical foreign function interface; :DLOPEN when using C code and
dynamical references to symbols; :C/C++ for C/C++ code with static
references to symbols.")
;;;# Mis-features
#-long-long
(pushnew 'no-long-long *features*)
(pushnew 'flat-namespace *features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Allocation
(defun %foreign-alloc (size)
"Allocate SIZE bytes of foreign-addressable memory."
(si:allocate-foreign-data :void size))
(defun foreign-free (ptr)
"Free a pointer PTR allocated by FOREIGN-ALLOC."
(si:free-foreign-data ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
`(let* ((,size-var ,size)
(,var (%foreign-alloc ,size-var)))
(unwind-protect
(progn ,@body)
(foreign-free ,var))))
;;;# Misc. Pointer Operations
(deftype foreign-pointer ()
'si:foreign-data)
(defun null-pointer ()
"Construct and return a null pointer."
(si:allocate-foreign-data :void 0))
(defun inc-pointer (ptr offset)
"Return a pointer OFFSET bytes past PTR."
(ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(typep ptr 'si:foreign-data))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(ffi:make-pointer address :void))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(ffi:pointer-address ptr))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes that can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
`(let ((,ptr-var (si:make-foreign-data-from-array ,vector)))
,@body))
;;;# Type Operations
(defconstant +translation-table+
'((:char :byte "char")
(:unsigned-char :unsigned-byte "unsigned char")
(:short :short "short")
(:unsigned-short :unsigned-short "unsigned short")
(:int :int "int")
(:unsigned-int :unsigned-int "unsigned int")
(:long :long "long")
(:unsigned-long :unsigned-long "unsigned long")
#+long-long
(:long-long :long-long "long long")
#+long-long
(:unsigned-long-long :unsigned-long-long "unsigned long long")
(:float :float "float")
(:double :double "double")
(:pointer :pointer-void "void*")
(:void :void "void")))
(defun cffi-type->ecl-type (type-keyword)
"Convert a CFFI type keyword to an ECL type keyword."
(or (second (find type-keyword +translation-table+ :key #'first))
(error "~S is not a valid CFFI type" type-keyword)))
(defun ecl-type->c-type (type-keyword)
"Convert a CFFI type keyword to an valid C type keyword."
(or (third (find type-keyword +translation-table+ :key #'second))
(error "~S is not a valid CFFI type" type-keyword)))
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(nth-value 0 (ffi:size-of-foreign-type
(cffi-type->ecl-type type-keyword))))
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(nth-value 1 (ffi:size-of-foreign-type
(cffi-type->ecl-type type-keyword))))
;;;# Dereferencing
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference an object of TYPE at OFFSET bytes from PTR."
(let* ((type (cffi-type->ecl-type type))
(type-size (ffi:size-of-foreign-type type)))
(si:foreign-data-ref-elt
(si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
(defun %mem-set (value ptr type &optional (offset 0))
"Set an object of TYPE at OFFSET bytes from PTR."
(let* ((type (cffi-type->ecl-type type))
(type-size (ffi:size-of-foreign-type type)))
(si:foreign-data-set-elt
(si:foreign-data-recast ptr (+ offset type-size) :void)
offset type value)))
;;; Inline versions that use C expressions instead of function calls.
(defparameter +mem-ref-strings+
(loop for (cffi-type ecl-type c-string) in +translation-table+
for string = (format nil "*((~A *)(((char*)#0)+#1))" c-string)
collect (list cffi-type ecl-type string)))
(defparameter +mem-set-strings+
(loop for (cffi-type ecl-type c-string) in +translation-table+
for string = (format nil "*((~A *)(((char*)#0)+#1))=#2" c-string)
collect (list cffi-type ecl-type string)))
(define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset 0))
(if (and (constantp type) (constantp offset))
(let ((record (assoc (eval type) +mem-ref-strings+)))
`(ffi:c-inline (,ptr ,offset)
(:pointer-void :cl-index) ; argument types
,(second record) ; return type
,(third record) ; the precomputed expansion
:one-liner t))
whole))
(define-compiler-macro %mem-set (&whole whole value ptr type &optional (offset 0))
(if (and (constantp type) (constantp offset))
(let ((record (assoc (eval type) +mem-set-strings+)))
`(ffi:c-inline (,ptr ,offset ,value) ; arguments with type translated
(:pointer-void :cl-index ,(second record))
:void ; does not return anything
,(third record) ; precomputed expansion
:one-liner t))
whole))
;;;# Calling Foreign Functions
(defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
(defun c-inline-function-call (thing fixed-types types values return-type dynamic-call variadic)
(when dynamic-call
(when (stringp thing)
(setf thing `(%foreign-symbol-pointer ,thing nil)))
(push thing values)
(push :pointer-void types))
(let* ((decl-args
(format nil "~{~A~^, ~}~A"
(mapcar #'ecl-type->c-type fixed-types) (if (null variadic) "" ", ...")))
(call-args
(if dynamic-call
;; #0 is already used in a cast (it is a function pointer)
(subseq +ecl-inline-codes+ 3 (max 3 (1- (* (length values) 3))))
;; #0 is not used, so we start from the beginning
(subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3))))))
(clines
(if dynamic-call
nil
(format nil "extern ~A ~A(~A);"
(ecl-type->c-type return-type) thing decl-args)))
(call-code
(if dynamic-call
(format nil "((~A (*)(~A))(#0))(~A)"
(ecl-type->c-type return-type) decl-args call-args)
(format nil "~A(~A)" thing call-args))))
`(progn
(ffi:clines ,@(ensure-list clines))
(ffi:c-inline ,values ,types ,return-type ,call-code :one-liner t :side-effects t))))
(defun dffi-function-pointer-call (pointer types values return-type)
(when (stringp pointer)
(setf pointer `(%foreign-symbol-pointer ,pointer nil)))
#-dffi
`(error "In interpreted code, attempted to call a foreign function~% ~A~%~
but ECL was built without support for that." ,pointer)
#+dffi
`(si::call-cfun ,pointer ,return-type (list ,@types) (list ,@values)))
(defun foreign-funcall-parse-args (args)
"Return three values, lists of arg types, values, and result type."
(let ((return-type :void))
(loop for (type arg) on args by #'cddr
if arg collect (cffi-type->ecl-type type) into types
and collect arg into values
else do (setf return-type (cffi-type->ecl-type type))
finally (return (values types values return-type)))))
(defmacro %foreign-funcall (name args &key library convention)
"Call a foreign function."
(declare (ignore library convention))
(multiple-value-bind (types values return-type)
(foreign-funcall-parse-args args)
`(ext:with-backend
:bytecodes
,(dffi-function-pointer-call name types values return-type)
:c/c++
,(ecase *cffi-ecl-method*
(:dffi (dffi-function-pointer-call name types values return-type))
(:dlopen (c-inline-function-call name types types values return-type t nil))
(:c/c++ (c-inline-function-call name types types values return-type nil nil))))))
(defmacro %foreign-funcall-pointer (pointer args &key convention)
"Funcall a pointer to a foreign function."
(declare (ignore convention))
(multiple-value-bind (types values return-type)
(foreign-funcall-parse-args args)
`(ext:with-backend
:bytecodes
,(dffi-function-pointer-call pointer types values return-type)
:c/c++
,(if (eq *cffi-ecl-method* :dffi)
(dffi-function-pointer-call pointer types values return-type)
(c-inline-function-call pointer types types values return-type t nil)))))
(defmacro %foreign-funcall-varargs (name args varargs &key library convention)
(declare (ignore library convention))
(multiple-value-bind (fixed-types fixed-values)
(foreign-funcall-parse-args args)
(multiple-value-bind (varargs-types varargs-values return-type)
(foreign-funcall-parse-args varargs)
(let ((all-types (append fixed-types varargs-types))
(values (append fixed-values varargs-values)))
`(ext:with-backend
:bytecodes
,(dffi-function-pointer-call name all-types values return-type)
:c/c++
,(ecase *cffi-ecl-method*
(:dffi (dffi-function-pointer-call name all-types values return-type))
(:dlopen (c-inline-function-call name fixed-types all-types values return-type t t))
(:c/c++ (c-inline-function-call name fixed-types all-types values return-type nil t))))))))
(defmacro %foreign-funcall-pointer-varargs (pointer args varargs &key convention)
(declare (ignore convention))
(multiple-value-bind (fixed-types fixed-values)
(foreign-funcall-parse-args args)
(multiple-value-bind (varargs-types varargs-values return-type)
(foreign-funcall-parse-args varargs)
(let ((all-types (append fixed-types varargs-types))
(values (append fixed-values varargs-values)))
`(ext:with-backend
:bytecodes
,(dffi-function-pointer-call pointer all-types values return-type)
:c/c++
,(if (eq *cffi-ecl-method* :dffi)
(dffi-function-pointer-call pointer all-types values return-type)
(c-inline-function-call pointer fixed-types all-types values return-type t t)))))))
;;;# Foreign Libraries
(defun %load-foreign-library (name path)
"Load a foreign library."
(declare (ignore name))
#-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~
FFI:LOAD-FOREIGN-LIBRARY with a constant argument instead.")
#+dffi
(handler-case (si:load-foreign-module path)
(file-error ()
(error "file error while trying to load `~A'" path))))
(defun %close-foreign-library (handle)
"Close a foreign library."
(handler-case (si::unload-foreign-module handle)
(undefined-function ()
(restart-case (error "Detected ECL prior to version 15.2.21. ~
Function CFFI:CLOSE-FOREIGN-LIBRARY isn't implemented yet.")
(ignore () :report "Continue anyway (foreign library will remain opened).")))))
(defun native-namestring (pathname)
(namestring pathname))
;;;# Callbacks
;;; Create a package to contain the symbols for callback functions.
;;; We want to redefine callbacks with the same symbol so the internal
;;; data structures are reused.
(defpackage #:cffi-callbacks
(:use))
(defvar *callbacks* (make-hash-table))
;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
;;; internal callback for NAME.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun intern-callback (name)
(intern (format nil "~A::~A"
(if-let (package (symbol-package name))
(package-name package)
"#")
(symbol-name name))
'#:cffi-callbacks)))
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(declare (ignore convention))
(let ((cb-name (intern-callback name))
(cb-type #.(if (> ext:+ecl-version-number+ 160102)
:default :cdecl)))
`(progn
(ffi:defcallback (,cb-name ,cb-type)
,(cffi-type->ecl-type rettype)
,(mapcar #'list arg-names
(mapcar #'cffi-type->ecl-type arg-types))
,body)
(setf (gethash ',name *callbacks*) ',cb-name))))
(defun %callback (name)
(multiple-value-bind (symbol winp)
(gethash name *callbacks*)
(unless winp
(error "Undefined callback: ~S" name))
(ffi:callback symbol)))
;;;# Foreign Globals
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(declare (ignore library))
(handler-case
(si:find-foreign-symbol (coerce name 'base-string)
:default :pointer-void 0)
(error (c) nil)))

313
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-gcl.lisp Normal file
View file

@ -0,0 +1,313 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-gcl.lisp --- CFFI-SYS implementation for GNU Common Lisp.
;;;
;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;; GCL specific notes:
;;;
;;; On ELF systems, a library can be loaded with the help of this:
;;; http://www.copyleft.de/lisp/gcl-elf-loader.html
;;;
;;; Another way is to link the library when creating a new image:
;;; (compiler::link nil "new_image" "" "-lfoo")
;;;
;;; As GCL's FFI is not dynamic, CFFI declarations will only work
;;; after compiled and loaded.
;;; *** this port is broken ***
;;; gcl doesn't compile the rest of CFFI anyway..
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:pointerp
#:%foreign-alloc
#:foreign-free
#:with-foreign-ptr
#:null-ptr
#:null-ptr-p
#:inc-ptr
#:%mem-ref
#:%mem-set
#:%foreign-funcall
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
;#:make-shareable-byte-vector
;#:with-pointer-to-vector-data
#:foreign-var-ptr
#:make-callback))
(in-package #:cffi-sys)
;;;# Mis-*features*
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :cffi/no-foreign-funcall *features*))
;;; Symbol case.
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Allocation
;;;
;;; Functions and macros for allocating foreign memory on the stack
;;; and on the heap. The main CFFI package defines macros that wrap
;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
;;; usage when the memory has dynamic extent.
(defentry %foreign-alloc (int) (int "malloc"))
;(defun foreign-alloc (size)
; "Allocate SIZE bytes on the heap and return a pointer."
; (%foreign-alloc size))
(defentry foreign-free (int) (void "free"))
;(defun foreign-free (ptr)
; "Free a PTR allocated by FOREIGN-ALLOC."
; (%free ptr))
(defmacro with-foreign-ptr ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
`(let* ((,size-var ,size)
(,var (foreign-alloc ,size-var)))
(unwind-protect
(progn ,@body)
(foreign-free ,var))))
;;;# Misc. Pointer Operations
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(integerp ptr))
(defun null-ptr ()
"Construct and return a null pointer."
0)
(defun null-ptr-p (ptr)
"Return true if PTR is a null pointer."
(= ptr 0))
(defun inc-ptr (ptr offset)
"Return a pointer OFFSET bytes past PTR."
(+ ptr offset))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
;(defun make-shareable-byte-vector (size)
; "Create a Lisp vector of SIZE bytes that can passed to
;WITH-POINTER-TO-VECTOR-DATA."
; (make-array size :element-type '(unsigned-byte 8)))
;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
; `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
; ,@body))
;;;# Dereferencing
(defmacro define-mem-ref/set (type gcl-type &optional c-name)
(unless c-name
(setq c-name (substitute #\_ #\Space type)))
(let ((ref-fn (concatenate 'string "ref_" c-name))
(set-fn (concatenate 'string "set_" c-name)))
`(progn
;; ref
(defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type)
0 "return *ptr;")
(defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn)))
(int) (,gcl-type ,ref-fn))
;; set
(defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type type)
0 "*ptr = value;")
(defentry ,(intern (string-upcase (substitute #\- #\_ set-fn)))
(int ,gcl-type) (void ,set-fn)))))
(define-mem-ref/set "char" char)
(define-mem-ref/set "unsigned char" char)
(define-mem-ref/set "short" int)
(define-mem-ref/set "unsigned short" int)
(define-mem-ref/set "int" int)
(define-mem-ref/set "unsigned int" int)
(define-mem-ref/set "long" int)
(define-mem-ref/set "unsigned long" int)
(define-mem-ref/set "float" float)
(define-mem-ref/set "double" double)
(define-mem-ref/set "void *" int "ptr")
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference an object of TYPE at OFFSET bytes from PTR."
(unless (zerop offset)
(incf ptr offset))
(ecase type
(:char (ref-char ptr))
(:unsigned-char (ref-unsigned-char ptr))
(:short (ref-short ptr))
(:unsigned-short (ref-unsigned-short ptr))
(:int (ref-int ptr))
(:unsigned-int (ref-unsigned-int ptr))
(:long (ref-long ptr))
(:unsigned-long (ref-unsigned-long ptr))
(:float (ref-float ptr))
(:double (ref-double ptr))
(:pointer (ref-ptr ptr))))
(defun %mem-set (value ptr type &optional (offset 0))
(unless (zerop offset)
(incf ptr offset))
(ecase type
(:char (set-char ptr value))
(:unsigned-char (set-unsigned-char ptr value))
(:short (set-short ptr value))
(:unsigned-short (set-unsigned-short ptr value))
(:int (set-int ptr value))
(:unsigned-int (set-unsigned-int ptr value))
(:long (set-long ptr value))
(:unsigned-long (set-unsigned-long ptr value))
(:float (set-float ptr value))
(:double (set-double ptr value))
(:pointer (set-ptr ptr value)))
value)
;;;# Calling Foreign Functions
;; TODO: figure out if these type conversions make any sense...
(defun convert-foreign-type (type-keyword)
"Convert a CFFI type keyword to a GCL type."
(ecase type-keyword
(:char 'char)
(:unsigned-char 'char)
(:short 'int)
(:unsigned-short 'int)
(:int 'int)
(:unsigned-int 'int)
(:long 'int)
(:unsigned-long 'int)
(:float 'float)
(:double 'double)
(:pointer 'int)
(:void 'void)))
(defparameter +cffi-types+
'(:char :unsigned-char :short :unsigned-short :int :unsigned-int
:long :unsigned-long :float :double :pointer))
(defcfun "int size_of(int type)" 0
"switch (type) {
case 0: return sizeof(char);
case 1: return sizeof(unsigned char);
case 2: return sizeof(short);
case 3: return sizeof(unsigned short);
case 4: return sizeof(int);
case 5: return sizeof(unsigned int);
case 6: return sizeof(long);
case 7: return sizeof(unsigned long);
case 8: return sizeof(float);
case 9: return sizeof(double);
case 10: return sizeof(void *);
default: return -1;
}")
(defentry size-of (int) (int "size_of"))
;; TODO: all this is doable inside the defcfun; figure that out..
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(size-of (position type-keyword +cffi-types+)))
(defcfun "int align_of(int type)" 0
"switch (type) {
case 0: return __alignof__(char);
case 1: return __alignof__(unsigned char);
case 2: return __alignof__(short);
case 3: return __alignof__(unsigned short);
case 4: return __alignof__(int);
case 5: return __alignof__(unsigned int);
case 6: return __alignof__(long);
case 7: return __alignof__(unsigned long);
case 8: return __alignof__(float);
case 9: return __alignof__(double);
case 10: return __alignof__(void *);
default: return -1;
}")
(defentry align-of (int) (int "align_of"))
;; TODO: like %foreign-type-size
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(align-of (position type-keyword +cffi-types+)))
#+ignore
(defun convert-external-name (name)
"Add an underscore to NAME if necessary for the ABI."
#+darwinppc-target (concatenate 'string "_" name)
#-darwinppc-target name)
(defmacro %foreign-funcall (function-name &rest args)
"Perform a foreign function all, document it more later."
`(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
(defun defcfun-helper-forms (name rettype args types)
"Return 2 values for DEFCFUN. A prelude form and a caller form."
(let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name))))
(values
`(defentry ,ff-name ,(mapcar #'convert-foreign-type types)
(,(convert-foreign-type rettype) ,name))
`(,ff-name ,@args))))
;;;# Callbacks
;;; XXX unimplemented
(defmacro make-callback (name rettype arg-names arg-types body-form)
0)
;;;# Loading Foreign Libraries
(defun %load-foreign-library (name)
"_Won't_ load the foreign library NAME."
(declare (ignore name)))
;;;# Foreign Globals
;;; XXX unimplemented
(defmacro foreign-var-ptr (name)
"Return a pointer pointing to the foreign symbol NAME."
0)

417
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-lispworks.lisp Normal file
View file

@ -0,0 +1,417 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-lispworks.lisp --- Lispworks CFFI-SYS implementation.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:cl #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:defcfun-helper-forms
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Misfeatures
#-lispworks-64bit (pushnew 'no-long-long *features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Basic Pointer Operations
(deftype foreign-pointer ()
'fli::pointer)
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(fli:pointerp ptr))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(fli:pointer-eq ptr1 ptr2))
;; We use FLI:MAKE-POINTER here instead of FLI:*NULL-POINTER* since old
;; versions of Lispworks don't seem to have it.
(defun null-pointer ()
"Return a null foreign pointer."
(fli:make-pointer :address 0 :type :void))
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(check-type ptr fli::pointer)
(fli:null-pointer-p ptr))
;; FLI:INCF-POINTER won't work on FLI pointers to :void so we
;; increment "manually."
(defun inc-pointer (ptr offset)
"Return a pointer OFFSET bytes past PTR."
(fli:make-pointer :type :void :address (+ (fli:pointer-address ptr) offset)))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(fli:make-pointer :type :void :address address))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(fli:pointer-address ptr))
;;;# Allocation
(defun %foreign-alloc (size)
"Allocate SIZE bytes of memory and return a pointer."
(fli:allocate-foreign-object :type :byte :nelems size))
(defun foreign-free (ptr)
"Free a pointer PTR allocated by FOREIGN-ALLOC."
(fli:free-foreign-object ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. Both the
pointer in VAR and the memory it points to have dynamic extent and may
be stack allocated if supported by the implementation."
(unless size-var
(setf size-var (gensym "SIZE")))
`(fli:with-dynamic-foreign-objects ()
(let* ((,size-var ,size)
(,var (fli:alloca :type :byte :nelems ,size-var)))
,@body)))
;;;# Shareable Vectors
(defun make-shareable-byte-vector (size)
"Create a shareable byte vector."
#+(or lispworks3 lispworks4 lispworks5.0)
(sys:in-static-area
(make-array size :element-type '(unsigned-byte 8)))
#-(or lispworks3 lispworks4 lispworks5.0)
(make-array size :element-type '(unsigned-byte 8) :allocation :static))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a pointer at the data in VECTOR."
`(fli:with-dynamic-lisp-array-pointer (,ptr-var ,vector)
,@body))
;;;# Dereferencing
(defun convert-foreign-type (cffi-type)
"Convert a CFFI type keyword to an FLI type."
(ecase cffi-type
(:char :byte)
(:unsigned-char '(:unsigned :byte))
(:short :short)
(:unsigned-short '(:unsigned :short))
(:int :int)
(:unsigned-int '(:unsigned :int))
(:long :long)
(:unsigned-long '(:unsigned :long))
;; On 32-bit platforms, Lispworks 5.0+ supports long-long for
;; DEFCFUN and FOREIGN-FUNCALL.
(:long-long '(:long :long))
(:unsigned-long-long '(:unsigned :long :long))
(:float :float)
(:double :double)
(:pointer :pointer)
(:void :void)))
;;; Convert a CFFI type keyword to a symbol suitable for passing to
;;; FLI:FOREIGN-TYPED-AREF.
#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
(defun convert-foreign-typed-aref-type (cffi-type)
(ecase cffi-type
((:char :short :int :long #+lispworks-64bit :long-long)
`(signed-byte ,(* 8 (%foreign-type-size cffi-type))))
((:unsigned-char :unsigned-short :unsigned-int :unsigned-long
#+lispworks-64bit :unsigned-long-long)
`(unsigned-byte ,(* 8 (%foreign-type-size cffi-type))))
(:float 'single-float)
(:double 'double-float)))
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference an object of type TYPE OFFSET bytes from PTR."
(unless (zerop offset)
(setf ptr (inc-pointer ptr offset)))
(fli:dereference ptr :type (convert-foreign-type type)))
;; Lispworks 5.0 on 64-bit platforms doesn't have [u]int64 support in
;; FOREIGN-TYPED-AREF. That was implemented in 5.1.
#+(and lispworks-64bit lispworks5.0)
(defun 64-bit-type-p (type)
(member type '(:long :unsigned-long :long-long :unsigned-long-long)))
;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-REF.
#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
(if (constantp type)
(let ((type (eval type)))
(if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type)
(eql type :pointer))
(let ((fli-type (convert-foreign-type type))
(ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
`(fli:dereference ,ptr-form :type ',fli-type))
(let ((lisp-type (convert-foreign-typed-aref-type type)))
`(locally
(declare (optimize (speed 3) (safety 0)))
(fli:foreign-typed-aref ',lisp-type ,ptr (the fixnum ,off))))))
form))
;;; Open-code the call to FLI:DEREFERENCE when TYPE is constant at
;;; macroexpansion time, when FLI:FOREIGN-TYPED-AREF is not available.
#-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
(if (constantp type)
(let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
(type (convert-foreign-type (eval type))))
`(fli:dereference ,ptr-form :type ',type))
form))
(defun %mem-set (value ptr type &optional (offset 0))
"Set the object of TYPE at OFFSET bytes from PTR."
(unless (zerop offset)
(setf ptr (inc-pointer ptr offset)))
(setf (fli:dereference ptr :type (convert-foreign-type type)) value))
;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-SET.
#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
(if (constantp type)
(once-only (val)
(let ((type (eval type)))
(if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type)
(eql type :pointer))
(let ((fli-type (convert-foreign-type type))
(ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
`(setf (fli:dereference ,ptr-form :type ',fli-type) ,val))
(let ((lisp-type (convert-foreign-typed-aref-type type)))
`(locally
(declare (optimize (speed 3) (safety 0)))
(setf (fli:foreign-typed-aref ',lisp-type ,ptr
(the fixnum ,off))
,val))))))
form))
;;; Open-code the call to (SETF FLI:DEREFERENCE) when TYPE is constant
;;; at macroexpansion time.
#-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
(if (constantp type)
(once-only (val)
(let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
(type (convert-foreign-type (eval type))))
`(setf (fli:dereference ,ptr-form :type ',type) ,val)))
form))
;;;# Foreign Type Operations
(defun %foreign-type-size (type)
"Return the size in bytes of a foreign type."
(fli:size-of (convert-foreign-type type)))
(defun %foreign-type-alignment (type)
"Return the structure alignment in bytes of foreign type."
#+(and darwin harp::powerpc)
(when (eq type :double)
(return-from %foreign-type-alignment 8))
;; Override not necessary for the remaining types...
(fli:align-of (convert-foreign-type type)))
;;;# Calling Foreign Functions
(defvar *foreign-funcallable-cache* (make-hash-table :test 'equal)
"Caches foreign funcallables created by %FOREIGN-FUNCALL or
%FOREIGN-FUNCALL-POINTER. We only need to have one per each
signature.")
(defun foreign-funcall-type-and-args (args)
"Returns a list of types, list of args and return type."
(let ((return-type :void))
(loop for (type arg) on args by #'cddr
if arg collect (convert-foreign-type type) into types
and collect arg into fargs
else do (setf return-type (convert-foreign-type type))
finally (return (values types fargs return-type)))))
(defun create-foreign-funcallable (types rettype convention)
"Creates a foreign funcallable for the signature TYPES -> RETTYPE."
#+mac (declare (ignore convention))
(format t "~&Creating foreign funcallable for signature ~S -> ~S~%"
types rettype)
;; yes, ugly, this most likely wants to be a top-level form...
(let ((internal-name (gensym)))
(funcall
(compile nil
`(lambda ()
(fli:define-foreign-funcallable ,internal-name
,(loop for type in types
collect (list (gensym) type))
:result-type ,rettype
:language :ansi-c
;; avoid warning about cdecl not being supported on mac
#-mac ,@(list :calling-convention convention)))))
internal-name))
(defun get-foreign-funcallable (types rettype convention)
"Returns a foreign funcallable for the signature TYPES -> RETTYPE -
either from the cache or newly created."
(let ((signature (cons rettype types)))
(or (gethash signature *foreign-funcallable-cache*)
;; (SETF GETHASH) is supposed to be thread-safe
(setf (gethash signature *foreign-funcallable-cache*)
(create-foreign-funcallable types rettype convention)))))
(defmacro %%foreign-funcall (foreign-function args convention)
"Does the actual work for %FOREIGN-FUNCALL-POINTER and %FOREIGN-FUNCALL.
Checks if a foreign funcallable which fits ARGS already exists and creates
and caches it if necessary. Finally calls it."
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(funcall (load-time-value
(get-foreign-funcallable ',types ',rettype ',convention))
,foreign-function ,@fargs)))
(defmacro %foreign-funcall (name args &key library convention)
"Calls a foreign function named NAME passing arguments ARGS."
`(%%foreign-funcall
(fli:make-pointer :symbol-name ,name
:module ',(if (eq library :default) nil library))
,args ,convention))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
"Calls a foreign function pointed at by PTR passing arguments ARGS."
`(%%foreign-funcall ,ptr ,args ,convention))
(defun defcfun-helper-forms (name lisp-name rettype args types options)
"Return 2 values for DEFCFUN. A prelude form and a caller form."
(let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
(values
`(fli:define-foreign-function (,ff-name ,name :source)
,(mapcar (lambda (ty) (list (gensym) (convert-foreign-type ty)))
types)
:result-type ,(convert-foreign-type rettype)
:language :ansi-c
:module ',(let ((lib (getf options :library)))
(if (eq lib :default) nil lib))
;; avoid warning about cdecl not being supported on mac platforms
#-mac ,@(list :calling-convention (getf options :convention)))
`(,ff-name ,@args))))
;;;# Callbacks
(defvar *callbacks* (make-hash-table))
;;; Create a package to contain the symbols for callback functions. We
;;; want to redefine callbacks with the same symbol so the internal data
;;; structures are reused.
(defpackage #:cffi-callbacks
(:use))
;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
;;; callback for NAME.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun intern-callback (name)
(intern (format nil "~A::~A"
(if-let (package (symbol-package name))
(package-name package)
"#")
(symbol-name name))
'#:cffi-callbacks)))
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(let ((cb-name (intern-callback name)))
`(progn
(fli:define-foreign-callable
(,cb-name :encode :lisp
:result-type ,(convert-foreign-type rettype)
:calling-convention ,convention
:language :ansi-c
:no-check nil)
,(mapcar (lambda (sym type)
(list sym (convert-foreign-type type)))
arg-names arg-types)
,body)
(setf (gethash ',name *callbacks*) ',cb-name))))
(defun %callback (name)
(multiple-value-bind (symbol winp)
(gethash name *callbacks*)
(unless winp
(error "Undefined callback: ~S" name))
(fli:make-pointer :symbol-name symbol :module :callbacks)))
;;;# Loading Foreign Libraries
(defun %load-foreign-library (name path)
"Load the foreign library NAME."
(fli:register-module (or name path) :connection-style :immediate
:real-name path))
(defun %close-foreign-library (name)
"Close the foreign library NAME."
(fli:disconnect-module name :remove t))
(defun native-namestring (pathname)
(namestring pathname))
;;;# Foreign Globals
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(values
(ignore-errors
(fli:make-pointer :symbol-name name :type :void
:module (if (eq library :default) nil library)))))

396
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-mcl.lisp Normal file
View file

@ -0,0 +1,396 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-mcl.lisp --- CFFI-SYS implementation for Digitool MCL.
;;;
;;; Copyright 2010 james.anderson@setf.de
;;; Copyright 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;; this is a stop-gap emulation. (at least) three things are not right
;;; - integer vector arguments are copied
;;; - return values are not typed
;;; - a shared library must be packaged as a framework and statically loaded
;;;
;;; on the topic of shared libraries, see
;;; http://developer.apple.com/library/mac/#documentation/DeveloperTools/Conceptual/MachOTopics/1-Articles/loading_code.html
;;; which describes how to package a shared library as a framework.
;;; once a framework exists, load it as, eg.
;;; (ccl::add-framework-bundle "fftw.framework" :pathname "ccl:frameworks;" )
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:ccl)
(:import-from #:alexandria #:once-only #:if-let)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp ; ccl:pointerp
#:pointer-eq
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%mem-ref
#:%mem-set
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Misfeatures
(pushnew 'flat-namespace *features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Allocation
;;;
;;; Functions and macros for allocating foreign memory on the stack
;;; and on the heap. The main CFFI package defines macros that wrap
;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
;;; usage when the memory has dynamic extent.
(defun %foreign-alloc (size)
"Allocate SIZE bytes on the heap and return a pointer."
(#_newPtr size))
(defun foreign-free (ptr)
"Free a PTR allocated by FOREIGN-ALLOC."
;; TODO: Should we make this a dead macptr?
(#_disposePtr ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
`(let ((,size-var ,size))
(ccl:%stack-block ((,var ,size-var))
,@body)))
;;;# Misc. Pointer Operations
(deftype foreign-pointer ()
'ccl:macptr)
(defun null-pointer ()
"Construct and return a null pointer."
(ccl:%null-ptr))
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(ccl:%null-ptr-p ptr))
(defun inc-pointer (ptr offset)
"Return a pointer OFFSET bytes past PTR."
(ccl:%inc-ptr ptr offset))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(ccl:%ptr-eql ptr1 ptr2))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(ccl:%int-to-ptr address))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(ccl:%ptr-to-int ptr))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes that can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)))
;;; from openmcl::macros.lisp
(defmacro with-pointer-to-vector-data ((ptr ivector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
(let* ((v (gensym))
(l (gensym)))
`(let* ((,v ,ivector)
(,l (length ,v)))
(unless (typep ,v 'ccl::ivector) (ccl::report-bad-arg ,v 'ccl::ivector))
;;;!!! this, unless it's possible to suppress gc
(let ((,ptr (#_newPtr ,l)))
(unwind-protect (progn (ccl::%copy-ivector-to-ptr ,v 0 ,ptr 0 ,l)
(mutliple-value-prog1
(locally ,@body)
(ccl::%copy-ptr-to-ivector ,ptr 0 ,v 0 ,l)))
(#_disposePtr ,ptr))))))
;;;# Dereferencing
;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
;;; macros that optimize the case where the type keyword is constant
;;; at compile-time.
(defmacro define-mem-accessors (&body pairs)
`(progn
(defun %mem-ref (ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (,fn ptr offset)))))
(defun %mem-set (value ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (setf (,fn ptr offset) value)))))
(define-compiler-macro %mem-ref
(&whole form ptr type &optional (offset 0))
(if (constantp type)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(,',fn ,ptr ,offset))))
form))
(define-compiler-macro %mem-set
(&whole form value ptr type &optional (offset 0))
(if (constantp type)
(once-only (value)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(setf (,',fn ,ptr ,offset)
,value)))))
form))))
(define-mem-accessors
(:char %get-signed-byte)
(:unsigned-char %get-unsigned-byte)
(:short %get-signed-word)
(:unsigned-short %get-unsigned-word)
(:int %get-signed-long)
(:unsigned-int %get-unsigned-long)
(:long %get-signed-long)
(:unsigned-long %get-unsigned-long)
(:long-long ccl::%get-signed-long-long)
(:unsigned-long-long ccl::%get-unsigned-long-long)
(:float %get-single-float)
(:double %get-double-float)
(:pointer %get-ptr))
(defun ccl::%get-unsigned-long-long (ptr offset)
(let ((value 0) (bit 0))
(dotimes (i 8)
(setf (ldb (byte 8 (shiftf bit (+ bit 8))) value)
(ccl:%get-unsigned-byte ptr (+ offset i))))
value))
(setf (fdefinition 'ccl::%get-signed-long-long)
(fdefinition 'ccl::%get-unsigned-long-long))
(defun (setf ccl::%get-unsigned-long-long) (value ptr offset)
(let ((bit 0))
(dotimes (i 8)
(setf (ccl:%get-unsigned-byte ptr (+ offset i))
(ldb (byte 8 (shiftf bit (+ bit 8))) value))))
ptr)
(setf (fdefinition '(setf ccl::%get-signed-long-long))
(fdefinition '(setf ccl::%get-unsigned-long-long)))
;;;# Calling Foreign Functions
(defun convert-foreign-type (type-keyword)
"Convert a CFFI type keyword to a ppc-ff-call type."
(ecase type-keyword
(:char :signed-byte)
(:unsigned-char :unsigned-byte)
(:short :signed-short)
(:unsigned-short :unsigned-short)
(:int :signed-fullword)
(:unsigned-int :unsigned-fullword)
(:long :signed-fullword)
(:unsigned-long :unsigned-fullword)
(:long-long :signed-doubleword)
(:unsigned-long-long :unsigned-doubleword)
(:float :single-float)
(:double :double-float)
(:pointer :address)
(:void :void)))
(defun ppc-ff-call-type=>mactype-name (type-keyword)
(ecase type-keyword
(:signed-byte :sint8)
(:unsigned-byte :uint8)
(:signed-short :sint16)
(:unsigned-short :uint16)
(:signed-halfword :sint16)
(:unsigned-halfword :uint16)
(:signed-fullword :sint32)
(:unsigned-fullword :uint32)
;(:signed-doubleword :long-long)
;(:unsigned-doubleword :unsigned-long-long)
(:single-float :single-float)
(:double-float :double-float)
(:address :pointer)
(:void :void)))
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(case type-keyword
((:long-long :unsigned-long-long) 8)
(t (ccl::mactype-record-size
(ccl::find-mactype
(ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword)))))))
;; There be dragons here. See the following thread for details:
;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(case type-keyword
((:long-long :unsigned-long-long) 4)
(t (ccl::mactype-record-size
(ccl::find-mactype
(ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword)))))))
(defun convert-foreign-funcall-types (args)
"Convert foreign types for a call to FOREIGN-FUNCALL."
(loop for (type arg) on args by #'cddr
collect (convert-foreign-type type)
if arg collect arg))
(defun convert-external-name (name)
"no '_' is necessary here, the internal lookup operators handle it"
name)
(defmacro %foreign-funcall (function-name args &key library convention)
"Perform a foreign function call, document it more later."
(declare (ignore library convention))
`(ccl::ppc-ff-call
(ccl::macho-address ,(ccl::get-macho-entry-point (convert-external-name function-name)))
,@(convert-foreign-funcall-types args)))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
(declare (ignore convention))
`(ccl::ppc-ff-call ,ptr ,@(convert-foreign-funcall-types args)))
;;;# Callbacks
;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
;;; entry points. It is safe to store the pointers directly because
;;; OpenMCL will update the address of these pointers when a saved image
;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
(defvar *callbacks* (make-hash-table))
;;; Create a package to contain the symbols for callback functions. We
;;; want to redefine callbacks with the same symbol so the internal data
;;; structures are reused.
(defpackage #:cffi-callbacks
(:use))
;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
;;; callback for NAME.
(defun intern-callback (name)
(intern (format nil "~A::~A"
(if-let (package (symbol-package name))
(package-name package)
"#")
(symbol-name name))
'#:cffi-callbacks))
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(declare (ignore convention))
(let ((cb-name (intern-callback name)))
`(progn
(ccl::ppc-defpascal ,cb-name
(;; ? ,@(when (eq convention :stdcall) '(:discard-stack-args))
,@(mapcan (lambda (sym type)
(list (ppc-ff-call-type=>mactype-name (convert-foreign-type type)) sym))
arg-names arg-types)
,(ppc-ff-call-type=>mactype-name (convert-foreign-type rettype)))
,body)
(setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
(defun %callback (name)
(or (gethash name *callbacks*)
(error "Undefined callback: ~S" name)))
;;;# Loading Foreign Libraries
(defun %load-foreign-library (name path)
"Load the foreign library NAME."
(declare (ignore path))
(setf name (string name))
;; for mcl emulate this wrt frameworks
(unless (and (> (length name) 10)
(string-equal name ".framework" :start1 (- (length name) 10)))
(setf name (concatenate 'string name ".framework")))
;; if the framework was not registered, add it
(unless (gethash name ccl::*framework-descriptors*)
(ccl::add-framework-bundle name :pathname "ccl:frameworks;" ))
(ccl::load-framework-bundle name))
(defun %close-foreign-library (name)
"Close the foreign library NAME."
;; for mcl do nothing
(declare (ignore name))
nil)
(defun native-namestring (pathname)
(ccl::posix-namestring (ccl:full-pathname pathname)))
;;;# Foreign Globals
(deftrap-inline "_findsymbol"
((map :pointer)
(name :pointer))
:pointer
())
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(declare (ignore library))
(ccl::macho-address
(ccl::get-macho-entry-point (convert-external-name name))))

342
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-mkcl.lisp Normal file
View file

@ -0,0 +1,342 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-mkcl.lisp --- MKCL backend for CFFI.
;;;
;;; Copyright (C) 2010-2012, Jean-Claude Beaudoin
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:alexandria)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Mis-features
(pushnew 'flat-namespace *features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Allocation
(defun %foreign-alloc (size)
"Allocate SIZE bytes of foreign-addressable memory."
(si:allocate-foreign-data :void size))
(defun foreign-free (ptr)
"Free a pointer PTR allocated by FOREIGN-ALLOC."
(si:free-foreign-data ptr)
nil)
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
`(let* ((,size-var ,size)
(,var (%foreign-alloc ,size-var)))
(unwind-protect
(progn ,@body)
(foreign-free ,var))))
;;;# Misc. Pointer Operations
(deftype foreign-pointer ()
'si:foreign)
(defun null-pointer ()
"Construct and return a null pointer."
(si:make-foreign-null-pointer))
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(si:null-pointer-p ptr))
(defun inc-pointer (ptr offset)
"Return a pointer OFFSET bytes past PTR."
(ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
;;(typep ptr 'si:foreign)
(si:foreignp ptr))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(ffi:make-pointer address :void))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(ffi:pointer-address ptr))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes that can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)))
;;; MKCL, built with the Boehm GC never moves allocated data, so this
;;; isn't nearly as hard to do.
(defun %vector-address (vector)
"Return the address of VECTOR's data."
(check-type vector (vector (unsigned-byte 8)))
#-mingw64
(ffi:c-inline (vector) (object)
:unsigned-long
"(uintptr_t) #0->vector.self.b8"
:side-effects nil
:one-liner t)
#+mingw64
(ffi:c-inline (vector) (object)
:unsigned-long-long
"(uintptr_t) #0->vector.self.b8"
:side-effects nil
:one-liner t))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
`(let ((,ptr-var (make-pointer (%vector-address ,vector))))
,@body))
;;;# Dereferencing
(defun %mem-ref (ptr type &optional (offset 0))
"Dereference an object of TYPE at OFFSET bytes from PTR."
(let* ((type (cffi-type->mkcl-type type))
(type-size (ffi:size-of-foreign-type type)))
(si:foreign-ref-elt
(si:foreign-recast ptr (+ offset type-size) :void) offset type)))
(defun %mem-set (value ptr type &optional (offset 0))
"Set an object of TYPE at OFFSET bytes from PTR."
(let* ((type (cffi-type->mkcl-type type))
(type-size (ffi:size-of-foreign-type type)))
(si:foreign-set-elt
(si:foreign-recast ptr (+ offset type-size) :void)
offset type value)))
;;;# Type Operations
(defconstant +translation-table+
'((:char :byte "char")
(:unsigned-char :unsigned-byte "unsigned char")
(:short :short "short")
(:unsigned-short :unsigned-short "unsigned short")
(:int :int "int")
(:unsigned-int :unsigned-int "unsigned int")
(:long :long "long")
(:unsigned-long :unsigned-long "unsigned long")
(:long-long :long-long "long long")
(:unsigned-long-long :unsigned-long-long "unsigned long long")
(:float :float "float")
(:double :double "double")
(:pointer :pointer-void "void*")
(:void :void "void")))
(defun cffi-type->mkcl-type (type-keyword)
"Convert a CFFI type keyword to an MKCL type keyword."
(or (second (find type-keyword +translation-table+ :key #'first))
(error "~S is not a valid CFFI type" type-keyword)))
(defun mkcl-type->c-type (type-keyword)
"Convert a CFFI type keyword to an valid C type keyword."
(or (third (find type-keyword +translation-table+ :key #'second))
(error "~S is not a valid CFFI type" type-keyword)))
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(nth-value 0 (ffi:size-of-foreign-type
(cffi-type->mkcl-type type-keyword))))
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(nth-value 1 (ffi:size-of-foreign-type
(cffi-type->mkcl-type type-keyword))))
;;;# Calling Foreign Functions
#|
(defconstant +mkcl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
|#
(defun produce-function-pointer-call (pointer types values return-type)
#|
(if (stringp pointer)
(produce-function-pointer-call
`(%foreign-symbol-pointer ,pointer nil) types values return-type)
`(ffi:c-inline
,(list* pointer values)
,(list* :pointer-void types) ,return-type
,(with-output-to-string (s)
(let ((types (mapcar #'mkcl-type->c-type types)))
;; On AMD64, the following code only works with the extra
;; argument ",...". If this is not present, functions
;; like sprintf do not work
(format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)"
(mkcl-type->c-type return-type) types
(subseq +mkcl-inline-codes+ 3
(max 3 (+ 2 (* (length values) 3)))))))
:one-liner t :side-effects t))
|#
;; The version here below is definitely not as efficient as the one above
;; but it has the great vertue of working in all cases, (contrary to the
;; silent and unsafe limitations of the one above). JCB
;; I should re-optimize this one day, when I get time... JCB
(progn
(when (stringp pointer)
(setf pointer `(%foreign-symbol-pointer ,pointer nil)))
`(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values))))
(defun foreign-funcall-parse-args (args)
"Return three values, lists of arg types, values, and result type."
(let ((return-type :void))
(loop for (type arg) on args by #'cddr
if arg collect (cffi-type->mkcl-type type) into types
and collect arg into values
else do (setf return-type (cffi-type->mkcl-type type))
finally (return (values types values return-type)))))
(defmacro %foreign-funcall (name args &key library convention)
"Call a foreign function."
(declare (ignore library convention))
(multiple-value-bind (types values return-type)
(foreign-funcall-parse-args args)
(produce-function-pointer-call name types values return-type)))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
"Funcall a pointer to a foreign function."
(declare (ignore convention))
(multiple-value-bind (types values return-type)
(foreign-funcall-parse-args args)
(produce-function-pointer-call ptr types values return-type)))
;;;# Foreign Libraries
(defun %load-foreign-library (name path)
"Load a foreign library."
(declare (ignore name))
(handler-case (si:load-foreign-module path)
(file-error ()
(error "file error while trying to load `~A'" path))))
(defun %close-foreign-library (handle)
;;(declare (ignore handle))
;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.")
(si:unload-foreign-module handle))
(defun native-namestring (pathname)
(namestring pathname))
;;;# Callbacks
;;; Create a package to contain the symbols for callback functions.
;;; We want to redefine callbacks with the same symbol so the internal
;;; data structures are reused.
(defpackage #:cffi-callbacks
(:use))
(defvar *callbacks* (make-hash-table))
;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
;;; internal callback for NAME.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun intern-callback (name)
(intern (format nil "~A::~A"
(if-let (package (symbol-package name))
(package-name package)
"#")
(symbol-name name))
'#:cffi-callbacks)))
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(declare (ignore convention))
(let ((cb-name (intern-callback name)))
`(progn
(ffi:defcallback (,cb-name :cdecl)
,(cffi-type->mkcl-type rettype)
,(mapcar #'list arg-names
(mapcar #'cffi-type->mkcl-type arg-types))
;;(block ,cb-name ,@body)
(block ,cb-name ,body))
(setf (gethash ',name *callbacks*) ',cb-name))))
(defun %callback (name)
(multiple-value-bind (symbol winp)
(gethash name *callbacks*)
(unless winp
(error "Undefined callback: ~S" name))
(ffi:callback symbol)))
;;;# Foreign Globals
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(declare (ignore library))
(values (ignore-errors (si:find-foreign-symbol name :default :pointer-void 0))))

314
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-openmcl.lisp Normal file
View file

@ -0,0 +1,314 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-openmcl.lisp --- CFFI-SYS implementation for OpenMCL.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:ccl)
(:import-from #:alexandria #:once-only #:if-let)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp ; ccl:pointerp
#:pointer-eq
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%mem-ref
#:%mem-set
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Misfeatures
(pushnew 'flat-namespace *features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Allocation
;;;
;;; Functions and macros for allocating foreign memory on the stack
;;; and on the heap. The main CFFI package defines macros that wrap
;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
;;; usage when the memory has dynamic extent.
(defun %foreign-alloc (size)
"Allocate SIZE bytes on the heap and return a pointer."
(ccl::malloc size))
(defun foreign-free (ptr)
"Free a PTR allocated by FOREIGN-ALLOC."
;; TODO: Should we make this a dead macptr?
(ccl::free ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
`(let ((,size-var ,size))
(%stack-block ((,var ,size-var))
,@body)))
;;;# Misc. Pointer Operations
(deftype foreign-pointer ()
'ccl:macptr)
(defun null-pointer ()
"Construct and return a null pointer."
(ccl:%null-ptr))
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(ccl:%null-ptr-p ptr))
(defun inc-pointer (ptr offset)
"Return a pointer OFFSET bytes past PTR."
(ccl:%inc-ptr ptr offset))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(ccl:%ptr-eql ptr1 ptr2))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
(ccl:%int-to-ptr address))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(ccl:%ptr-to-int ptr))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes that can passed to
WITH-POINTER-TO-VECTOR-DATA."
(make-array size :element-type '(unsigned-byte 8)))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
`(ccl:with-pointer-to-ivector (,ptr-var ,vector)
,@body))
;;;# Dereferencing
;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
;;; macros that optimize the case where the type keyword is constant
;;; at compile-time.
(defmacro define-mem-accessors (&body pairs)
`(progn
(defun %mem-ref (ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (,fn ptr offset)))))
(defun %mem-set (value ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (setf (,fn ptr offset) value)))))
(define-compiler-macro %mem-ref
(&whole form ptr type &optional (offset 0))
(if (constantp type)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(,',fn ,ptr ,offset))))
form))
(define-compiler-macro %mem-set
(&whole form value ptr type &optional (offset 0))
(if (constantp type)
(once-only (value)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(setf (,',fn ,ptr ,offset)
,value)))))
form))))
(define-mem-accessors
(:char %get-signed-byte)
(:unsigned-char %get-unsigned-byte)
(:short %get-signed-word)
(:unsigned-short %get-unsigned-word)
(:int %get-signed-long)
(:unsigned-int %get-unsigned-long)
#+(or 32-bit-target windows-target) (:long %get-signed-long)
#+(and (not windows-target) 64-bit-target) (:long ccl::%%get-signed-longlong)
#+(or 32-bit-target windows-target) (:unsigned-long %get-unsigned-long)
#+(and 64-bit-target (not windows-target)) (:unsigned-long ccl::%%get-unsigned-longlong)
(:long-long ccl::%get-signed-long-long)
(:unsigned-long-long ccl::%get-unsigned-long-long)
(:float %get-single-float)
(:double %get-double-float)
(:pointer %get-ptr))
;;;# Calling Foreign Functions
(defun convert-foreign-type (type-keyword)
"Convert a CFFI type keyword to an OpenMCL type."
(ecase type-keyword
(:char :signed-byte)
(:unsigned-char :unsigned-byte)
(:short :signed-short)
(:unsigned-short :unsigned-short)
(:int :signed-int)
(:unsigned-int :unsigned-int)
(:long :signed-long)
(:unsigned-long :unsigned-long)
(:long-long :signed-doubleword)
(:unsigned-long-long :unsigned-doubleword)
(:float :single-float)
(:double :double-float)
(:pointer :address)
(:void :void)))
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(/ (ccl::foreign-type-bits
(ccl::parse-foreign-type
(convert-foreign-type type-keyword)))
8))
;; There be dragons here. See the following thread for details:
;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(/ (ccl::foreign-type-alignment
(ccl::parse-foreign-type
(convert-foreign-type type-keyword))) 8))
(defun convert-foreign-funcall-types (args)
"Convert foreign types for a call to FOREIGN-FUNCALL."
(loop for (type arg) on args by #'cddr
collect (convert-foreign-type type)
if arg collect arg))
(defun convert-external-name (name)
"Add an underscore to NAME if necessary for the ABI."
#+darwin (concatenate 'string "_" name)
#-darwin name)
(defmacro %foreign-funcall (function-name args &key library convention)
"Perform a foreign function call, document it more later."
(declare (ignore library convention))
`(external-call
,(convert-external-name function-name)
,@(convert-foreign-funcall-types args)))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
(declare (ignore convention))
`(ff-call ,ptr ,@(convert-foreign-funcall-types args)))
;;;# Callbacks
;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
;;; entry points. It is safe to store the pointers directly because
;;; OpenMCL will update the address of these pointers when a saved image
;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
(defvar *callbacks* (make-hash-table))
;;; Create a package to contain the symbols for callback functions. We
;;; want to redefine callbacks with the same symbol so the internal data
;;; structures are reused.
(defpackage #:cffi-callbacks
(:use))
;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
;;; callback for NAME.
(defun intern-callback (name)
(intern (format nil "~A::~A"
(if-let (package (symbol-package name))
(package-name package)
"#")
(symbol-name name))
'#:cffi-callbacks))
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(let ((cb-name (intern-callback name)))
`(progn
(defcallback ,cb-name
(,@(when (eq convention :stdcall)
'(:discard-stack-args))
,@(mapcan (lambda (sym type)
(list (convert-foreign-type type) sym))
arg-names arg-types)
,(convert-foreign-type rettype))
,body)
(setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
(defun %callback (name)
(or (gethash name *callbacks*)
(error "Undefined callback: ~S" name)))
;;;# Loading Foreign Libraries
(defun %load-foreign-library (name path)
"Load the foreign library NAME."
(declare (ignore name))
(open-shared-library path))
(defun %close-foreign-library (name)
"Close the foreign library NAME."
;; C-S-L sometimes ends in an endless loop
;; with :COMPLETELY T
(close-shared-library name :completely nil))
(defun native-namestring (pathname)
(ccl::native-translated-namestring pathname))
;;;# Foreign Globals
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(declare (ignore library))
(foreign-symbol-address (convert-external-name name)))

408
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-sbcl.lisp Normal file
View file

@ -0,0 +1,408 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:sb-alien)
(:import-from #:alexandria
#:once-only #:with-unique-names #:when-let #:removef)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Misfeatures
(pushnew 'flat-namespace *features*)
;;;# Symbol Case
(declaim (inline canonicalize-symbol-name-case))
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(string-upcase name))
;;;# Basic Pointer Operations
(deftype foreign-pointer ()
'sb-sys:system-area-pointer)
(declaim (inline pointerp))
(defun pointerp (ptr)
"Return true if PTR is a foreign pointer."
(sb-sys:system-area-pointer-p ptr))
(declaim (inline pointer-eq))
(defun pointer-eq (ptr1 ptr2)
"Return true if PTR1 and PTR2 point to the same address."
(declare (type system-area-pointer ptr1 ptr2))
(sb-sys:sap= ptr1 ptr2))
(declaim (inline null-pointer))
(defun null-pointer ()
"Construct and return a null pointer."
(sb-sys:int-sap 0))
(declaim (inline null-pointer-p))
(defun null-pointer-p (ptr)
"Return true if PTR is a null pointer."
(declare (type system-area-pointer ptr))
(zerop (sb-sys:sap-int ptr)))
(declaim (inline inc-pointer))
(defun inc-pointer (ptr offset)
"Return a pointer pointing OFFSET bytes past PTR."
(declare (type system-area-pointer ptr)
(type integer offset))
(sb-sys:sap+ ptr offset))
(declaim (inline make-pointer))
(defun make-pointer (address)
"Return a pointer pointing to ADDRESS."
;; (declare (type (unsigned-byte 32) address))
(sb-sys:int-sap address))
(declaim (inline pointer-address))
(defun pointer-address (ptr)
"Return the address pointed to by PTR."
(declare (type system-area-pointer ptr))
(sb-sys:sap-int ptr))
;;;# Allocation
;;;
;;; Functions and macros for allocating foreign memory on the stack
;;; and on the heap. The main CFFI package defines macros that wrap
;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
;;; when the memory has dynamic extent.
(declaim (inline %foreign-alloc))
(defun %foreign-alloc (size)
"Allocate SIZE bytes on the heap and return a pointer."
;; (declare (type (unsigned-byte 32) size))
(alien-sap (make-alien (unsigned 8) size)))
(declaim (inline foreign-free))
(defun foreign-free (ptr)
"Free a PTR allocated by FOREIGN-ALLOC."
(declare (type system-area-pointer ptr)
(optimize speed))
(free-alien (sap-alien ptr (* (unsigned 8)))))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind VAR to SIZE bytes of foreign memory during BODY. The
pointer in VAR is invalid beyond the dynamic extent of BODY, and
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
;; If the size is constant we can stack-allocate.
(if (constantp size)
(let ((alien-var (gensym "ALIEN")))
`(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
(let ((,size-var ,(eval size))
(,var (alien-sap ,alien-var)))
(declare (ignorable ,size-var))
,@body)))
`(let* ((,size-var ,size)
(,var (%foreign-alloc ,size-var)))
(unwind-protect
(progn ,@body)
(foreign-free ,var)))))
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
;;; should be defined to perform a copy-in/copy-out if the Lisp
;;; implementation can't do this.
(declaim (inline make-shareable-byte-vector))
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of SIZE bytes can passed to
WITH-POINTER-TO-VECTOR-DATA."
; (declare (type sb-int:index size))
(make-array size :element-type '(unsigned-byte 8)))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
(let ((vector-var (gensym "VECTOR")))
`(let ((,vector-var ,vector))
(declare (type (sb-kernel:simple-unboxed-array (*)) ,vector-var))
(sb-sys:with-pinned-objects (,vector-var)
(let ((,ptr-var (sb-sys:vector-sap ,vector-var)))
,@body)))))
;;;# Dereferencing
;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
;;; macros that optimize the case where the type keyword is constant
;;; at compile-time.
(defmacro define-mem-accessors (&body pairs)
`(progn
(defun %mem-ref (ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (,fn ptr offset)))))
(defun %mem-set (value ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (setf (,fn ptr offset) value)))))
(define-compiler-macro %mem-ref
(&whole form ptr type &optional (offset 0))
(if (constantp type)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(,',fn ,ptr ,offset))))
form))
(define-compiler-macro %mem-set
(&whole form value ptr type &optional (offset 0))
(if (constantp type)
(once-only (value)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(setf (,',fn ,ptr ,offset)
,value)))))
form))))
;;; Look up alien type information and build both define-mem-accessors form
;;; and convert-foreign-type function definition.
(defmacro define-type-mapping (accessor-table alien-table)
(let* ((accessible-types
(remove 'void alien-table :key #'second))
(size-and-signedp-forms
(mapcar (lambda (name)
(list (eval `(alien-size ,(second name)))
(typep -1 `(alien ,(second name)))))
accessible-types)))
`(progn
(define-mem-accessors
,@(loop for (cffi-keyword alien-type fixed-accessor)
in accessible-types
and (alien-size signedp)
in size-and-signedp-forms
for (signed-ref unsigned-ref)
= (cdr (assoc alien-size accessor-table))
collect
`(,cffi-keyword
,(or fixed-accessor
(if signedp signed-ref unsigned-ref)
(error "No accessor found for ~S"
alien-type)))))
(defun convert-foreign-type (type-keyword)
(ecase type-keyword
,@(loop for (cffi-keyword alien-type) in alien-table
collect `(,cffi-keyword (quote ,alien-type))))))))
(define-type-mapping
((8 sb-sys:signed-sap-ref-8 sb-sys:sap-ref-8)
(16 sb-sys:signed-sap-ref-16 sb-sys:sap-ref-16)
(32 sb-sys:signed-sap-ref-32 sb-sys:sap-ref-32)
(64 sb-sys:signed-sap-ref-64 sb-sys:sap-ref-64))
((:char char)
(:unsigned-char unsigned-char)
(:short short)
(:unsigned-short unsigned-short)
(:int int)
(:unsigned-int unsigned-int)
(:long long)
(:unsigned-long unsigned-long)
(:long-long long-long)
(:unsigned-long-long unsigned-long-long)
(:float single-float
sb-sys:sap-ref-single)
(:double double-float
sb-sys:sap-ref-double)
(:pointer system-area-pointer
sb-sys:sap-ref-sap)
(:void void)))
;;;# Calling Foreign Functions
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(/ (sb-alien-internals:alien-type-bits
(sb-alien-internals:parse-alien-type
(convert-foreign-type type-keyword) nil)) 8))
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
#+(and darwin ppc (not ppc64))
(case type-keyword
((:double :long-long :unsigned-long-long)
(return-from %foreign-type-alignment 8)))
;; No override necessary for other types...
(/ (sb-alien-internals:alien-type-alignment
(sb-alien-internals:parse-alien-type
(convert-foreign-type type-keyword) nil)) 8))
(defun foreign-funcall-type-and-args (args)
"Return an SB-ALIEN function type for ARGS."
(let ((return-type 'void))
(loop for (type arg) on args by #'cddr
if arg collect (convert-foreign-type type) into types
and collect arg into fargs
else do (setf return-type (convert-foreign-type type))
finally (return (values types fargs return-type)))))
(defmacro %%foreign-funcall (name types fargs rettype)
"Internal guts of %FOREIGN-FUNCALL."
`(alien-funcall
(extern-alien ,name (function ,rettype ,@types))
,@fargs))
(defmacro %foreign-funcall (name args &key library convention)
"Perform a foreign function call, document it more later."
(declare (ignore library convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(%%foreign-funcall ,name ,types ,fargs ,rettype)))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
"Funcall a pointer to a foreign function."
(declare (ignore convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
(with-unique-names (function)
`(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
(alien-funcall ,function ,@fargs)))))
;;;# Callbacks
;;; The *CALLBACKS* hash table contains a direct mapping of CFFI
;;; callback names to SYSTEM-AREA-POINTERs obtained by ALIEN-LAMBDA.
;;; SBCL will maintain the addresses of the callbacks across saved
;;; images, so it is safe to store the pointers directly.
(defvar *callbacks* (make-hash-table))
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(check-type convention (member :stdcall :cdecl))
`(setf (gethash ',name *callbacks*)
(alien-sap
(sb-alien::alien-lambda
#+alien-callback-conventions
(,convention ,(convert-foreign-type rettype))
#-alien-callback-conventions
,(convert-foreign-type rettype)
,(mapcar (lambda (sym type)
(list sym (convert-foreign-type type)))
arg-names arg-types)
,body))))
(defun %callback (name)
(or (gethash name *callbacks*)
(error "Undefined callback: ~S" name)))
;;;# Loading and Closing Foreign Libraries
#+darwin
(defun call-within-initial-thread (fn &rest args)
(let (result
error
(sem (sb-thread:make-semaphore)))
(sb-thread:interrupt-thread
;; KLUDGE: find a better way to get the initial thread.
(car (last (sb-thread:list-all-threads)))
(lambda ()
(multiple-value-setq (result error)
(ignore-errors (apply fn args)))
(sb-thread:signal-semaphore sem)))
(sb-thread:wait-on-semaphore sem)
(if error
(signal error)
result)))
(declaim (inline %load-foreign-library))
(defun %load-foreign-library (name path)
"Load a foreign library."
(declare (ignore name))
;; As of MacOS X 10.6.6, loading things like CoreFoundation from a
;; thread other than the initial one results in a crash.
#+darwin (call-within-initial-thread 'load-shared-object path)
#-darwin (load-shared-object path))
;;; SBCL 1.0.21.15 renamed SB-ALIEN::SHARED-OBJECT-FILE but introduced
;;; SB-ALIEN:UNLOAD-SHARED-OBJECT which we can use instead.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun unload-shared-object-present-p ()
(multiple-value-bind (foundp kind)
(find-symbol "UNLOAD-SHARED-OBJECT" "SB-ALIEN")
(if (and foundp (eq kind :external))
'(:and)
'(:or)))))
(defun %close-foreign-library (handle)
"Closes a foreign library."
#+#.(cffi-sys::unload-shared-object-present-p)
(sb-alien:unload-shared-object handle)
#-#.(cffi-sys::unload-shared-object-present-p)
(sb-thread:with-mutex (sb-alien::*shared-objects-lock*)
(let ((obj (find (sb-ext:native-namestring handle)
sb-alien::*shared-objects*
:key #'sb-alien::shared-object-file
:test #'string=)))
(when obj
(sb-alien::dlclose-or-lose obj)
(removef sb-alien::*shared-objects* obj)
#+(and linkage-table (not win32))
(sb-alien::update-linkage-table)))))
(defun native-namestring (pathname)
(sb-ext:native-namestring pathname))
;;;# Foreign Globals
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(declare (ignore library))
(when-let (address (sb-sys:find-foreign-symbol-address name))
(sb-sys:int-sap address)))

322
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-scl.lisp Normal file
View file

@ -0,0 +1,322 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Lisp.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2006-2007, Scieneer Pty Ltd.
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Administrivia
(defpackage #:cffi-sys
(:use #:common-lisp #:alien #:c-call)
(:import-from #:alexandria #:once-only #:with-unique-names)
(:export
#:canonicalize-symbol-name-case
#:foreign-pointer
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:make-pointer
#:pointer-address
#:%foreign-alloc
#:foreign-free
#:with-foreign-pointer
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
#:%foreign-type-size
#:%load-foreign-library
#:%close-foreign-library
#:native-namestring
#:%mem-ref
#:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:%foreign-symbol-pointer
#:%defcallback
#:%callback))
(in-package #:cffi-sys)
;;;# Mis-features
(pushnew 'flat-namespace *features*)
;;;# Symbol Case
(defun canonicalize-symbol-name-case (name)
(declare (string name))
(if (eq ext:*case-mode* :upper)
(string-upcase name)
(string-downcase name)))
;;;# Basic Pointer Operations
(deftype foreign-pointer ()
'sys:system-area-pointer)
(declaim (inline pointerp))
(defun pointerp (ptr)
"Return true if 'ptr is a foreign pointer."
(sys:system-area-pointer-p ptr))
(declaim (inline pointer-eq))
(defun pointer-eq (ptr1 ptr2)
"Return true if 'ptr1 and 'ptr2 point to the same address."
(sys:sap= ptr1 ptr2))
(declaim (inline null-pointer))
(defun null-pointer ()
"Construct and return a null pointer."
(sys:int-sap 0))
(declaim (inline null-pointer-p))
(defun null-pointer-p (ptr)
"Return true if 'ptr is a null pointer."
(zerop (sys:sap-int ptr)))
(declaim (inline inc-pointer))
(defun inc-pointer (ptr offset)
"Return a pointer pointing 'offset bytes past 'ptr."
(sys:sap+ ptr offset))
(declaim (inline make-pointer))
(defun make-pointer (address)
"Return a pointer pointing to 'address."
(sys:int-sap address))
(declaim (inline pointer-address))
(defun pointer-address (ptr)
"Return the address pointed to by 'ptr."
(sys:sap-int ptr))
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
"Bind 'var to 'size bytes of foreign memory during 'body. The
pointer in 'var is invalid beyond the dynamic extent of 'body, and
may be stack-allocated if supported by the implementation. If
'size-var is supplied, it will be bound to 'size during 'body."
(unless size-var
(setf size-var (gensym (symbol-name '#:size))))
;; If the size is constant we can stack-allocate.
(cond ((constantp size)
(let ((alien-var (gensym (symbol-name '#:alien))))
`(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
(let ((,size-var ,size)
(,var (alien-sap ,alien-var)))
(declare (ignorable ,size-var))
,@body))))
(t
`(let ((,size-var ,size))
(alien:with-bytes (,var ,size-var)
,@body)))))
;;;# Allocation
;;;
;;; Functions and macros for allocating foreign memory on the stack and on the
;;; heap. The main CFFI package defines macros that wrap 'foreign-alloc and
;;; 'foreign-free in 'unwind-protect for the common usage when the memory has
;;; dynamic extent.
(defun %foreign-alloc (size)
"Allocate 'size bytes on the heap and return a pointer."
(declare (type (unsigned-byte #-64bit 32 #+64bit 64) size))
(alien-funcall (extern-alien "malloc"
(function system-area-pointer unsigned))
size))
(defun foreign-free (ptr)
"Free a 'ptr allocated by 'foreign-alloc."
(declare (type system-area-pointer ptr))
(alien-funcall (extern-alien "free"
(function (values) system-area-pointer))
ptr))
;;;# Shareable Vectors
(defun make-shareable-byte-vector (size)
"Create a Lisp vector of 'size bytes that can passed to
'with-pointer-to-vector-data."
(make-array size :element-type '(unsigned-byte 8)))
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
"Bind 'ptr-var to a foreign pointer to the data in 'vector."
(let ((vector-var (gensym (symbol-name '#:vector))))
`(let ((,vector-var ,vector))
(ext:with-pinned-object (,vector-var)
(let ((,ptr-var (sys:vector-sap ,vector-var)))
,@body)))))
;;;# Dereferencing
;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
;;; macros that optimize the case where the type keyword is constant
;;; at compile-time.
(defmacro define-mem-accessors (&body pairs)
`(progn
(defun %mem-ref (ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (,fn ptr offset)))))
(defun %mem-set (value ptr type &optional (offset 0))
(ecase type
,@(loop for (keyword fn) in pairs
collect `(,keyword (setf (,fn ptr offset) value)))))
(define-compiler-macro %mem-ref
(&whole form ptr type &optional (offset 0))
(if (constantp type)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(,',fn ,ptr ,offset))))
form))
(define-compiler-macro %mem-set
(&whole form value ptr type &optional (offset 0))
(if (constantp type)
(once-only (value)
(ecase (eval type)
,@(loop for (keyword fn) in pairs
collect `(,keyword `(setf (,',fn ,ptr ,offset)
,value)))))
form))))
(define-mem-accessors
(:char sys:signed-sap-ref-8)
(:unsigned-char sys:sap-ref-8)
(:short sys:signed-sap-ref-16)
(:unsigned-short sys:sap-ref-16)
(:int sys:signed-sap-ref-32)
(:unsigned-int sys:sap-ref-32)
(:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64)
(:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64)
(:long-long sys:signed-sap-ref-64)
(:unsigned-long-long sys:sap-ref-64)
(:float sys:sap-ref-single)
(:double sys:sap-ref-double)
#+long-float (:long-double sys:sap-ref-long)
(:pointer sys:sap-ref-sap))
;;;# Calling Foreign Functions
(defun convert-foreign-type (type-keyword)
"Convert a CFFI type keyword to an ALIEN type."
(ecase type-keyword
(:char 'char)
(:unsigned-char 'unsigned-char)
(:short 'short)
(:unsigned-short 'unsigned-short)
(:int 'int)
(:unsigned-int 'unsigned-int)
(:long 'long)
(:unsigned-long 'unsigned-long)
(:long-long '(signed 64))
(:unsigned-long-long '(unsigned 64))
(:float 'single-float)
(:double 'double-float)
#+long-float
(:long-double 'long-float)
(:pointer 'system-area-pointer)
(:void 'void)))
(defun %foreign-type-size (type-keyword)
"Return the size in bytes of a foreign type."
(values (truncate (alien-internals:alien-type-bits
(alien-internals:parse-alien-type
(convert-foreign-type type-keyword)))
8)))
(defun %foreign-type-alignment (type-keyword)
"Return the alignment in bytes of a foreign type."
(values (truncate (alien-internals:alien-type-alignment
(alien-internals:parse-alien-type
(convert-foreign-type type-keyword)))
8)))
(defun foreign-funcall-type-and-args (args)
"Return an 'alien function type for 'args."
(let ((return-type nil))
(loop for (type arg) on args by #'cddr
if arg collect (convert-foreign-type type) into types
and collect arg into fargs
else do (setf return-type (convert-foreign-type type))
finally (return (values types fargs return-type)))))
(defmacro %%foreign-funcall (name types fargs rettype)
"Internal guts of '%foreign-funcall."
`(alien-funcall (extern-alien ,name (function ,rettype ,@types))
,@fargs))
(defmacro %foreign-funcall (name args &key library convention)
"Perform a foreign function call, document it more later."
(declare (ignore library convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(%%foreign-funcall ,name ,types ,fargs ,rettype)))
(defmacro %foreign-funcall-pointer (ptr args &key convention)
"Funcall a pointer to a foreign function."
(declare (ignore convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
(with-unique-names (function)
`(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
(alien-funcall ,function ,@fargs)))))
;;; Callbacks
(defmacro %defcallback (name rettype arg-names arg-types body
&key convention)
(declare (ignore convention))
`(alien:defcallback ,name
(,(convert-foreign-type rettype)
,@(mapcar (lambda (sym type)
(list sym (convert-foreign-type type)))
arg-names arg-types))
,body))
(declaim (inline %callback))
(defun %callback (name)
(alien:callback-sap name))
;;;# Loading and Closing Foreign Libraries
(defun %load-foreign-library (name path)
"Load the foreign library 'name."
(declare (ignore name))
(ext:load-dynamic-object path))
(defun %close-foreign-library (name)
"Closes the foreign library 'name."
(ext:close-dynamic-object name))
(defun native-namestring (pathname)
(ext:unix-namestring pathname nil))
;;;# Foreign Globals
(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol 'name."
(declare (ignore library))
(let ((sap (sys:foreign-symbol-address name)))
(if (zerop (sys:sap-int sap)) nil sap)))

713
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/early-types.lisp Normal file
View file

@ -0,0 +1,713 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; early-types.lisp --- Low-level foreign type operations.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;;;# Early Type Definitions
;;;
;;; This module contains basic operations on foreign types. These
;;; definitions are in a separate file because they may be used in
;;; compiler macros defined later on.
(in-package #:cffi)
;;;# Foreign Types
;;;
;;; Type specifications are of the form (type {args}*). The type
;;; parser can specify how its arguments should look like through a
;;; lambda list.
;;;
;;; "type" is a shortcut for "(type)", ie, no args were specified.
;;;
;;; Examples of such types: boolean, (boolean), (boolean :int) If the
;;; boolean type parser specifies the lambda list: &optional
;;; (base-type :int), then all of the above three type specs would be
;;; parsed to an identical type.
;;;
;;; Type parsers, defined with DEFINE-PARSE-METHOD should return a
;;; subtype of the foreign-type class.
(defvar *type-parsers* (make-hash-table :test 'equal)
"Hash table of defined type parsers.")
(define-condition cffi-error (error)
())
(define-condition foreign-type-error (cffi-error)
((type-name :initarg :type-name
:initform (error "Must specify TYPE-NAME.")
:accessor foreign-type-error/type-name)
(namespace :initarg :namespace
:initform :default
:accessor foreign-type-error/namespace)))
(defun foreign-type-error/compound-name (e)
(let ((name (foreign-type-error/type-name e))
(namespace (foreign-type-error/namespace e)))
(if (eq namespace :default)
name
`(,namespace ,name))))
(define-condition simple-foreign-type-error (simple-error foreign-type-error)
())
(defun simple-foreign-type-error (type-name namespace format-control &rest format-arguments)
(error 'simple-foreign-type-error
:type-name type-name :namespace namespace
:format-control format-control :format-arguments format-arguments))
(define-condition undefined-foreign-type-error (foreign-type-error)
()
(:report (lambda (e stream)
(format stream "Unknown CFFI type ~S" (foreign-type-error/compound-name e)))))
(defun undefined-foreign-type-error (type-name &optional (namespace :default))
(error 'undefined-foreign-type-error :type-name type-name :namespace namespace))
;; TODO this is not according to the C namespace rules,
;; see bug: https://bugs.launchpad.net/cffi/+bug/1527947
(deftype c-namespace-name ()
'(member :default :struct :union))
;; for C namespaces read: https://stackoverflow.com/questions/12579142/type-namespace-in-c
;; (section 6.2.3 Name spaces of identifiers)
;; NOTE: :struct is probably an unfortunate name for the tagged (?) namespace
(defun find-type-parser (symbol &optional (namespace :default))
"Return the type parser for SYMBOL. NAMESPACE is either :DEFAULT (for
variables, functions, and typedefs) or :STRUCT (for structs, unions, and enums)."
(check-type symbol (and symbol (not null)))
(check-type namespace c-namespace-name)
(or (gethash (cons namespace symbol) *type-parsers*)
(undefined-foreign-type-error symbol namespace)))
(defun (setf find-type-parser) (func symbol &optional (namespace :default))
"Set the type parser for SYMBOL."
(check-type symbol (and symbol (not null)))
(check-type namespace c-namespace-name)
;; TODO Shall we signal a redefinition warning here?
(setf (gethash (cons namespace symbol) *type-parsers*) func))
(defun undefine-foreign-type (symbol &optional (namespace :default))
(remhash (cons namespace symbol) *type-parsers*)
(values))
;;; Using a generic function would have been nicer but generates lots
;;; of style warnings in SBCL. (Silly reason, yes.)
(defmacro define-parse-method (name lambda-list &body body)
"Define a type parser on NAME and lists whose CAR is NAME."
(discard-docstring body)
(warn-if-kw-or-belongs-to-cl name)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (find-type-parser ',name)
(lambda ,lambda-list ,@body))
',name))
;;; Utility function for the simple case where the type takes no
;;; arguments.
(defun notice-foreign-type (name type &optional (namespace :default))
(setf (find-type-parser name namespace) (lambda () type))
name)
;;;# Generic Functions on Types
(defgeneric canonicalize (foreign-type)
(:documentation
"Return the most primitive foreign type for FOREIGN-TYPE, either a built-in
type--a keyword--or a struct/union type--a list of the form (:STRUCT/:UNION name).
Signals an error if FOREIGN-TYPE is undefined."))
(defgeneric aggregatep (foreign-type)
(:documentation
"Return true if FOREIGN-TYPE is an aggregate type."))
(defgeneric foreign-type-alignment (foreign-type)
(:documentation
"Return the structure alignment in bytes of a foreign type."))
(defgeneric foreign-type-size (foreign-type)
(:documentation
"Return the size in bytes of a foreign type."))
(defgeneric unparse-type (foreign-type)
(:documentation
"Unparse FOREIGN-TYPE to a type specification (symbol or list)."))
;;;# Foreign Types
(defclass foreign-type ()
()
(:documentation "Base class for all foreign types."))
(defmethod make-load-form ((type foreign-type) &optional env)
"Return the form used to dump types to a FASL file."
(declare (ignore env))
`(parse-type ',(unparse-type type)))
(defmethod foreign-type-size (type)
"Return the size in bytes of a foreign type."
(foreign-type-size (parse-type type)))
(defclass named-foreign-type (foreign-type)
((name
;; Name of this foreign type, a symbol.
:initform (error "Must specify a NAME.")
:initarg :name
:accessor name)))
(defmethod print-object ((type named-foreign-type) stream)
"Print a FOREIGN-TYPEDEF instance to STREAM unreadably."
(print-unreadable-object (type stream :type t :identity nil)
(format stream "~S" (name type))))
;;; Return the type's name which can be passed to PARSE-TYPE. If
;;; that's not the case for some subclass of NAMED-FOREIGN-TYPE then
;;; it should specialize UNPARSE-TYPE.
(defmethod unparse-type ((type named-foreign-type))
(name type))
;;;# Built-In Foreign Types
(defclass foreign-built-in-type (foreign-type)
((type-keyword
;; Keyword in CFFI-SYS representing this type.
:initform (error "A type keyword is required.")
:initarg :type-keyword
:accessor type-keyword))
(:documentation "A built-in foreign type."))
(defmethod canonicalize ((type foreign-built-in-type))
"Return the built-in type keyword for TYPE."
(type-keyword type))
(defmethod aggregatep ((type foreign-built-in-type))
"Returns false, built-in types are never aggregate types."
nil)
(defmethod foreign-type-alignment ((type foreign-built-in-type))
"Return the alignment of a built-in type."
(%foreign-type-alignment (type-keyword type)))
(defmethod foreign-type-size ((type foreign-built-in-type))
"Return the size of a built-in type."
(%foreign-type-size (type-keyword type)))
(defmethod unparse-type ((type foreign-built-in-type))
"Returns the symbolic representation of a built-in type."
(type-keyword type))
(defmethod print-object ((type foreign-built-in-type) stream)
"Print a FOREIGN-TYPE instance to STREAM unreadably."
(print-unreadable-object (type stream :type t :identity nil)
(format stream "~S" (type-keyword type))))
(defvar *built-in-foreign-types* nil)
(defmacro define-built-in-foreign-type (keyword)
"Defines a built-in foreign-type."
`(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew ,keyword *built-in-foreign-types*)
(notice-foreign-type
,keyword (make-instance 'foreign-built-in-type :type-keyword ,keyword))))
;;;# Foreign Pointer Types
(defclass foreign-pointer-type (foreign-built-in-type)
((pointer-type
;; Type of object pointed at by this pointer, or nil for an
;; untyped (void) pointer.
:initform nil
:initarg :pointer-type
:accessor pointer-type))
(:default-initargs :type-keyword :pointer))
;;; Define the type parser for the :POINTER type. If no type argument
;;; is provided, a void pointer will be created.
(let ((void-pointer (make-instance 'foreign-pointer-type)))
(define-parse-method :pointer (&optional type)
(if type
(make-instance 'foreign-pointer-type :pointer-type (parse-type type))
;; A bit of premature optimization here.
void-pointer)))
;;; Unparse a foreign pointer type when dumping to a fasl.
(defmethod unparse-type ((type foreign-pointer-type))
(if (pointer-type type)
`(:pointer ,(unparse-type (pointer-type type)))
:pointer))
;;; Print a foreign pointer type unreadably in unparsed form.
(defmethod print-object ((type foreign-pointer-type) stream)
(print-unreadable-object (type stream :type t :identity nil)
(format stream "~S" (unparse-type type))))
;;;# Structure Type
(defgeneric bare-struct-type-p (foreign-type)
(:documentation
"Return true if FOREIGN-TYPE is a bare struct type or an alias of a bare struct type. "))
(defmethod bare-struct-type-p ((type foreign-type))
"Return true if FOREIGN-TYPE is a bare struct type or an alias of a bare struct type. "
nil)
(defclass foreign-struct-type (named-foreign-type)
((slots
;; Hash table of slots in this structure, keyed by name.
:initform (make-hash-table)
:initarg :slots
:accessor slots)
(size
;; Cached size in bytes of this structure.
:initarg :size
:accessor size)
(alignment
;; This struct's alignment requirements
:initarg :alignment
:accessor alignment)
(bare
;; we use this flag to support the (old, deprecated) semantics of
;; bare struct types. FOO means (:POINTER (:STRUCT FOO) in
;; functions declarations whereas FOO in a structure definition is
;; a proper aggregate type: (:STRUCT FOO), etc.
:initform nil
:initarg :bare
:reader bare-struct-type-p)))
(defun slots-in-order (structure-type)
"A list of the structure's slots in order."
(sort (loop for slots being the hash-value of (structure-slots structure-type)
collect slots)
#'<
:key 'slot-offset))
(defmethod canonicalize ((type foreign-struct-type))
(if (bare-struct-type-p type)
:pointer
`(:struct ,(name type))))
(defmethod unparse-type ((type foreign-struct-type))
(if (bare-struct-type-p type)
(name type)
(canonicalize type)))
(defmethod aggregatep ((type foreign-struct-type))
"Returns true, structure types are aggregate."
t)
(defmethod foreign-type-size ((type foreign-struct-type))
"Return the size in bytes of a foreign structure type."
(size type))
(defmethod foreign-type-alignment ((type foreign-struct-type))
"Return the alignment requirements for this struct."
(alignment type))
(defclass foreign-union-type (foreign-struct-type) ())
(defmethod canonicalize ((type foreign-union-type))
(if (bare-struct-type-p type)
:pointer
`(:union ,(name type))))
;;;# Foreign Typedefs
(defclass foreign-type-alias (foreign-type)
((actual-type
;; The FOREIGN-TYPE instance this type is an alias for.
:initarg :actual-type
:accessor actual-type
:initform (error "Must specify an ACTUAL-TYPE.")))
(:documentation "A type that aliases another type."))
(defmethod canonicalize ((type foreign-type-alias))
"Return the built-in type keyword for TYPE."
(canonicalize (actual-type type)))
(defmethod aggregatep ((type foreign-type-alias))
"Return true if TYPE's actual type is aggregate."
(aggregatep (actual-type type)))
(defmethod foreign-type-alignment ((type foreign-type-alias))
"Return the alignment of a foreign typedef."
(foreign-type-alignment (actual-type type)))
(defmethod foreign-type-size ((type foreign-type-alias))
"Return the size in bytes of a foreign typedef."
(foreign-type-size (actual-type type)))
(defclass foreign-typedef (foreign-type-alias named-foreign-type)
())
(defun follow-typedefs (type)
(if (typep type 'foreign-typedef)
(follow-typedefs (actual-type type))
type))
(defmethod bare-struct-type-p ((type foreign-typedef))
(bare-struct-type-p (follow-typedefs type)))
(defun structure-slots (type)
"The hash table of slots for the structure type."
(slots (follow-typedefs type)))
;;;# Type Translators
;;;
;;; Type translation is done with generic functions at runtime for
;;; subclasses of TRANSLATABLE-FOREIGN-TYPE.
;;;
;;; The main interface for defining type translations is through the
;;; generic functions TRANSLATE-{TO,FROM}-FOREIGN and
;;; FREE-TRANSLATED-OBJECT.
(defclass translatable-foreign-type (foreign-type) ())
;;; ENHANCED-FOREIGN-TYPE is used to define translations on top of
;;; previously defined foreign types.
(defclass enhanced-foreign-type (translatable-foreign-type
foreign-type-alias)
((unparsed-type :accessor unparsed-type)))
;;; If actual-type isn't parsed already, let's parse it. This way we
;;; don't have to export PARSE-TYPE and users don't have to worry
;;; about this in DEFINE-FOREIGN-TYPE or DEFINE-PARSE-METHOD.
(defmethod initialize-instance :after ((type enhanced-foreign-type) &key)
(unless (typep (actual-type type) 'foreign-type)
(setf (actual-type type) (parse-type (actual-type type)))))
(defmethod unparse-type ((type enhanced-foreign-type))
(unparsed-type type))
;;; Checks NAMEs, not object identity.
(defun check-for-typedef-cycles (type)
(let ((seen (make-hash-table :test 'eq)))
(labels ((%check (cur-type)
(when (typep cur-type 'foreign-typedef)
(when (gethash (name cur-type) seen)
(simple-foreign-type-error type :default
"Detected cycle in type ~S." type))
(setf (gethash (name cur-type) seen) t)
(%check (actual-type cur-type)))))
(%check type))))
;;; Only now we define PARSE-TYPE because it needs to do some extra
;;; work for ENHANCED-FOREIGN-TYPES.
(defun parse-type (type)
(let* ((spec (ensure-list type))
(ptype (apply (find-type-parser (car spec)) (cdr spec))))
(when (typep ptype 'foreign-typedef)
(check-for-typedef-cycles ptype))
(when (typep ptype 'enhanced-foreign-type)
(setf (unparsed-type ptype) type))
ptype))
(defun ensure-parsed-base-type (type)
(follow-typedefs
(if (typep type 'foreign-type)
type
(parse-type type))))
(defun canonicalize-foreign-type (type)
"Convert TYPE to a built-in type by following aliases.
Signals an error if the type cannot be resolved."
(canonicalize (parse-type type)))
;;; Translate VALUE to a foreign object of the type represented by
;;; TYPE, which will be a subclass of TRANSLATABLE-FOREIGN-TYPE.
;;; Returns the foreign value and an optional second value which will
;;; be passed to FREE-TRANSLATED-OBJECT as the PARAM argument.
(defgeneric translate-to-foreign (value type)
(:method (value type)
(declare (ignore type))
value))
(defgeneric translate-into-foreign-memory (value type pointer)
(:documentation
"Translate the Lisp value into the foreign memory location given by pointer. Return value is not used.")
(:argument-precedence-order type value pointer))
;;; Similar to TRANSLATE-TO-FOREIGN, used exclusively by
;;; (SETF FOREIGN-STRUCT-SLOT-VALUE).
(defgeneric translate-aggregate-to-foreign (ptr value type))
;;; Translate the foreign object VALUE from the type repsented by
;;; TYPE, which will be a subclass of TRANSLATABLE-FOREIGN-TYPE.
;;; Returns the converted Lisp value.
(defgeneric translate-from-foreign (value type)
(:argument-precedence-order type value)
(:method (value type)
(declare (ignore type))
value))
;;; Free an object allocated by TRANSLATE-TO-FOREIGN. VALUE is a
;;; foreign object of the type represented by TYPE, which will be a
;;; TRANSLATABLE-FOREIGN-TYPE subclass. PARAM, if present, contains
;;; the second value returned by TRANSLATE-TO-FOREIGN, and is used to
;;; communicate between the two functions.
;;;
;;; FIXME: I don't think this PARAM argument is necessary anymore
;;; because the TYPE object can contain that information. [2008-12-31 LO]
(defgeneric free-translated-object (value type param)
(:method (value type param)
(declare (ignore value type param))))
;;;## Macroexpansion Time Translation
;;;
;;; The following EXPAND-* generic functions are similar to their
;;; TRANSLATE-* counterparts but are usually called at macroexpansion
;;; time. They offer a way to optimize the runtime translators.
;;; This special variable is bound by the various :around methods
;;; below to the respective form generated by the above %EXPAND-*
;;; functions. This way, an expander can "bail out" by calling the
;;; next method. All 6 of the below-defined GFs have a default method
;;; that simply answers the rtf bound by the default :around method.
(defvar *runtime-translator-form*)
;;; EXPAND-FROM-FOREIGN
(defgeneric expand-from-foreign (value type)
(:method (value type)
(declare (ignore type))
value))
(defmethod expand-from-foreign :around (value (type translatable-foreign-type))
(let ((*runtime-translator-form* `(translate-from-foreign ,value ,type)))
(call-next-method)))
(defmethod expand-from-foreign (value (type translatable-foreign-type))
(declare (ignore value))
*runtime-translator-form*)
;;; EXPAND-TO-FOREIGN
;; The second return value is used to tell EXPAND-TO-FOREIGN-DYN that
;; an unspecialized method was called.
(defgeneric expand-to-foreign (value type)
(:method (value type)
(declare (ignore type))
(values value t)))
(defmethod expand-to-foreign :around (value (type translatable-foreign-type))
(let ((*runtime-translator-form* `(translate-to-foreign ,value ,type)))
(call-next-method)))
(defmethod expand-to-foreign (value (type translatable-foreign-type))
(declare (ignore value))
(values *runtime-translator-form* t))
;;; EXPAND-INTO-FOREIGN-MEMORY
(defgeneric expand-into-foreign-memory (value type ptr)
(:method (value type ptr)
(declare (ignore type))
value))
(defmethod expand-into-foreign-memory :around
(value (type translatable-foreign-type) ptr)
(let ((*runtime-translator-form*
`(translate-into-foreign-memory ,value ,type ,ptr)))
(call-next-method)))
(defmethod expand-into-foreign-memory (value (type translatable-foreign-type) ptr)
(declare (ignore value))
*runtime-translator-form*)
;;; EXPAND-TO-FOREIGN-DYN
(defgeneric expand-to-foreign-dyn (value var body type)
(:method (value var body type)
(declare (ignore type))
`(let ((,var ,value)) ,@body)))
(defmethod expand-to-foreign-dyn :around
(value var body (type enhanced-foreign-type))
(let ((*runtime-translator-form*
(with-unique-names (param)
`(multiple-value-bind (,var ,param)
(translate-to-foreign ,value ,type)
(unwind-protect
(progn ,@body)
(free-translated-object ,var ,type ,param))))))
(call-next-method)))
;;; If this method is called it means the user hasn't defined a
;;; to-foreign-dyn expansion, so we use the to-foreign expansion.
;;;
;;; However, we do so *only* if there's a specialized
;;; EXPAND-TO-FOREIGN for TYPE because otherwise we want to use the
;;; above *RUNTIME-TRANSLATOR-FORM* which includes a call to
;;; FREE-TRANSLATED-OBJECT. (Or else there would occur no translation
;;; at all.)
(defun foreign-expand-runtime-translator-or-binding (value var body type)
(multiple-value-bind (expansion default-etp-p)
(expand-to-foreign value type)
(if default-etp-p
*runtime-translator-form*
`(let ((,var ,expansion))
,@body))))
(defmethod expand-to-foreign-dyn (value var body (type enhanced-foreign-type))
(foreign-expand-runtime-translator-or-binding value var body type))
;;; EXPAND-TO-FOREIGN-DYN-INDIRECT
;;; Like expand-to-foreign-dyn, but always give form that returns a
;;; pointer to the object, even if it's directly representable in
;;; CL, e.g. numbers.
(defgeneric expand-to-foreign-dyn-indirect (value var body type)
(:method (value var body type)
(declare (ignore type))
`(let ((,var ,value)) ,@body)))
(defmethod expand-to-foreign-dyn-indirect :around
(value var body (type translatable-foreign-type))
(let ((*runtime-translator-form*
`(with-foreign-object (,var ',(unparse-type type))
(translate-into-foreign-memory ,value ,type ,var)
,@body)))
(call-next-method)))
(defmethod expand-to-foreign-dyn-indirect
(value var body (type foreign-pointer-type))
`(with-foreign-object (,var :pointer)
(translate-into-foreign-memory ,value ,type ,var)
,@body))
(defmethod expand-to-foreign-dyn-indirect
(value var body (type foreign-built-in-type))
`(with-foreign-object (,var ,type)
(translate-into-foreign-memory ,value ,type ,var)
,@body))
(defmethod expand-to-foreign-dyn-indirect
(value var body (type translatable-foreign-type))
(foreign-expand-runtime-translator-or-binding value var body type))
(defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-type-alias))
(expand-to-foreign-dyn-indirect value var body (actual-type type)))
;;; User interface for converting values from/to foreign using the
;;; type translators. The compiler macros use the expanders when
;;; possible.
(defun convert-to-foreign (value type)
(translate-to-foreign value (parse-type type)))
(define-compiler-macro convert-to-foreign (value type)
(if (constantp type)
(expand-to-foreign value (parse-type (eval type)))
`(translate-to-foreign ,value (parse-type ,type))))
(defun convert-from-foreign (value type)
(translate-from-foreign value (parse-type type)))
(define-compiler-macro convert-from-foreign (value type)
(if (constantp type)
(expand-from-foreign value (parse-type (eval type)))
`(translate-from-foreign ,value (parse-type ,type))))
(defun convert-into-foreign-memory (value type ptr)
(translate-into-foreign-memory value (parse-type type) ptr))
(define-compiler-macro convert-into-foreign-memory (value type ptr)
(if (constantp type)
(expand-into-foreign-memory value (parse-type (eval type)) ptr)
`(translate-into-foreign-memory ,value (parse-type ,type) ,ptr)))
(defun free-converted-object (value type param)
(free-translated-object value (parse-type type) param))
;;;# Enhanced typedefs
(defclass enhanced-typedef (foreign-typedef)
())
(defmethod translate-to-foreign (value (type enhanced-typedef))
(translate-to-foreign value (actual-type type)))
(defmethod translate-into-foreign-memory (value (type enhanced-typedef) pointer)
(translate-into-foreign-memory value (actual-type type) pointer))
(defmethod translate-from-foreign (value (type enhanced-typedef))
(translate-from-foreign value (actual-type type)))
(defmethod free-translated-object (value (type enhanced-typedef) param)
(free-translated-object value (actual-type type) param))
(defmethod expand-from-foreign (value (type enhanced-typedef))
(expand-from-foreign value (actual-type type)))
(defmethod expand-to-foreign (value (type enhanced-typedef))
(expand-to-foreign value (actual-type type)))
(defmethod expand-to-foreign-dyn (value var body (type enhanced-typedef))
(expand-to-foreign-dyn value var body (actual-type type)))
(defmethod expand-into-foreign-memory (value (type enhanced-typedef) ptr)
(expand-into-foreign-memory value (actual-type type) ptr))
;;;# User-defined Types and Translations.
(defmacro define-foreign-type (name supers slots &rest options)
(multiple-value-bind (new-options simple-parser actual-type initargs)
(let ((keywords '(:simple-parser :actual-type :default-initargs)))
(apply #'values
(remove-if (lambda (opt) (member (car opt) keywords)) options)
(mapcar (lambda (kw) (cdr (assoc kw options))) keywords)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass ,name ,(or supers '(enhanced-foreign-type))
,slots
(:default-initargs ,@(when actual-type `(:actual-type ',actual-type))
,@initargs)
,@new-options)
,(when simple-parser
`(define-parse-method ,(car simple-parser) (&rest args)
(apply #'make-instance ',name args)))
',name)))
(defmacro defctype (name base-type &optional documentation)
"Utility macro for simple C-like typedefs."
(declare (ignore documentation))
(warn-if-kw-or-belongs-to-cl name)
(let* ((btype (parse-type base-type))
(dtype (if (typep btype 'enhanced-foreign-type)
'enhanced-typedef
'foreign-typedef)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(notice-foreign-type
',name (make-instance ',dtype :name ',name :actual-type ,btype)))))
;;; For Verrazano. We memoize the type this way to help detect cycles.
(defmacro defctype* (name base-type)
"Like DEFCTYPE but defers instantiation until parse-time."
`(eval-when (:compile-toplevel :load-toplevel :execute)
(let (memoized-type)
(define-parse-method ,name ()
(unless memoized-type
(setf memoized-type (make-instance 'foreign-typedef :name ',name
:actual-type nil)
(actual-type memoized-type) (parse-type ',base-type)))
memoized-type))))

369
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/enum.lisp Normal file
View file

@ -0,0 +1,369 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enum.lisp --- Defining foreign constants as Lisp keywords.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi)
;; TODO the accessors names are rather inconsistent:
;; FOREIGN-ENUM-VALUE FOREIGN-BITFIELD-VALUE
;; FOREIGN-ENUM-KEYWORD FOREIGN-BITFIELD-SYMBOLS
;; FOREIGN-ENUM-KEYWORD-LIST FOREIGN-BITFIELD-SYMBOL-LIST
;; I'd rename them to: FOREIGN-*-KEY(S) and FOREIGN-*-ALL-KEYS -- attila
;; TODO bitfield is a confusing name, because the C standard calls
;; the "int foo : 3" type as a bitfield. Maybe rename to defbitmask?
;; -- attila
;;;# Foreign Constants as Lisp Keywords
;;;
;;; This module defines the DEFCENUM macro, which provides an
;;; interface for defining a type and associating a set of integer
;;; constants with keyword symbols for that type.
;;;
;;; The keywords are automatically translated to the appropriate
;;; constant for the type by a type translator when passed as
;;; arguments or a return value to a foreign function.
(defclass foreign-enum (named-foreign-type enhanced-foreign-type)
((keyword-values
:initform (error "Must specify KEYWORD-VALUES.")
:initarg :keyword-values
:reader keyword-values)
(value-keywords
:initform (error "Must specify VALUE-KEYWORDS.")
:initarg :value-keywords
:reader value-keywords))
(:documentation "Describes a foreign enumerated type."))
(deftype enum-key ()
'(and symbol (not null)))
(defparameter +valid-enum-base-types+ *built-in-integer-types*)
(defun parse-foreign-enum-like (type-name base-type values
&optional field-mode-p)
(let ((keyword-values (make-hash-table :test 'eq))
(value-keywords (make-hash-table))
(field-keywords (list))
(bit-index->keyword (make-array 0 :adjustable t
:element-type t))
(default-value (if field-mode-p 1 0))
(most-extreme-value 0)
(has-negative-value? nil))
(dolist (pair values)
(destructuring-bind (keyword &optional (value default-value valuep))
(ensure-list pair)
(check-type keyword enum-key)
;;(check-type value integer)
(when (> (abs value) (abs most-extreme-value))
(setf most-extreme-value value))
(when (minusp value)
(setf has-negative-value? t))
(if field-mode-p
(if valuep
(when (and (>= value default-value)
(single-bit-p value))
(setf default-value (ash value 1)))
(setf default-value (ash default-value 1)))
(setf default-value (1+ value)))
(if (gethash keyword keyword-values)
(error "A foreign enum cannot contain duplicate keywords: ~S."
keyword)
(setf (gethash keyword keyword-values) value))
;; This is completely arbitrary behaviour: we keep the last
;; value->keyword mapping. I suppose the opposite would be
;; just as good (keeping the first). Returning a list with all
;; the keywords might be a solution too? Suggestions
;; welcome. --luis
(setf (gethash value value-keywords) keyword)
(when (and field-mode-p
(single-bit-p value))
(let ((bit-index (1- (integer-length value))))
(push keyword field-keywords)
(when (<= (array-dimension bit-index->keyword 0)
bit-index)
(setf bit-index->keyword
(adjust-array bit-index->keyword (1+ bit-index)
:initial-element nil)))
(setf (aref bit-index->keyword bit-index)
keyword)))))
(if base-type
(progn
(setf base-type (canonicalize-foreign-type base-type))
;; I guess we don't lose much by not strictly adhering to
;; the C standard here, and some libs out in the wild are
;; already using e.g. :double.
#+nil
(assert (member base-type +valid-enum-base-types+ :test 'eq) ()
"Invalid base type ~S for enum type ~S. Must be one of ~S."
base-type type-name +valid-enum-base-types+))
;; details: https://stackoverflow.com/questions/1122096/what-is-the-underlying-type-of-a-c-enum
(let ((bits (integer-length most-extreme-value)))
(setf base-type
(let ((most-uint-bits (load-time-value (* (foreign-type-size :unsigned-int) 8)))
(most-ulong-bits (load-time-value (* (foreign-type-size :unsigned-long) 8)))
(most-ulonglong-bits (load-time-value (* (foreign-type-size :unsigned-long-long) 8))))
(or (if has-negative-value?
(cond
((<= (1+ bits) most-uint-bits)
:int)
((<= (1+ bits) most-ulong-bits)
:long)
((<= (1+ bits) most-ulonglong-bits)
:long-long))
(cond
((<= bits most-uint-bits)
:unsigned-int)
((<= bits most-ulong-bits)
:unsigned-long)
((<= bits most-ulonglong-bits)
:unsigned-long-long)))
(error "Enum value ~S of enum ~S is too large to store."
most-extreme-value type-name))))))
(values base-type keyword-values value-keywords
field-keywords (when field-mode-p
(alexandria:copy-array
bit-index->keyword :adjustable nil
:fill-pointer nil)))))
(defun make-foreign-enum (type-name base-type values)
"Makes a new instance of the foreign-enum class."
(multiple-value-bind
(base-type keyword-values value-keywords)
(parse-foreign-enum-like type-name base-type values)
(make-instance 'foreign-enum
:name type-name
:actual-type (parse-type base-type)
:keyword-values keyword-values
:value-keywords value-keywords)))
(defun %defcenum-like (name-and-options enum-list type-factory)
(discard-docstring enum-list)
(destructuring-bind (name &optional base-type)
(ensure-list name-and-options)
(let ((type (funcall type-factory name base-type enum-list)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(notice-foreign-type ',name
;; ,type is not enough here, someone needs to
;; define it when we're being loaded from a fasl.
(,type-factory ',name ',base-type ',enum-list))
,@(remove nil
(mapcar (lambda (key)
(unless (keywordp key)
`(defconstant ,key ,(foreign-enum-value type key))))
(foreign-enum-keyword-list type)))))))
(defmacro defcenum (name-and-options &body enum-list)
"Define an foreign enumerated type."
(%defcenum-like name-and-options enum-list 'make-foreign-enum))
(defun hash-keys-to-list (ht)
(loop for k being the hash-keys in ht collect k))
(defun foreign-enum-keyword-list (enum-type)
"Return a list of KEYWORDS defined in ENUM-TYPE."
(hash-keys-to-list (keyword-values (ensure-parsed-base-type enum-type))))
;;; These [four] functions could be good canditates for compiler macros
;;; when the value or keyword is constant. I am not going to bother
;;; until someone has a serious performance need to do so though. --jamesjb
(defun %foreign-enum-value (type keyword &key errorp)
(check-type keyword enum-key)
(or (gethash keyword (keyword-values type))
(when errorp
(error "~S is not defined as a keyword for enum type ~S."
keyword type))))
(defun foreign-enum-value (type keyword &key (errorp t))
"Convert a KEYWORD into an integer according to the enum TYPE."
(let ((type-obj (ensure-parsed-base-type type)))
(if (not (typep type-obj 'foreign-enum))
(error "~S is not a foreign enum type." type)
(%foreign-enum-value type-obj keyword :errorp errorp))))
(defun %foreign-enum-keyword (type value &key errorp)
(check-type value integer)
(or (gethash value (value-keywords type))
(when errorp
(error "~S is not defined as a value for enum type ~S."
value type))))
(defun foreign-enum-keyword (type value &key (errorp t))
"Convert an integer VALUE into a keyword according to the enum TYPE."
(let ((type-obj (ensure-parsed-base-type type)))
(if (not (typep type-obj 'foreign-enum))
(error "~S is not a foreign enum type." type)
(%foreign-enum-keyword type-obj value :errorp errorp))))
(defmethod translate-to-foreign (value (type foreign-enum))
(if (typep value 'enum-key)
(%foreign-enum-value type value :errorp t)
value))
(defmethod translate-into-foreign-memory
(value (type foreign-enum) pointer)
(setf (mem-aref pointer (unparse-type (actual-type type)))
(translate-to-foreign value type)))
(defmethod translate-from-foreign (value (type foreign-enum))
(%foreign-enum-keyword type value :errorp t))
(defmethod expand-to-foreign (value (type foreign-enum))
(once-only (value)
`(if (typep ,value 'enum-key)
(%foreign-enum-value ,type ,value :errorp t)
,value)))
;;; There are two expansions necessary for an enum: first, the enum
;;; keyword needs to be translated to an int, and then the int needs
;;; to be made indirect.
(defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-enum))
(expand-to-foreign-dyn-indirect ; Make the integer indirect
(with-unique-names (feint)
(call-next-method value feint (list feint) type)) ; TRANSLATABLE-FOREIGN-TYPE method
var
body
(actual-type type)))
;;;# Foreign Bitfields as Lisp keywords
;;;
;;; DEFBITFIELD is an abstraction similar to the one provided by DEFCENUM.
;;; With some changes to DEFCENUM, this could certainly be implemented on
;;; top of it.
(defclass foreign-bitfield (foreign-enum)
((field-keywords
:initform (error "Must specify FIELD-KEYWORDS.")
:initarg :field-keywords
:reader field-keywords)
(bit-index->keyword
:initform (error "Must specify BIT-INDEX->KEYWORD")
:initarg :bit-index->keyword
:reader bit-index->keyword))
(:documentation "Describes a foreign bitfield type."))
(defun make-foreign-bitfield (type-name base-type values)
"Makes a new instance of the foreign-bitfield class."
(multiple-value-bind
(base-type keyword-values value-keywords
field-keywords bit-index->keyword)
(parse-foreign-enum-like type-name base-type values t)
(make-instance 'foreign-bitfield
:name type-name
:actual-type (parse-type base-type)
:keyword-values keyword-values
:value-keywords value-keywords
:field-keywords field-keywords
:bit-index->keyword bit-index->keyword)))
(defmacro defbitfield (name-and-options &body masks)
"Define an foreign enumerated type."
(%defcenum-like name-and-options masks 'make-foreign-bitfield))
(defun foreign-bitfield-symbol-list (bitfield-type)
"Return a list of SYMBOLS defined in BITFIELD-TYPE."
(field-keywords (ensure-parsed-base-type bitfield-type)))
(defun %foreign-bitfield-value (type symbols)
(declare (optimize speed))
(labels ((process-one (symbol)
(check-type symbol symbol)
(or (gethash symbol (keyword-values type))
(error "~S is not a valid symbol for bitfield type ~S."
symbol type))))
(declare (dynamic-extent #'process-one))
(cond
((consp symbols)
(reduce #'logior symbols :key #'process-one))
((null symbols)
0)
(t
(process-one symbols)))))
(defun foreign-bitfield-value (type symbols)
"Convert a list of symbols into an integer according to the TYPE bitfield."
(let ((type-obj (ensure-parsed-base-type type)))
(assert (typep type-obj 'foreign-bitfield) ()
"~S is not a foreign bitfield type." type)
(%foreign-bitfield-value type-obj symbols)))
(define-compiler-macro foreign-bitfield-value (&whole form type symbols)
"Optimize for when TYPE and SYMBOLS are constant."
(declare (notinline foreign-bitfield-value))
(if (and (constantp type) (constantp symbols))
(foreign-bitfield-value (eval type) (eval symbols))
form))
(defun %foreign-bitfield-symbols (type value)
(check-type value integer)
(check-type type foreign-bitfield)
(loop
:with bit-index->keyword = (bit-index->keyword type)
:for bit-index :from 0 :below (array-dimension bit-index->keyword 0)
:for mask = 1 :then (ash mask 1)
:for key = (aref bit-index->keyword bit-index)
:when (and key
(= (logand value mask) mask))
:collect key))
(defun foreign-bitfield-symbols (type value)
"Convert an integer VALUE into a list of matching symbols according to
the bitfield TYPE."
(let ((type-obj (ensure-parsed-base-type type)))
(if (not (typep type-obj 'foreign-bitfield))
(error "~S is not a foreign bitfield type." type)
(%foreign-bitfield-symbols type-obj value))))
(define-compiler-macro foreign-bitfield-symbols (&whole form type value)
"Optimize for when TYPE and SYMBOLS are constant."
(declare (notinline foreign-bitfield-symbols))
(if (and (constantp type) (constantp value))
`(quote ,(foreign-bitfield-symbols (eval type) (eval value)))
form))
(defmethod translate-to-foreign (value (type foreign-bitfield))
(if (integerp value)
value
(%foreign-bitfield-value type (ensure-list value))))
(defmethod translate-from-foreign (value (type foreign-bitfield))
(%foreign-bitfield-symbols type value))
(defmethod expand-to-foreign (value (type foreign-bitfield))
(flet ((expander (value type)
`(if (integerp ,value)
,value
(%foreign-bitfield-value ,type (ensure-list ,value)))))
(if (constantp value)
(eval (expander value type))
(expander value type))))
(defmethod expand-from-foreign (value (type foreign-bitfield))
(flet ((expander (value type)
`(%foreign-bitfield-symbols ,type ,value)))
(if (constantp value)
(eval (expander value type))
(expander value type))))

111
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/features.lisp Normal file
View file

@ -0,0 +1,111 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; features.lisp --- CFFI-specific features (DEPRECATED).
;;;
;;; Copyright (C) 2006-2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :cffi *features*))
;;; CFFI-SYS backends take care of pushing the appropriate features to
;;; *features*. See each cffi-*.lisp file.
;;;
;;; Not anymore, I think we should use TRIVIAL-FEATURES for the
;;; platform features instead. Less pain. CFFI-FEATURES is now
;;; deprecated and this code will stay here for a while for backwards
;;; compatibility purposes, to be removed in a future release.
(defpackage #:cffi-features
(:use #:cl)
(:export
#:cffi-feature-p
;; Features related to the CFFI-SYS backend. Why no-*? This
;; reflects the hope that these symbols will go away completely
;; meaning that at some point all lisps will support long-longs,
;; the foreign-funcall primitive, etc...
#:no-long-long
#:no-foreign-funcall
#:no-stdcall
#:flat-namespace
;; Only SCL supports long-double...
;;#:no-long-double
;; Features related to the operating system.
;; More should be added.
#:darwin
#:unix
#:windows
;; Features related to the processor.
;; More should be added.
#:ppc32
#:x86
#:x86-64
#:sparc
#:sparc64
#:hppa
#:hppa64))
(in-package #:cffi-features)
(defun cffi-feature-p (feature-expression)
"Matches a FEATURE-EXPRESSION against those symbols in *FEATURES*
that belong to the CFFI-FEATURES package."
(when (eql feature-expression t)
(return-from cffi-feature-p t))
(let ((features-package (find-package '#:cffi-features)))
(flet ((cffi-feature-eq (name feature-symbol)
(and (eq (symbol-package feature-symbol) features-package)
(string= name (symbol-name feature-symbol)))))
(etypecase feature-expression
(symbol
(not (null (member (symbol-name feature-expression) *features*
:test #'cffi-feature-eq))))
(cons
(ecase (first feature-expression)
(:and (every #'cffi-feature-p (rest feature-expression)))
(:or (some #'cffi-feature-p (rest feature-expression)))
(:not (not (cffi-feature-p (cadr feature-expression))))))))))
;;; for backwards compatibility
(mapc (lambda (sym) (pushnew sym *features*))
'(#+darwin darwin
#+unix unix
#+windows windows
#+ppc ppc32
#+x86 x86
#+x86-64 x86-64
#+sparc sparc
#+sparc64 sparc64
#+hppa hppa
#+hppa64 hppa64
#+cffi-sys::no-long-long no-long-long
#+cffi-sys::flat-namespace flat-namespace
#+cffi-sys::no-foreign-funcall no-foreign-funcall
#+cffi-sys::no-stdcall no-stdcall
))

90
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/foreign-vars.lisp Normal file
View file

@ -0,0 +1,90 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; foreign-vars.lisp --- High-level interface to foreign globals.
;;;
;;; Copyright (C) 2005-2008, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi)
;;;# Accessing Foreign Globals
;;; Called by FOREIGN-OPTIONS in functions.lisp.
(defun parse-defcvar-options (options)
(destructuring-bind (&key (library :default) read-only) options
(list :library library :read-only read-only)))
(defun get-var-pointer (symbol)
"Return a pointer to the foreign global variable relative to SYMBOL."
(foreign-symbol-pointer (get symbol 'foreign-var-name)
:library (get symbol 'foreign-var-library)))
;;; Note: this will lookup not only variables but also functions.
(defun foreign-symbol-pointer (name &key (library :default))
(check-type name string)
(%foreign-symbol-pointer
name (if (eq library :default)
:default
(foreign-library-handle
(get-foreign-library library)))))
(defun fs-pointer-or-lose (foreign-name library)
"Like foreign-symbol-ptr but throws an error instead of
returning nil when foreign-name is not found."
(or (foreign-symbol-pointer foreign-name :library library)
(error "Trying to access undefined foreign variable ~S." foreign-name)))
(defmacro defcvar (name-and-options type &optional documentation)
"Define a foreign global variable."
(multiple-value-bind (lisp-name foreign-name options)
(parse-name-and-options name-and-options t)
(let ((fn (symbolicate '#:%var-accessor- lisp-name))
(read-only (getf options :read-only))
(library (getf options :library)))
;; We can't really setf an aggregate type.
(when (aggregatep (parse-type type))
(setq read-only t))
`(progn
(setf (documentation ',lisp-name 'variable) ,documentation)
;; Save foreign-name and library for posterior access by
;; GET-VAR-POINTER.
(setf (get ',lisp-name 'foreign-var-name) ,foreign-name)
(setf (get ',lisp-name 'foreign-var-library) ',library)
;; Getter
(defun ,fn ()
(mem-ref (fs-pointer-or-lose ,foreign-name ',library) ',type))
;; Setter
(defun (setf ,fn) (value)
,(if read-only '(declare (ignore value)) (values))
,(if read-only
`(error ,(format nil
"Trying to modify read-only foreign var: ~A."
lisp-name))
`(setf (mem-ref (fs-pointer-or-lose ,foreign-name ',library)
',type)
value)))
;; While most Lisps already expand DEFINE-SYMBOL-MACRO to an
;; EVAL-WHEN form like this, that is not required by the
;; standard so we do it ourselves.
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-symbol-macro ,lisp-name (,fn)))))))

441
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/functions.lisp Normal file
View file

@ -0,0 +1,441 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; functions.lisp --- High-level interface to foreign functions.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi)
;;;# Calling Foreign Functions
;;;
;;; FOREIGN-FUNCALL is the main primitive for calling foreign
;;; functions. It converts each argument based on the installed
;;; translators for its type, then passes the resulting list to
;;; CFFI-SYS:%FOREIGN-FUNCALL.
;;;
;;; For implementation-specific reasons, DEFCFUN doesn't use
;;; FOREIGN-FUNCALL directly and might use something else (passed to
;;; TRANSLATE-OBJECTS as the CALL-FORM argument) instead of
;;; CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function.
(defun translate-objects (syms args types rettype call-form &optional indirect)
"Helper function for FOREIGN-FUNCALL and DEFCFUN. If 'indirect is T, all arguments are represented by foreign pointers, even those that can be represented by CL objects."
(if (null args)
(expand-from-foreign call-form (parse-type rettype))
(funcall
(if indirect
#'expand-to-foreign-dyn-indirect
#'expand-to-foreign-dyn)
(car args) (car syms)
(list (translate-objects (cdr syms) (cdr args)
(cdr types) rettype call-form indirect))
(parse-type (car types)))))
(defun parse-args-and-types (args)
"Returns 4 values: types, canonicalized types, args and return type."
(let* ((len (length args))
(return-type (if (oddp len) (lastcar args) :void)))
(loop repeat (floor len 2)
for (type arg) on args by #'cddr
collect type into types
collect (canonicalize-foreign-type type) into ctypes
collect arg into fargs
finally (return (values types ctypes fargs return-type)))))
;;; While the options passed directly to DEFCFUN/FOREIGN-FUNCALL have
;;; precedence, we also grab its library's options, if possible.
(defun parse-function-options (options &key pointer)
(destructuring-bind (&key (library :default libraryp)
(cconv nil cconv-p)
(calling-convention cconv calling-convention-p)
(convention calling-convention))
options
(when cconv-p
(warn-obsolete-argument :cconv :convention))
(when calling-convention-p
(warn-obsolete-argument :calling-convention :convention))
(list* :convention
(or convention
(when libraryp
(let ((lib-options (foreign-library-options
(get-foreign-library library))))
(getf lib-options :convention)))
:cdecl)
;; Don't pass the library option if we're dealing with
;; FOREIGN-FUNCALL-POINTER.
(unless pointer
(list :library library)))))
(defun structure-by-value-p (ctype)
"A structure or union is to be called or returned by value."
(let ((actual-type (ensure-parsed-base-type ctype)))
(or (and (typep actual-type 'foreign-struct-type)
(not (bare-struct-type-p actual-type)))
#+cffi::no-long-long (typep actual-type 'emulated-llong-type))))
(defun fn-call-by-value-p (argument-types return-type)
"One or more structures in the arguments or return from the function are called by value."
(or (some 'structure-by-value-p argument-types)
(structure-by-value-p return-type)))
(defvar *foreign-structures-by-value*
(lambda (&rest args)
(declare (ignore args))
(restart-case
(error "Unable to call structures by value without cffi-libffi loaded.")
(load-cffi-libffi () :report "Load cffi-libffi."
(asdf:operate 'asdf:load-op 'cffi-libffi))))
"A function that produces a form suitable for calling structures by value.")
(defun foreign-funcall-form (thing options args pointerp)
(multiple-value-bind (types ctypes fargs rettype)
(parse-args-and-types args)
(let ((syms (make-gensym-list (length fargs)))
(fsbvp (fn-call-by-value-p ctypes rettype)))
(if fsbvp
;; Structures by value call through *foreign-structures-by-value*
(funcall *foreign-structures-by-value*
thing
fargs
syms
types
rettype
ctypes
pointerp)
(translate-objects
syms fargs types rettype
`(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
;; No structures by value, direct call
,thing
(,@(mapcan #'list ctypes syms)
,(canonicalize-foreign-type rettype))
,@(parse-function-options options :pointer pointerp)))))))
(defmacro foreign-funcall (name-and-options &rest args)
"Wrapper around %FOREIGN-FUNCALL that translates its arguments."
(let ((name (car (ensure-list name-and-options)))
(options (cdr (ensure-list name-and-options))))
(foreign-funcall-form name options args nil)))
(defmacro foreign-funcall-pointer (pointer options &rest args)
(foreign-funcall-form pointer options args t))
(defun promote-varargs-type (builtin-type)
"Default argument promotions."
(case builtin-type
(:float :double)
((:char :short) :int)
((:unsigned-char :unsigned-short) :unsigned-int)
(t builtin-type)))
;; If cffi-sys doesn't provide a %foreign-funcall-varargs macros we
;; define one that use %foreign-funcall.
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp '%foreign-funcall-varargs)
(defmacro %foreign-funcall-varargs (name fixed-args varargs
&rest args &key convention library)
(declare (ignore convention library))
`(%foreign-funcall ,name ,(append fixed-args varargs) ,@args)))
(unless (fboundp '%foreign-funcall-pointer-varargs)
(defmacro %foreign-funcall-pointer-varargs (pointer fixed-args varargs
&rest args &key convention)
(declare (ignore convention))
`(%foreign-funcall-pointer ,pointer ,(append fixed-args varargs) ,@args))))
(defun foreign-funcall-varargs-form (thing options fixed-args varargs pointerp)
(multiple-value-bind (fixed-types fixed-ctypes fixed-fargs)
(parse-args-and-types fixed-args)
(multiple-value-bind (varargs-types varargs-ctypes varargs-fargs rettype)
(parse-args-and-types varargs)
(let ((fixed-syms (make-gensym-list (length fixed-fargs)))
(varargs-syms (make-gensym-list (length varargs-fargs))))
(translate-objects
(append fixed-syms varargs-syms)
(append fixed-fargs varargs-fargs)
(append fixed-types varargs-types)
rettype
`(,(if pointerp '%foreign-funcall-pointer-varargs '%foreign-funcall-varargs)
,thing
,(mapcan #'list fixed-ctypes fixed-syms)
,(append
(mapcan #'list
(mapcar #'promote-varargs-type varargs-ctypes)
(loop for sym in varargs-syms
and type in varargs-ctypes
if (eq type :float)
collect `(float ,sym 1.0d0)
else collect sym))
(list (canonicalize-foreign-type rettype)))
,@options))))))
(defmacro foreign-funcall-varargs (name-and-options fixed-args
&rest varargs)
"Wrapper around %FOREIGN-FUNCALL that translates its arguments
and does type promotion for the variadic arguments."
(let ((name (car (ensure-list name-and-options)))
(options (cdr (ensure-list name-and-options))))
(foreign-funcall-varargs-form name options fixed-args varargs nil)))
(defmacro foreign-funcall-pointer-varargs (pointer options fixed-args
&rest varargs)
"Wrapper around %FOREIGN-FUNCALL-POINTER that translates its
arguments and does type promotion for the variadic arguments."
(foreign-funcall-varargs-form pointer options fixed-args varargs t))
;;;# Defining Foreign Functions
;;;
;;; The DEFCFUN macro provides a declarative interface for defining
;;; Lisp functions that call foreign functions.
;; If cffi-sys doesn't provide a defcfun-helper-forms,
;; we define one that uses %foreign-funcall.
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp 'defcfun-helper-forms)
(defun defcfun-helper-forms (name lisp-name rettype args types options)
(declare (ignore lisp-name))
(values
'()
`(%foreign-funcall ,name ,(append (mapcan #'list types args)
(list rettype))
,@options)))))
(defun %defcfun (lisp-name foreign-name return-type args options docstring)
(let* ((arg-names (mapcar #'first args))
(arg-types (mapcar #'second args))
(syms (make-gensym-list (length args)))
(call-by-value (fn-call-by-value-p arg-types return-type)))
(multiple-value-bind (prelude caller)
(if call-by-value
(values nil nil)
(defcfun-helper-forms
foreign-name lisp-name (canonicalize-foreign-type return-type)
syms (mapcar #'canonicalize-foreign-type arg-types) options))
`(progn
,prelude
(defun ,lisp-name ,arg-names
,@(ensure-list docstring)
,(if call-by-value
`(foreign-funcall
,(cons foreign-name options)
,@(append (mapcan #'list arg-types arg-names)
(list return-type)))
(translate-objects
syms arg-names arg-types return-type caller)))))))
(defun %defcfun-varargs (lisp-name foreign-name return-type args options doc)
(with-unique-names (varargs)
(let ((arg-names (mapcar #'car args)))
`(defmacro ,lisp-name (,@arg-names &rest ,varargs)
,@(ensure-list doc)
`(foreign-funcall-varargs
,'(,foreign-name ,@options)
,,`(list ,@(loop for (name type) in args
collect `',type collect name))
,@,varargs
,',return-type)))))
(defgeneric translate-underscore-separated-name (name)
(:method ((name string))
(values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name)))))
(:method ((name symbol))
(substitute #\_ #\- (string-downcase (symbol-name name)))))
(defun collapse-prefix (l special-words)
(unless (null l)
(multiple-value-bind (newpre skip) (check-prefix l special-words)
(cons newpre (collapse-prefix (nthcdr skip l) special-words)))))
(defun check-prefix (l special-words)
(let ((pl (loop for i from (1- (length l)) downto 0
collect (apply #'concatenate 'simple-string (butlast l i)))))
(loop for w in special-words
for p = (position-if #'(lambda (s) (string= s w)) pl)
when p do (return-from check-prefix (values (nth p pl) (1+ p))))
(values (first l) 1)))
(defgeneric translate-camelcase-name (name &key upper-initial-p special-words)
(:method ((name string) &key upper-initial-p special-words)
(declare (ignore upper-initial-p))
(values (intern (reduce #'(lambda (s1 s2)
(concatenate 'simple-string s1 "-" s2))
(mapcar #'string-upcase
(collapse-prefix
(split-if #'(lambda (ch)
(or (upper-case-p ch)
(digit-char-p ch)))
name)
special-words))))))
(:method ((name symbol) &key upper-initial-p special-words)
(apply #'concatenate
'string
(loop for str in (split-if #'(lambda (ch) (eq ch #\-))
(string name)
:elide)
for first-word-p = t then nil
for e = (member str special-words
:test #'equal :key #'string-upcase)
collect (cond
((and first-word-p (not upper-initial-p))
(string-downcase str))
(e (first e))
(t (string-capitalize str)))))))
(defgeneric translate-name-from-foreign (foreign-name package &optional varp)
(:method (foreign-name package &optional varp)
(declare (ignore package))
(let ((sym (translate-underscore-separated-name foreign-name)))
(if varp
(values (intern (format nil "*~A*"
(canonicalize-symbol-name-case
(symbol-name sym)))))
sym))))
(defgeneric translate-name-to-foreign (lisp-name package &optional varp)
(:method (lisp-name package &optional varp)
(declare (ignore package))
(let ((name (translate-underscore-separated-name lisp-name)))
(if varp
(string-trim '(#\*) name)
name))))
(defun lisp-name (spec varp)
(check-type spec string)
(translate-name-from-foreign spec *package* varp))
(defun foreign-name (spec varp)
(check-type spec (and symbol (not null)))
(translate-name-to-foreign spec *package* varp))
(defun foreign-options (opts varp)
(if varp
(funcall 'parse-defcvar-options opts)
(parse-function-options opts)))
(defun lisp-name-p (name)
(and name (symbolp name) (not (keywordp name))))
(defun %parse-name-and-options (spec varp)
(cond
((stringp spec)
(values (lisp-name spec varp) spec nil))
((symbolp spec)
(assert (not (null spec)))
(values spec (foreign-name spec varp) nil))
((and (consp spec) (stringp (first spec)))
(destructuring-bind (foreign-name &rest options)
spec
(cond
((or (null options)
(keywordp (first options)))
(values (lisp-name foreign-name varp) foreign-name options))
(t
(assert (lisp-name-p (first options)))
(values (first options) foreign-name (rest options))))))
((and (consp spec) (lisp-name-p (first spec)))
(destructuring-bind (lisp-name &rest options)
spec
(cond
((or (null options)
(keywordp (first options)))
(values lisp-name (foreign-name spec varp) options))
(t
(assert (stringp (first options)))
(values lisp-name (first options) (rest options))))))
(t
(error "Not a valid foreign function specifier: ~A" spec))))
;;; DEFCFUN's first argument has can have the following syntax:
;;;
;;; 1. string
;;; 2. symbol
;;; 3. \( string [symbol] options* )
;;; 4. \( symbol [string] options* )
;;;
;;; The string argument denotes the foreign function's name. The
;;; symbol argument is used to name the Lisp function. If one isn't
;;; present, its name is derived from the other. See the user
;;; documentation for an explanation of the derivation rules.
(defun parse-name-and-options (spec &optional varp)
(multiple-value-bind (lisp-name foreign-name options)
(%parse-name-and-options spec varp)
(values lisp-name foreign-name (foreign-options options varp))))
;;; If we find a &REST token at the end of ARGS, it means this is a
;;; varargs foreign function therefore we define a lisp macro using
;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
;;; %DEFCFUN.
(defmacro defcfun (name-and-options return-type &body args)
"Defines a Lisp function that calls a foreign function."
(let ((docstring (when (stringp (car args)) (pop args))))
(multiple-value-bind (lisp-name foreign-name options)
(parse-name-and-options name-and-options)
(if (eq (lastcar args) '&rest)
(%defcfun-varargs lisp-name foreign-name return-type
(butlast args) options docstring)
(%defcfun lisp-name foreign-name return-type args options
docstring)))))
;;;# Defining Callbacks
(defun inverse-translate-objects (args types declarations rettype call)
`(let (,@(loop for arg in args and type in types
collect (list arg (expand-from-foreign
arg (parse-type type)))))
,@declarations
,(expand-to-foreign call (parse-type rettype))))
(defun parse-defcallback-options (options)
(destructuring-bind (&key (cconv :cdecl cconv-p)
(calling-convention cconv calling-convention-p)
(convention calling-convention))
options
(when cconv-p
(warn-obsolete-argument :cconv :convention))
(when calling-convention-p
(warn-obsolete-argument :calling-convention :convention))
(list :convention convention)))
(defmacro defcallback (name-and-options return-type args &body body)
(multiple-value-bind (body declarations)
(parse-body body :documentation t)
(let ((arg-names (mapcar #'car args))
(arg-types (mapcar #'cadr args))
(name (car (ensure-list name-and-options)))
(options (cdr (ensure-list name-and-options))))
`(progn
(%defcallback ,name ,(canonicalize-foreign-type return-type)
,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
,(inverse-translate-objects
arg-names arg-types declarations return-type
`(block ,name ,@body))
,@(parse-defcallback-options options))
',name))))
(declaim (inline get-callback))
(defun get-callback (symbol)
(%callback symbol))
(defmacro callback (name)
`(%callback ',name))

458
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/libraries.lisp Normal file
View file

@ -0,0 +1,458 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; libraries.lisp --- Finding and loading foreign libraries.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2006-2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi)
;;;# Finding Foreign Libraries
;;;
;;; We offer two ways for the user of a CFFI library to define
;;; his/her own library directories: *FOREIGN-LIBRARY-DIRECTORIES*
;;; for regular libraries and *DARWIN-FRAMEWORK-DIRECTORIES* for
;;; Darwin frameworks.
;;;
;;; These two special variables behave similarly to
;;; ASDF:*CENTRAL-REGISTRY* as its arguments are evaluated before
;;; being used. We used our MINI-EVAL instead of the full-blown EVAL
;;; and the evaluated form should yield a single pathname or a list of
;;; pathnames.
;;;
;;; Only after failing to find a library through the normal ways
;;; (eg: on Linux LD_LIBRARY_PATH, /etc/ld.so.cache, /usr/lib/, /lib)
;;; do we try to find the library ourselves.
(defun explode-path-environment-variable (name)
(mapcar #'uiop:ensure-directory-pathname
(split-if (lambda (c) (eql #\: c))
(uiop:getenv name)
:elide)))
(defun darwin-fallback-library-path ()
(or (explode-path-environment-variable "DYLD_FALLBACK_LIBRARY_PATH")
(list (merge-pathnames #p"lib/" (user-homedir-pathname))
#p"/opt/local/lib/"
#p"/usr/local/lib/"
#p"/usr/lib/")))
(defvar *foreign-library-directories*
(if (featurep :darwin)
'((explode-path-environment-variable "LD_LIBRARY_PATH")
(explode-path-environment-variable "DYLD_LIBRARY_PATH")
(uiop:getcwd)
(darwin-fallback-library-path))
'())
"List onto which user-defined library paths can be pushed.")
(defun fallback-darwin-framework-directories ()
(or (explode-path-environment-variable "DYLD_FALLBACK_FRAMEWORK_PATH")
(list (uiop:getcwd)
(merge-pathnames #p"Library/Frameworks/" (user-homedir-pathname))
#p"/Library/Frameworks/"
#p"/System/Library/Frameworks/")))
(defvar *darwin-framework-directories*
'((explode-path-environment-variable "DYLD_FRAMEWORK_PATH")
(fallback-darwin-framework-directories))
"List of directories where Frameworks are searched for.")
(defun mini-eval (form)
"Simple EVAL-like function to evaluate the elements of
*FOREIGN-LIBRARY-DIRECTORIES* and *DARWIN-FRAMEWORK-DIRECTORIES*."
(typecase form
(cons (apply (car form) (mapcar #'mini-eval (cdr form))))
(symbol (symbol-value form))
(t form)))
(defun parse-directories (list)
(mappend (compose #'ensure-list #'mini-eval) list))
(defun find-file (path directories)
"Searches for PATH in a list of DIRECTORIES and returns the first it finds."
(some (lambda (directory) (probe-file (merge-pathnames path directory)))
directories))
(defun find-darwin-framework (framework-name)
"Searches for FRAMEWORK-NAME in *DARWIN-FRAMEWORK-DIRECTORIES*."
(dolist (directory (parse-directories *darwin-framework-directories*))
(let ((path (make-pathname
:name framework-name
:directory
(append (pathname-directory directory)
(list (format nil "~A.framework" framework-name))))))
(when (probe-file path)
(return-from find-darwin-framework path)))))
;;;# Defining Foreign Libraries
;;;
;;; Foreign libraries can be defined using the
;;; DEFINE-FOREIGN-LIBRARY macro. Example usage:
;;;
;;; (define-foreign-library opengl
;;; (:darwin (:framework "OpenGL"))
;;; (:unix (:or "libGL.so" "libGL.so.1"
;;; #p"/myhome/mylibGL.so"))
;;; (:windows "opengl32.dll")
;;; ;; an hypothetical example of a particular platform
;;; ((:and :some-system :some-cpu) "libGL-support.lib")
;;; ;; if no other clauses apply, this one will and a type will be
;;; ;; automagically appended to the name passed to :default
;;; (t (:default "libGL")))
;;;
;;; This information is stored in the *FOREIGN-LIBRARIES* hashtable
;;; and when the library is loaded through LOAD-FOREIGN-LIBRARY (or
;;; USE-FOREIGN-LIBRARY) the first clause matched by FEATUREP is
;;; processed.
(defvar *foreign-libraries* (make-hash-table :test 'eq)
"Hashtable of defined libraries.")
(defclass foreign-library ()
((name :initform nil :initarg :name :accessor foreign-library-name)
(type :initform :system :initarg :type)
(spec :initarg :spec)
(options :initform nil :initarg :options)
(handle :initform nil :initarg :handle :accessor foreign-library-handle)
(pathname :initform nil)))
(defmethod print-object ((library foreign-library) stream)
(with-slots (name pathname) library
(print-unreadable-object (library stream :type t)
(when name
(format stream "~A" name))
(when pathname
(format stream " ~S" (file-namestring pathname))))))
(define-condition foreign-library-undefined-error (error)
((name :initarg :name :reader fl-name))
(:report (lambda (c s)
(format s "Undefined foreign library: ~S"
(fl-name c)))))
(defun get-foreign-library (lib)
"Look up a library by NAME, signalling an error if not found."
(if (typep lib 'foreign-library)
lib
(or (gethash lib *foreign-libraries*)
(error 'foreign-library-undefined-error :name lib))))
(defun (setf get-foreign-library) (value name)
(setf (gethash name *foreign-libraries*) value))
(defun foreign-library-type (lib)
(slot-value (get-foreign-library lib) 'type))
(defun foreign-library-pathname (lib)
(slot-value (get-foreign-library lib) 'pathname))
(defun %foreign-library-spec (lib)
(assoc-if (lambda (feature)
(or (eq feature t)
(featurep feature)))
(slot-value lib 'spec)))
(defun foreign-library-spec (lib)
(second (%foreign-library-spec lib)))
(defun foreign-library-options (lib)
(append (cddr (%foreign-library-spec lib))
(slot-value lib 'options)))
(defun foreign-library-search-path (lib)
(loop for (opt val) on (foreign-library-options lib) by #'cddr
when (eql opt :search-path)
append (ensure-list val) into search-path
finally (return (mapcar #'pathname search-path))))
(defun foreign-library-loaded-p (lib)
(not (null (foreign-library-handle (get-foreign-library lib)))))
(defun list-foreign-libraries (&key (loaded-only t) type)
"Return a list of defined foreign libraries.
If LOADED-ONLY is non-null only loaded libraries are returned.
TYPE restricts the output to a specific library type: if NIL
all libraries are returned."
(let ((libs (hash-table-values *foreign-libraries*)))
(remove-if (lambda (lib)
(or (and type
(not (eql type (foreign-library-type lib))))
(and loaded-only
(not (foreign-library-loaded-p lib)))))
libs)))
;; :CONVENTION, :CALLING-CONVENTION and :CCONV are coalesced,
;; the former taking priority
;; options with NULL values are removed
(defun clean-spec-up (spec)
(mapcar (lambda (x)
(list* (first x) (second x)
(let* ((opts (cddr x))
(cconv (getf opts :cconv))
(calling-convention (getf opts :calling-convention))
(convention (getf opts :convention))
(search-path (getf opts :search-path)))
(remf opts :cconv) (remf opts :calling-convention)
(when cconv
(warn-obsolete-argument :cconv :convention))
(when calling-convention
(warn-obsolete-argument :calling-convention
:convention))
(setf (getf opts :convention)
(or convention calling-convention cconv))
(setf (getf opts :search-path)
(mapcar #'pathname (ensure-list search-path)))
(loop for (opt val) on opts by #'cddr
when val append (list opt val) into new-opts
finally (return new-opts)))))
spec))
(defmethod initialize-instance :after
((lib foreign-library) &key search-path
(cconv :cdecl cconv-p)
(calling-convention cconv calling-convention-p)
(convention calling-convention))
(with-slots (type options spec) lib
(check-type type (member :system :test :grovel-wrapper))
(setf spec (clean-spec-up spec))
(let ((all-options
(apply #'append options (mapcar #'cddr spec))))
(assert (subsetp (loop for (key . nil) on all-options by #'cddr
collect key)
'(:convention :search-path)))
(when cconv-p
(warn-obsolete-argument :cconv :convention))
(when calling-convention-p
(warn-obsolete-argument :calling-convention :convention))
(flet ((set-option (key value)
(when value (setf (getf options key) value))))
(set-option :convention convention)
(set-option :search-path
(mapcar #'pathname (ensure-list search-path)))))))
(defun register-foreign-library (name spec &rest options)
(let ((old-handle
(when-let ((old-lib (gethash name *foreign-libraries*)))
(foreign-library-handle old-lib))))
(setf (get-foreign-library name)
(apply #'make-instance 'foreign-library
:name name
:spec spec
:handle old-handle
options))
name))
(defmacro define-foreign-library (name-and-options &body pairs)
"Defines a foreign library NAME that can be posteriorly used with
the USE-FOREIGN-LIBRARY macro."
(destructuring-bind (name . options)
(ensure-list name-and-options)
(check-type name symbol)
`(register-foreign-library ',name ',pairs ,@options)))
;;;# LOAD-FOREIGN-LIBRARY-ERROR condition
;;;
;;; The various helper functions that load foreign libraries can
;;; signal this error when something goes wrong. We ignore the host's
;;; error. We should probably reuse its error message.
(define-condition load-foreign-library-error (simple-error)
())
(defun read-new-value ()
(format *query-io* "~&Enter a new value (unevaluated): ")
(force-output *query-io*)
(read *query-io*))
(defun fl-error (control &rest arguments)
(error 'load-foreign-library-error
:format-control control
:format-arguments arguments))
;;;# Loading Foreign Libraries
(defun load-darwin-framework (name framework-name)
"Tries to find and load a darwin framework in one of the directories
in *DARWIN-FRAMEWORK-DIRECTORIES*. If unable to find FRAMEWORK-NAME,
it signals a LOAD-FOREIGN-LIBRARY-ERROR."
(let ((framework (find-darwin-framework framework-name)))
(if framework
(load-foreign-library-path name (native-namestring framework))
(fl-error "Unable to find framework ~A" framework-name))))
(defun report-simple-error (name error)
(fl-error "Unable to load foreign library (~A).~% ~A"
name
(format nil "~?" (simple-condition-format-control error)
(simple-condition-format-arguments error))))
;;; FIXME: haven't double checked whether all Lisps signal a
;;; SIMPLE-ERROR on %load-foreign-library failure. In any case they
;;; should be throwing a more specific error.
(defun load-foreign-library-path (name path &optional search-path)
"Tries to load PATH using %LOAD-FOREIGN-LIBRARY which should try and
find it using the OS's usual methods. If that fails we try to find it
ourselves."
(handler-case
(values (%load-foreign-library name path)
(pathname path))
(simple-error (error)
(let ((dirs (parse-directories *foreign-library-directories*)))
(if-let (file (find-file path (append search-path dirs)))
(handler-case
(values (%load-foreign-library name (native-namestring file))
file)
(simple-error (error)
(report-simple-error name error)))
(report-simple-error name error))))))
(defun try-foreign-library-alternatives (name library-list &optional search-path)
"Goes through a list of alternatives and only signals an error when
none of alternatives were successfully loaded."
(dolist (lib library-list)
(multiple-value-bind (handle pathname)
(ignore-errors (load-foreign-library-helper name lib search-path))
(when handle
(return-from try-foreign-library-alternatives
(values handle pathname)))))
;; Perhaps we should show the error messages we got for each
;; alternative if we can figure out a nice way to do that.
(fl-error "Unable to load any of the alternatives:~% ~S" library-list))
(defparameter *cffi-feature-suffix-map*
'((:windows . ".dll")
(:darwin . ".dylib")
(:unix . ".so")
(t . ".so"))
"Mapping of OS feature keywords to shared library suffixes.")
(defun default-library-suffix ()
"Return a string to use as default library suffix based on the
operating system. This is used to implement the :DEFAULT option.
This will need to be extended as we test on more OSes."
(or (cdr (assoc-if #'featurep *cffi-feature-suffix-map*))
(fl-error "Unable to determine the default library suffix on this OS.")))
(defun load-foreign-library-helper (name thing &optional search-path)
(etypecase thing
((or pathname string)
(load-foreign-library-path name (filter-pathname thing) search-path))
(cons
(ecase (first thing)
(:framework (load-darwin-framework name (second thing)))
(:default
(unless (stringp (second thing))
(fl-error "Argument to :DEFAULT must be a string."))
(let ((library-path
(concatenate 'string
(second thing)
(default-library-suffix))))
(load-foreign-library-path name library-path search-path)))
(:or (try-foreign-library-alternatives name (rest thing) search-path))))))
(defun %do-load-foreign-library (library search-path)
(flet ((%do-load (lib name spec)
(when (foreign-library-spec lib)
(with-slots (handle pathname) lib
(setf (values handle pathname)
(load-foreign-library-helper
name spec (foreign-library-search-path lib)))))
lib))
(etypecase library
(symbol
(let* ((lib (get-foreign-library library))
(spec (foreign-library-spec lib)))
(%do-load lib library spec)))
((or string list)
(let* ((lib-name (gensym
(format nil "~:@(~A~)-"
(if (listp library)
(first library)
(file-namestring library)))))
(lib (make-instance 'foreign-library
:type :system
:name lib-name
:spec `((t ,library))
:search-path search-path)))
;; first try to load the anonymous library
;; and register it only if that worked
(%do-load lib lib-name library)
(setf (get-foreign-library lib-name) lib))))))
(defun filter-pathname (thing)
(typecase thing
(pathname (namestring thing))
(t thing)))
(defun load-foreign-library (library &key search-path)
"Loads a foreign LIBRARY which can be a symbol denoting a library defined
through DEFINE-FOREIGN-LIBRARY; a pathname or string in which case we try to
load it directly first then search for it in *FOREIGN-LIBRARY-DIRECTORIES*;
or finally list: either (:or lib1 lib2) or (:framework <framework-name>)."
(let ((library (filter-pathname library)))
(restart-case
(progn
;; dlopen/dlclose does reference counting, but the CFFI-SYS
;; API has no infrastructure to track that. Therefore if we
;; want to avoid increasing the internal dlopen reference
;; counter, and thus thwarting dlclose, then we need to try
;; to call CLOSE-FOREIGN-LIBRARY and ignore any signaled
;; errors.
(ignore-some-conditions (foreign-library-undefined-error)
(close-foreign-library library))
(%do-load-foreign-library library search-path))
;; Offer these restarts that will retry the call to
;; %LOAD-FOREIGN-LIBRARY.
(retry ()
:report "Try loading the foreign library again."
(load-foreign-library library :search-path search-path))
(use-value (new-library)
:report "Use another library instead."
:interactive read-new-value
(load-foreign-library new-library :search-path search-path)))))
(defmacro use-foreign-library (name)
`(load-foreign-library ',name))
;;;# Closing Foreign Libraries
(defun close-foreign-library (library)
"Closes a foreign library."
(let* ((library (filter-pathname library))
(lib (get-foreign-library library))
(handle (foreign-library-handle lib)))
(when handle
(%close-foreign-library handle)
(setf (foreign-library-handle lib) nil)
t)))
(defun reload-foreign-libraries (&key (test #'foreign-library-loaded-p))
"(Re)load all currently loaded foreign libraries."
(let ((libs (list-foreign-libraries)))
(loop for l in libs
for name = (foreign-library-name l)
when (funcall test name)
do (load-foreign-library name))
libs))

181
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/package.lisp Normal file
View file

@ -0,0 +1,181 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; package.lisp --- Package definition for CFFI.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cl-user)
(defpackage #:cffi
(:use #:common-lisp #:cffi-sys #:babel-encodings)
(:import-from #:alexandria
#:compose
#:ensure-list
#:featurep
#:format-symbol
#:hash-table-values
#:if-let
#:ignore-some-conditions
#:lastcar
#:make-gensym-list
#:make-keyword
#:mappend
#:once-only
#:parse-body
#:simple-style-warning
#:symbolicate
#:unwind-protect-case
#:when-let
#:with-unique-names)
(:export
;; Types.
#:foreign-pointer
;; FIXME: the following types are undocumented. They should
;; probably be replaced with a proper type introspection API
;; though.
#:*built-in-foreign-types*
#:*other-builtin-types*
#:*built-in-integer-types*
#:*built-in-float-types*
;; Primitive pointer operations.
#:foreign-free
#:foreign-alloc
#:mem-aptr
#:mem-aref
#:mem-ref
#:pointerp
#:pointer-eq
#:null-pointer
#:null-pointer-p
#:inc-pointer
#:incf-pointer
#:with-foreign-pointer
#:make-pointer
#:pointer-address
;; Shareable vectors.
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
;; Foreign string operations.
#:*default-foreign-encoding*
#:foreign-string-alloc
#:foreign-string-free
#:foreign-string-to-lisp
#:lisp-string-to-foreign
#:with-foreign-string
#:with-foreign-strings
#:with-foreign-pointer-as-string
;; Foreign array operations.
;; TODO: document these
#:foreign-array-alloc
#:foreign-array-free
#:foreign-array-to-lisp
#:lisp-array-to-foreign
#:with-foreign-array
#:foreign-aref
;; Foreign function operations.
#:defcfun
#:foreign-funcall
#:foreign-funcall-pointer
#:foreign-funcall-varargs
#:foreign-funcall-pointer-varargs
#:translate-camelcase-name
#:translate-name-from-foreign
#:translate-name-to-foreign
#:translate-underscore-separated-name
;; Foreign library operations.
#:*foreign-library-directories*
#:*darwin-framework-directories*
#:foreign-library
#:foreign-library-name
#:foreign-library-pathname
#:foreign-library-type
#:foreign-library-loaded-p
#:list-foreign-libraries
#:define-foreign-library
#:load-foreign-library
#:load-foreign-library-error
#:use-foreign-library
#:close-foreign-library
#:reload-foreign-libraries
;; Callbacks.
#:callback
#:get-callback
#:defcallback
;; Foreign type operations.
#:defcstruct
#:defcunion
#:defctype
#:defcenum
#:defbitfield
#:define-foreign-type
#:define-parse-method
#:define-c-struct-wrapper
#:foreign-enum-keyword
#:foreign-enum-keyword-list
#:foreign-enum-value
#:foreign-bitfield-symbol-list
#:foreign-bitfield-symbols
#:foreign-bitfield-value
#:foreign-slot-pointer
#:foreign-slot-value
#:foreign-slot-type
#:foreign-slot-offset
#:foreign-slot-count
#:foreign-slot-names
#:foreign-type-alignment
#:foreign-type-size
#:with-foreign-object
#:with-foreign-objects
#:with-foreign-slots
#:convert-to-foreign
#:convert-from-foreign
#:convert-into-foreign-memory
#:free-converted-object
#:translation-forms-for-class
;; Extensible foreign type operations.
#:define-translation-method ; FIXME: undocumented
#:translate-to-foreign
#:translate-from-foreign
#:translate-into-foreign-memory
#:free-translated-object
#:expand-to-foreign-dyn
#:expand-to-foreign
#:expand-from-foreign
#:expand-into-foreign-memory
;; Foreign globals.
#:defcvar
#:get-var-pointer
#:foreign-symbol-pointer
))

305
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/strings.lisp Normal file
View file

@ -0,0 +1,305 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; strings.lisp --- Operations on foreign strings.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi)
;;;# Foreign String Conversion
;;;
;;; Functions for converting NULL-terminated C-strings to Lisp strings
;;; and vice versa. The string functions accept an ENCODING keyword
;;; argument which is used to specify the encoding to use when
;;; converting to/from foreign strings.
(defvar *default-foreign-encoding* :utf-8
"Default foreign encoding.")
;;; TODO: refactor, sigh. Also, this should probably be a function.
(defmacro bget (ptr off &optional (bytes 1) (endianness :ne))
(let ((big-endian (member endianness
'(:be #+big-endian :ne #+little-endian :re))))
(once-only (ptr off)
(ecase bytes
(1 `(mem-ref ,ptr :uint8 ,off))
(2 (if big-endian
#+big-endian
`(mem-ref ,ptr :uint16 ,off)
#-big-endian
`(dpb (mem-ref ,ptr :uint8 ,off) (byte 8 8)
(mem-ref ,ptr :uint8 (1+ ,off)))
#+little-endian
`(mem-ref ,ptr :uint16 ,off)
#-little-endian
`(dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 8)
(mem-ref ,ptr :uint8 ,off))))
(4 (if big-endian
#+big-endian
`(mem-ref ,ptr :uint32 ,off)
#-big-endian
`(dpb (mem-ref ,ptr :uint8 ,off) (byte 8 24)
(dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 16)
(dpb (mem-ref ,ptr :uint8 (+ ,off 2)) (byte 8 8)
(mem-ref ,ptr :uint8 (+ ,off 3)))))
#+little-endian
`(mem-ref ,ptr :uint32 ,off)
#-little-endian
`(dpb (mem-ref ,ptr :uint8 (+ ,off 3)) (byte 8 24)
(dpb (mem-ref ,ptr :uint8 (+ ,off 2)) (byte 8 16)
(dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 8)
(mem-ref ,ptr :uint8 ,off))))))))))
(defmacro bset (val ptr off &optional (bytes 1) (endianness :ne))
(let ((big-endian (member endianness
'(:be #+big-endian :ne #+little-endian :re))))
(ecase bytes
(1 `(setf (mem-ref ,ptr :uint8 ,off) ,val))
(2 (if big-endian
#+big-endian
`(setf (mem-ref ,ptr :uint16 ,off) ,val)
#-big-endian
`(setf (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 0) ,val)
(mem-ref ,ptr :uint8 ,off) (ldb (byte 8 8) ,val))
#+little-endian
`(setf (mem-ref ,ptr :uint16 ,off) ,val)
#-little-endian
`(setf (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 0) ,val)
(mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 8) ,val))))
(4 (if big-endian
#+big-endian
`(setf (mem-ref ,ptr :uint32 ,off) ,val)
#-big-endian
`(setf (mem-ref ,ptr :uint8 (+ 3 ,off)) (ldb (byte 8 0) ,val)
(mem-ref ,ptr :uint8 (+ 2 ,off)) (ldb (byte 8 8) ,val)
(mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 16) ,val)
(mem-ref ,ptr :uint8 ,off) (ldb (byte 8 24) ,val))
#+little-endian
`(setf (mem-ref ,ptr :uint32 ,off) ,val)
#-little-endian
`(setf (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 0) ,val)
(mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 8) ,val)
(mem-ref ,ptr :uint8 (+ ,off 2)) (ldb (byte 8 16) ,val)
(mem-ref ,ptr :uint8 (+ ,off 3)) (ldb (byte 8 24) ,val)))))))
;;; TODO: tackle optimization notes.
(defparameter *foreign-string-mappings*
(instantiate-concrete-mappings
;; :optimize ((speed 3) (debug 0) (compilation-speed 0) (safety 0))
:octet-seq-getter bget
:octet-seq-setter bset
:octet-seq-type foreign-pointer
:code-point-seq-getter babel::string-get
:code-point-seq-setter babel::string-set
:code-point-seq-type babel:simple-unicode-string))
(defun null-terminator-len (encoding)
(length (enc-nul-encoding (get-character-encoding encoding))))
(defun lisp-string-to-foreign (string buffer bufsize &key (start 0) end offset
(encoding *default-foreign-encoding*))
(check-type string string)
(when offset
(setq buffer (inc-pointer buffer offset)))
(with-checked-simple-vector ((string (coerce string 'babel:unicode-string))
(start start) (end end))
(declare (type simple-string string))
(let ((mapping (lookup-mapping *foreign-string-mappings* encoding))
(nul-len (null-terminator-len encoding)))
(assert (plusp bufsize))
(multiple-value-bind (size end)
(funcall (octet-counter mapping) string start end (- bufsize nul-len))
(funcall (encoder mapping) string start end buffer 0)
(dotimes (i nul-len)
(setf (mem-ref buffer :char (+ size i)) 0))))
buffer))
;;; Expands into a loop that calculates the length of the foreign
;;; string at PTR plus OFFSET, using ACCESSOR and looking for a null
;;; terminator of LENGTH bytes.
(defmacro %foreign-string-length (ptr offset type length)
(once-only (ptr offset)
`(do ((i 0 (+ i ,length)))
((zerop (mem-ref ,ptr ,type (+ ,offset i))) i)
(declare (fixnum i)))))
;;; Return the length in octets of the null terminated foreign string
;;; at POINTER plus OFFSET octets, assumed to be encoded in ENCODING,
;;; a CFFI encoding. This should be smart enough to look for 8-bit vs
;;; 16-bit null terminators, as appropriate for the encoding.
(defun foreign-string-length (pointer &key (encoding *default-foreign-encoding*)
(offset 0))
(ecase (null-terminator-len encoding)
(1 (%foreign-string-length pointer offset :uint8 1))
(2 (%foreign-string-length pointer offset :uint16 2))
(4 (%foreign-string-length pointer offset :uint32 4))))
(defun foreign-string-to-lisp (pointer &key (offset 0) count
(max-chars (1- array-total-size-limit))
(encoding *default-foreign-encoding*))
"Copy at most COUNT bytes from POINTER plus OFFSET encoded in
ENCODING into a Lisp string and return it. If POINTER is a null
pointer, NIL is returned."
(unless (null-pointer-p pointer)
(let ((count (or count
(foreign-string-length
pointer :encoding encoding :offset offset)))
(mapping (lookup-mapping *foreign-string-mappings* encoding)))
(assert (plusp max-chars))
(multiple-value-bind (size new-end)
(funcall (code-point-counter mapping)
pointer offset (+ offset count) max-chars)
(let ((string (make-string size :element-type 'babel:unicode-char)))
(funcall (decoder mapping) pointer offset new-end string 0)
(values string (- new-end offset)))))))
;;;# Using Foreign Strings
(defun foreign-string-alloc (string &key (encoding *default-foreign-encoding*)
(null-terminated-p t) (start 0) end)
"Allocate a foreign string containing Lisp string STRING.
The string must be freed with FOREIGN-STRING-FREE."
(check-type string string)
(with-checked-simple-vector ((string (coerce string 'babel:unicode-string))
(start start) (end end))
(declare (type simple-string string))
(let* ((mapping (lookup-mapping *foreign-string-mappings* encoding))
(count (funcall (octet-counter mapping) string start end 0))
(nul-length (if null-terminated-p
(null-terminator-len encoding)
0))
(length (+ count nul-length))
(ptr (foreign-alloc :char :count length)))
(funcall (encoder mapping) string start end ptr 0)
(dotimes (i nul-length)
(setf (mem-ref ptr :char (+ count i)) 0))
(values ptr length))))
(defun foreign-string-free (ptr)
"Free a foreign string allocated by FOREIGN-STRING-ALLOC."
(foreign-free ptr))
(defmacro with-foreign-string ((var-or-vars lisp-string &rest args) &body body)
"VAR-OR-VARS is not evaluated and should be a list of the form
\(VAR &OPTIONAL BYTE-SIZE-VAR) or just a VAR symbol. VAR is
bound to a foreign string containing LISP-STRING in BODY. When
BYTE-SIZE-VAR is specified then bind the C buffer size
\(including the possible null terminator\(s)) to this variable."
(destructuring-bind (var &optional size-var)
(ensure-list var-or-vars)
`(multiple-value-bind (,var ,@(when size-var (list size-var)))
(foreign-string-alloc ,lisp-string ,@args)
(unwind-protect
(progn ,@body)
(foreign-string-free ,var)))))
(defmacro with-foreign-strings (bindings &body body)
"See WITH-FOREIGN-STRING's documentation."
(if bindings
`(with-foreign-string ,(first bindings)
(with-foreign-strings ,(rest bindings)
,@body))
`(progn ,@body)))
(defmacro with-foreign-pointer-as-string
((var-or-vars size &rest args) &body body)
"VAR-OR-VARS is not evaluated and should be a list of the form
\(VAR &OPTIONAL SIZE-VAR) or just a VAR symbol. VAR is bound to
a foreign buffer of size SIZE within BODY. The return value is
constructed by calling FOREIGN-STRING-TO-LISP on the foreign
buffer along with ARGS." ; fix wording, sigh
(destructuring-bind (var &optional size-var)
(ensure-list var-or-vars)
`(with-foreign-pointer (,var ,size ,size-var)
(progn
,@body
(values (foreign-string-to-lisp ,var ,@args))))))
;;;# Automatic Conversion of Foreign Strings
(define-foreign-type foreign-string-type ()
(;; CFFI encoding of this string.
(encoding :initform nil :initarg :encoding :reader encoding)
;; Should we free after translating from foreign?
(free-from-foreign :initarg :free-from-foreign
:reader fst-free-from-foreign-p
:initform nil :type boolean)
;; Should we free after translating to foreign?
(free-to-foreign :initarg :free-to-foreign
:reader fst-free-to-foreign-p
:initform t :type boolean))
(:actual-type :pointer)
(:simple-parser :string))
;;; describe me
(defun fst-encoding (type)
(or (encoding type) *default-foreign-encoding*))
;;; Display the encoding when printing a FOREIGN-STRING-TYPE instance.
(defmethod print-object ((type foreign-string-type) stream)
(print-unreadable-object (type stream :type t)
(format stream "~S" (fst-encoding type))))
(defmethod translate-to-foreign ((s string) (type foreign-string-type))
(values (foreign-string-alloc s :encoding (fst-encoding type))
(fst-free-to-foreign-p type)))
(defmethod translate-to-foreign (obj (type foreign-string-type))
(cond
((pointerp obj)
(values obj nil))
;; FIXME: we used to support UB8 vectors but not anymore.
;; ((typep obj '(array (unsigned-byte 8)))
;; (values (foreign-string-alloc obj) t))
(t (error "~A is not a Lisp string or pointer." obj))))
(defmethod translate-from-foreign (ptr (type foreign-string-type))
(unwind-protect
(values (foreign-string-to-lisp ptr :encoding (fst-encoding type)))
(when (fst-free-from-foreign-p type)
(foreign-free ptr))))
(defmethod free-translated-object (ptr (type foreign-string-type) free-p)
(when free-p
(foreign-string-free ptr)))
(defmethod expand-to-foreign-dyn-indirect
(value var body (type foreign-string-type))
(alexandria:with-gensyms (str)
(expand-to-foreign-dyn
value
str
(list
(expand-to-foreign-dyn-indirect str var body (parse-type :pointer)))
type)))
;;;# STRING+PTR
(define-foreign-type foreign-string+ptr-type (foreign-string-type)
()
(:simple-parser :string+ptr))
(defmethod translate-from-foreign (value (type foreign-string+ptr-type))
(list (call-next-method) value))

133
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/structures.lisp Normal file
View file

@ -0,0 +1,133 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; structures.lisp --- Methods for translating foreign structures.
;;;
;;; Copyright (C) 2011, Liam M. Healy <lhealy@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi)
;;; Definitions for conversion of foreign structures.
(defmethod translate-into-foreign-memory ((object list)
(type foreign-struct-type)
p)
(unless (bare-struct-type-p type)
(loop for (name value) on object by #'cddr
do (setf (foreign-slot-value p (unparse-type type) name)
(let ((slot (gethash name (structure-slots type))))
(convert-to-foreign value (slot-type slot)))))))
(defmethod translate-to-foreign (value (type foreign-struct-type))
(let ((ptr (foreign-alloc type)))
(translate-into-foreign-memory value type ptr)
ptr))
(defmethod translate-from-foreign (p (type foreign-struct-type))
;; Iterate over slots, make plist
(if (bare-struct-type-p type)
p
(let ((plist (list)))
(loop for slot being the hash-value of (structure-slots type)
for name = (slot-name slot)
do (setf (getf plist name)
(foreign-struct-slot-value p slot)))
plist)))
(defmethod free-translated-object (ptr (type foreign-struct-type) freep)
(unless (bare-struct-type-p type)
;; Look for any pointer slots and free them first
(loop for slot being the hash-value of (structure-slots type)
when (and (listp (slot-type slot)) (eq (first (slot-type slot)) :pointer))
do
;; Free if the pointer is to a specific type, not generic :pointer
(free-translated-object
(foreign-slot-value ptr type (slot-name slot))
(rest (slot-type slot))
freep))
(foreign-free ptr)))
(defmacro define-translation-method ((object type method) &body body)
"Define a translation method for the foreign structure type; 'method is one of :into, :from, or :to, meaning relation to foreign memory. If :into, the variable 'pointer is the foreign pointer. Note: type must be defined and loaded before this macro is expanded, and just the bare name (without :struct) should be specified."
(let ((tclass (class-name (class-of (cffi::parse-type `(:struct ,type))))))
(when (eq tclass 'foreign-struct-type)
(error "Won't replace existing translation method for foreign-struct-type"))
`(defmethod
,(case method
(:into 'translate-into-foreign-memory)
(:from 'translate-from-foreign)
(:to 'translate-to-foreign))
;; Arguments to the method
(,object
(type ,tclass)
,@(when (eq method :into) '(pointer))) ; is intentional variable capture a good idea?
;; The body
(declare (ignorable type)) ; I can't think of a reason why you'd want to use this
,@body)))
(defmacro translation-forms-for-class (class type-class)
"Make forms for translation of foreign structures to and from a standard class. The class slots are assumed to have the same name as the foreign structure."
;; Possible improvement: optional argument to map structure slot names to/from class slot names.
`(progn
(defmethod translate-from-foreign (pointer (type ,type-class))
;; Make the instance from the plist
(apply 'make-instance ',class (call-next-method)))
(defmethod translate-into-foreign-memory ((object ,class) (type ,type-class) pointer)
(call-next-method
;; Translate into a plist and call the general method
(loop for slot being the hash-value of (structure-slots type)
for name = (slot-name slot)
append (list slot-name (slot-value object slot-name)))
type
pointer))))
;;; For a class already defined and loaded, and a defcstruct already defined, use
;;; (translation-forms-for-class class type-class)
;;; to connnect the two. It would be nice to have a macro to do all three simultaneously.
;;; (defmacro define-foreign-structure (class ))
#|
(defmacro define-structure-conversion
(value-symbol type lisp-class slot-names to-form from-form &optional (struct-name type))
"Define the functions necessary to convert to and from a foreign structure. The to-form sets each of the foreign slots in succession, assume the foreign object exists. The from-form creates the Lisp object, making it with the correct value by reference to foreign slots."
`(flet ((map-slots (fn val)
(maphash
(lambda (name slot-struct)
(funcall fn (foreign-slot-value val ',type name) (slot-type slot-struct)))
(slots (follow-typedefs (parse-type ',type))))))
;; Convert this to a separate function so it doesn't have to be recomputed on the fly each time.
(defmethod translate-to-foreign ((,value-symbol ,lisp-class) (type ,type))
(let ((p (foreign-alloc ',struct-name)))
;;(map-slots #'translate-to-foreign ,value-symbol) ; recursive translation of slots
(with-foreign-slots (,slot-names p ,struct-name)
,to-form)
(values p t))) ; second value is passed to FREE-TRANSLATED-OBJECT
(defmethod free-translated-object (,value-symbol (p ,type) freep)
(when freep
;; Is this redundant?
(map-slots #'free-translated-object value) ; recursively free slots
(foreign-free ,value-symbol)))
(defmethod translate-from-foreign (,value-symbol (type ,type))
(with-foreign-slots (,slot-names ,value-symbol ,struct-name)
,from-form))))
|#

1051
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/types.lisp Normal file
View file

File diff suppressed because it is too large Load diff

84
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/utils.lisp Normal file
View file

@ -0,0 +1,84 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; utils.lisp --- Various utilities.
;;;
;;; Copyright (C) 2005-2008, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi)
(defmacro discard-docstring (body-var &optional force)
"Discards the first element of the list in body-var if it's a
string and the only element (or if FORCE is T)."
`(when (and (stringp (car ,body-var)) (or ,force (cdr ,body-var)))
(pop ,body-var)))
(defun single-bit-p (integer)
"Answer whether INTEGER, which must be an integer, is a single
set twos-complement bit."
(if (<= integer 0)
nil ; infinite set bits for negatives
(loop until (logbitp 0 integer)
do (setf integer (ash integer -1))
finally (return (zerop (ash integer -1))))))
;;; This function is here because it needs to be defined early. It's
;;; used by DEFINE-PARSE-METHOD and DEFCTYPE to warn users when
;;; they're defining types whose names belongs to the KEYWORD or CL
;;; packages. CFFI itself gets to use keywords without a warning.
(defun warn-if-kw-or-belongs-to-cl (name)
(let ((package (symbol-package name)))
(when (and (not (eq *package* (find-package '#:cffi)))
(member package '(#:common-lisp #:keyword)
:key #'find-package))
(warn "Defining a foreign type named ~S. This symbol belongs to the ~A ~
package and that may interfere with other code using CFFI."
name (package-name package)))))
(define-condition obsolete-argument-warning (style-warning)
((old-arg :initarg :old-arg :reader old-arg)
(new-arg :initarg :new-arg :reader new-arg))
(:report (lambda (c s)
(format s "Keyword ~S is obsolete, please use ~S"
(old-arg c) (new-arg c)))))
(defun warn-obsolete-argument (old-arg new-arg)
(warn 'obsolete-argument-warning
:old-arg old-arg :new-arg new-arg))
(defun split-if (test seq &optional (dir :before))
(remove-if #'(lambda (x) (equal x (subseq seq 0 0)))
(loop for start fixnum = 0
then (if (eq dir :before)
stop
(the fixnum (1+ (the fixnum stop))))
while (< start (length seq))
for stop = (position-if test seq
:start (if (eq dir :elide)
start
(the fixnum (1+ start))))
collect (subseq seq start
(if (and stop (eq dir :after))
(the fixnum (1+ (the fixnum stop)))
stop))
while stop)))