Update of /project/rdnzl/cvsroot/RDNZL
In directory clnet:/tmp/cvs-serv27065
Modified Files:
CHANGELOG.txt arrays.lisp load.lisp port-ccl.lisp
port-sbcl.lisp rdnzl.asd
Added Files:
port-ecl.lisp
Log Message:
release 0.10.0 (ECL support)
--- /project/rdnzl/cvsroot/RDNZL/CHANGELOG.txt 2006/05/24 21:49:09 1.8
+++ /project/rdnzl/cvsroot/RDNZL/CHANGELOG.txt 2006/06/12 08:47:10 1.9
@@ -1,3 +1,7 @@
+Version 0.10.0
+2006-06-12
+ECL port (provided by Michael Goffioul)
+
Version 0.9.5
2006-05-24
Fixed delivery scripts and IMPORT statement for LW
--- /project/rdnzl/cvsroot/RDNZL/arrays.lisp 2006/02/18 22:26:12 1.5
+++ /project/rdnzl/cvsroot/RDNZL/arrays.lisp 2006/06/12 08:47:10 1.6
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/arrays.lisp,v 1.5 2006/02/18 22:26:12 eweitz Exp $
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/arrays.lisp,v 1.6 2006/06/12 08:47:10 eweitz Exp $
;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.
@@ -43,7 +43,7 @@
;; FFI array so we don't have the expensive call to INVOKE on each
;; iteration - but we don't do that now
`(let* ((,array ,array-form)
- (,length [%Length ,array]))
+ (,length (property ,array "Length")))
(dotimes (,i ,length)
(let ((,var (get-array-element ,array ,i)))
,@body))
--- /project/rdnzl/cvsroot/RDNZL/load.lisp 2006/02/18 22:26:12 1.5
+++ /project/rdnzl/cvsroot/RDNZL/load.lisp 2006/06/12 08:47:10 1.6
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/load.lisp,v 1.5 2006/02/18 22:26:12 eweitz Exp $
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/load.lisp,v 1.6 2006/06/12 08:47:10 eweitz Exp $
;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.
@@ -43,6 +43,7 @@
#+:allegro "port-acl"
#+:cormanlisp "port-ccl"
#+:clisp "port-clisp"
+ #+:ecl "port-ecl"
#+:lispworks "port-lw"
#+:sbcl "port-sbcl"
"ffi"
--- /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp 2006/05/24 21:49:09 1.6
+++ /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp 2006/06/12 08:47:10 1.7
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp,v 1.6 2006/05/24 21:49:09 eweitz Exp $
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp,v 1.7 2006/06/12 08:47:10 eweitz Exp $
;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.
--- /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp 2006/05/24 21:49:09 1.4
+++ /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp 2006/06/12 08:47:10 1.5
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp,v 1.4 2006/05/24 21:49:09 eweitz Exp $
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp,v 1.5 2006/06/12 08:47:10 eweitz Exp $
;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.
--- /project/rdnzl/cvsroot/RDNZL/rdnzl.asd 2006/05/24 21:49:09 1.7
+++ /project/rdnzl/cvsroot/RDNZL/rdnzl.asd 2006/06/12 08:47:10 1.8
@@ -1,5 +1,5 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.7 2006/05/24 21:49:09 eweitz Exp $
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.8 2006/06/12 08:47:10 eweitz Exp $
;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved.
@@ -46,6 +46,7 @@
#+:allegro (:file "port-acl") ; AllegroCL-specific stuff here
#+:cormanlisp (:file "port-ccl") ; Corman-specific stuff here
#+:clisp (:file "port-clisp") ; CLISP-specific stuff here
+ #+:ecl (:file "port-ecl") ; ECL-specific stuff here
#+:lispworks (:file "port-lw") ; LispWorks-specific stuff here
#+:sbcl (:file "port-sbcl") ; SBCL-specific stuff here
(:file "ffi")
--- /project/rdnzl/cvsroot/RDNZL/port-ecl.lisp 2006/06/12 08:47:10 NONE
+++ /project/rdnzl/cvsroot/RDNZL/port-ecl.lisp 2006/06/12 08:47:10 1.1
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ecl.lisp,v 1.1 2006/06/12 08:47:10 eweitz Exp $
;;; Copyright (c) 2004-2006, Vasilis Margioulas, Michael Goffioul, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; ECL-specific definitions
(in-package :rdnzl)
(defvar *dll-path* nil
"The name of RDNZL.dll.")
(defmacro ffi-register-module (dll-path &optional module-name)
"Store the DLL name provided by the argument DLL-PATH."
(declare (ignore module-name))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setq *dll-path* ,dll-path)))
(defun ffi-pointer-p (object)
"Tests whether OBJECT is an FFI pointer."
(eql (type-of object) 'si::foreign-data))
(defun ffi-null-pointer-p (pointer)
"Returns whether the FFI pointer POINTER is a null pointer."
(ffi:null-pointer-p pointer))
(defun ffi-pointer-address (pointer)
"Returns the address of the FFI pointer POINTER."
(ffi:pointer-address pointer))
(defun ffi-make-pointer (name)
"Returns an FFI pointer to the address specified by the name NAME."
(ffi:callback name))
(defun ffi-map-type (type-name)
"Maps type names like FFI-INTEGER to their corresponding names in
the ECL FFI."
(ecase type-name
(ffi-void :void)
(ffi-void-pointer :pointer-void)
(ffi-const-string '(* :unsigned-short))
(ffi-integer :int)
(ffi-boolean :byte)
(ffi-wide-char :unsigned-short)
(ffi-float :float)
(ffi-double :double)))
(defmacro ffi-define-function* ((lisp-name c-name)
arg-list
result-type)
"Defines a Lisp function LISP-NAME which acts as an interface
to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE)
pairs. All types are supposed to be symbols mappable by
FFI-MAP-TYPE above."
(cond ((or (member result-type '(ffi-wide-char ffi-boolean))
(find 'ffi-wide-char arg-list :key #'second :test #'eq)
(find 'ffi-boolean arg-list :key #'second :test #'eq))
;; define a wrapper if one of the args and/or the return type
;; is a __wchar_t because ECL doesn't handle this
;; type automatically
(with-unique-names (internal-name result)
`(progn
(ffi:def-function (,c-name ,internal-name)
,(mapcar (lambda (name-and-type)
(destructuring-bind (name type) name-and-type
(list name (ffi-map-type type))))
arg-list)
,@(when (ffi-map-type result-type)
`(:returning ,(ffi-map-type result-type)))
:module ,*dll-path*)
(defun ,lisp-name ,(mapcar #'first arg-list)
(let ((,result (,internal-name ,@(loop for (name type) in arg-list
if (eq type 'ffi-wide-char)
collect `(char-code ,name)
else if (eq type 'ffi-boolean)
collect `(if ,name 1 0)
else
collect name))))
,(cond ((eq result-type 'ffi-wide-char)
`(code-char ,result))
((eq result-type 'ffi-boolean)
`(if (= ,result 0) nil t))
(t result)))))))
(t
`(ffi:def-function (,c-name ,lisp-name)
,(mapcar (lambda (name-and-type)
(destructuring-bind (name type) name-and-type
(list name (ffi-map-type type))))
arg-list)
,@(when (ffi-map-type result-type)
`(:returning ,(ffi-map-type result-type)))
:module ,*dll-path*))))
(defmacro ffi-define-callable ((c-name result-type)
arg-list
&body body)
"Defines a Lisp function which can be called from C.
ARG-LIST is a list of \(NAME TYPE) pairs. All types are supposed
to be symbols mappable by FFI-MAP-TYPE above."
`(ffi:defcallback ,c-name ,(ffi-map-type result-type)
,(mapcar (lambda (name-and-type)
(destructuring-bind (name type) name-and-type
(list name (ffi-map-type type))))
arg-list)
,@body))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-unicode-string ((var lisp-string) &body body)
(with-unique-names (str-len k)
`(let* ((,str-len (length ,lisp-string)))
(ffi:with-foreign-object (,var `(:array :unsigned-short ,(1+ ,str-len)))
(loop for ,k below ,str-len
do (si::foreign-data-set-elt ,var (* 2 ,k) :unsigned-short (char-code (char ,lisp-string ,k))))
(si::foreign-data-set-elt ,var (* 2 ,str-len) :unsigned-short 0)
,@body)))))
(defun unicode-string-to-lisp (ubyte16-array)
(let ((char-list (loop for k from 0
for uc = (si::foreign-data-ref-elt ubyte16-array (* 2 k) :unsigned-short)
while (/= uc 0) collect (code-char uc))))
(coerce char-list 'string)))
(defmacro ffi-get-call-by-ref-string (function object length-function)
"Calls the foreign function FUNCTION. FUNCTION is supposed to call
a C function f with the signature void f\(..., __wchar_t *s) where s
is a result string which is returned by this macro. OBJECT is the
first argument given to f. Prior to calling f the length of the
result string s is obtained by evaluating \(LENGTH-FUNCTION OBJECT)."
(with-rebinding (object)
(with-unique-names (length temp)
`(let* ((,length (,length-function ,object)))
(ffi:with-foreign-object (,temp `(:array :unsigned-short ,(1+ ,length)))
(,function ,object ,temp)
(unicode-string-to-lisp ,temp))))))
(defmacro ffi-call-with-foreign-string* (function string &optional other-args)
"Applies the foreign function FUNCTION to the string STRING and
OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native'
Lisp objects) is converted to a foreign array prior to calling
FUNCTION. STRING may be NIL which means that this argument is skipped
\(i.e. the macro actually needs a better name)."
(with-rebinding (other-args)
(with-unique-names (length arg-pointers ffi-arg-pointers arg i
arg-pointer foreign-string)
(declare (ignorable foreign-string))
`(let* ((,length (length ,other-args))
(,arg-pointers (make-array ,length :initial-element nil)))
(unwind-protect
(let ((,ffi-arg-pointers
(loop for ,arg in ,other-args
for ,i from 0
for ,arg-pointer = (cond
((container-p ,arg) (pointer ,arg))
(t (setf (aref ,arg-pointers ,i)
(box* ,arg))))
collect ,arg-pointer)))
,(cond (string
`(with-unicode-string (,foreign-string ,string)
(apply #',function ,foreign-string ,ffi-arg-pointers)))
(t
`(apply #',function ,ffi-arg-pointers))))
;; all .NET elements that were solely created (by BOX*)
;; for this FFI call are immediately freed
(dotimes (,i ,length)
(named-when (,arg-pointer (aref ,arg-pointers ,i))
(%free-dot-net-container ,arg-pointer))))))))
(defmacro ffi-call-with-args* (function object name args)
"Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a
list of CONTAINER structures or `native' Lisp objects) is converted to
a foreign array prior to calling FUNCTION. If NAME is not NIL, then
it should be a string and the first argument to FUNCTION will be the
corresponding foreign string."
(with-rebinding (args)
(with-unique-names (length arg-pointers ffi-arg-pointers arg i
arg-pointer foreign-name)
`(let* ((,length (length ,args))
(,arg-pointers (make-array ,length :initial-element nil)))
(unwind-protect
(progn
(ffi:with-foreign-object (,ffi-arg-pointers `(:array :pointer-void ,,length))
(loop for ,arg in ,args
for ,i from 0
for ,arg-pointer = (cond
((container-p ,arg) (pointer ,arg))
(t (setf (aref ,arg-pointers ,i)
(box* ,arg))))
do (si::foreign-data-set-elt ,ffi-arg-pointers (* 4 ,i) :pointer-void ,arg-pointer))
,(cond (name
`(with-unicode-string (,foreign-name ,name)
(,function ,foreign-name
,object
,length
,ffi-arg-pointers)))
(t `(,function ,object
,length
,ffi-arg-pointers)))))
;; all .NET elements that were solely created (by BOX*)
;; for this FFI call are immediately freed
(dotimes (,i ,length)
(named-when (,arg-pointer (aref ,arg-pointers ,i))
(%free-dot-net-container ,arg-pointer))))))))
(defun flag-for-finalization (object &optional function)
"Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT
is removed by GC."
;; don't know how to do that in ECL
(declare (ignore object function)))
(defun register-exit-function (function &optional name)
"Makes sure the function FUNCTION \(with no arguments) is called
before the Lisp images exits."
;; don't know how to do that in ECL
(declare (ignore function name)))
(defun full-gc ()
"Invokes a full garbage collection."
(si::gc t))
(export 'lf-to-crlf :rdnzl)
(defun lf-to-crlf (string)
"Add #\Return before each #\Newline in STRING."
(loop with new-string = (make-array (+ (length string) (count #\Newline string))
:element-type 'character
:fill-pointer 0)
for c across string
when (char= c #\Newline)
do (vector-push-extend #\Return new-string)
do (vector-push-extend c new-string)
finally (return new-string)))
