Update of /project/cello/cvsroot/hello-cffi In directory clnet:/tmp/cvs-serv16185

Added Files: arrays.lisp callbacks.lisp definers.lisp ffi-extender.lisp hello-cffi.asd hello-cffi.lpr my-uffi-compat.lisp Log Message:

--- /project/cello/cvsroot/hello-cffi/arrays.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/arrays.lisp 2006/05/17 04:29:42 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright © 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.

(in-package :ffx)

(defparameter *gl-rsrc* nil)

(defparameter *fgn-mem* nil)

(defun fgn-dump () (print (length *fgn-mem*)) (loop for fgn in *fgn-mem* do (print fgn) summing (fgn-amt fgn)))

#+check (fgn-dump)

(defun ffx-reset (&optional force) (hic-reset force))

(defun hic-reset (&optional force) (if force (progn (loop for fgn in *fgn-mem* do (print fgn) (foreign-free (fgn-ptr fgn)) finally (setf *fgn-mem* nil)) (loop for fgn in *gl-rsrc* do (print fgn) (glfree (fgn-type fgn)(fgn-ptr fgn)) finally (setf *gl-rsrc* nil)) (progn (when *fgn-mem* (loop for fgn in *fgn-mem* do (print fgn) finally (break "above fgn-mem not freed"))) (when *gl-rsrc* (loop for fgn in *gl-rsrc* do (print fgn) finally (break "above *gl-rsrc* not freed")))))))

(defstruct fgn ptr id type amt)

(defmethod print-object ((fgn fgn) s) (format s "fgnmem ~a :amt ~a :type ~a" (fgn-id fgn)(fgn-amt fgn)(fgn-type fgn)))

(defmacro fgn-alloc (type amt-form &rest keys) (let ((amt (gensym)) (ptr (gensym))) `(let* ((,amt ,amt-form) (,ptr (falloc ,type ,amt))) (call-fgn-alloc ,type ,amt ,ptr (list ,@keys)))))

(defun call-fgn-alloc (type amt ptr keys) ;;(print `(call-fgn-alloc ,type ,amt ,keys)) (fgn-ptr (car (push (make-fgn :id keys :type type :amt amt :ptr ptr) *fgn-mem*))))

(defun fgn-free (&rest fgn-ptrs) ;; (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 :type type :amt amt :ptr resource) *gl-rsrc*))

