[cello-cvs] CVS cello/hello-cffi
ktilton
ktilton at common-lisp.net
Wed May 17 18:52:21 UTC 2006
Update of /project/cello/cvsroot/cello/hello-cffi
In directory clnet:/tmp/cvs-serv10478/hello-cffi
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/cello/hello-cffi/arrays.lisp 2006/05/17 18:52:21 NONE
+++ /project/cello/cvsroot/cello/hello-cffi/arrays.lisp 2006/05/17 18:52:21 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 , at 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 , at 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 , at 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 , at values)
(setf ,place (make-floatv , at 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))
, at 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/cello/hello-cffi/callbacks.lisp 2006/05/17 18:52:21 NONE
+++ /project/cello/cvsroot/cello/hello-cffi/callbacks.lisp 2006/05/17 18:52:21 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 , at 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)
(, at native-args)
, at body)
#+allegro
`(ff:defun-foreign-callable ,name ,native-args
(declare (:convention ,(ecase call-convention
(:cdecl :c)
(:stdcall :stdcall))))
, at 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/cello/hello-cffi/definers.lisp 2006/05/17 18:52:21 NONE
+++ /project/cello/cvsroot/cello/hello-cffi/definers.lisp 2006/05/17 18:52:21 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/cello/hello-cffi/definers.lisp,v 1.1 2006/05/17 18:52:20 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)
, at 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 , at cast-vars)
, at 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/cello/hello-cffi/ffi-extender.lisp 2006/05/17 18:52:21 NONE
+++ /project/cello/cvsroot/cello/hello-cffi/ffi-extender.lisp 2006/05/17 18:52:21 1.1
[110 lines skipped]
--- /project/cello/cvsroot/cello/hello-cffi/hello-cffi.asd 2006/05/17 18:52:21 NONE
+++ /project/cello/cvsroot/cello/hello-cffi/hello-cffi.asd 2006/05/17 18:52:21 1.1
[134 lines skipped]
--- /project/cello/cvsroot/cello/hello-cffi/hello-cffi.lpr 2006/05/17 18:52:21 NONE
+++ /project/cello/cvsroot/cello/hello-cffi/hello-cffi.lpr 2006/05/17 18:52:21 1.1
[171 lines skipped]
--- /project/cello/cvsroot/cello/hello-cffi/my-uffi-compat.lisp 2006/05/17 18:52:21 NONE
+++ /project/cello/cvsroot/cello/hello-cffi/my-uffi-compat.lisp 2006/05/17 18:52:21 1.1
[187 lines skipped]
More information about the Cello-cvs
mailing list