GopherProxy

	tcffi-allegro.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-allegro.lisp (16300B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL.
	4 ;;;
	5 ;;; Copyright (C) 2005-2009, 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 ;;;# Administrivia
	29
	30 (defpackage #:cffi-sys
	31 (:use #:common-lisp)
	32 (:import-from #:alexandria #:if-let #:with-unique-names #:once-only)
	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 #:defcfun-helper-forms
	59 #:%defcallback
	60 #:%callback))
	61
	62 (in-package #:cffi-sys)
	63
	64 ;;;# Mis-features
	65
	66 #-64bit (pushnew 'no-long-long features)
	67 (pushnew 'flat-namespace features)
	68
	69 ;;;# Symbol Case
	70
	71 (defun canonicalize-symbol-name-case (name)
	72 (declare (string name))
	73 (if (eq excl:current-case-mode :case-sensitive-lower)
	74 (string-downcase name)
	75 (string-upcase name)))
	76
	77 ;;;# Basic Pointer Operations
	78
	79 (deftype foreign-pointer ()
	80 'ff:foreign-address)
	81
	82 (defun pointerp (ptr)
	83 "Return true if PTR is a foreign pointer."
	84 (ff:foreign-address-p ptr))
	85
	86 (defun pointer-eq (ptr1 ptr2)
	87 "Return true if PTR1 and PTR2 point to the same address."
	88 (eql ptr1 ptr2))
	89
	90 (defun null-pointer ()
	91 "Return a null pointer."
	92 0)
	93
	94 (defun null-pointer-p (ptr)
	95 "Return true if PTR is a null pointer."
	96 (zerop ptr))
	97
	98 (defun inc-pointer (ptr offset)
	99 "Return a pointer pointing OFFSET bytes past PTR."
	100 (+ ptr offset))
	101
	102 (defun make-pointer (address)
	103 "Return a pointer pointing to ADDRESS."
	104 (check-type address ff:foreign-address)
	105 address)
	106
	107 (defun pointer-address (ptr)
	108 "Return the address pointed to by PTR."
	109 (check-type ptr ff:foreign-address)
	110 ptr)
	111
	112 ;;;# Allocation
	113 ;;;
	114 ;;; Functions and macros for allocating foreign memory on the stack
	115 ;;; and on the heap. The main CFFI package defines macros that wrap
	116 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
	117 ;;; when the memory has dynamic extent.
	118
	119 (defun %foreign-alloc (size)
	120 "Allocate SIZE bytes on the heap and return a pointer."
	121 (ff:allocate-fobject :char :c size))
	122
	123 (defun foreign-free (ptr)
	124 "Free a PTR allocated by FOREIGN-ALLOC."
	125 (ff:free-fobject ptr))
	126
	127 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
	128 "Bind VAR to SIZE bytes of foreign memory during BODY. The
	129 pointer in VAR is invalid beyond the dynamic extent of BODY, and
	130 may be stack-allocated if supported by the implementation. If
	131 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
	132 (unless size-var
	133 (setf size-var (gensym "SIZE")))
	134 #+(version>= 8 1)
	135 (when (and (constantp size) (<= (eval size) ff:*max-stack-fobject-byte…
	136 (return-from with-foreign-pointer
	137 `(let ((,size-var ,(eval size)))
	138 (declare (ignorable ,size-var))
	139 (ff:with-static-fobject (,var '(:array :char ,(eval size))
	140 :allocation :foreign-static-gc)
	141 ;; (excl::stack-allocated-p var) => T
	142 (let ((,var (ff:fslot-address ,var)))
	143 ,@body)))))
	144 `(let* ((,size-var ,size)
	145 (,var (ff:allocate-fobject :char :c ,size-var)))
	146 (unwind-protect
	147 (progn ,@body)
	148 (ff:free-fobject ,var))))
	149
	150 ;;;# Shareable Vectors
	151 ;;;
	152 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
	153 ;;; should be defined to perform a copy-in/copy-out if the Lisp
	154 ;;; implementation can't do this.
	155
	156 (defun make-shareable-byte-vector (size)
	157 "Create a Lisp vector of SIZE bytes can passed to
	158 WITH-POINTER-TO-VECTOR-DATA."
	159 (make-array size :element-type '(unsigned-byte 8)
	160 :allocation :static-reclaimable))
	161
	162 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
	163 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
	164 ;; An array allocated in static-reclamable is a non-simple array in
	165 ;; the normal Lisp allocation area, pointing to a simple array in
	166 ;; the static-reclaimable allocation area. Therefore we have to get
	167 ;; out the simple-array to find the pointer to the actual contents.
	168 (with-unique-names (simple-vec)
	169 `(excl:with-underlying-simple-vector (,vector ,simple-vec)
	170 (let ((,ptr-var (ff:fslot-address-typed :unsigned-char :lisp
	171 ,simple-vec)))
	172 ,@body))))
	173
	174 ;;;# Dereferencing
	175
	176 (defun convert-foreign-type (type-keyword)
	177 "Convert a CFFI type keyword to an Allegro type."
	178 (ecase type-keyword
	179 (:char :char)
	180 (:unsigned-char :unsigned-char)
	181 (:short :short)
	182 (:unsigned-short :unsigned-short)
	183 (:int :int)
	184 (:unsigned-int :unsigned-int)
	185 (:long :long)
	186 (:unsigned-long :unsigned-long)
	187 (:long-long
	188 #+64bit :nat
	189 #-64bit (error "this platform does not support :long-long."))
	190 (:unsigned-long-long
	191 #+64bit :unsigned-nat
	192 #-64bit (error "this platform does not support :unsigned-long-long"…
	193 (:float :float)
	194 (:double :double)
	195 (:pointer :unsigned-nat)
	196 (:void :void)))
	197
	198 (defun %mem-ref (ptr type &optional (offset 0))
	199 "Dereference an object of TYPE at OFFSET bytes from PTR."
	200 (unless (zerop offset)
	201 (setf ptr (inc-pointer ptr offset)))
	202 (ff:fslot-value-typed (convert-foreign-type type) :c ptr))
	203
	204 ;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the
	205 ;;; CFFI type is constant. Allegro does its own transformation on the
	206 ;;; call that results in efficient code.
	207 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
	208 (if (constantp type)
	209 (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
	210 `(ff:fslot-value-typed ',(convert-foreign-type (eval type))
	211 :c ,ptr-form))
	212 form))
	213
	214 (defun %mem-set (value ptr type &optional (offset 0))
	215 "Set the object of TYPE at OFFSET bytes from PTR."
	216 (unless (zerop offset)
	217 (setf ptr (inc-pointer ptr offset)))
	218 (setf (ff:fslot-value-typed (convert-foreign-type type) :c ptr) value))
	219
	220 ;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED)
	221 ;;; when the CFFI type is constant. Allegro does its own
	222 ;;; transformation on the call that results in efficient code.
	223 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off…
	224 (if (constantp type)
	225 (once-only (val)
	226 (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
	227 `(setf (ff:fslot-value-typed ',(convert-foreign-type (eval typ…
	228 :c ,ptr-form) ,val)))
	229 form))
	230
	231 ;;;# Calling Foreign Functions
	232
	233 (defun %foreign-type-size (type-keyword)
	234 "Return the size in bytes of a foreign type."
	235 (ff:sizeof-fobject (convert-foreign-type type-keyword)))
	236
	237 (defun %foreign-type-alignment (type-keyword)
	238 "Returns the alignment in bytes of a foreign type."
	239 #+(and powerpc macosx32)
	240 (when (eq type-keyword :double)
	241 (return-from %foreign-type-alignment 8))
	242 ;; No override necessary for the remaining types....
	243 (ff::sized-ftype-prim-align
	244 (ff::iforeign-type-sftype
	245 (ff:get-foreign-type
	246 (convert-foreign-type type-keyword)))))
	247
	248 (defun foreign-funcall-type-and-args (args)
	249 "Returns a list of types, list of args and return type."
	250 (let ((return-type :void))
	251 (loop for (type arg) on args by #'cddr
	252 if arg collect type into types
	253 and collect arg into fargs
	254 else do (setf return-type type)
	255 finally (return (values types fargs return-type)))))
	256
	257 (defun convert-to-lisp-type (type)
	258 (ecase type
	259 ((:char :short :int :long :nat)
	260 `(signed-byte ,(* 8 (ff:sizeof-fobject type))))
	261 ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsig…
	262 `(unsigned-byte ,(* 8 (ff:sizeof-fobject type))))
	263 (:float 'single-float)
	264 (:double 'double-float)
	265 (:void 'null)))
	266
	267 (defun allegro-type-pair (cffi-type)
	268 ;; the :FOREIGN-ADDRESS pseudo-type accepts both pointers and
	269 ;; arrays. We need the latter for shareable byte vector support.
	270 (if (eq cffi-type :pointer)
	271 (list :foreign-address)
	272 (let ((ftype (convert-foreign-type cffi-type)))
	273 (list ftype (convert-to-lisp-type ftype)))))
	274
	275 #+ignore
	276 (defun note-named-foreign-function (symbol name types rettype)
	277 "Give Allegro's compiler a hint to perform a direct call."
	278 `(eval-when (:compile-toplevel :load-toplevel :execute)
	279 (setf (get ',symbol 'system::direct-ff-call)
	280 (list '(,name :language :c)
	281 t ; callback
	282 :c ; convention
	283 ;; return type '(:c-type lisp-type)
	284 ',(allegro-type-pair rettype)
	285 ;; arg types '({(:c-type lisp-type)}*)
	286 '(,@(mapcar #'allegro-type-pair types))
	287 nil ; arg-checking
	288 ff::ep-flag-never-release))))
	289
	290 (defmacro %foreign-funcall (name args &key convention library)
	291 (declare (ignore convention library))
	292 (multiple-value-bind (types fargs rettype)
	293 (foreign-funcall-type-and-args args)
	294 `(system::ff-funcall
	295 (load-time-value (excl::determine-foreign-address
	296 '(,name :language :c)
	297 #-(version>= 8 1) ff::ep-flag-never-release
	298 #+(version>= 8 1) ff::ep-flag-always-release
	299 nil ; method-index
	300 ))
	301 ;; arg types {'(:c-type lisp-type) argN}*
	302 ,@(mapcan (lambda (type arg)
	303 `(',(allegro-type-pair type) ,arg))
	304 types fargs)
	305 ;; return type '(:c-type lisp-type)
	306 ',(allegro-type-pair rettype))))
	307
	308 (defun defcfun-helper-forms (name lisp-name rettype args types options)
	309 "Return 2 values for DEFCFUN. A prelude form and a caller form."
	310 (declare (ignore options))
	311 (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-na…
	312 (values
	313 `(ff:def-foreign-call (,ff-name ,name)
	314 ,(loop for type in types
	315 collect (list* (gensym) (allegro-type-pair type)))
	316 :returning ,(allegro-type-pair rettype)
	317 ;; Don't use call-direct when there are no arguments.
	318 ,@(unless (null args) '(:call-direct t))
	319 :arg-checking nil
	320 :strings-convert nil
	321 #+(version>= 8 1) ,@'(:release-heap :when-ok
	322 :release-heap-ignorable t)
	323 #+smp ,@'(:release-heap-implies-allow-gc t))
	324 `(,ff-name ,@args))))
	325
	326 ;;; See doc/allegro-internals.txt for a clue about entry-vec.
	327 (defmacro %foreign-funcall-pointer (ptr args &key convention)
	328 (declare (ignore convention))
	329 (multiple-value-bind (types fargs rettype)
	330 (foreign-funcall-type-and-args args)
	331 (with-unique-names (entry-vec)
	332 `(let ((,entry-vec (excl::make-entry-vec-boa)))
	333 (setf (aref ,entry-vec 1) ,ptr) ; set jump address
	334 (system::ff-funcall
	335 ,entry-vec
	336 ;; arg types {'(:c-type lisp-type) argN}*
	337 ,@(mapcan (lambda (type arg)
	338 `(',(allegro-type-pair type) ,arg))
	339 types fargs)
	340 ;; return type '(:c-type lisp-type)
	341 ',(allegro-type-pair rettype))))))
	342
	343 ;;;# Callbacks
	344
	345 ;;; The CALLBACKS hash table contains information about a callback
	346 ;;; for the Allegro FFI. The key is the name of the CFFI callback,
	347 ;;; and the value is a cons, the car containing the symbol the
	348 ;;; callback was defined on in the CFFI-CALLBACKS package, the cdr
	349 ;;; being an Allegro FFI pointer (a fixnum) that can be passed to C
	350 ;;; functions.
	351 ;;;
	352 ;;; These pointers must be restored when a saved Lisp image is loaded.
	353 ;;; The RESTORE-CALLBACKS function is added to RESTART-ACTIONS to
	354 ;;; re-register the callbacks during Lisp startup.
	355 (defvar callbacks (make-hash-table))
	356
	357 ;;; Register a callback in the CALLBACKS hash table.
	358 (defun register-callback (cffi-name callback-name)
	359 (setf (gethash cffi-name callbacks)
	360 (cons callback-name (ff:register-foreign-callable
	361 callback-name :reuse t))))
	362
	363 ;;; Restore the saved pointers in CALLBACKS when loading an image.
	364 (defun restore-callbacks ()
	365 (maphash (lambda (key value)
	366 (register-callback key (car value)))
	367 callbacks))
	368
	369 ;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing
	370 ;;; CFFI is restarted.
	371 (eval-when (:load-toplevel :execute)
	372 (pushnew 'restore-callbacks excl:restart-actions))
	373
	374 ;;; Create a package to contain the symbols for callback functions.
	375 (defpackage #:cffi-callbacks
	376 (:use))
	377
	378 (defun intern-callback (name)
	379 (intern (format nil "~A::~A"
	380 (if-let (package (symbol-package name))
	381 (package-name package)
	382 "#")
	383 (symbol-name name))
	384 '#:cffi-callbacks))
	385
	386 (defun convert-calling-convention (convention)
	387 (ecase convention
	388 (:cdecl :c)
	389 (:stdcall :stdcall)))
	390
	391 (defmacro %defcallback (name rettype arg-names arg-types body
	392 &key convention)
	393 (declare (ignore rettype))
	394 (let ((cb-name (intern-callback name)))
	395 `(progn
	396 (ff:defun-foreign-callable ,cb-name
	397 ,(mapcar (lambda (sym type) (list sym (convert-foreign-type t…
	398 arg-names arg-types)
	399 (declare (:convention ,(convert-calling-convention convention)))
	400 ,body)
	401 (register-callback ',name ',cb-name))))
	402
	403 ;;; Return the saved Lisp callback pointer from CALLBACKS for the
	404 ;;; CFFI callback named NAME.
	405 (defun %callback (name)
	406 (or (cdr (gethash name callbacks))
	407 (error "Undefined callback: ~S" name)))
	408
	409 ;;;# Loading and Closing Foreign Libraries
	410
	411 (defun %load-foreign-library (name path)
	412 "Load a foreign library."
	413 ;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load
	414 ;; the argument. However, previous versions do not and will only
	415 ;; foreign load the argument if its type is a member of the
	416 ;; EXCL::LOAD-FOREIGN-TYPES list. Therefore, we bind that special
	417 ;; to a list containing whatever type NAME has.
	418 (declare (ignore name))
	419 (let ((excl::load-foreign-types
	420 (list (pathname-type (parse-namestring path)))))
	421 (handler-case
	422 (progn
	423 #+(version>= 7) (load path :foreign t)
	424 #-(version>= 7) (load path))
	425 (file-error (fe)
	426 (error (change-class fe 'simple-error))))
	427 path))
	428
	429 (defun %close-foreign-library (name)
	430 "Close the foreign library NAME."
	431 (ff:unload-foreign-library name))
	432
	433 (defun native-namestring (pathname)
	434 (namestring pathname))
	435
	436 ;;;# Foreign Globals
	437
	438 (defun convert-external-name (name)
	439 "Add an underscore to NAME if necessary for the ABI."
	440 #+macosx (concatenate 'string "_" name)
	441 #-macosx name)
	442
	443 (defun %foreign-symbol-pointer (name library)
	444 "Returns a pointer to a foreign symbol NAME."
	445 (declare (ignore library))
	446 (prog1 (ff:get-entry-point (convert-external-name name))))