GopherProxy

	tcffi-mkcl.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-mkcl.lisp (12048B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; cffi-mkcl.lisp --- MKCL backend for CFFI.
	4 ;;;
	5 ;;; Copyright (C) 2010-2012, Jean-Claude Beaudoin
	6 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]>
	7 ;;;
	8 ;;; Permission is hereby granted, free of charge, to any person
	9 ;;; obtaining a copy of this software and associated documentation
	10 ;;; files (the "Software"), to deal in the Software without
	11 ;;; restriction, including without limitation the rights to use, copy,
	12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
	13 ;;; of the Software, and to permit persons to whom the Software is
	14 ;;; furnished to do so, subject to the following conditions:
	15 ;;;
	16 ;;; The above copyright notice and this permission notice shall be
	17 ;;; included in all copies or substantial portions of the Software.
	18 ;;;
	19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
	20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
	21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
	22 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
	23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
	24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
	26 ;;; DEALINGS IN THE SOFTWARE.
	27 ;;;
	28
	29 ;;;# Administrivia
	30
	31 (defpackage #:cffi-sys
	32 (:use #:common-lisp #:alexandria)
	33 (:export
	34 #:canonicalize-symbol-name-case
	35 #:foreign-pointer
	36 #:pointerp
	37 #:pointer-eq
	38 #:null-pointer
	39 #:null-pointer-p
	40 #:inc-pointer
	41 #:make-pointer
	42 #:pointer-address
	43 #:%foreign-alloc
	44 #:foreign-free
	45 #:with-foreign-pointer
	46 #:%foreign-funcall
	47 #:%foreign-funcall-pointer
	48 #:%foreign-type-alignment
	49 #:%foreign-type-size
	50 #:%load-foreign-library
	51 #:%close-foreign-library
	52 #:native-namestring
	53 #:%mem-ref
	54 #:%mem-set
	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 ;;;# Mis-features
	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 (defun %foreign-alloc (size)
	76 "Allocate SIZE bytes of foreign-addressable memory."
	77 (si:allocate-foreign-data :void size))
	78
	79 (defun foreign-free (ptr)
	80 "Free a pointer PTR allocated by FOREIGN-ALLOC."
	81 (si:free-foreign-data ptr)
	82 nil)
	83
	84 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
	85 "Bind VAR to SIZE bytes of foreign memory during BODY. The
	86 pointer in VAR is invalid beyond the dynamic extent of BODY, and
	87 may be stack-allocated if supported by the implementation. If
	88 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
	89 (unless size-var
	90 (setf size-var (gensym "SIZE")))
	91 `(let* ((,size-var ,size)
	92 (,var (%foreign-alloc ,size-var)))
	93 (unwind-protect
	94 (progn ,@body)
	95 (foreign-free ,var))))
	96
	97 ;;;# Misc. Pointer Operations
	98
	99 (deftype foreign-pointer ()
	100 'si:foreign)
	101
	102 (defun null-pointer ()
	103 "Construct and return a null pointer."
	104 (si:make-foreign-null-pointer))
	105
	106 (defun null-pointer-p (ptr)
	107 "Return true if PTR is a null pointer."
	108 (si:null-pointer-p ptr))
	109
	110 (defun inc-pointer (ptr offset)
	111 "Return a pointer OFFSET bytes past PTR."
	112 (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
	113
	114 (defun pointerp (ptr)
	115 "Return true if PTR is a foreign pointer."
	116 ;;(typep ptr 'si:foreign)
	117 (si:foreignp ptr))
	118
	119 (defun pointer-eq (ptr1 ptr2)
	120 "Return true if PTR1 and PTR2 point to the same address."
	121 (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
	122
	123 (defun make-pointer (address)
	124 "Return a pointer pointing to ADDRESS."
	125 (ffi:make-pointer address :void))
	126
	127 (defun pointer-address (ptr)
	128 "Return the address pointed to by PTR."
	129 (ffi:pointer-address ptr))
	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 ;;; MKCL, built with the Boehm GC never moves allocated data, so this
	143 ;;; isn't nearly as hard to do.
	144 (defun %vector-address (vector)
	145 "Return the address of VECTOR's data."
	146 (check-type vector (vector (unsigned-byte 8)))
	147 #-mingw64
	148 (ffi:c-inline (vector) (object)
	149 :unsigned-long
	150 "(uintptr_t) #0->vector.self.b8"
	151 :side-effects nil
	152 :one-liner t)
	153 #+mingw64
	154 (ffi:c-inline (vector) (object)
	155 :unsigned-long-long
	156 "(uintptr_t) #0->vector.self.b8"
	157 :side-effects nil
	158 :one-liner t))
	159
	160 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
	161 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
	162 `(let ((,ptr-var (make-pointer (%vector-address ,vector))))
	163 ,@body))
	164
	165 ;;;# Dereferencing
	166
	167 (defun %mem-ref (ptr type &optional (offset 0))
	168 "Dereference an object of TYPE at OFFSET bytes from PTR."
	169 (let* ((type (cffi-type->mkcl-type type))
	170 (type-size (ffi:size-of-foreign-type type)))
	171 (si:foreign-ref-elt
	172 (si:foreign-recast ptr (+ offset type-size) :void) offset type)))
	173
	174 (defun %mem-set (value ptr type &optional (offset 0))
	175 "Set an object of TYPE at OFFSET bytes from PTR."
	176 (let* ((type (cffi-type->mkcl-type type))
	177 (type-size (ffi:size-of-foreign-type type)))
	178 (si:foreign-set-elt
	179 (si:foreign-recast ptr (+ offset type-size) :void)
	180 offset type value)))
	181
	182 ;;;# Type Operations
	183
	184 (defconstant +translation-table+
	185 '((:char :byte "char")
	186 (:unsigned-char :unsigned-byte "unsigned char")
	187 (:short :short "short")
	188 (:unsigned-short :unsigned-short "unsigned short")
	189 (:int :int "int")
	190 (:unsigned-int :unsigned-int "unsigned int")
	191 (:long :long "long")
	192 (:unsigned-long :unsigned-long "unsigned long")
	193 (:long-long :long-long "long long")
	194 (:unsigned-long-long :unsigned-long-long "unsigned long long")
	195 (:float :float "float")
	196 (:double :double "double")
	197 (:pointer :pointer-void "void*")
	198 (:void :void "void")))
	199
	200 (defun cffi-type->mkcl-type (type-keyword)
	201 "Convert a CFFI type keyword to an MKCL type keyword."
	202 (or (second (find type-keyword +translation-table+ :key #'first))
	203 (error "~S is not a valid CFFI type" type-keyword)))
	204
	205 (defun mkcl-type->c-type (type-keyword)
	206 "Convert a CFFI type keyword to an valid C type keyword."
	207 (or (third (find type-keyword +translation-table+ :key #'second))
	208 (error "~S is not a valid CFFI type" type-keyword)))
	209
	210 (defun %foreign-type-size (type-keyword)
	211 "Return the size in bytes of a foreign type."
	212 (nth-value 0 (ffi:size-of-foreign-type
	213 (cffi-type->mkcl-type type-keyword))))
	214
	215 (defun %foreign-type-alignment (type-keyword)
	216 "Return the alignment in bytes of a foreign type."
	217 (nth-value 1 (ffi:size-of-foreign-type
	218 (cffi-type->mkcl-type type-keyword))))
	219
	220 ;;;# Calling Foreign Functions
	221
	222 #\|
	223 (defconstant +mkcl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c…
	224 \|#
	225
	226 (defun produce-function-pointer-call (pointer types values return-type)
	227 #\|
	228 (if (stringp pointer)
	229 (produce-function-pointer-call
	230 `(%foreign-symbol-pointer ,pointer nil) types values return-type)
	231 `(ffi:c-inline
	232 ,(list* pointer values)
	233 ,(list* :pointer-void types) ,return-type
	234 ,(with-output-to-string (s)
	235 (let ((types (mapcar #'mkcl-type->c-type types)))
	236 ;; On AMD64, the following code only works with the extra
	237 ;; argument ",...". If this is not present, functions
	238 ;; like sprintf do not work
	239 (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)"
	240 (mkcl-type->c-type return-type) types
	241 (subseq +mkcl-inline-codes+ 3
	242 (max 3 (+ 2 (* (length values) 3)))))))
	243 :one-liner t :side-effects t))
	244 \|#
	245 ;; The version here below is definitely not as efficient as the one ab…
	246 ;; but it has the great vertue of working in all cases, (contrary to t…
	247 ;; silent and unsafe limitations of the one above). JCB
	248 ;; I should re-optimize this one day, when I get time... JCB
	249 (progn
	250 (when (stringp pointer)
	251 (setf pointer `(%foreign-symbol-pointer ,pointer nil)))
	252 `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values))…
	253
	254
	255 (defun foreign-funcall-parse-args (args)
	256 "Return three values, lists of arg types, values, and result type."
	257 (let ((return-type :void))
	258 (loop for (type arg) on args by #'cddr
	259 if arg collect (cffi-type->mkcl-type type) into types
	260 and collect arg into values
	261 else do (setf return-type (cffi-type->mkcl-type type))
	262 finally (return (values types values return-type)))))
	263
	264 (defmacro %foreign-funcall (name args &key library convention)
	265 "Call a foreign function."
	266 (declare (ignore library convention))
	267 (multiple-value-bind (types values return-type)
	268 (foreign-funcall-parse-args args)
	269 (produce-function-pointer-call name types values return-type)))
	270
	271 (defmacro %foreign-funcall-pointer (ptr args &key convention)
	272 "Funcall a pointer to a foreign function."
	273 (declare (ignore convention))
	274 (multiple-value-bind (types values return-type)
	275 (foreign-funcall-parse-args args)
	276 (produce-function-pointer-call ptr types values return-type)))
	277
	278 ;;;# Foreign Libraries
	279
	280 (defun %load-foreign-library (name path)
	281 "Load a foreign library."
	282 (declare (ignore name))
	283 (handler-case (si:load-foreign-module path)
	284 (file-error ()
	285 (error "file error while trying to load `~A'" path))))
	286
	287 (defun %close-foreign-library (handle)
	288 ;;(declare (ignore handle))
	289 ;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.")
	290 (si:unload-foreign-module handle))
	291
	292 (defun native-namestring (pathname)
	293 (namestring pathname))
	294
	295 ;;;# Callbacks
	296
	297 ;;; Create a package to contain the symbols for callback functions.
	298 ;;; We want to redefine callbacks with the same symbol so the internal
	299 ;;; data structures are reused.
	300 (defpackage #:cffi-callbacks
	301 (:use))
	302
	303 (defvar callbacks (make-hash-table))
	304
	305 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
	306 ;;; internal callback for NAME.
	307 (eval-when (:compile-toplevel :load-toplevel :execute)
	308 (defun intern-callback (name)
	309 (intern (format nil "~A::~A"
	310 (if-let (package (symbol-package name))
	311 (package-name package)
	312 "#")
	313 (symbol-name name))
	314 '#:cffi-callbacks)))
	315
	316 (defmacro %defcallback (name rettype arg-names arg-types body
	317 &key convention)
	318 (declare (ignore convention))
	319 (let ((cb-name (intern-callback name)))
	320 `(progn
	321 (ffi:defcallback (,cb-name :cdecl)
	322 ,(cffi-type->mkcl-type rettype)
	323 ,(mapcar #'list arg-names
	324 (mapcar #'cffi-type->mkcl-type arg-type…
	325 ;;(block ,cb-name ,@body)
	326 (block ,cb-name ,body))
	327 (setf (gethash ',name callbacks) ',cb-name))))
	328
	329 (defun %callback (name)
	330 (multiple-value-bind (symbol winp)
	331 (gethash name callbacks)
	332 (unless winp
	333 (error "Undefined callback: ~S" name))
	334 (ffi:callback symbol)))
	335
	336 ;;;# Foreign Globals
	337
	338 (defun %foreign-symbol-pointer (name library)
	339 "Returns a pointer to a foreign symbol NAME."
	340 (declare (ignore library))
	341 (values (ignore-errors (si:find-foreign-symbol name :default :pointer-…
	342