[cello-cvs] CVS hello-c
ktilton
ktilton at common-lisp.net
Mon May 15 16:36:13 UTC 2006
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 , at 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 , 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
@@ -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))
, at 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 , at 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 @@
, at 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)
+ , 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)
@@ -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 at nyc.rr.com>"
:version "1.0.0"
:maintainer "Kenny Tilton <ktilton at 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))
More information about the Cello-cvs
mailing list