;;; ffi-glue.lisp
;;;
;;; ffi glue to have callbacks in clisp and cmucl
;;;
;;; Copyright (C) 2004 Philippe Brochard (hocwp@free.fr)
;;;
;;; #date#: Tue Feb  1 20:01:53 2005
;;;
;;; The authors grant you the rights to distribute
;;; and use this software as governed by the terms
;;; of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html),
;;; known as the LLGPL.
;;;
;;; Note for Clisp only user :
;;;   this package enable callbacks in both clisp and
;;; cmucl. So if you want to use only clisp, you can safely
;;; replace def-callback with defun, callback with function
;;; and funcall-callback with funcall and ignore
;;; convert-array-to-pointer.


(in-package :common-lisp-user)

(defpackage :ffi-glue
  (:use :common-lisp)
  (:export :def-callback
	   :callback
	   :convert-array-to-pointer
	   :funcall-callback))

(in-package :ffi-glue)


;;; DEF-CALLBACK
#+CLISP
(defmacro def-callback (name (type &rest args) &body body)
  (declare (ignore type))
  `(defun ,name ,(mapcar #'(lambda (x) `,(car x)) args)
     ,@body))

#+CMU
(defmacro def-callback (name (type &rest args) &body body)
  `(alien:def-callback ,name (,(intern (string type) :c-call)
			      ,@(mapcar #'(lambda (x)
					    `(,(car x) ,(intern (string (second x)) :c-call)))
					args))
		       ,@body))


#+SBCL
(defmacro def-callback (name (type &rest args) &body body)
  `(callback:defcallback ,name (,(intern (string type) :sb-alien)
				,@(mapcar #'(lambda (x)
					      `(,(car x) ,(intern (string (second x)) :sb-alien)))
					  args))
			 ,@body))


#-(or CLISP CMU SBCL)
(defmacro def-callback (name (type &rest args) &body body)
  (error "DEF-CALLBACK: Sorry, callbacks are not yet implemented in this plateform: ~A~%" name))



;;; CALLBACK
#+CLISP
(defmacro callback (fun)
  `(function ,fun))

#+CMU
(defmacro callback (fun)
  `(alien:callback ,fun))


#+SBCL
(defmacro callback (fun)
  `(callback:callback ,fun))


#-(or CLISP CMU SBCL)
(defmacro callback (fun)
  `(function ,fun))



;;; CONVERT-ARRAY-TO-POINTER
#+CLISP
(defun convert-array-to-pointer (type array)
  (declare (ignore type))
  array)

#+(or CMU SBCL)
(defun convert-array-to-pointer (type array)
  (ecase type
    (single-float
     (let ((ret (uffi:allocate-foreign-object 'single-float (length array))))
       (dotimes (i (length array))
	 (setf (uffi:deref-array ret 'single-float i) (svref array i)))
       ret))
    (unsigned-byte
     (let ((ret (uffi:allocate-foreign-object :unsigned-byte (length array))))
       (dotimes (i (length array))
	 (setf (uffi:deref-array ret :unsigned-byte i) (aref array i)))
       ret))))

#-(or CLISP CMU SBCL)
(defun convert-array-to-pointer (type array)
  (declare (ignore type))
  array)





;;; FUNCALL-CALLBACK
#+CLISP
(defmacro funcall-callback (callback type &rest args)
  (declare (ignore type))
  `(funcall (function ,callback) ,@args))

#+CMU
(defmacro funcall-callback (callback type &rest args)
  `(alien:alien-funcall (alien:sap-alien (alien:callback ,callback)
					 (,@(mapcar #'(lambda (x)
							`(,@(intern (string x) :c-call)))
						    type)))
			,@args))


#+SBCL
(defmacro funcall-callback (callback type &rest args)
  `(sb-alien:alien-funcall (sb-alien:sap-alien (callback:callback ,callback)
					       (,@(mapcar #'(lambda (x)
							      `(,@(intern (string x) :sb-alien)))
							  type)))
			   ,@args))


#-(or CLISP CMU SBCL)
(defmacro funcall-callback (callback type &rest args)
  (declare (ignore type))
  `(funcall (function ,callback) ,@args))