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

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