src/cffi-clasp.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-clasp.lisp --- CFFI-SYS implementation for Clasp.
   4 ;;;
   5 ;;; Copyright (C) 2017 Frank Goenninger  <frank.goenninger@goenninger.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cffi-sys)
  29
  30 ;;;# Mis-features
  31
  32 (pushnew 'flat-namespace cl:*features*)
  33
  34 ;;;# Symbol Case
  35
  36 (defun canonicalize-symbol-name-case (name)
  37   (declare (string name))
  38   (string-upcase name))
  39
  40 ;;;# Allocation
  41
  42 (defun %foreign-alloc (size)
  43   "Allocate SIZE bytes of foreign-addressable memory."
  44   (clasp-ffi:%foreign-alloc size))
  45
  46 (defun foreign-free (ptr)
  47   "Free a pointer PTR allocated by FOREIGN-ALLOC."
  48   (clasp-ffi:%foreign-free ptr))
  49
  50 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  51   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  52 pointer in VAR is invalid beyond the dynamic extent of BODY, and
  53 may be stack-allocated if supported by the implementation.  If
  54 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
  55   (unless size-var
  56     (setf size-var (gensym "SIZE")))
  57   `(let* ((,size-var ,size)
  58           (,var (%foreign-alloc ,size-var)))
  59      (unwind-protect
  60           (progn ,@body)
  61        (foreign-free ,var))))
  62
  63 ;;;# Misc. Pointer Operations
  64
  65 (deftype foreign-pointer ()
  66   'clasp-ffi:foreign-data)
  67
  68 (defun null-pointer-p (ptr)
  69   "Test if PTR is a null pointer."
  70   (clasp-ffi:%null-pointer-p ptr))
  71
  72 (defun null-pointer ()
  73   "Construct and return a null pointer."
  74   (clasp-ffi:%make-nullpointer))
  75
  76 (defun make-pointer (address)
  77   "Return a pointer pointing to ADDRESS."
  78   (clasp-ffi:%make-pointer address))
  79
  80 (defun inc-pointer (ptr offset)
  81   "Return a pointer OFFSET bytes past PTR."
  82   (clasp-ffi:%inc-pointer ptr offset))
  83
  84 (defun pointer-address (ptr)
  85   "Return the address pointed to by PTR."
  86   (clasp-ffi:%foreign-data-address ptr))
  87
  88 (defun pointerp (ptr)
  89   "Return true if PTR is a foreign pointer."
  90   (typep ptr 'clasp-ffi:foreign-data))
  91
  92 (defun pointer-eq (ptr1 ptr2)
  93   "Return true if PTR1 and PTR2 point to the same address."
  94   (check-type ptr1 clasp-ffi:foreign-data)
  95   (check-type ptr2 clasp-ffi:foreign-data)
  96   (eql (pointer-address ptr1) (pointer-address ptr2)))
  97
  98
  99 ;;;# Shareable Vectors
 100 ;;;
 101 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 102 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 103 ;;; implementation can't do this.
 104
 105 (defun make-shareable-byte-vector (size)
 106   "Create a Lisp vector of SIZE bytes that can passed to
 107 WITH-POINTER-TO-VECTOR-DATA."
 108   (make-array size :element-type '(unsigned-byte 8)))
 109
 110 ;; frgo, 2016-07-02: TODO: Implemenent!
 111 ;; (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 112 ;;   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 113 ;;   `(let ((,ptr-var (si:make-foreign-data-from-array ,vector)))
 114 ;;      ,@body))
 115
 116 (defun %foreign-type-size (type-keyword)
 117   "Return the size in bytes of a foreign type."
 118   (clasp-ffi:%foreign-type-size type-keyword))
 119
 120 (defun %foreign-type-alignment (type-keyword)
 121   "Return the alignment in bytes of a foreign type."
 122   (clasp-ffi:%foreign-type-alignment type-keyword))
 123
 124 ;;;# Dereferencing
 125
 126 (defun %mem-ref (ptr type &optional (offset 0))
 127   "Dereference an object of TYPE at OFFSET bytes from PTR."
 128   (clasp-ffi:%mem-ref ptr type offset))
 129
 130 (defun %mem-set (value ptr type &optional (offset 0))
 131   "Set an object of TYPE at OFFSET bytes from PTR."
 132   (clasp-ffi:%mem-set ptr type value offset))
 133
 134 (defmacro %foreign-funcall (name args &key library convention)
 135   "Call a foreign function."
 136   (declare (ignore library convention))
 137   `(clasp-ffi:%foreign-funcall ,name ,@args))
 138
 139 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 140   "Funcall a pointer to a foreign function."
 141   (declare (ignore convention))
 142   `(clasp-ffi:%foreign-funcall-pointer ,ptr ,@args))
 143
 144 ;;;# Foreign Libraries
 145
 146 (defun %load-foreign-library (name path)
 147   "Load a foreign library."
 148   (clasp-ffi:%load-foreign-library name path))
 149
 150 (defun %close-foreign-library (handle)
 151   "Close a foreign library."
 152   (clasp-ffi:%close-foreign-library handle))
 153
 154 (defun %foreign-symbol-pointer (name library)
 155   "Returns a pointer to a foreign symbol NAME."
 156   (clasp-ffi:%foreign-symbol-pointer name library))
 157
 158 (defun native-namestring (pathname)
 159   (namestring pathname))
 160
 161 ;;;# Callbacks
 162
 163 (defmacro %defcallback (name rettype arg-names arg-types body
 164                         &key convention)
 165   `(clasp-ffi:%defcallback (,name ,@(when convention `(:convention ,convention)))
 166                            ,rettype ,arg-names ,arg-types ,body))
 167
 168 (defun %callback (name)
 169   (clasp-ffi:%get-callback name))