(defun glfree (type resource) (let ((fgn (find (cons type resource) *gl-rsrc* :test 'equal :key (lambda (g) (cons (fgn-type g)(fgn-ptr g)))))) (if fgn (setf *gl-rsrc* (delete fgn *gl-rsrc*)) (format t "~&Freeing unknown GL resource ~a" (cons type resource))) #+nonono (ecase type (:texture (ogl:ogl-texture-delete resource)))))

(defmacro make-ff-array (type &rest values) (let ((fv (gensym))(n (gensym))(vs (gensym))) `(let ((,fv (fgn-alloc ',type ,(length values) :make-ff-array)) (,vs (list ,@values))) (dotimes (,n ,(length values) ,fv) (setf (ff-elt ,fv ,type ,n) (coerce (nth ,n ,vs) ',(if (keywordp type) (intern (symbol-name type)) (get type 'ffi-cast))))))))

(defmacro ff-list (array type count) (let ((a (gensym))(n (gensym))) `(loop with ,a = ,array for ,n below ,count collecting (ff-elt ,a ,type ,n))))

(defun make-floatv (&rest floats) (let* ((co (fgn-alloc :float (length floats) :make-floatv)) ) (apply 'ff-floatv-setf co floats)))

(defmacro ff-floatv-ensure (place &rest values) `(if ,place (ff-floatv-setf ,place ,@values) (setf ,place (make-floatv ,@values))))

(defun ff-floatv-setf (array &rest floats) (loop for f in floats and n upfrom 0 do (setf (mem-aref array :float n) (* 1.0 f))) array)

;--------- with-ff-array-elements ------------------------------------------

(defmacro with-ff-array-elements ((fa type &rest refs) &body body) `(let ,(let ((refn -1)) (mapcar (lambda (ref) `(,ref (mem-aref ,fa ,type) ,(incf refn))) refs)) ,@body))

;-------- ff-elt ---------------------------------------

(defmacro ff-elt-p (v n) `(mem-aref ,v :pointer ,n))

(defmacro ff-elt (v type n) `(mem-aref ,v ',type ,n))

(defun elti (v n) (ff-elt v :int n))

(defun (setf elti) (value v n) (setf (ff-elt v :int n) (coerce value 'integer)))

(defun eltf (v n) (ff-elt v :float n))

(defun (setf eltf) (value v n) (setf (ff-elt v :float n) (coerce value 'float)))

(defun elt$ (v n) (ff-elt v :string n))

(defun (setf elt$) (value v n) (setf (ff-elt v :string n) value))

(defun eltd (v n) (ff-elt v :double n))

(defun (setf eltd) (value v n) (setf (ff-elt v :double n) (coerce value 'double-float)))

(defmacro fgn-pa (pa n) `(mem-aref ,pa :pointer ,n))

(eval-when (compile load eval) (export '(ffx-reset ff-elt ff-list eltf eltd elti fgn-pa with-ff-array-elements make-ff-array make-floatv ff-floatv-ensure hic-reset fgn-alloc fgn-free gllog glfree)))--- /project/cello/cvsroot/hello-cffi/callbacks.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/callbacks.lisp 2006/05/17 04:29:42 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright © 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.

(in-package :ffx)

#+precffi (defun ff-register-callable (callback-name) #+allegro (ff:register-foreign-callable callback-name) #+lispworks (let ((cb (progn ;; fli:pointer-address (fli:make-pointer :symbol-name (symbol-name callback-name) ;; leak? :functionp t)))) (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 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 `(fli:define-foreign-callable (,(symbol-name name) :result-type ,result-type :calling-convention ,call-convention) (,@native-args) ,@body) #+allegro `(ff:defun-foreign-callable ,name ,native-args (declare (:convention ,(ecase call-convention (:cdecl :c) (:stdcall :stdcall)))) ,@body)))

#+(or) (ff-defun-callable :cdecl :int square ((arg-1 :int)(data :pointer)) (list data (* arg-1 arg-1)))

(eval-when (compile load eval) (export '(ff-register-callable ff-defun-callable ff-pointer-address)))--- /project/cello/cvsroot/hello-cffi/definers.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/definers.lisp 2006/05/17 04:29:42 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright © 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE.

;; $Header: /project/cello/cvsroot/hello-cffi/definers.lisp,v 1.1 2006/05/17 04:29:42 ktilton Exp $

(in-package :ffx)

(eval-when (compile load eval) (export '( defun-ffx defun-ffx-multi dffr dfc dft dfenum make-ff-pointer ff-pointer-address )))

(defun ff-pointer-address (ff-ptr) #-lispworks ff-ptr #+lispworks (fli:pointer-address ff-ptr))

;;;(defun make-ff-pointer (n) ;;; #-lispworks ;;; n ;;; #+lispworks ;;; (fli:make-pointer :address n :pointer-type '(:pointer :void)))

(defun make-ff-pointer (n) #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) #+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) (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 `(* ,type))) (push (list var type) args))))) (cast-vars (mapcar (lambda (var-type) (copy-symbol (car var-type))) var-types))) `(progn (def-function (,name$ ,lispfn) ,var-types :returning ,rtn :module ,module$)

(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))

[59 lines skipped] --- /project/cello/cvsroot/hello-cffi/ffi-extender.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/ffi-extender.lisp 2006/05/17 04:29:42 1.1

[110 lines skipped] --- /project/cello/cvsroot/hello-cffi/hello-cffi.asd 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/hello-cffi.asd 2006/05/17 04:29:42 1.1

[134 lines skipped] --- /project/cello/cvsroot/hello-cffi/hello-cffi.lpr 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/hello-cffi.lpr 2006/05/17 04:29:42 1.1

[171 lines skipped] --- /project/cello/cvsroot/hello-cffi/my-uffi-compat.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/my-uffi-compat.lisp 2006/05/17 04:29:42 1.1

[187 lines skipped]