cffi-corman.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) README (DIR) LICENSE --- cffi-corman.lisp (11583B) --- 1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; cffi-corman.lisp --- CFFI-SYS implementation for Corman Lisp. 4 ;;; 5 ;;; Copyright (C) 2005-2008, Luis Oliveira <loliveira(@)common-lisp.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 ;;; This port is suffering from bitrot as of 2007-03-29. Corman Lisp 29 ;;; is too funky with ASDF, crashes easily, makes it very painful to 30 ;;; do any testing. -- luis 31 32 ;;;# Administrivia 33 34 (defpackage #:cffi-sys 35 (:use #:common-lisp #:c-types) 36 (:import-from #:alexandria #:with-unique-names) 37 (:export 38 #:canonicalize-symbol-name-case 39 #:foreign-pointer 40 #:pointerp 41 #:pointer-eq 42 #:null-pointer 43 #:null-pointer-p 44 #:inc-pointer 45 #:make-pointer 46 #:pointer-address 47 #:%foreign-alloc 48 #:foreign-free 49 #:with-foreign-pointer 50 #:%foreign-funcall 51 #:%foreign-type-alignment 52 #:%foreign-type-size 53 #:%load-foreign-library 54 #:native-namestring 55 #:%mem-ref 56 #:%mem-set 57 ;#:make-shareable-byte-vector 58 ;#:with-pointer-to-vector-data 59 #:foreign-symbol-pointer 60 #:defcfun-helper-forms 61 #:%defcallback 62 #:%callback)) 63 64 (in-package #:cffi-sys) 65 66 ;;;# Misfeatures 67 68 (pushnew 'no-long-long *features*) 69 (pushnew 'no-foreign-funcall *features*) 70 71 ;;;$ Symbol Case 72 73 (defun canonicalize-symbol-name-case (name) 74 (declare (string name)) 75 (string-upcase name)) 76 77 ;;;# Basic Pointer Operations 78 79 (deftype foreign-pointer () 80 'cl::foreign) 81 82 (defun pointerp (ptr) 83 "Return true if PTR is a foreign pointer." 84 (cpointerp ptr)) 85 86 (defun pointer-eq (ptr1 ptr2) 87 "Return true if PTR1 and PTR2 point to the same address." 88 (cpointer= ptr1 ptr2)) 89 90 (defun null-pointer () 91 "Return a null pointer." 92 (create-foreign-ptr)) 93 94 (defun null-pointer-p (ptr) 95 "Return true if PTR is a null pointer." 96 (cpointer-null ptr)) 97 98 (defun inc-pointer (ptr offset) 99 "Return a pointer pointing OFFSET bytes past PTR." 100 (let ((new-ptr (create-foreign-ptr))) 101 (setf (cpointer-value new-ptr) 102 (+ (cpointer-value ptr) offset)) 103 new-ptr)) 104 105 (defun make-pointer (address) 106 "Return a pointer pointing to ADDRESS." 107 (int-to-foreign-ptr address)) 108 109 (defun pointer-address (ptr) 110 "Return the address pointed to by PTR." 111 (foreign-ptr-to-int ptr)) 112 113 ;;;# Allocation 114 ;;; 115 ;;; Functions and macros for allocating foreign memory on the stack 116 ;;; and on the heap. The main CFFI package defines macros that wrap 117 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage 118 ;;; when the memory has dynamic extent. 119 120 (defun %foreign-alloc (size) 121 "Allocate SIZE bytes on the heap and return a pointer." 122 (malloc size)) 123 124 (defun foreign-free (ptr) 125 "Free a PTR allocated by FOREIGN-ALLOC." 126 (free ptr)) 127 128 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) 129 "Bind VAR to SIZE bytes of foreign memory during BODY. The 130 pointer in VAR is invalid beyond the dynamic extent of BODY, and 131 may be stack-allocated if supported by the implementation. If 132 SIZE-VAR is supplied, it will be bound to SIZE during BODY." 133 (unless size-var 134 (setf size-var (gensym "SIZE"))) 135 `(let* ((,size-var ,size) 136 (,var (malloc ,size-var))) 137 (unwind-protect 138 (progn ,@body) 139 (free ,var)))) 140 141 ;;;# Shareable Vectors 142 ;;; 143 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA 144 ;;; should be defined to perform a copy-in/copy-out if the Lisp 145 ;;; implementation can't do this. 146 147 ;(defun make-shareable-byte-vector (size) 148 ; "Create a Lisp vector of SIZE bytes can passed to 149 ;WITH-POINTER-TO-VECTOR-DATA." 150 ; (make-array size :element-type '(unsigned-byte 8))) 151 ; 152 ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) 153 ; "Bind PTR-VAR to a foreign pointer to the data in VECTOR." 154 ; `(sb-sys:without-gcing 155 ; (let ((,ptr-var (sb-sys:vector-sap ,vector))) 156 ; ,@body))) 157 158 ;;;# Dereferencing 159 160 ;;; According to the docs, Corman's C Function Definition Parser 161 ;;; converts int to long, so we'll assume that. 162 (defun convert-foreign-type (type-keyword) 163 "Convert a CFFI type keyword to a CormanCL type." 164 (ecase type-keyword 165 (:char :char) 166 (:unsigned-char :unsigned-char) 167 (:short :short) 168 (:unsigned-short :unsigned-short) 169 (:int :long) 170 (:unsigned-int :unsigned-long) 171 (:long :long) 172 (:unsigned-long :unsigned-long) 173 (:float :single-float) 174 (:double :double-float) 175 (:pointer :handle) 176 (:void :void))) 177 178 (defun %mem-ref (ptr type &optional (offset 0)) 179 "Dereference an object of TYPE at OFFSET bytes from PTR." 180 (unless (eql offset 0) 181 (setq ptr (inc-pointer ptr offset))) 182 (ecase type 183 (:char (cref (:char *) ptr 0)) 184 (:unsigned-char (cref (:unsigned-char *) ptr 0)) 185 (:short (cref (:short *) ptr 0)) 186 (:unsigned-short (cref (:unsigned-short *) ptr 0)) 187 (:int (cref (:long *) ptr 0)) 188 (:unsigned-int (cref (:unsigned-long *) ptr 0)) 189 (:long (cref (:long *) ptr 0)) 190 (:unsigned-long (cref (:unsigned-long *) ptr 0)) 191 (:float (cref (:single-float *) ptr 0)) 192 (:double (cref (:double-float *) ptr 0)) 193 (:pointer (cref (:handle *) ptr 0)))) 194 195 ;(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) 196 ; (if (constantp type) 197 ; `(cref (,(convert-foreign-type type) *) ,ptr ,offset) 198 ; form)) 199 200 (defun %mem-set (value ptr type &optional (offset 0)) 201 "Set the object of TYPE at OFFSET bytes from PTR." 202 (unless (eql offset 0) 203 (setq ptr (inc-pointer ptr offset))) 204 (ecase type 205 (:char (setf (cref (:char *) ptr 0) value)) 206 (:unsigned-char (setf (cref (:unsigned-char *) ptr 0) value)) 207 (:short (setf (cref (:short *) ptr 0) value)) 208 (:unsigned-short (setf (cref (:unsigned-short *) ptr 0) value)) 209 (:int (setf (cref (:long *) ptr 0) value)) 210 (:unsigned-int (setf (cref (:unsigned-long *) ptr 0) value)) 211 (:long (setf (cref (:long *) ptr 0) value)) 212 (:unsigned-long (setf (cref (:unsigned-long *) ptr 0) value)) 213 (:float (setf (cref (:single-float *) ptr 0) value)) 214 (:double (setf (cref (:double-float *) ptr 0) value)) 215 (:pointer (setf (cref (:handle *) ptr 0) value)))) 216 217 ;;;# Calling Foreign Functions 218 219 (defun %foreign-type-size (type-keyword) 220 "Return the size in bytes of a foreign type." 221 (sizeof (convert-foreign-type type-keyword))) 222 223 ;;; Couldn't find anything in sys/ffi.lisp and the C declaration parser 224 ;;; doesn't seem to care about alignment so we'll assume that it's the 225 ;;; same as its size. 226 (defun %foreign-type-alignment (type-keyword) 227 (sizeof (convert-foreign-type type-keyword))) 228 229 (defun find-dll-containing-function (name) 230 "Searches for NAME in the loaded DLLs. If found, returns 231 the DLL's name (a string), else returns NIL." 232 (dolist (dll ct::*dlls-loaded*) 233 (when (ignore-errors 234 (ct::get-dll-proc-address name (ct::dll-record-handle dll))) 235 (return (ct::dll-record-name dll))))) 236 237 ;;; This won't work at all... 238 #|| 239 (defmacro %foreign-funcall (name &rest args) 240 (let ((sym (gensym))) 241 `(let (,sym) 242 (ct::install-dll-function ,(find-dll-containing-function name) 243 ,name ,sym) 244 (funcall ,sym ,@(loop for (type arg) on args by #'cddr 245 if arg collect arg))))) 246 ||# 247 248 ;;; It *might* be possible to implement by copying most of the code 249 ;;; from Corman's DEFUN-DLL. Alternatively, it could implemented the 250 ;;; same way as Lispworks' foreign-funcall. In practice, nobody uses 251 ;;; Corman with CFFI, apparently. :) 252 (defmacro %foreign-funcall (name &rest args) 253 "Call a foreign function NAME passing arguments ARGS." 254 `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args)) 255 256 (defun defcfun-helper-forms (name lisp-name rettype args types) 257 "Return 2 values for DEFCFUN. A prelude form and a caller form." 258 (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))) 259 ;; XXX This will only work if the dll is already loaded, fix this. 260 (dll (find-dll-containing-function name))) 261 (values 262 `(defun-dll ,ff-name 263 ,(mapcar (lambda (type) 264 (list (gensym) (convert-foreign-type type))) 265 types) 266 :return-type ,(convert-foreign-type rettype) 267 :library-name ,dll 268 :entry-name ,name 269 ;; we want also :pascal linkage type to access 270 ;; the win32 api for instance.. 271 :linkage-type :c) 272 `(,ff-name ,@args)))) 273 274 ;;;# Callbacks 275 276 ;;; defun-c-callback vs. defun-direct-c-callback? 277 ;;; same issue as Allegro, no return type declaration, should we coerce? 278 (defmacro %defcallback (name rettype arg-names arg-types body-form) 279 (declare (ignore rettype)) 280 (with-unique-names (cb-sym) 281 `(progn 282 (defun-c-callback ,cb-sym 283 ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type))) 284 arg-names arg-types) 285 ,body-form) 286 (setf (get ',name 'callback-ptr) 287 (get-callback-procinst ',cb-sym))))) 288 289 ;;; Just continue to use the plist for now even though this really 290 ;;; should use a *CALLBACKS* hash table and not define the callbacks 291 ;;; as gensyms. Someone with access to Corman should update this. 292 (defun %callback (name) 293 (get name 'callback-ptr)) 294 295 ;;;# Loading Foreign Libraries 296 297 (defun %load-foreign-library (name) 298 "Load the foreign library NAME." 299 (ct::get-dll-record name)) 300 301 (defun %close-foreign-library (name) 302 "Close the foreign library NAME." 303 (error "Not implemented.")) 304 305 (defun native-namestring (pathname) 306 (namestring pathname)) ; TODO: confirm 307 308 ;;;# Foreign Globals 309 310 ;;; FFI to GetProcAddress from the Win32 API. 311 ;;; "The GetProcAddress function retrieves the address of an exported 312 ;;; function or variable from the specified dynamic-link library (DLL)." 313 (defun-dll get-proc-address 314 ((module HMODULE) 315 (name LPCSTR)) 316 :return-type FARPROC 317 :library-name "Kernel32.dll" 318 :entry-name "GetProcAddress" 319 :linkage-type :pascal) 320 321 (defun foreign-symbol-pointer (name) 322 "Returns a pointer to a foreign symbol NAME." 323 (let ((str (lisp-string-to-c-string name))) 324 (unwind-protect 325 (dolist (dll ct::*dlls-loaded*) 326 (let ((ptr (get-proc-address 327 (int-to-foreign-ptr (ct::dll-record-handle dll)) 328 str))) 329 (when (not (cpointer-null ptr)) 330 (return ptr)))) 331 (free str))))