Tmux etc

sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/src/cffi-clasp.lisp

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