Hello,
Douglas Crosher has contributed a CFFI-SYS backend for the Scieneer
Common Lisp. Attached is a diff. Also, you can grab a darcs patch here:
http://common-lisp.net/~loliveira/patches/scl.patch
Thu Feb 23 06:17:57 WET 2006 Luis Oliveira <[EMAIL PROTECTED]>
* SCL port, courtesy of Douglas Crosher
- Makefile: new test-scl target. Add SCL's fasl file extensions
to the clean target.
- Remove SCL TODO item.
- New file: cffi-scl.lisp.
- New primitive type :long-double. Since it's only supported by
SCL, it's not worth adding a no-long-double feature just yet.
- New tests for :long-double.
- Add information about SCL and the new :long-double type to
the user manual.
diff -rN -u cffi-old/Makefile cffi-new/Makefile
--- cffi-old/Makefile 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/Makefile 2006-02-23 05:20:54.000000000 +0000
@@ -32,6 +32,7 @@
SBCL=sbcl
CLISP=clisp
ALLEGRO=acl
+SCL=scl
shlibs:
@$(MAKE) -wC tests shlibs
@@ -39,7 +40,7 @@
clean:
@$(MAKE) -wC tests clean
find . -name ".fasls" | xargs rm -rf
- find . \( -name "*.dfsl" -o -name "*.fasl" -o -name "*.fas" -o -name "*.lib" -o -name "*.x86f" -o -name "*.ppcf" -o -name "*.nfasl" -o -name "*.ufsl" -o -name "*.fsl" \) -exec rm {} \;
+ find . \( -name "*.dfsl" -o -name "*.fasl" -o -name "*.fas" -o -name "*.lib" -o -name "*.x86f" -o -name "*.amd64f" -o -name "*.sparcf" -o -name "*.sparc64f" -o -name "*.hpf" -o -name "*.hp64f" -o -name "*.ppcf" -o -name "*.nfasl" -o -name "*.ufsl" -o -name "*.fsl" \) -exec rm {} \;
test-openmcl:
@-$(OPENMCL) --load tests/run-tests.lisp
@@ -50,6 +51,9 @@
test-cmucl:
@-$(CMUCL) -load tests/run-tests.lisp
+test-scl:
+ @-$(SCL) -load tests/run-tests.lisp
+
test-clisp:
@-$(CLISP) -q -x '(load "tests/run-tests.lisp")'
diff -rN -u cffi-old/TODO cffi-new/TODO
--- cffi-old/TODO 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/TODO 2006-02-23 05:10:09.000000000 +0000
@@ -21,8 +21,6 @@
-> Fix the ECL port.
-> Fix bugs in the Corman port.
-> Port to MCL.
--> Port to SCL. Note: Its maintainer has offered to do a port. It might
- be a good idea to wait until CFFI-SYS is stable, though.
### Features
@@ -77,7 +75,8 @@
-> More compiler macros on some of the CFFI-SYS implementations.
-> Optimize UFFI-COMPAT when the vector stuff is implemented.
-> Being able to declare that some C int will always fit in a Lisp
- fixnum.
+ fixnum. Allegro has a :fixnum ftype and CMUCL/SBCL can use
+ (unsigned-byte 29) others could perhaps behave like :int?
-> An option for defcfun to expand into a compiler macro which would
allow the macroexpansion-time translators to look at the forms
passed to the function.
diff -rN -u cffi-old/cffi-tests.asd cffi-new/cffi-tests.asd
--- cffi-old/cffi-tests.asd 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/cffi-tests.asd 2006-02-23 02:21:12.000000000 +0000
@@ -70,7 +70,7 @@
(:file "misc-types")))))
(defmethod perform ((o test-op) (c (eql (find-system :cffi-tests))))
- (or (funcall (intern "DO-TESTS" '#:regression-test))
+ (or (funcall (intern (symbol-name '#:do-tests) '#:regression-test))
(error "test-op failed.")))
;;; vim: ft=lisp et
diff -rN -u cffi-old/cffi.asd cffi-new/cffi.asd
--- cffi-old/cffi.asd 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/cffi.asd 2006-02-23 02:21:12.000000000 +0000
@@ -25,7 +25,7 @@
;;; DEALINGS IN THE SOFTWARE.
;;;
-#-(or openmcl sbcl cmu clisp lispworks ecl allegro cormanlisp)
+#-(or openmcl sbcl cmu scl clisp lispworks ecl allegro cormanlisp)
(error "Sorry, this Lisp is not yet supported. Patches welcome!")
(defpackage #:cffi-system
@@ -46,6 +46,7 @@
#+openmcl (:file "cffi-openmcl")
#+sbcl (:file "cffi-sbcl")
#+cmu (:file "cffi-cmucl")
+ #+scl (:file "cffi-scl")
#+clisp (:file "cffi-clisp")
#+lispworks (:file "cffi-lispworks")
#+ecl (:file "cffi-ecl")
diff -rN -u cffi-old/doc/cffi-manual.texinfo cffi-new/doc/cffi-manual.texinfo
--- cffi-old/doc/cffi-manual.texinfo 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/doc/cffi-manual.texinfo 2006-02-23 05:37:43.000000000 +0000
@@ -300,10 +300,9 @@
@cffi{} supports various free and commercial Lisp implementations:
Allegro CL, Corman CL, @sc{clisp}, @acronym{CMUCL}, @acronym{ECL},
-LispWorks, [EMAIL PROTECTED] and @acronym{SBCL}.
+LispWorks, [EMAIL PROTECTED], @acronym{SBCL} and the Scieneer CL.
-There are also plans to support Digitool @acronym{MCL}, @acronym{GCL}
-and Scieneer CL.
+There are also plans to support Digitool @acronym{MCL}, and @acronym{GCL}.
@section Allegro CL
@@ -445,6 +444,14 @@
@end itemize
[EMAIL PROTECTED] The Scieneer Common Lisp
+
[EMAIL PROTECTED] platforms:} linux/x86, linux/amd64.
+
+Version 1.2.10 or newer is recommended. Passes all tests.
+The x86 and AMD64 ports feature long-double support.
+
+
@c ===================================================================
@c CHAPTER: An Introduction to Foreign Interfaces and CFFI
@@ -1784,6 +1791,10 @@
@impnote{This is not true for Lispworks (on linux/x86 and win32 at
least). --luis}
[EMAIL PROTECTED]:long-double}
+
+This type is only supported on SCL.
+
@ForeignType{:pointer}
A foreign pointer to an object of any type, corresponding to
diff -rN -u cffi-old/src/cffi-scl.lisp cffi-new/src/cffi-scl.lisp
--- cffi-old/src/cffi-scl.lisp 1970-01-01 01:00:00.000000000 +0100
+++ cffi-new/src/cffi-scl.lisp 2006-02-23 06:15:09.000000000 +0000
@@ -0,0 +1,320 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Lisp.
+;;;
+;;; Copyright (C) 2005, James Bielman <[EMAIL PROTECTED]>
+;;; Copyright (C) 2006, Scieneer Pty Ltd.
+;;;
+;;; 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.
+;;;
+
+;;; For posterity, a few optimizations we might use in the future:
+
+#-(and)
+(defun lisp-string-to-foreign (string ptr size)
+ (c-call::deport-string-to-system-area string ptr size :iso-8859-1))
+
+#-(and)
+(defun foreign-string-to-lisp (ptr &optional (size most-positive-fixnum)
+ (null-terminated-p t))
+ (unless (null-pointer-p ptr)
+ (if null-terminated-p
+ (c-call::naturalize-c-string ptr :iso-8859-1)
+ (c-call::naturalize-c-string ptr :iso-8859-1 size))))
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+ (:use #:common-lisp #:alien #:c-call #:cffi-utils)
+ (:export
+ #:pointerp
+ #:pointer-eq
+ #:null-pointer
+ #:null-pointer-p
+ #:inc-pointer
+ #:make-pointer
+ #:pointer-address
+ #:%foreign-alloc
+ #:foreign-free
+ #:with-foreign-pointer
+ #:%foreign-funcall
+ #:%foreign-funcall-pointer
+ #:%foreign-type-alignment
+ #:%foreign-type-size
+ #:%load-foreign-library
+ #:%close-foreign-library
+ #:%mem-ref
+ #:%mem-set
+ #:make-shareable-byte-vector
+ #:with-pointer-to-vector-data
+ #:foreign-symbol-pointer
+ #:%defcallback
+ #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (mapc (lambda (feature) (pushnew feature *features*))
+ '(;; OS/CPU features.
+ #+unix cffi-features:unix
+ #+x86 cffi-features:x86
+ #+amd64 cffi-features:x86-64
+ #+(and ppc (not ppc64)) cffi-features:ppc32
+ )))
+
+;;;# Basic Pointer Operations
+
+(declaim (inline pointerp))
+(defun pointerp (ptr)
+ "Return true if 'ptr is a foreign pointer."
+ (sys:system-area-pointer-p ptr))
+
+(declaim (inline pointer-eq))
+(defun pointer-eq (ptr1 ptr2)
+ "Return true if 'ptr1 and 'ptr2 point to the same address."
+ (sys:sap= ptr1 ptr2))
+
+(declaim (inline null-pointer))
+(defun null-pointer ()
+ "Construct and return a null pointer."
+ (sys:int-sap 0))
+
+(declaim (inline null-pointer-p))
+(defun null-pointer-p (ptr)
+ "Return true if 'ptr is a null pointer."
+ (zerop (sys:sap-int ptr)))
+
+(declaim (inline inc-pointer))
+(defun inc-pointer (ptr offset)
+ "Return a pointer pointing 'offset bytes past 'ptr."
+ (sys:sap+ ptr offset))
+
+(declaim (inline make-pointer))
+(defun make-pointer (address)
+ "Return a pointer pointing to 'address."
+ (sys:int-sap address))
+
+(declaim (inline pointer-address))
+(defun pointer-address (ptr)
+ "Return the address pointed to by 'ptr."
+ (sys:sap-int ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+ "Bind 'var to 'size bytes of foreign memory during 'body. The
+ pointer in 'var is invalid beyond the dynamic extent of 'body, and
+ may be stack-allocated if supported by the implementation. If
+ 'size-var is supplied, it will be bound to 'size during 'body."
+ (unless size-var
+ (setf size-var (gensym (symbol-name '#:size))))
+ ;; If the size is constant we can stack-allocate.
+ (cond ((constantp size)
+ (let ((alien-var (gensym (symbol-name '#:alien))))
+ `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
+ (let ((,size-var ,(eval size))
+ (,var (alien-sap ,alien-var)))
+ (declare (ignorable ,size-var))
+ ,@body))))
+ (t
+ `(let* ((,size-var ,size)
+ (,var (alien::make-local-bytes ,size-var)))
+ (alien:with-bytes (,var ,size-var)
+ ,@body)))))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack and on the
+;;; heap. The main CFFI package defines macros that wrap 'foreign-alloc and
+;;; 'foreign-free in 'unwind-protect for the common usage when the memory has
+;;; dynamic extent.
+
+(defun %foreign-alloc (size)
+ "Allocate 'size bytes on the heap and return a pointer."
+ (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size))
+ (alien-funcall (extern-alien "malloc"
+ (function system-area-pointer unsigned))
+ size))
+
+(defun foreign-free (ptr)
+ "Free a 'ptr allocated by 'foreign-alloc."
+ (declare (type system-area-pointer ptr))
+ (alien-funcall (extern-alien "free"
+ (function (values) system-area-pointer))
+ ptr))
+
+;;;# Shareable Vectors
+
+(defun make-shareable-byte-vector (size)
+ "Create a Lisp vector of 'size bytes that can passed to
+ 'with-pointer-to-vector-data."
+ (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+ "Bind 'ptr-var to a foreign pointer to the data in 'vector."
+ (let ((vector-var (gensym (symbol-name '#:vector))))
+ `(let ((,vector-var ,vector))
+ (ext:with-pinned-object (,vector-var)
+ (let ((,ptr-var (sys:vector-sap ,vector-var)))
+ ,@body)))))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+ `(progn
+ (defun %mem-ref (ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword accessor) in pairs
+ collect `(,keyword (,accessor ptr offset)))))
+ (defun %mem-set (value ptr type &optional (offset 0))
+ (ecase type
+ ,@(loop for (keyword accessor) in pairs
+ collect `(,keyword (setf (,accessor ptr offset) value)))))
+ (define-compiler-macro %mem-ref
+ (&whole form ptr type &optional (offset 0))
+ (if (constantp type)
+ (ecase (eval type)
+ ,@(loop for (keyword accessor) in pairs
+ collect `(,keyword `(,',accessor ,ptr ,offset))))
+ form))
+ (define-compiler-macro %mem-set
+ (&whole form value ptr type &optional (offset 0))
+ (if (constantp type)
+ (ecase (eval type)
+ ,@(loop for (keyword accessor) in pairs
+ collect `(,keyword `(setf (,',accessor ,ptr ,offset)
+ ,value))))
+ form))))
+
+(define-mem-accessors
+ (:char sys:signed-sap-ref-8)
+ (:unsigned-char sys:sap-ref-8)
+ (:short sys:signed-sap-ref-16)
+ (:unsigned-short sys:sap-ref-16)
+ (:int sys:signed-sap-ref-32)
+ (:unsigned-int sys:sap-ref-32)
+ (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64)
+ (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64)
+ (:long-long sys:signed-sap-ref-64)
+ (:unsigned-long-long sys:sap-ref-64)
+ (:float sys:sap-ref-single)
+ (:double sys:sap-ref-double)
+ #+long-float (:long-double sys:sap-ref-long)
+ (:pointer sys:sap-ref-sap))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+ "Convert a CFFI type keyword to an ALIEN type."
+ (ecase type-keyword
+ (:char 'char)
+ (:unsigned-char 'unsigned-char)
+ (:short 'short)
+ (:unsigned-short 'unsigned-short)
+ (:int 'int)
+ (:unsigned-int 'unsigned-int)
+ (:long 'long)
+ (:unsigned-long 'unsigned-long)
+ (:long-long '(signed 64))
+ (:unsigned-long-long '(unsigned 64))
+ (:float 'single-float)
+ (:double 'double-float)
+ #+long-float
+ (:long-double 'long-float)
+ (:pointer 'system-area-pointer)
+ (:void 'void)))
+
+(defun %foreign-type-size (type-keyword)
+ "Return the size in bytes of a foreign type."
+ (values (truncate (alien-internals:alien-type-bits
+ (alien-internals:parse-alien-type
+ (convert-foreign-type type-keyword)))
+ 8)))
+
+(defun %foreign-type-alignment (type-keyword)
+ "Return the alignment in bytes of a foreign type."
+ (values (truncate (alien-internals:alien-type-alignment
+ (alien-internals:parse-alien-type
+ (convert-foreign-type type-keyword)))
+ 8)))
+
+(defun foreign-funcall-type-and-args (args)
+ "Return an 'alien function type for 'args."
+ (let ((return-type nil))
+ (loop for (type arg) on args by #'cddr
+ if arg collect (convert-foreign-type type) into types
+ and collect arg into fargs
+ else do (setf return-type (convert-foreign-type type))
+ finally (return (values types fargs return-type)))))
+
+(defmacro %%foreign-funcall (name types fargs rettype)
+ "Internal guts of '%foreign-funcall."
+ `(alien-funcall (extern-alien ,name (function ,rettype ,@types))
+ ,@fargs))
+
+(defmacro %foreign-funcall (name &rest args)
+ "Perform a foreign function call, document it more later."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
+
+(defmacro %foreign-funcall-pointer (ptr &rest args)
+ "Funcall a pointer to a foreign function."
+ (multiple-value-bind (types fargs rettype)
+ (foreign-funcall-type-and-args args)
+ (with-unique-names (function)
+ `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
+ (alien-funcall ,function ,@fargs)))))
+
+;;; Callbacks
+
+(defmacro %defcallback (name rettype arg-names arg-types &body body)
+ `(alien:defcallback ,name
+ (,(convert-foreign-type rettype)
+ ,@(mapcar (lambda (sym type)
+ (list sym (convert-foreign-type type)))
+ arg-names arg-types))
+ ,@body))
+
+(declaim (inline %callback))
+(defun %callback (name)
+ (alien:callback-sap name))
+
+;;;# Loading and Closing Foreign Libraries
+
+(defun %load-foreign-library (name)
+ "Load the foreign library 'name."
+ (ext:load-dynamic-object name))
+
+(defun %close-foreign-library (name)
+ "Closes the foreign library 'name."
+ (ext:close-dynamic-object name))
+
+;;;# Foreign Globals
+
+(defun foreign-symbol-pointer (name kind)
+ "Returns a pointer to a foreign symbol 'name. The 'kind is one of :code or
+ :data, and is ignored on some platforms."
+ (declare (ignore kind))
+ (prog1 (ignore-errors (sys:foreign-symbol-address name))))
diff -rN -u cffi-old/src/features.lisp cffi-new/src/features.lisp
--- cffi-old/src/features.lisp 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/src/features.lisp 2006-02-23 05:34:06.000000000 +0000
@@ -39,6 +39,9 @@
#:no-long-long
#:no-foreign-funcall
+ ;; Only SCL support long-double...
+ ;;#:no-long-double
+
;; Features related to the operating system.
;; Currently only these are pushed to *features*, more should be added.
#:darwin
@@ -49,4 +52,5 @@
;; Currently only these are pushed to *features*, more should be added.
#:ppc32
#:x86
- #:x86-64))
+ #:x86-64
+ ))
diff -rN -u cffi-old/src/functions.lisp cffi-new/src/functions.lisp
--- cffi-old/src/functions.lisp 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/src/functions.lisp 2006-02-23 05:49:44.000000000 +0000
@@ -215,6 +215,7 @@
return-type `(block ,name ,@body)))
',name))))
+(declaim (inline get-callback))
(defun get-callback (symbol)
(%callback symbol))
diff -rN -u cffi-old/src/libraries.lisp cffi-new/src/libraries.lisp
--- cffi-old/src/libraries.lisp 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/src/libraries.lisp 2006-02-23 02:21:13.000000000 +0000
@@ -113,7 +113,7 @@
(defmacro define-foreign-library (name &body pairs)
"Defines a foreign library NAME that can be posteriorly used with
the USE-FOREIGN-LIBRARY macro."
- `(eval-when (#+cmu :compile-toplevel :load-toplevel :execute)
+ `(eval-when (#+(or cmu scl) :compile-toplevel :load-toplevel :execute)
(setf (get-foreign-library ',name) ',pairs)
',name))
@@ -243,7 +243,7 @@
(:or (try-foreign-library-alternatives (rest library)))))))
(defmacro use-foreign-library (name)
- `(eval-when (:load-toplevel :execute #+cmu :compile-toplevel)
+ `(eval-when (:load-toplevel :execute #+(or cmu scl) :compile-toplevel)
(load-foreign-library ',name)))
;;;# Closing Foreign Libraries
diff -rN -u cffi-old/src/types.lisp cffi-new/src/types.lisp
--- cffi-old/src/types.lisp 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/src/types.lisp 2006-02-23 05:42:04.000000000 +0000
@@ -848,6 +848,10 @@
(define-built-in-foreign-type :long-long)
(define-built-in-foreign-type :unsigned-long-long))
+;;; When some lisp other than SCL supports :long-double we should
+;;; use #-cffi-features:no-long-double here instead.
+#+(and scl long-float) (define-built-in-foreign-type :long-double)
+
;;; A couple of handy typedefs.
(defctype :uchar :unsigned-char :translate-p nil)
diff -rN -u cffi-old/tests/callbacks.lisp cffi-new/tests/callbacks.lisp
--- cffi-old/tests/callbacks.lisp 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/tests/callbacks.lisp 2006-02-23 05:30:38.000000000 +0000
@@ -45,6 +45,8 @@
(defcfun "expect_long_long_sum" :int (f :pointer))
(defcfun "expect_unsigned_long_long_sum" :int (f :pointer)))
+#+(and scl long-float)
+(defcfun "expect_long_double_sum" :int (f :pointer))
(defcallback sum-char :char ((a :char) (b :char))
"Test if the named block is present and the docstring too."
@@ -97,6 +99,11 @@
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
+#+(and scl long-float)
+(defcallback sum-long-double :long-double ((a :long-double) (b :long-double))
+ ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+ (+ a b))
+
(defcallback sum-pointer :pointer ((ptr :pointer) (offset :int))
(inc-pointer ptr offset))
@@ -155,6 +162,11 @@
(expect-double-sum (callback sum-double))
1)
+#+(and scl long-float)
+(deftest callbacks.long-double
+ (expect-long-double-sum (callback sum-long-double))
+ 1)
+
(deftest callbacks.pointer
(expect-pointer-sum (callback sum-pointer))
1)
diff -rN -u cffi-old/tests/defcfun.lisp cffi-new/tests/defcfun.lisp
--- cffi-old/tests/defcfun.lisp 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/tests/defcfun.lisp 2006-02-23 02:21:13.000000000 +0000
@@ -82,6 +82,16 @@
6.0d0)
+#+(and scl long-float)
+(defcfun ("sqrtl" c-sqrtl) :long-double
+ (n :long-double))
+
+#+(and scl long-float)
+(deftest defcfun.long-double
+ (c-sqrtl 36.0l0)
+ 6.0l0)
+
+
(defcfun "strlen" :int
(n :string))
@@ -166,6 +176,13 @@
(sprintf s "%.2f" :double (float pi 1.0d0)))
"3.14")
+#+(and scl long-float)
+(deftest defcfun.varargs.long-double
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (sprintf s "%.2Lf" :long-double pi))
+ "3.14")
+
(deftest defcfun.varargs.string
(with-foreign-pointer-as-string (s 100)
(sprintf s "%s, %s!" :string "Hello" :string "world"))
diff -rN -u cffi-old/tests/funcall.lisp cffi-new/tests/funcall.lisp
--- cffi-old/tests/funcall.lisp 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/tests/funcall.lisp 2006-02-23 02:21:13.000000000 +0000
@@ -71,6 +71,11 @@
(foreign-funcall "sqrt" :double 36.0d0 :double)
6.0d0)
+#+(and scl long-float)
+(deftest funcall.long-double
+ (foreign-funcall "sqrtl" :long-double 36.0l0 :long-double)
+ 6.0l0)
+
(deftest funcall.string.1
(foreign-funcall "strlen" :string "Hello" :int)
5)
@@ -120,6 +125,14 @@
:double (coerce pi 'double-float) :int))
"3.14")
+#+(and scl long-float)
+(deftest funcall.varargs.long-double
+ (with-foreign-pointer-as-string (s 100)
+ (setf (mem-ref s :char) 0)
+ (foreign-funcall "sprintf" :pointer s :string "%.2Lf"
+ :long-double pi :int))
+ "3.14")
+
(deftest funcall.varargs.string
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
diff -rN -u cffi-old/tests/libtest.c cffi-new/tests/libtest.c
--- cffi-old/tests/libtest.c 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/tests/libtest.c 2006-02-23 02:21:13.000000000 +0000
@@ -167,6 +167,13 @@
}
DLLEXPORT
+int expect_long_double_sum(long double (*f)(long double, long double))
+{
+ /*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
+ return f(-20.0, -22.0) == -42.0;
+}
+
+DLLEXPORT
int expect_pointer_sum(void* (*f)(void*, int))
{
return f(NULL, 0xDEAD) == (void *) 0xDEAD;
diff -rN -u cffi-old/tests/memory.lisp cffi-new/tests/memory.lisp
--- cffi-old/tests/memory.lisp 2006-02-23 06:44:18.000000000 +0000
+++ cffi-new/tests/memory.lisp 2006-02-23 04:30:14.000000000 +0000
@@ -125,6 +125,29 @@
(mem-ref p :double))
#.*double-min*)
+;;; TODO: use something like *DOUBLE-MIN/MAX* above once we actually
+;;; have an available lisp that supports long double.
+;#-cffi-features:no-long-float
+#+(and scl long-double)
+(progn
+ (deftest deref.long-double.1
+ (with-foreign-object (p :long-double)
+ (setf (mem-ref p :long-double) 0.0l0)
+ (mem-ref p :long-double))
+ 0.0l0)
+
+ (deftest deref.long-double.2
+ (with-foreign-object (p :long-double)
+ (setf (mem-ref p :long-double) most-positive-long-float)
+ (mem-ref p :long-double))
+ #.most-positive-long-float)
+
+ (deftest deref.long-double.3
+ (with-foreign-object (p :long-double)
+ (setf (mem-ref p :long-double) least-positive-long-float)
+ (mem-ref p :long-double))
+ #.least-positive-long-float))
+
;;; make sure the lisp doesn't convert NULL to NIL
(deftest deref.pointer.null
(with-foreign-object (p :pointer)
As I mention in the log message, I couldn't find any other Lisp that
supports long double, so adding the respective feature to cffi-features
doesn't seem worth the trouble. AFAICT, Lispworks is the only one that
mentions long double in the documentation but it doesn't seem to be
implemented in win32, linux or darwin...
--
Luís Oliveira
luismbo (@) gmail (.) com
Equipa Portuguesa do Translation Project
http://www.iro.umontreal.ca/translation/registry.cgi?team=pt
_______________________________________________
cffi-devel mailing list
cffi-devel@common-lisp.net
http://common-lisp.net/cgi-bin/mailman/listinfo/cffi-devel
