Update of /project/cello/cvsroot/hello-c In directory clnet:/tmp/cvs-serv16563
Modified Files: arrays.lisp callbacks.lisp definers.lisp Added Files: ffi-extender.lisp hello-cffi.asd hello-cffi.lpr my-uffi-compat.lisp Log Message:
--- /project/cello/cvsroot/hello-c/arrays.lisp 2005/05/23 23:51:57 1.1 +++ /project/cello/cvsroot/hello-c/arrays.lisp 2006/05/15 16:36:13 1.2 @@ -23,7 +23,7 @@
-(in-package :hello-c) +(in-package :ffx)
(defparameter *gl-rsrc* nil)
@@ -46,7 +46,7 @@ (progn (loop for fgn in *fgn-mem* do (print fgn) - (fgn-free (fgn-ptr fgn)) + (foreign-free (fgn-ptr fgn)) finally (setf *fgn-mem* nil)) (loop for fgn in *gl-rsrc* do (print fgn) @@ -72,11 +72,11 @@ (let ((amt (gensym)) (ptr (gensym))) `(let* ((,amt ,amt-form) - (,ptr (allocate-foreign-object ,type ,amt))) + (,ptr (falloc ,type ,amt))) (call-fgn-alloc ,type ,amt ,ptr (list ,@keys)))))
(defun call-fgn-alloc (type amt ptr keys) - ;;(print `(fgnalloc ,type ,amt ,keys)) + ;;(print `(call-fgn-alloc ,type ,amt ,keys)) (fgn-ptr (car (push (make-fgn :id keys :type type :amt amt @@ -84,12 +84,14 @@ *fgn-mem*))))
(defun fgn-free (&rest fgn-ptrs) - (loop for fgn-ptr in fgn-ptrs do - (let ((fgn (find fgn-ptr *fgn-mem* :key 'fgn-ptr))) - (if fgn - (setf *fgn-mem* (delete fgn *fgn-mem*)) - (format t "~&Freeing unknown FGN ~a" fgn-ptr)) - (free-foreign-object fgn-ptr)))) + ;; (print `(fgn-free freeing ,@fgn-ptrs)) + (let ((start (copy-list fgn-ptrs))) + (loop for fgn-ptr in start do + (let ((fgn (find fgn-ptr *fgn-mem* :key 'fgn-ptr))) + (if fgn + (setf *fgn-mem* (delete fgn *fgn-mem*)) + (format t "~&Freeing unknown FGN ~a" fgn-ptr)) + (foreign-free fgn-ptr)))))
(defun gllog (type resource amt &rest keys) (push (make-fgn :id keys @@ -138,7 +140,7 @@ (defun ff-floatv-setf (array &rest floats) (loop for f in floats and n upfrom 0 - do (setf (deref-array array '(:array :float) n) (* 1.0 f))) + do (setf (mem-aref array :float n) (* 1.0 f))) array)
;--------- with-ff-array-elements ------------------------------------------ @@ -147,17 +149,17 @@ (defmacro with-ff-array-elements ((fa type &rest refs) &body body) `(let ,(let ((refn -1)) (mapcar (lambda (ref) - `(,ref (deref-array ,fa '(:array ,type) ,(incf refn)))) + `(,ref (mem-aref ,fa ,type) ,(incf refn))) refs)) ,@body))
;-------- ff-elt ---------------------------------------
(defmacro ff-elt-p (v n) - `(deref-array ,v '(:array (* :void)) ,n)) + `(mem-aref ,v :pointer ,n))
(defmacro ff-elt (v type n) - `(deref-array ,v '(:array ,type) ,n)) + `(mem-aref ,v ',type ,n))
(defun elti (v n) (ff-elt v :int n)) @@ -172,10 +174,10 @@ (setf (ff-elt v :float n) (coerce value 'float)))
(defun elt$ (v n) - (ff-elt v :cstring n)) + (ff-elt v :string n))
(defun (setf elt$) (value v n) - (setf (ff-elt v :cstring n) value)) + (setf (ff-elt v :string n) value))
(defun eltd (v n) (ff-elt v :double n)) @@ -184,7 +186,7 @@ (setf (ff-elt v :double n) (coerce value 'double-float)))
(defmacro fgn-pa (pa n) - `(deref-array ,pa '(:array (* :void)) ,n)) + `(mem-aref ,pa :pointer ,n))
(eval-when (compile load eval) (export '(ffx-reset --- /project/cello/cvsroot/hello-c/callbacks.lisp 2005/05/23 23:51:57 1.1 +++ /project/cello/cvsroot/hello-c/callbacks.lisp 2006/05/15 16:36:13 1.2 @@ -21,8 +21,10 @@ ;;; IN THE SOFTWARE.
-(in-package :hello-c) +(in-package :ffx)
+ +#+precffi (defun ff-register-callable (callback-name) #+allegro (ff:register-foreign-callable callback-name) @@ -33,8 +35,18 @@ (print (list :ff-register-callable-returns cb)) cb))
+(defun ff-register-callable (callback-name) + (let ((known-callback (cffi:get-callback callback-name))) + (assert known-callback) + known-callback)) + +(defmacro ff-defun-callable (call-convention result-type name args &body body) + (declare (ignorable call-convention)) + `(defcallback ,name ,result-type ,args ,@body)) + +#+precffi (defmacro ff-defun-callable (call-convention result-type name args &body body) - (declare (ignorable result-type)) + (declare (ignorable call-convention result-type)) (let ((native-args (when args ;; without this p-f-a returns '(:void) as if for declare (process-function-args args)))) #+lispworks @@ -50,35 +62,13 @@ ,@body)))
-#+test -(ff-defun-callable :cdecl :int square ((arg-1 :int)(data (* :void))) +#+(or) +(ff-defun-callable :cdecl :int square ((arg-1 :int)(data :pointer)) (list data (* arg-1 arg-1)))
-(defmacro ff-def-call ((module iname ename) args) - #+cormanlisp - (assert module () "Module (dll name, in fact) required for Corman Lisp") - #+cormanlisp - `(ct:defun-dll ,iname ,args - :return-type :short - :library-name ,module ;; required according Corman doc - :entry-name ,ename - :linkage-type :c) ;; ?? - - #+allegro (declare (ignorable module)) - #+allegro - `(ff:def-foreign-call (,iname ,ename) ,args) - #+lispworks - `(fli:define-foreign-function (,iname ,ename) - ,(mapcar (lambda (arg) (if (listp (cadr arg)) - (list (car arg) (substitute :pointer '* (cadr arg))) - arg)) - args) - :module ,module - :result-type :int))
(eval-when (compile load eval) (export '(ff-register-callable ff-defun-callable - ff-def-call ff-pointer-address))) \ No newline at end of file --- /project/cello/cvsroot/hello-c/definers.lisp 2005/07/10 21:35:01 1.2 +++ /project/cello/cvsroot/hello-c/definers.lisp 2006/05/15 16:36:13 1.3 @@ -20,9 +20,9 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.
-;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ +;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.3 2006/05/15 16:36:13 ktilton Exp $
-(in-package :hello-c) +(in-package :ffx)
(eval-when (compile load eval) (export '( @@ -46,12 +46,57 @@ ;;; (fli:make-pointer :address n :pointer-type '(:pointer :void)))
(defun make-ff-pointer (n) - #+allegro (ff:make-foreign-pointer :address n :type '(* void)) #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) - #-(or lispworks allegro) n + #+clisp (ffi:unsigned-foreign-address n) + #-(or clisp lispworks) n )
(defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) + (declare (ignore module$)) + (let* ((lisp-fn (lisp-fn name$)) + (lispfn (intern (string-upcase name$))) + (var-types (let (args) + (assert (evenp (length type-args)) () "uneven arg-list for ~a" name$) + (dotimes (n (floor (length type-args) 2) (nreverse args)) + (let ((type (elt type-args (* 2 n))) + (var (elt type-args (1+ (* 2 n))))) + (when (eql #* (elt (symbol-name var) 0)) + ;; no, good with *: (setf var (intern (subseq (symbol-name var) 1))) + (setf type :pointer)) + (push (list var type) args))))) + (cast-vars (mapcar (lambda (var-type) + (copy-symbol (car var-type))) var-types))) + `(progn + (cffi:defcfun (,name$ ,lispfn) ,(if (and (consp rtn) (eq '* (car rtn))) + :pointer rtn) + ,@var-types) + + (defun ,lisp-fn ,(mapcar #'car var-types) + (let ,(mapcar (lambda (cast-var var-type) + `(,cast-var ,(if (listp (cadr var-type)) + (car var-type) + (case (cadr var-type) + (:int `(coerce ,(car var-type) 'integer)) + (:long `(coerce ,(car var-type) 'integer)) + (:unsigned-long `(coerce ,(car var-type) 'integer)) + (:unsigned-int `(coerce ,(car var-type) 'integer)) + (:float `(coerce ,(car var-type) 'float)) + (:double `(coerce ,(car var-type) 'double-float)) + (:string (car var-type)) + (:pointer (car var-type)) + (otherwise + (let ((ffc (get (cadr var-type) 'ffi-cast))) + (assert ffc () "Don't know how to cast ~a" (cadr var-type)) + `(coerce ,(car var-type) ',ffc))))))) + cast-vars var-types) + (prog1 + (,lispfn ,@cast-vars) + ,@post-processing))) + (eval-when (compile eval load) + (export '(,lispfn ,lisp-fn)))))) + +#+precffi +(defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (let* ((lisp-fn (lisp-fn name$)) (lispfn (intern (string-upcase name$))) (var-types (let (args) @@ -81,7 +126,7 @@ (:unsigned-int `(coerce ,(car var-type) 'integer)) (:float `(coerce ,(car var-type) 'float)) (:double `(coerce ,(car var-type) 'double-float)) - (:cstring (car var-type)) + (:string (car var-type)) (otherwise (let ((ffc (get (cadr var-type) 'ffi-cast))) (assert ffc () "Don't know how to cast ~a" (cadr var-type)) @@ -121,7 +166,7 @@ (defmacro dft (ctype ffi-type ffi-cast) `(progn (setf (get ',ctype 'ffi-cast) ',ffi-cast) - (def-foreign-type ,ctype ,ffi-type) + (defctype ,ctype ,ffi-type) (eval-when (compile eval load) (export ',ctype))))
--- /project/cello/cvsroot/hello-c/ffi-extender.lisp 2006/05/15 16:36:13 NONE +++ /project/cello/cvsroot/hello-c/ffi-extender.lisp 2006/05/15 16:36:13 1.1 (in-package :cl-user)
(defpackage #:ffi-extender (:nicknames #:ffx) (:shadowing-import-from #:cffi #:with-foreign-object #:load-foreign-library #:with-foreign-string) (:use #:common-lisp #:cffi) (:export #:def-type #:def-foreign-type #:def-constant #:null-char-p #:def-enum #:def-struct #:get-slot-value #:get-slot-pointer #:def-array-pointer #:def-union #:allocate-foreign-object #:with-foreign-object #:with-foreign-objects #:size-of-foreign-type #:pointer-address #:deref-pointer #:ensure-char-character #:ensure-char-integer #:ensure-char-storable #:null-pointer-p #:+null-cstring-pointer+ #:char-array-to-pointer #:with-cast-pointer #:def-foreign-var #:convert-from-cstring #:convert-to-cstring #:free-cstring #:with-cstring #:with-cstrings #:def-function #:find-foreign-library #:load-foreign-library #:default-foreign-library-type #:run-shell-command #:convert-from-foreign-string #:convert-to-foreign-string #:allocate-foreign-string #:with-foreign-string #:foreign-string-length ; not implemented #:convert-from-foreign-usb8 ))
(in-package :ffx)--- /project/cello/cvsroot/hello-c/hello-cffi.asd 2006/05/15 16:36:13 NONE +++ /project/cello/cvsroot/hello-c/hello-cffi.asd 2006/05/15 16:36:13 1.1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1))) (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
#-(or openmcl sbcl cmu clisp lispworks ecl allegro cormanlisp) (error "Sorry, this Lisp is not yet supported. Patches welcome!")
(asdf:defsystem :hello-cffi :name "Hello CFFI" :author "Kenny Tilton ktilton@nyc.rr.com" :version "1.0.0" :maintainer "Kenny Tilton ktilton@nyc.rr.com" :licence "Lisp Lesser GNU Public License" :description "CFFI Add-ons" :long-description "Extensions and utilities for CFFI" :depends-on (:cffi :cffi-uffi-compat) :serial t :components ((:file "my-uffi-compat") (:file "ffi-extender") (:file "definers") (:file "arrays") (:file "callbacks"))) --- /project/cello/cvsroot/hello-c/hello-cffi.lpr 2006/05/15 16:36:13 NONE +++ /project/cello/cvsroot/hello-c/hello-cffi.lpr 2006/05/15 16:36:13 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*-
(in-package :cg-user)
(defpackage :HELLO-C)
(define-project :name :hello-cffi :modules (list (make-instance 'module :name "my-uffi-compat.lisp") (make-instance 'module :name "ffi-extender.lisp") (make-instance 'module :name "definers.lisp") (make-instance 'module :name "arrays.lisp") (make-instance 'module :name "callbacks.lisp")) :projects (list (make-instance 'project-module :name "C:\0devtools\cffi\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :hello-c :main-form nil :compilation-unit t :verbose nil :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t "Initializing"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'default-init-function :on-restart 'do-default-restart)
;; End of Project Definition --- /project/cello/cvsroot/hello-c/my-uffi-compat.lisp 2006/05/15 16:36:13 NONE +++ /project/cello/cvsroot/hello-c/my-uffi-compat.lisp 2006/05/15 16:36:13 1.1 (in-package :cffi)
(eval-when (compile load eval) (export '(falloc)))
(defun deref-array (array type position) (mem-aref array type position))
(defun (setf deref-array) (value array type position) (setf (mem-aref array type position) value))
(defun falloc (type &optional (size 1)) (cffi:foreign-alloc type :count size))
(defun free-foreign-object (ptr) (foreign-free ptr))