GopherProxy

	tcffi-cmucl.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-cmucl.lisp (13220B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; cffi-cmucl.lisp --- CFFI-SYS implementation for CMU CL.
	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 #:alien #:c-call)
	32 (:import-from #:alexandria #:once-only #:with-unique-names #:if-let)
	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 ;;;# 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 ;;;# Basic Pointer Operations
	74
	75 (deftype foreign-pointer ()
	76 'sys:system-area-pointer)
	77
	78 (declaim (inline pointerp))
	79 (defun pointerp (ptr)
	80 "Return true if PTR is a foreign pointer."
	81 (sys:system-area-pointer-p ptr))
	82
	83 (declaim (inline pointer-eq))
	84 (defun pointer-eq (ptr1 ptr2)
	85 "Return true if PTR1 and PTR2 point to the same address."
	86 (sys:sap= ptr1 ptr2))
	87
	88 (declaim (inline null-pointer))
	89 (defun null-pointer ()
	90 "Construct and return a null pointer."
	91 (sys:int-sap 0))
	92
	93 (declaim (inline null-pointer-p))
	94 (defun null-pointer-p (ptr)
	95 "Return true if PTR is a null pointer."
	96 (zerop (sys:sap-int ptr)))
	97
	98 (declaim (inline inc-pointer))
	99 (defun inc-pointer (ptr offset)
	100 "Return a pointer pointing OFFSET bytes past PTR."
	101 (sys:sap+ ptr offset))
	102
	103 (declaim (inline make-pointer))
	104 (defun make-pointer (address)
	105 "Return a pointer pointing to ADDRESS."
	106 (sys:int-sap address))
	107
	108 (declaim (inline pointer-address))
	109 (defun pointer-address (ptr)
	110 "Return the address pointed to by PTR."
	111 (sys:sap-int ptr))
	112
	113 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
	114 "Bind VAR to SIZE bytes of foreign memory during BODY. The
	115 pointer in VAR is invalid beyond the dynamic extent of BODY, and
	116 may be stack-allocated if supported by the implementation. If
	117 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
	118 (unless size-var
	119 (setf size-var (gensym "SIZE")))
	120 ;; If the size is constant we can stack-allocate.
	121 (if (constantp size)
	122 (let ((alien-var (gensym "ALIEN")))
	123 `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
	124 (let ((,size-var ,(eval size))
	125 (,var (alien-sap ,alien-var)))
	126 (declare (ignorable ,size-var))
	127 ,@body)))
	128 `(let* ((,size-var ,size)
	129 (,var (%foreign-alloc ,size-var)))
	130 (unwind-protect
	131 (progn ,@body)
	132 (foreign-free ,var)))))
	133
	134 ;;;# Allocation
	135 ;;;
	136 ;;; Functions and macros for allocating foreign memory on the stack
	137 ;;; and on the heap. The main CFFI package defines macros that wrap
	138 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
	139 ;;; when the memory has dynamic extent.
	140
	141 (defun %foreign-alloc (size)
	142 "Allocate SIZE bytes on the heap and return a pointer."
	143 (declare (type (unsigned-byte 32) size))
	144 (alien-funcall
	145 (extern-alien
	146 "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
	154 (extern-alien
	155 "free"
	156 (function (values) system-area-pointer))
	157 ptr))
	158
	159 ;;;# Shareable Vectors
	160 ;;;
	161 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
	162 ;;; should be defined to perform a copy-in/copy-out if the Lisp
	163 ;;; implementation can't do this.
	164
	165 (defun make-shareable-byte-vector (size)
	166 "Create a Lisp vector of SIZE bytes that can passed to
	167 WITH-POINTER-TO-VECTOR-DATA."
	168 (make-array size :element-type '(unsigned-byte 8)))
	169
	170 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
	171 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
	172 `(sys:without-gcing
	173 (let ((,ptr-var (sys:vector-sap ,vector)))
	174 ,@body)))
	175
	176 ;;;# Dereferencing
	177
	178 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
	179 ;;; macros that optimize the case where the type keyword is constant
	180 ;;; at compile-time.
	181 (defmacro define-mem-accessors (&body pairs)
	182 `(progn
	183 (defun %mem-ref (ptr type &optional (offset 0))
	184 (ecase type
	185 ,@(loop for (keyword fn) in pairs
	186 collect `(,keyword (,fn ptr offset)))))
	187 (defun %mem-set (value ptr type &optional (offset 0))
	188 (ecase type
	189 ,@(loop for (keyword fn) in pairs
	190 collect `(,keyword (setf (,fn ptr offset) value)))))
	191 (define-compiler-macro %mem-ref
	192 (&whole form ptr type &optional (offset 0))
	193 (if (constantp type)
	194 (ecase (eval type)
	195 ,@(loop for (keyword fn) in pairs
	196 collect `(,keyword `(,',fn ,ptr ,offset))))
	197 form))
	198 (define-compiler-macro %mem-set
	199 (&whole form value ptr type &optional (offset 0))
	200 (if (constantp type)
	201 (once-only (value)
	202 (ecase (eval type)
	203 ,@(loop for (keyword fn) in pairs
	204 collect `(,keyword `(setf (,',fn ,ptr ,offset)
	205 ,value)))))
	206 form))))
	207
	208 (define-mem-accessors
	209 (:char sys:signed-sap-ref-8)
	210 (:unsigned-char sys:sap-ref-8)
	211 (:short sys:signed-sap-ref-16)
	212 (:unsigned-short sys:sap-ref-16)
	213 (:int sys:signed-sap-ref-32)
	214 (:unsigned-int sys:sap-ref-32)
	215 (:long sys:signed-sap-ref-32)
	216 (:unsigned-long sys:sap-ref-32)
	217 (:long-long sys:signed-sap-ref-64)
	218 (:unsigned-long-long sys:sap-ref-64)
	219 (:float sys:sap-ref-single)
	220 (:double sys:sap-ref-double)
	221 (:pointer sys:sap-ref-sap))
	222
	223 ;;;# Calling Foreign Functions
	224
	225 (defun convert-foreign-type (type-keyword)
	226 "Convert a CFFI type keyword to an ALIEN type."
	227 (ecase type-keyword
	228 (:char 'char)
	229 (:unsigned-char 'unsigned-char)
	230 (:short 'short)
	231 (:unsigned-short 'unsigned-short)
	232 (:int 'int)
	233 (:unsigned-int 'unsigned-int)
	234 (:long 'long)
	235 (:unsigned-long 'unsigned-long)
	236 (:long-long '(signed 64))
	237 (:unsigned-long-long '(unsigned 64))
	238 (:float 'single-float)
	239 (:double 'double-float)
	240 (:pointer 'system-area-pointer)
	241 (:void 'void)))
	242
	243 (defun %foreign-type-size (type-keyword)
	244 "Return the size in bytes of a foreign type."
	245 (/ (alien-internals:alien-type-bits
	246 (alien-internals:parse-alien-type
	247 (convert-foreign-type type-keyword))) 8))
	248
	249 (defun %foreign-type-alignment (type-keyword)
	250 "Return the alignment in bytes of a foreign type."
	251 (/ (alien-internals:alien-type-alignment
	252 (alien-internals:parse-alien-type
	253 (convert-foreign-type type-keyword))) 8))
	254
	255 (defun foreign-funcall-type-and-args (args)
	256 "Return an ALIEN function type for ARGS."
	257 (let ((return-type nil))
	258 (loop for (type arg) on args by #'cddr
	259 if arg collect (convert-foreign-type type) into types
	260 and collect arg into fargs
	261 else do (setf return-type (convert-foreign-type type))
	262 finally (return (values types fargs return-type)))))
	263
	264 (defmacro %%foreign-funcall (name types fargs rettype)
	265 "Internal guts of %FOREIGN-FUNCALL."
	266 `(alien-funcall
	267 (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 (defvar callbacks (make-hash-table))
	289
	290 ;;; Create a package to contain the symbols for callback functions. We
	291 ;;; want to redefine callbacks with the same symbol so the internal data
	292 ;;; structures are reused.
	293 (defpackage #:cffi-callbacks
	294 (:use))
	295
	296 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the inter…
	297 ;;; callback for NAME.
	298 (eval-when (:compile-toplevel :load-toplevel :execute)
	299 (defun intern-callback (name)
	300 (intern (format nil "~A::~A"
	301 (if-let (package (symbol-package name))
	302 (package-name package)
	303 name)
	304 (symbol-name name))
	305 '#:cffi-callbacks)))
	306
	307 (defmacro %defcallback (name rettype arg-names arg-types body
	308 &key convention)
	309 (declare (ignore convention))
	310 (let ((cb-name (intern-callback name)))
	311 `(progn
	312 (def-callback ,cb-name
	313 (,(convert-foreign-type rettype)
	314 ,@(mapcar (lambda (sym type)
	315 (list sym (convert-foreign-type type)))
	316 arg-names arg-types))
	317 ,body)
	318 (setf (gethash ',name callbacks) (callback ,cb-name)))))
	319
	320 (defun %callback (name)
	321 (multiple-value-bind (pointer winp)
	322 (gethash name callbacks)
	323 (unless winp
	324 (error "Undefined callback: ~S" name))
	325 pointer))
	326
	327 ;;; CMUCL makes new callback trampolines when it reloads, so we need
	328 ;;; to update CFFI's copies.
	329 (defun reset-callbacks ()
	330 (loop for k being the hash-keys of callbacks
	331 do (setf (gethash k callbacks)
	332 (alien::symbol-trampoline (intern-callback k)))))
	333
	334 ;; Needs to be after cmucl's restore-callbacks, so put at the end...
	335 (unless (member 'reset-callbacks ext:after-save-initializations)
	336 (setf ext:after-save-initializations
	337 (append ext:after-save-initializations (list 'reset-callbacks)…
	338
	339 ;;;# Loading and Closing Foreign Libraries
	340
	341 ;;; Work-around for compiling ffi code without loading the
	342 ;;; respective library at compile-time.
	343 (setf c::top-level-lambda-max 0)
	344
	345 (defun %load-foreign-library (name path)
	346 "Load the foreign library NAME."
	347 ;; On some platforms SYS::LOAD-OBJECT-FILE signals an error when
	348 ;; loading fails, but on others (Linux for instance) it returns
	349 ;; two values: NIL and an error string.
	350 (declare (ignore name))
	351 (multiple-value-bind (ret message)
	352 (sys::load-object-file path)
	353 (cond
	354 ;; Loading failed.
	355 ((stringp message) (error "~A" message))
	356 ;; The library was already loaded.
	357 ((null ret) (cdr (rassoc path sys::global-table :test #'string=)…
	358 ;; The library has been loaded, but since SYS::LOAD-OBJECT-FILE
	359 ;; returns an alist of all loaded libraries along with their add…
	360 ;; we return only the handler associated with the library just loa…
	361 (t (cdr (rassoc path ret :test #'string=))))))
	362
	363 ;;; XXX: doesn't work on Darwin; does not check for errors. I suppose we…
	364 ;;; want something like SBCL's dlclose-or-lose in foreign-load.lisp:66
	365 (defun %close-foreign-library (handler)
	366 "Closes a foreign library."
	367 (let ((lib (rassoc (ext:unix-namestring handler) sys::global-table
	368 :test #'string=)))
	369 (sys::dlclose (car lib))
	370 (setf (car lib) (sys:int-sap 0))))
	371
	372 (defun native-namestring (pathname)
	373 (ext:unix-namestring pathname nil))
	374
	375 ;;;# Foreign Globals
	376
	377 (defun %foreign-symbol-pointer (name library)
	378 "Returns a pointer to a foreign symbol NAME."
	379 (declare (ignore library))
	380 (let ((address (sys:alternate-get-global-address
	381 (vm:extern-alien-name name))))
	382 (if (zerop address)
	383 nil
	384 (sys:int-sap address))))