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

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