GopherProxy

	tcffi-openmcl.lisp - clic - Clic is an command line interactive client for goph…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tcffi-openmcl.lisp (10662B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; cffi-openmcl.lisp --- CFFI-SYS implementation for OpenMCL.
	4 ;;;
	5 ;;; Copyright (C) 2005-2006, James Bielman <[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 #:ccl)
	32 (:import-from #:alexandria #:once-only #:if-let)
	33 (:export
	34 #:canonicalize-symbol-name-case
	35 #:foreign-pointer
	36 #:pointerp ; ccl:pointerp
	37 #:pointer-eq
	38 #:%foreign-alloc
	39 #:foreign-free
	40 #:with-foreign-pointer
	41 #:null-pointer
	42 #:null-pointer-p
	43 #:inc-pointer
	44 #:make-pointer
	45 #:pointer-address
	46 #:%mem-ref
	47 #:%mem-set
	48 #:%foreign-funcall
	49 #:%foreign-funcall-pointer
	50 #:%foreign-type-alignment
	51 #:%foreign-type-size
	52 #:%load-foreign-library
	53 #:%close-foreign-library
	54 #:native-namestring
	55 #:make-shareable-byte-vector
	56 #:with-pointer-to-vector-data
	57 #:%foreign-symbol-pointer
	58 #:%defcallback
	59 #:%callback))
	60
	61 (in-package #:cffi-sys)
	62
	63 ;;;# Misfeatures
	64
	65 (pushnew 'flat-namespace features)
	66
	67 ;;;# Symbol Case
	68
	69 (defun canonicalize-symbol-name-case (name)
	70 (declare (string name))
	71 (string-upcase name))
	72
	73 ;;;# Allocation
	74 ;;;
	75 ;;; Functions and macros for allocating foreign memory on the stack
	76 ;;; and on the heap. The main CFFI package defines macros that wrap
	77 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
	78 ;;; usage when the memory has dynamic extent.
	79
	80 (defun %foreign-alloc (size)
	81 "Allocate SIZE bytes on the heap and return a pointer."
	82 (ccl::malloc size))
	83
	84 (defun foreign-free (ptr)
	85 "Free a PTR allocated by FOREIGN-ALLOC."
	86 ;; TODO: Should we make this a dead macptr?
	87 (ccl::free ptr))
	88
	89 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
	90 "Bind VAR to SIZE bytes of foreign memory during BODY. The
	91 pointer in VAR is invalid beyond the dynamic extent of BODY, and
	92 may be stack-allocated if supported by the implementation. If
	93 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
	94 (unless size-var
	95 (setf size-var (gensym "SIZE")))
	96 `(let ((,size-var ,size))
	97 (%stack-block ((,var ,size-var))
	98 ,@body)))
	99
	100 ;;;# Misc. Pointer Operations
	101
	102 (deftype foreign-pointer ()
	103 'ccl:macptr)
	104
	105 (defun null-pointer ()
	106 "Construct and return a null pointer."
	107 (ccl:%null-ptr))
	108
	109 (defun null-pointer-p (ptr)
	110 "Return true if PTR is a null pointer."
	111 (ccl:%null-ptr-p ptr))
	112
	113 (defun inc-pointer (ptr offset)
	114 "Return a pointer OFFSET bytes past PTR."
	115 (ccl:%inc-ptr ptr offset))
	116
	117 (defun pointer-eq (ptr1 ptr2)
	118 "Return true if PTR1 and PTR2 point to the same address."
	119 (ccl:%ptr-eql ptr1 ptr2))
	120
	121 (defun make-pointer (address)
	122 "Return a pointer pointing to ADDRESS."
	123 (ccl:%int-to-ptr address))
	124
	125 (defun pointer-address (ptr)
	126 "Return the address pointed to by PTR."
	127 (ccl:%ptr-to-int ptr))
	128
	129 ;;;# Shareable Vectors
	130 ;;;
	131 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
	132 ;;; should be defined to perform a copy-in/copy-out if the Lisp
	133 ;;; implementation can't do this.
	134
	135 (defun make-shareable-byte-vector (size)
	136 "Create a Lisp vector of SIZE bytes that can passed to
	137 WITH-POINTER-TO-VECTOR-DATA."
	138 (make-array size :element-type '(unsigned-byte 8)))
	139
	140 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
	141 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
	142 `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
	143 ,@body))
	144
	145 ;;;# Dereferencing
	146
	147 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
	148 ;;; macros that optimize the case where the type keyword is constant
	149 ;;; at compile-time.
	150 (defmacro define-mem-accessors (&body pairs)
	151 `(progn
	152 (defun %mem-ref (ptr type &optional (offset 0))
	153 (ecase type
	154 ,@(loop for (keyword fn) in pairs
	155 collect `(,keyword (,fn ptr offset)))))
	156 (defun %mem-set (value ptr type &optional (offset 0))
	157 (ecase type
	158 ,@(loop for (keyword fn) in pairs
	159 collect `(,keyword (setf (,fn ptr offset) value)))))
	160 (define-compiler-macro %mem-ref
	161 (&whole form ptr type &optional (offset 0))
	162 (if (constantp type)
	163 (ecase (eval type)
	164 ,@(loop for (keyword fn) in pairs
	165 collect `(,keyword `(,',fn ,ptr ,offset))))
	166 form))
	167 (define-compiler-macro %mem-set
	168 (&whole form value ptr type &optional (offset 0))
	169 (if (constantp type)
	170 (once-only (value)
	171 (ecase (eval type)
	172 ,@(loop for (keyword fn) in pairs
	173 collect `(,keyword `(setf (,',fn ,ptr ,offset)
	174 ,value)))))
	175 form))))
	176
	177 (define-mem-accessors
	178 (:char %get-signed-byte)
	179 (:unsigned-char %get-unsigned-byte)
	180 (:short %get-signed-word)
	181 (:unsigned-short %get-unsigned-word)
	182 (:int %get-signed-long)
	183 (:unsigned-int %get-unsigned-long)
	184 #+(or 32-bit-target windows-target) (:long %get-signed-long)
	185 #+(and (not windows-target) 64-bit-target) (:long ccl::%%get-signed-lo…
	186 #+(or 32-bit-target windows-target) (:unsigned-long %get-unsigned-long)
	187 #+(and 64-bit-target (not windows-target)) (:unsigned-long ccl::%%get-…
	188 (:long-long ccl::%get-signed-long-long)
	189 (:unsigned-long-long ccl::%get-unsigned-long-long)
	190 (:float %get-single-float)
	191 (:double %get-double-float)
	192 (:pointer %get-ptr))
	193
	194 ;;;# Calling Foreign Functions
	195
	196 (defun convert-foreign-type (type-keyword)
	197 "Convert a CFFI type keyword to an OpenMCL type."
	198 (ecase type-keyword
	199 (:char :signed-byte)
	200 (:unsigned-char :unsigned-byte)
	201 (:short :signed-short)
	202 (:unsigned-short :unsigned-short)
	203 (:int :signed-int)
	204 (:unsigned-int :unsigned-int)
	205 (:long :signed-long)
	206 (:unsigned-long :unsigned-long)
	207 (:long-long :signed-doubleword)
	208 (:unsigned-long-long :unsigned-doubleword)
	209 (:float :single-float)
	210 (:double :double-float)
	211 (:pointer :address)
	212 (:void :void)))
	213
	214 (defun %foreign-type-size (type-keyword)
	215 "Return the size in bytes of a foreign type."
	216 (/ (ccl::foreign-type-bits
	217 (ccl::parse-foreign-type
	218 (convert-foreign-type type-keyword)))
	219 8))
	220
	221 ;; There be dragons here. See the following thread for details:
	222 ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
	223 (defun %foreign-type-alignment (type-keyword)
	224 "Return the alignment in bytes of a foreign type."
	225 (/ (ccl::foreign-type-alignment
	226 (ccl::parse-foreign-type
	227 (convert-foreign-type type-keyword))) 8))
	228
	229 (defun convert-foreign-funcall-types (args)
	230 "Convert foreign types for a call to FOREIGN-FUNCALL."
	231 (loop for (type arg) on args by #'cddr
	232 collect (convert-foreign-type type)
	233 if arg collect arg))
	234
	235 (defun convert-external-name (name)
	236 "Add an underscore to NAME if necessary for the ABI."
	237 #+darwin (concatenate 'string "_" name)
	238 #-darwin name)
	239
	240 (defmacro %foreign-funcall (function-name args &key library convention)
	241 "Perform a foreign function call, document it more later."
	242 (declare (ignore library convention))
	243 `(external-call
	244 ,(convert-external-name function-name)
	245 ,@(convert-foreign-funcall-types args)))
	246
	247 (defmacro %foreign-funcall-pointer (ptr args &key convention)
	248 (declare (ignore convention))
	249 `(ff-call ,ptr ,@(convert-foreign-funcall-types args)))
	250
	251 ;;;# Callbacks
	252
	253 ;;; The CALLBACKS hash table maps CFFI callback names to OpenMCL "macp…
	254 ;;; entry points. It is safe to store the pointers directly because
	255 ;;; OpenMCL will update the address of these pointers when a saved image
	256 ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
	257 (defvar callbacks (make-hash-table))
	258
	259 ;;; Create a package to contain the symbols for callback functions. We
	260 ;;; want to redefine callbacks with the same symbol so the internal data
	261 ;;; structures are reused.
	262 (defpackage #:cffi-callbacks
	263 (:use))
	264
	265 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the inter…
	266 ;;; callback for NAME.
	267 (defun intern-callback (name)
	268 (intern (format nil "~A::~A"
	269 (if-let (package (symbol-package name))
	270 (package-name package)
	271 "#")
	272 (symbol-name name))
	273 '#:cffi-callbacks))
	274
	275 (defmacro %defcallback (name rettype arg-names arg-types body
	276 &key convention)
	277 (let ((cb-name (intern-callback name)))
	278 `(progn
	279 (defcallback ,cb-name
	280 (,@(when (eq convention :stdcall)
	281 '(:discard-stack-args))
	282 ,@(mapcan (lambda (sym type)
	283 (list (convert-foreign-type type) sym))
	284 arg-names arg-types)
	285 ,(convert-foreign-type rettype))
	286 ,body)
	287 (setf (gethash ',name callbacks) (symbol-value ',cb-name)))))
	288
	289 (defun %callback (name)
	290 (or (gethash name callbacks)
	291 (error "Undefined callback: ~S" name)))
	292
	293 ;;;# Loading Foreign Libraries
	294
	295 (defun %load-foreign-library (name path)
	296 "Load the foreign library NAME."
	297 (declare (ignore name))
	298 (open-shared-library path))
	299
	300 (defun %close-foreign-library (name)
	301 "Close the foreign library NAME."
	302 ;; C-S-L sometimes ends in an endless loop
	303 ;; with :COMPLETELY T
	304 (close-shared-library name :completely nil))
	305
	306 (defun native-namestring (pathname)
	307 (ccl::native-translated-namestring pathname))
	308
	309 ;;;# Foreign Globals
	310
	311 (defun %foreign-symbol-pointer (name library)
	312 "Returns a pointer to a foreign symbol NAME."
	313 (declare (ignore library))
	314 (foreign-symbol-address (convert-external-name name)))