mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-14 13:21:54 -08:00
106 lines
3.3 KiB
Common Lisp
106 lines
3.3 KiB
Common Lisp
;-*- Mode: Lisp -*-
|
|
;;;; Author: Juan Jose Garcia-Ripoll
|
|
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
|
|
;;;; Contains: Foreign Function Interface regression tests
|
|
|
|
(in-package :cl-test)
|
|
|
|
;;; Date: 23/03/2006
|
|
;;; From: Klaus Falb
|
|
;;; Fixed: 26/02/2006 (juanjo)
|
|
;;; Description:
|
|
;;;
|
|
;;; Callback functions have to be declared static so that there
|
|
;;; are no conflicts among callbacks in different files.
|
|
;;;
|
|
;;; Fixed: 13/04/2006 (juanjo)
|
|
;;; Description:
|
|
;;;
|
|
;;; Header <internal.h> should be included as <ecl/internal.h>
|
|
;;;
|
|
|
|
(deftest ffi-001-callback
|
|
(and
|
|
(zerop (si::system "rm -rf tmp; mkdir tmp"))
|
|
(with-open-file (s "tmp/a.lsp" :direction :output
|
|
:if-exists :supersede
|
|
:if-does-not-exist :create)
|
|
(print '(ffi:defcallback foo :void () nil) s))
|
|
(with-open-file (s "tmp/b.lsp" :direction :output
|
|
:if-exists :supersede
|
|
:if-does-not-exist :create)
|
|
(print '(ffi:defcallback foo :void () nil) s))
|
|
(compile-file "tmp/a.lsp" :system-p t)
|
|
(compile-file "tmp/b.lsp" :system-p t)
|
|
(c:build-program "tmp/foo" :lisp-files
|
|
(list (compile-file-pathname "tmp/a.lsp" :type :object)
|
|
(compile-file-pathname "tmp/b.lsp" :type :object)))
|
|
(probe-file (compile-file-pathname "tmp/foo" :type :program))
|
|
(zerop (si::system "rm -rf tmp"))
|
|
t)
|
|
t)
|
|
|
|
;;; Date: 29/07/2008
|
|
;;; From: Juajo
|
|
;;; Description:
|
|
;;; Callback examples based on the C compiler
|
|
;;;
|
|
(deftest ffi-002-callback
|
|
(and
|
|
(zerop (si::system "rm -rf tmp; mkdir tmp"))
|
|
(with-open-file (s "tmp/c.lsp" :direction :output
|
|
:if-exists :supersede
|
|
:if-does-not-exist :create)
|
|
(print
|
|
'(defun callback-user (callback arg)
|
|
(ffi:c-inline (callback arg) (:pointer-void :int) :int "
|
|
int (*foo)(int) = #0;
|
|
@(return) = foo(#1);
|
|
"
|
|
:one-liner nil :side-effects nil))
|
|
s)
|
|
(print
|
|
'(ffi:defcallback ffi-002-foo :int ((a :int))
|
|
(1+ a))
|
|
s))
|
|
(compile-file "tmp/c.lsp" :load t)
|
|
(eql (callback-user (ffi:callback 'ffi-002-foo) 2) 3)
|
|
t)
|
|
t)
|
|
|
|
;;; Date: 29/07/2008
|
|
;;; From: Juajo
|
|
;;; Description:
|
|
;;; Callback examples based on the DFFI. Only work if this feature
|
|
;;; has been linked in.
|
|
;;;
|
|
#+(or)
|
|
(deftest ffi-002b-callback
|
|
(and
|
|
(zerop (si::system "rm -rf tmp; mkdir tmp"))
|
|
(with-open-file (s "tmp/c.lsp" :direction :output
|
|
:if-exists :supersede
|
|
:if-does-not-exist :create)
|
|
(print
|
|
'(defun callback-user (callback arg)
|
|
(ffi:c-inline (callback arg) (:pointer-void :int) :int "
|
|
int (*foo)(int) = #0;
|
|
@(return) = foo(#1);
|
|
"
|
|
:one-liner nil :side-effects nil))
|
|
s))
|
|
(compile-file "tmp/c.lsp" :load t)
|
|
(eval '(ffi:defcallback foo-002b :int ((a :int))
|
|
(1+ a)))
|
|
(eql (callback-user (ffi:callback 'foo-002b) 2) 3)
|
|
t)
|
|
t)
|
|
|
|
;;; Date: 25/04/2010 (Juanjo)
|
|
;;; Description:
|
|
;;; Regression test to ensure that two foreign data compare
|
|
;;; EQUAL when their addresses are the same.
|
|
(deftest ffi-003-foreign-data-equal
|
|
(equal (ffi:make-pointer 1234 :void)
|
|
(ffi:make-pointer 1234 :int))
|
|
t)
|