Tmux etc
This commit is contained in:
Ian Keane
parent
276853ba84
commit
1cb167b597
361 changed files with 77302 additions and 4 deletions
|
|
@ -0,0 +1,132 @@
|
|||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; funcall.lisp -- FOREIGN-FUNCALL implementation using libffi
|
||||
;;;
|
||||
;;; Copyright (C) 2009, 2010, 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)
|
||||
|
||||
(define-condition libffi-error (cffi-error)
|
||||
((function-name
|
||||
:initarg :function-name :reader function-name)))
|
||||
|
||||
(define-condition simple-libffi-error (simple-error libffi-error)
|
||||
())
|
||||
|
||||
(defun libffi-error (function-name format-control &rest format-arguments)
|
||||
(error 'simple-libffi-error
|
||||
:function-name function-name
|
||||
:format-control format-control
|
||||
:format-arguments format-arguments))
|
||||
|
||||
(defun make-libffi-cif (function-name return-type argument-types
|
||||
&optional (abi :default-abi))
|
||||
"Generate or retrieve the Call InterFace needed to call the function through libffi."
|
||||
(let* ((argument-count (length argument-types))
|
||||
(cif (foreign-alloc '(:struct ffi-cif)))
|
||||
(ffi-argtypes (foreign-alloc :pointer :count argument-count)))
|
||||
(loop
|
||||
:for type :in argument-types
|
||||
:for index :from 0
|
||||
:do (setf (mem-aref ffi-argtypes :pointer index)
|
||||
(make-libffi-type-descriptor (parse-type type))))
|
||||
(unless (eql :ok (libffi/prep-cif cif abi argument-count
|
||||
(make-libffi-type-descriptor (parse-type return-type))
|
||||
ffi-argtypes))
|
||||
(libffi-error function-name
|
||||
"The 'ffi_prep_cif' libffi call failed for function ~S."
|
||||
function-name))
|
||||
cif))
|
||||
|
||||
(defun free-libffi-cif (ptr)
|
||||
(foreign-free (foreign-slot-value ptr '(:struct ffi-cif) 'argument-types))
|
||||
(foreign-free ptr))
|
||||
|
||||
(defun translate-objects-ret (symbols function-arguments types return-type call-form)
|
||||
(translate-objects
|
||||
symbols
|
||||
function-arguments
|
||||
types
|
||||
return-type
|
||||
(if (or (eql return-type :void)
|
||||
(typep (parse-type return-type) 'translatable-foreign-type))
|
||||
call-form
|
||||
;; built-in types won't be translated by
|
||||
;; expand-from-foreign, we have to do it here
|
||||
`(mem-ref
|
||||
,call-form
|
||||
',(canonicalize-foreign-type return-type)))
|
||||
t))
|
||||
|
||||
(defun foreign-funcall-form/fsbv-with-libffi (function function-arguments symbols types
|
||||
return-type argument-types
|
||||
&optional pointerp (abi :default-abi))
|
||||
"A body of foreign-funcall calling the libffi function #'call (ffi_call)."
|
||||
(let ((argument-count (length argument-types)))
|
||||
`(with-foreign-objects ((argument-values :pointer ,argument-count)
|
||||
,@(unless (eql return-type :void)
|
||||
`((result ',return-type))))
|
||||
,(translate-objects-ret
|
||||
symbols function-arguments types return-type
|
||||
;; NOTE: We must delay the cif creation until the first call
|
||||
;; because it's FOREIGN-ALLOC'd, i.e. it gets corrupted by an
|
||||
;; image save/restore cycle. This way a lib will remain usable
|
||||
;; through a save/restore cycle if the save happens before any
|
||||
;; FFI calls will have been made, i.e. nothing is malloc'd yet.
|
||||
`(progn
|
||||
(loop
|
||||
:for arg :in (list ,@symbols)
|
||||
:for count :from 0
|
||||
:do (setf (mem-aref argument-values :pointer count) arg))
|
||||
(let* ((libffi-cif-cache (load-time-value (cons 'libffi-cif-cache nil)))
|
||||
(libffi-cif (or (cdr libffi-cif-cache)
|
||||
(setf (cdr libffi-cif-cache)
|
||||
;; FIXME ideally we should install a finalizer on the cons
|
||||
;; that calls FREE-LIBFFI-CIF on the cif (when the function
|
||||
;; gets redefined, and the cif becomes unreachable). but a
|
||||
;; finite world is full of compromises... - attila
|
||||
(make-libffi-cif ,function ',return-type
|
||||
',argument-types ',abi)))))
|
||||
(libffi/call libffi-cif
|
||||
,(if pointerp
|
||||
function
|
||||
`(foreign-symbol-pointer ,function))
|
||||
,(if (eql return-type :void) '(null-pointer) 'result)
|
||||
argument-values)
|
||||
,(if (eql return-type :void)
|
||||
'(values)
|
||||
'result)))))))
|
||||
|
||||
(setf *foreign-structures-by-value* 'foreign-funcall-form/fsbv-with-libffi)
|
||||
|
||||
;; DEPRECATED Its presence encourages the use of #+fsbv which may lead to the
|
||||
;; situation where a fasl was produced by an image that has fsbv feature
|
||||
;; and then ends up being loaded into an image later that has no fsbv support
|
||||
;; loaded. Use explicit ASDF dependencies instead and assume the presence
|
||||
;; of the feature accordingly.
|
||||
(pushnew :fsbv *features*)
|
||||
|
||||
;; DEPRECATED This is here only for backwards compatibility until its fate is
|
||||
;; decided. See the mailing list discussion for details.
|
||||
(defctype :sizet size-t)
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; init.lisp --- Load libffi and define basics
|
||||
;;;
|
||||
;;; Copyright (C) 2009, 2010, 2011 Liam 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)
|
||||
|
||||
;;; See file:///usr/share/doc/libffi-dev/html/The-Basics.html#The-Basics
|
||||
|
||||
(defcfun ("ffi_prep_cif" libffi/prep-cif) status
|
||||
(ffi-cif :pointer)
|
||||
(ffi-abi abi)
|
||||
(nargs :uint)
|
||||
(rtype :pointer)
|
||||
(argtypes :pointer))
|
||||
|
||||
(defcfun ("ffi_call" libffi/call) :void
|
||||
(ffi-cif :pointer)
|
||||
(function :pointer)
|
||||
(rvalue :pointer)
|
||||
(avalues :pointer))
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; libffi-types.lisp -- CFFI-Grovel definitions for libffi
|
||||
;;;
|
||||
;;; Copyright (C) 2009, 2010, 2011, 2017 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)
|
||||
|
||||
#+linux
|
||||
(define "_GNU_SOURCE")
|
||||
|
||||
;; When installed through Mac Ports, libffi include files
|
||||
;; will be found in /opt/local/include.
|
||||
#+darwin
|
||||
(cc-flags "-I/opt/local/include/")
|
||||
|
||||
#+openbsd
|
||||
(cc-flags "-I/usr/local/include")
|
||||
|
||||
#+freebsd
|
||||
(cc-flags "-I/usr/local/include")
|
||||
|
||||
(pkg-config-cflags "libffi" :optional t)
|
||||
|
||||
#+darwin
|
||||
(include "ffi/ffi.h")
|
||||
#-darwin
|
||||
(include "ffi.h")
|
||||
|
||||
(cenum status
|
||||
((:ok "FFI_OK"))
|
||||
((:bad-typedef "FFI_BAD_TYPEDEF"))
|
||||
((:bad-abi "FFI_BAD_ABI")))
|
||||
|
||||
#+freebsd
|
||||
(cenum abi
|
||||
((:default-abi "FFI_DEFAULT_ABI")))
|
||||
|
||||
#+(and windows x86-64)
|
||||
(cenum abi
|
||||
((:default-abi "FFI_DEFAULT_ABI"))
|
||||
((:win64 "FFI_WIN64")))
|
||||
|
||||
#+(and windows (not x86-64))
|
||||
(cenum abi
|
||||
((:default-abi "FFI_DEFAULT_ABI"))
|
||||
((:sysv "FFI_SYSV"))
|
||||
((:stdcall "FFI_STDCALL")))
|
||||
|
||||
#-(or freebsd windows)
|
||||
(cenum abi
|
||||
((:default-abi "FFI_DEFAULT_ABI"))
|
||||
#-x86-64
|
||||
((:sysv "FFI_SYSV"))
|
||||
((:unix64 "FFI_UNIX64")))
|
||||
|
||||
(ctype ffi-abi "ffi_abi")
|
||||
|
||||
(ctype size-t "size_t")
|
||||
|
||||
(cstruct ffi-type "struct _ffi_type"
|
||||
(size "size" :type size-t)
|
||||
(alignment "alignment" :type :unsigned-short)
|
||||
(type "type" :type :unsigned-short)
|
||||
(elements "elements" :type :pointer))
|
||||
|
||||
(cstruct ffi-cif "ffi_cif"
|
||||
(abi "abi" :type ffi-abi)
|
||||
(argument-count "nargs" :type :unsigned-int)
|
||||
(argument-types "arg_types" :type :pointer)
|
||||
(return-type "rtype" :type :pointer)
|
||||
(bytes "bytes" :type :unsigned-int)
|
||||
(flags "flags" :type :unsigned-int))
|
||||
|
||||
(constant (+type-void+ "FFI_TYPE_VOID"))
|
||||
(constant (+type-int+ "FFI_TYPE_INT"))
|
||||
(constant (+type-float+ "FFI_TYPE_FLOAT"))
|
||||
(constant (+type-double+ "FFI_TYPE_DOUBLE"))
|
||||
(constant (+type-longdouble+ "FFI_TYPE_LONGDOUBLE"))
|
||||
(constant (+type-uint8+ "FFI_TYPE_UINT8"))
|
||||
(constant (+type-sint8+ "FFI_TYPE_SINT8"))
|
||||
(constant (+type-uint16+ "FFI_TYPE_UINT16"))
|
||||
(constant (+type-sint16+ "FFI_TYPE_SINT16"))
|
||||
(constant (+type-uint32+ "FFI_TYPE_UINT32"))
|
||||
(constant (+type-sint32+ "FFI_TYPE_SINT32"))
|
||||
(constant (+type-uint64+ "FFI_TYPE_UINT64"))
|
||||
(constant (+type-sint64+ "FFI_TYPE_SINT64"))
|
||||
(constant (+type-struct+ "FFI_TYPE_STRUCT"))
|
||||
(constant (+type-pointer+ "FFI_TYPE_POINTER"))
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; libffi.lisp --- Load libffi
|
||||
;;;
|
||||
;;; Copyright (C) 2009, 2011 Liam M. Healy
|
||||
;;;
|
||||
;;; 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)
|
||||
|
||||
(define-foreign-library (libffi)
|
||||
(:darwin (:or "libffi.dylib" "libffi32.dylib" "/usr/lib/libffi.dylib"))
|
||||
(:solaris (:or "/usr/lib/amd64/libffi.so" "/usr/lib/libffi.so"))
|
||||
(:openbsd "libffi.so")
|
||||
(:unix (:or "libffi.so.7" "libffi32.so.7" "libffi.so.6" "libffi32.so.6" "libffi.so.5" "libffi32.so.5"))
|
||||
(:windows (:or "libffi-7.dll" "libffi-6.dll" "libffi-5.dll" "libffi.dll"))
|
||||
(t (:default "libffi")))
|
||||
|
||||
(load-foreign-library 'libffi)
|
||||
|
|
@ -0,0 +1,106 @@
|
|||
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; type-descriptors.lisp --- Build malloc'd libffi type descriptors
|
||||
;;;
|
||||
;;; Copyright (C) 2009, 2011 Liam M. Healy
|
||||
;;;
|
||||
;;; 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 type-descriptor-ptr (type)
|
||||
`(foreign-symbol-pointer ,(format nil "ffi_type_~(~A~)" type)))
|
||||
|
||||
(defmacro type-descriptor-ptr/integer (type)
|
||||
`(foreign-symbol-pointer
|
||||
,(format nil "ffi_type_~Aint~D"
|
||||
(if (string-equal type "unsigned"
|
||||
:end1 (min 8 (length (string type))))
|
||||
"u" "s")
|
||||
(* 8 (foreign-type-size type)))))
|
||||
|
||||
(defun %make-libffi-type-descriptor/struct (type)
|
||||
(labels
|
||||
((slot-multiplicity (slot)
|
||||
(if (typep slot 'aggregate-struct-slot)
|
||||
(slot-count slot)
|
||||
1))
|
||||
(number-of-items (structure-type)
|
||||
"Total number of items in the foreign structure."
|
||||
(loop for val being the hash-value of (structure-slots structure-type)
|
||||
sum (slot-multiplicity val))))
|
||||
(let* ((ptr (foreign-alloc '(:struct ffi-type)))
|
||||
(nitems (number-of-items type))
|
||||
(type-pointer-array
|
||||
(foreign-alloc :pointer :count (1+ nitems))))
|
||||
(loop for slot in (slots-in-order type)
|
||||
for ltp = (make-libffi-type-descriptor
|
||||
(parse-type (slot-type slot)))
|
||||
with slot-counter = 0
|
||||
do (if ltp
|
||||
(loop
|
||||
repeat (slot-multiplicity slot)
|
||||
do (setf
|
||||
(mem-aref
|
||||
type-pointer-array :pointer slot-counter)
|
||||
ltp)
|
||||
(incf slot-counter))
|
||||
(libffi-error nil
|
||||
"Slot type ~A in foreign structure is unknown to libffi."
|
||||
(unparse-type (slot-type slot)))))
|
||||
(setf (mem-aref type-pointer-array :pointer nitems)
|
||||
(null-pointer))
|
||||
(macrolet ((store (slot value)
|
||||
`(setf (foreign-slot-value ptr '(:struct ffi-type) ',slot) ,value)))
|
||||
(store size 0)
|
||||
(store alignment 0)
|
||||
(store type +type-struct+)
|
||||
(store elements type-pointer-array))
|
||||
ptr)))
|
||||
|
||||
(defgeneric make-libffi-type-descriptor (object)
|
||||
(:documentation "Build a libffi struct that describes the type for libffi. This will be used as a cached static read-only argument when the actual call happens.")
|
||||
(:method ((object foreign-built-in-type))
|
||||
(let ((type-keyword (type-keyword object)))
|
||||
#.`(case type-keyword
|
||||
,@(loop
|
||||
:for type :in (append *built-in-float-types*
|
||||
*other-builtin-types*)
|
||||
:collect `(,type (type-descriptor-ptr ,type)))
|
||||
,@(loop
|
||||
:for type :in *built-in-integer-types*
|
||||
:collect `(,type (type-descriptor-ptr/integer ,type)))
|
||||
;; there's a generic error report in an :around method
|
||||
)))
|
||||
(:method ((type foreign-pointer-type))
|
||||
;; simplify all pointer types into a void*
|
||||
(type-descriptor-ptr :pointer))
|
||||
(:method ((type foreign-struct-type))
|
||||
(%make-libffi-type-descriptor/struct type))
|
||||
(:method :around (object)
|
||||
(let ((result (call-next-method)))
|
||||
(assert result () "~S failed on ~S. That's bad."
|
||||
'make-libffi-type-descriptor object)
|
||||
result))
|
||||
(:method ((type foreign-type-alias))
|
||||
;; Set the type pointer on demand for alias types (e.g. typedef, enum, etc)
|
||||
(make-libffi-type-descriptor (actual-type type))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue