[cello-cvs] CVS hello-cffi

ktilton ktilton at common-lisp.net
Wed May 17 04:29:42 UTC 2006


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 , 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/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 , 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/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)
         , 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/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]



More information about the Cello-cvs mailing list