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)))
-
eweitz