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

132
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/libffi/funcall.lisp Normal file
View file

@ -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)