cffi-scl.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-scl.lisp (11099B) --- 1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Lisp. 4 ;;; 5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com> 6 ;;; Copyright (C) 2006-2007, Scieneer Pty Ltd. 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 #:alien #:c-call) 33 (:import-from #:alexandria #:once-only #:with-unique-names) 34 (:export 35 #:canonicalize-symbol-name-case 36 #:foreign-pointer 37 #:pointerp 38 #:pointer-eq 39 #:null-pointer 40 #:null-pointer-p 41 #:inc-pointer 42 #:make-pointer 43 #:pointer-address 44 #:%foreign-alloc 45 #:foreign-free 46 #:with-foreign-pointer 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 #:%mem-ref 55 #:%mem-set 56 #:make-shareable-byte-vector 57 #:with-pointer-to-vector-data 58 #:%foreign-symbol-pointer 59 #:%defcallback 60 #:%callback)) 61 62 (in-package #:cffi-sys) 63 64 ;;;# Mis-features 65 66 (pushnew 'flat-namespace *features*) 67 68 ;;;# Symbol Case 69 70 (defun canonicalize-symbol-name-case (name) 71 (declare (string name)) 72 (if (eq ext:*case-mode* :upper) 73 (string-upcase name) 74 (string-downcase name))) 75 76 ;;;# Basic Pointer Operations 77 78 (deftype foreign-pointer () 79 'sys:system-area-pointer) 80 81 (declaim (inline pointerp)) 82 (defun pointerp (ptr) 83 "Return true if 'ptr is a foreign pointer." 84 (sys:system-area-pointer-p ptr)) 85 86 (declaim (inline pointer-eq)) 87 (defun pointer-eq (ptr1 ptr2) 88 "Return true if 'ptr1 and 'ptr2 point to the same address." 89 (sys:sap= ptr1 ptr2)) 90 91 (declaim (inline null-pointer)) 92 (defun null-pointer () 93 "Construct and return a null pointer." 94 (sys:int-sap 0)) 95 96 (declaim (inline null-pointer-p)) 97 (defun null-pointer-p (ptr) 98 "Return true if 'ptr is a null pointer." 99 (zerop (sys:sap-int ptr))) 100 101 (declaim (inline inc-pointer)) 102 (defun inc-pointer (ptr offset) 103 "Return a pointer pointing 'offset bytes past 'ptr." 104 (sys:sap+ ptr offset)) 105 106 (declaim (inline make-pointer)) 107 (defun make-pointer (address) 108 "Return a pointer pointing to 'address." 109 (sys:int-sap address)) 110 111 (declaim (inline pointer-address)) 112 (defun pointer-address (ptr) 113 "Return the address pointed to by 'ptr." 114 (sys:sap-int ptr)) 115 116 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) 117 "Bind 'var to 'size bytes of foreign memory during 'body. The 118 pointer in 'var is invalid beyond the dynamic extent of 'body, and 119 may be stack-allocated if supported by the implementation. If 120 'size-var is supplied, it will be bound to 'size during 'body." 121 (unless size-var 122 (setf size-var (gensym (symbol-name '#:size)))) 123 ;; If the size is constant we can stack-allocate. 124 (cond ((constantp size) 125 (let ((alien-var (gensym (symbol-name '#:alien)))) 126 `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) 127 (let ((,size-var ,size) 128 (,var (alien-sap ,alien-var))) 129 (declare (ignorable ,size-var)) 130 ,@body)))) 131 (t 132 `(let ((,size-var ,size)) 133 (alien:with-bytes (,var ,size-var) 134 ,@body))))) 135 136 ;;;# Allocation 137 ;;; 138 ;;; Functions and macros for allocating foreign memory on the stack and on the 139 ;;; heap. The main CFFI package defines macros that wrap 'foreign-alloc and 140 ;;; 'foreign-free in 'unwind-protect for the common usage when the memory has 141 ;;; dynamic extent. 142 143 (defun %foreign-alloc (size) 144 "Allocate 'size bytes on the heap and return a pointer." 145 (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size)) 146 (alien-funcall (extern-alien "malloc" 147 (function system-area-pointer unsigned)) 148 size)) 149 150 (defun foreign-free (ptr) 151 "Free a 'ptr allocated by 'foreign-alloc." 152 (declare (type system-area-pointer ptr)) 153 (alien-funcall (extern-alien "free" 154 (function (values) system-area-pointer)) 155 ptr)) 156 157 ;;;# Shareable Vectors 158 159 (defun make-shareable-byte-vector (size) 160 "Create a Lisp vector of 'size bytes that can passed to 161 'with-pointer-to-vector-data." 162 (make-array size :element-type '(unsigned-byte 8))) 163 164 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) 165 "Bind 'ptr-var to a foreign pointer to the data in 'vector." 166 (let ((vector-var (gensym (symbol-name '#:vector)))) 167 `(let ((,vector-var ,vector)) 168 (ext:with-pinned-object (,vector-var) 169 (let ((,ptr-var (sys:vector-sap ,vector-var))) 170 ,@body))))) 171 172 ;;;# Dereferencing 173 174 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler 175 ;;; macros that optimize the case where the type keyword is constant 176 ;;; at compile-time. 177 (defmacro define-mem-accessors (&body pairs) 178 `(progn 179 (defun %mem-ref (ptr type &optional (offset 0)) 180 (ecase type 181 ,@(loop for (keyword fn) in pairs 182 collect `(,keyword (,fn ptr offset))))) 183 (defun %mem-set (value ptr type &optional (offset 0)) 184 (ecase type 185 ,@(loop for (keyword fn) in pairs 186 collect `(,keyword (setf (,fn ptr offset) value))))) 187 (define-compiler-macro %mem-ref 188 (&whole form ptr type &optional (offset 0)) 189 (if (constantp type) 190 (ecase (eval type) 191 ,@(loop for (keyword fn) in pairs 192 collect `(,keyword `(,',fn ,ptr ,offset)))) 193 form)) 194 (define-compiler-macro %mem-set 195 (&whole form value ptr type &optional (offset 0)) 196 (if (constantp type) 197 (once-only (value) 198 (ecase (eval type) 199 ,@(loop for (keyword fn) in pairs 200 collect `(,keyword `(setf (,',fn ,ptr ,offset) 201 ,value))))) 202 form)))) 203 204 (define-mem-accessors 205 (:char sys:signed-sap-ref-8) 206 (:unsigned-char sys:sap-ref-8) 207 (:short sys:signed-sap-ref-16) 208 (:unsigned-short sys:sap-ref-16) 209 (:int sys:signed-sap-ref-32) 210 (:unsigned-int sys:sap-ref-32) 211 (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64) 212 (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64) 213 (:long-long sys:signed-sap-ref-64) 214 (:unsigned-long-long sys:sap-ref-64) 215 (:float sys:sap-ref-single) 216 (:double sys:sap-ref-double) 217 #+long-float (:long-double sys:sap-ref-long) 218 (:pointer sys:sap-ref-sap)) 219 220 ;;;# Calling Foreign Functions 221 222 (defun convert-foreign-type (type-keyword) 223 "Convert a CFFI type keyword to an ALIEN type." 224 (ecase type-keyword 225 (:char 'char) 226 (:unsigned-char 'unsigned-char) 227 (:short 'short) 228 (:unsigned-short 'unsigned-short) 229 (:int 'int) 230 (:unsigned-int 'unsigned-int) 231 (:long 'long) 232 (:unsigned-long 'unsigned-long) 233 (:long-long '(signed 64)) 234 (:unsigned-long-long '(unsigned 64)) 235 (:float 'single-float) 236 (:double 'double-float) 237 #+long-float 238 (:long-double 'long-float) 239 (:pointer 'system-area-pointer) 240 (:void 'void))) 241 242 (defun %foreign-type-size (type-keyword) 243 "Return the size in bytes of a foreign type." 244 (values (truncate (alien-internals:alien-type-bits 245 (alien-internals:parse-alien-type 246 (convert-foreign-type type-keyword))) 247 8))) 248 249 (defun %foreign-type-alignment (type-keyword) 250 "Return the alignment in bytes of a foreign type." 251 (values (truncate (alien-internals:alien-type-alignment 252 (alien-internals:parse-alien-type 253 (convert-foreign-type type-keyword))) 254 8))) 255 256 (defun foreign-funcall-type-and-args (args) 257 "Return an 'alien function type for 'args." 258 (let ((return-type nil)) 259 (loop for (type arg) on args by #'cddr 260 if arg collect (convert-foreign-type type) into types 261 and collect arg into fargs 262 else do (setf return-type (convert-foreign-type type)) 263 finally (return (values types fargs return-type))))) 264 265 (defmacro %%foreign-funcall (name types fargs rettype) 266 "Internal guts of '%foreign-funcall." 267 `(alien-funcall (extern-alien ,name (function ,rettype ,@types)) 268 ,@fargs)) 269 270 (defmacro %foreign-funcall (name args &key library convention) 271 "Perform a foreign function call, document it more later." 272 (declare (ignore library convention)) 273 (multiple-value-bind (types fargs rettype) 274 (foreign-funcall-type-and-args args) 275 `(%%foreign-funcall ,name ,types ,fargs ,rettype))) 276 277 (defmacro %foreign-funcall-pointer (ptr args &key convention) 278 "Funcall a pointer to a foreign function." 279 (declare (ignore convention)) 280 (multiple-value-bind (types fargs rettype) 281 (foreign-funcall-type-and-args args) 282 (with-unique-names (function) 283 `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr)) 284 (alien-funcall ,function ,@fargs))))) 285 286 ;;; Callbacks 287 288 (defmacro %defcallback (name rettype arg-names arg-types body 289 &key convention) 290 (declare (ignore convention)) 291 `(alien:defcallback ,name 292 (,(convert-foreign-type rettype) 293 ,@(mapcar (lambda (sym type) 294 (list sym (convert-foreign-type type))) 295 arg-names arg-types)) 296 ,body)) 297 298 (declaim (inline %callback)) 299 (defun %callback (name) 300 (alien:callback-sap name)) 301 302 ;;;# Loading and Closing Foreign Libraries 303 304 (defun %load-foreign-library (name path) 305 "Load the foreign library 'name." 306 (declare (ignore name)) 307 (ext:load-dynamic-object path)) 308 309 (defun %close-foreign-library (name) 310 "Closes the foreign library 'name." 311 (ext:close-dynamic-object name)) 312 313 (defun native-namestring (pathname) 314 (ext:unix-namestring pathname nil)) 315 316 ;;;# Foreign Globals 317 318 (defun %foreign-symbol-pointer (name library) 319 "Returns a pointer to a foreign symbol 'name." 320 (declare (ignore library)) 321 (let ((sap (sys:foreign-symbol-address name))) 322 (if (zerop (sys:sap-int sap)) nil sap)))