GopherProxy

	tcffi-clasp.lisp - clic - Clic is an command line interactive client for gopher…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tcffi-clasp.lisp (6322B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; cffi-clasp.lisp --- CFFI-SYS implementation for Clasp.
	4 ;;;
	5 ;;; Copyright (C) 2017 Frank Goenninger <[email protected]…
	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 ;;;# Administrivia
	29
	30 (defpackage #:cffi-sys
	31 (:use #:common-lisp #:alexandria)
	32 (:export
	33 #:canonicalize-symbol-name-case
	34 #:foreign-pointer
	35 #:pointerp
	36 #:pointer-eq
	37 #:%foreign-alloc
	38 #:foreign-free
	39 #:with-foreign-pointer
	40 #:null-pointer
	41 #:null-pointer-p
	42 #:inc-pointer
	43 #:make-pointer
	44 #:pointer-address
	45 #:%mem-ref
	46 #:%mem-set
	47 #:%foreign-funcall
	48 #:%foreign-funcall-pointer
	49 #:%foreign-type-alignment
	50 #:%foreign-type-size
	51 #:%load-foreign-library
	52 #:%close-foreign-library
	53 #:native-namestring
	54 #:make-shareable-byte-vector
	55 #:with-pointer-to-vector-data
	56 #:%defcallback
	57 #:%callback
	58 #:%foreign-symbol-pointer))
	59
	60 (in-package #:cffi-sys)
	61
	62 ;;;# Mis-features
	63
	64 (pushnew 'flat-namespace cl:features)
	65
	66 ;;;# Symbol Case
	67
	68 (defun canonicalize-symbol-name-case (name)
	69 (declare (string name))
	70 (string-upcase name))
	71
	72 ;;;# Allocation
	73
	74 (defun %foreign-alloc (size)
	75 "Allocate SIZE bytes of foreign-addressable memory."
	76 (clasp-ffi:%foreign-alloc size))
	77
	78 (defun foreign-free (ptr)
	79 "Free a pointer PTR allocated by FOREIGN-ALLOC."
	80 (clasp-ffi:%foreign-free ptr))
	81
	82 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
	83 "Bind VAR to SIZE bytes of foreign memory during BODY. The
	84 pointer in VAR is invalid beyond the dynamic extent of BODY, and
	85 may be stack-allocated if supported by the implementation. If
	86 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
	87 (unless size-var
	88 (setf size-var (gensym "SIZE")))
	89 `(let* ((,size-var ,size)
	90 (,var (%foreign-alloc ,size-var)))
	91 (unwind-protect
	92 (progn ,@body)
	93 (foreign-free ,var))))
	94
	95 ;;;# Misc. Pointer Operations
	96
	97 (deftype foreign-pointer ()
	98 'clasp-ffi:foreign-data)
	99
	100 (defun null-pointer-p (ptr)
	101 "Test if PTR is a null pointer."
	102 (clasp-ffi:%null-pointer-p ptr))
	103
	104 (defun null-pointer ()
	105 "Construct and return a null pointer."
	106 (clasp-ffi:%make-nullpointer))
	107
	108 (defun make-pointer (address)
	109 "Return a pointer pointing to ADDRESS."
	110 (clasp-ffi:%make-pointer address))
	111
	112 (defun inc-pointer (ptr offset)
	113 "Return a pointer OFFSET bytes past PTR."
	114 (clasp-ffi:%inc-pointer ptr offset))
	115
	116 (defun pointer-address (ptr)
	117 "Return the address pointed to by PTR."
	118 (clasp-ffi:%foreign-data-address ptr))
	119
	120 (defun pointerp (ptr)
	121 "Return true if PTR is a foreign pointer."
	122 (typep ptr 'clasp-ffi:foreign-data))
	123
	124 (defun pointer-eq (ptr1 ptr2)
	125 "Return true if PTR1 and PTR2 point to the same address."
	126 (check-type ptr1 clasp-ffi:foreign-data)
	127 (check-type ptr2 clasp-ffi:foreign-data)
	128 (eql (pointer-address ptr1) (pointer-address ptr2)))
	129
	130
	131 ;;;# Shareable Vectors
	132 ;;;
	133 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
	134 ;;; should be defined to perform a copy-in/copy-out if the Lisp
	135 ;;; implementation can't do this.
	136
	137 (defun make-shareable-byte-vector (size)
	138 "Create a Lisp vector of SIZE bytes that can passed to
	139 WITH-POINTER-TO-VECTOR-DATA."
	140 (make-array size :element-type '(unsigned-byte 8)))
	141
	142 ;; frgo, 2016-07-02: TODO: Implemenent!
	143 ;; (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
	144 ;; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
	145 ;; `(let ((,ptr-var (si:make-foreign-data-from-array ,vector)))
	146 ;; ,@body))
	147
	148 (defun %foreign-type-size (type-keyword)
	149 "Return the size in bytes of a foreign type."
	150 (clasp-ffi:%foreign-type-size type-keyword))
	151
	152 (defun %foreign-type-alignment (type-keyword)
	153 "Return the alignment in bytes of a foreign type."
	154 (clasp-ffi:%foreign-type-alignment type-keyword))
	155
	156 ;;;# Dereferencing
	157
	158 (defun %mem-ref (ptr type &optional (offset 0))
	159 "Dereference an object of TYPE at OFFSET bytes from PTR."
	160 (clasp-ffi:%mem-ref ptr type offset))
	161
	162 (defun %mem-set (value ptr type &optional (offset 0))
	163 "Set an object of TYPE at OFFSET bytes from PTR."
	164 (clasp-ffi:%mem-set ptr type value offset))
	165
	166 (defmacro %foreign-funcall (name args &key library convention)
	167 "Call a foreign function."
	168 (declare (ignore library convention))
	169 `(clasp-ffi:%foreign-funcall ,name ,@args))
	170
	171 (defmacro %foreign-funcall-pointer (ptr args &key convention)
	172 "Funcall a pointer to a foreign function."
	173 (declare (ignore convention))
	174 `(clasp-ffi:%foreign-funcall-pointer ,ptr ,@args))
	175
	176 ;;;# Foreign Libraries
	177
	178 (defun %load-foreign-library (name path)
	179 "Load a foreign library."
	180 (clasp-ffi:%load-foreign-library name path))
	181
	182 (defun %close-foreign-library (handle)
	183 "Close a foreign library."
	184 (clasp-ffi:%close-foreign-library handle))
	185
	186 (defun %foreign-symbol-pointer (name library)
	187 "Returns a pointer to a foreign symbol NAME."
	188 (clasp-ffi:%foreign-symbol-pointer name library))
	189
	190 (defun native-namestring (pathname)
	191 (namestring pathname))
	192
	193 ;;;# Callbacks
	194
	195 (defmacro %defcallback (name rettype arg-names arg-types body
	196 &key convention)
	197 `(clasp-ffi:%defcallback (,name ,@(when convention `(:convention ,conv…
	198 ,rettype ,arg-names ,arg-types ,body))
	199
	200 (defun %callback (name)
	201 (clasp-ffi:%get-callback name))