201 lines
6.2 KiB
Common Lisp
201 lines
6.2 KiB
Common Lisp
;;;; -*- 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))
|