[rdnzl-cvs] CVS RDNZL
eweitz
eweitz at common-lisp.net
Wed Feb 1 01:00:57 UTC 2006
Update of /project/rdnzl/cvsroot/RDNZL
In directory common-lisp:/tmp/cvs-serv4420
Modified Files:
CHANGELOG.txt RDNZL.dll README.txt adapter.lisp arrays.lisp
container.lisp direct.lisp ffi.lisp import.lisp load.lisp
packages.lisp port-acl.lisp port-ccl.lisp port-clisp.lisp
port-lw.lisp rdnzl.asd reader.lisp specials.lisp util.lisp
Added Files:
port-sbcl.lisp
Log Message:
0.9.0 release
--- /project/rdnzl/cvsroot/RDNZL/CHANGELOG.txt 2006/01/13 07:06:28 1.4
+++ /project/rdnzl/cvsroot/RDNZL/CHANGELOG.txt 2006/02/01 01:00:56 1.5
@@ -1,3 +1,7 @@
+Version 0.9.0
+2006-02-01
+Experimental support for SBCL/Win32
+
Version 0.8.0
2006-01-13
Fix mechanism which releases delegate adapters (thanks to Dominic Robinson)
Binary files /project/rdnzl/cvsroot/RDNZL/RDNZL.dll 2005/11/21 14:03:40 1.2 and /project/rdnzl/cvsroot/RDNZL/RDNZL.dll 2006/02/01 01:00:56 1.3 differ
--- /project/rdnzl/cvsroot/RDNZL/README.txt 2005/01/03 00:55:40 1.1.1.1
+++ /project/rdnzl/cvsroot/RDNZL/README.txt 2006/02/01 01:00:56 1.2
@@ -1,29 +1,29 @@
-Installation
-------------
-
-First, put the file 'RDNZL.dll' somewhere where the foreign language
-interface of your Lisp can find it. A safe bet is to put it in the
-folder where your Lisp image starts up.
-
-Probably the easiest way to install RDNZL is to LOAD the file
-'load.lisp' which comes with the distribution. Evaluate a form like
-
- (load "c:/path/to/rdnzl/load.lisp")
-
-or use the facilities of your IDE to LOAD this file.
-
-This should compile and load RDNZL on most Common Lisp
-implementations.
-
-As an alternative you can use ASDF, RDNZL comes with an ASDF system
-definition file 'rdnzl.asd'.
-
-
-Documentation
--------------
-
-Complete documentation for RDNZL can be found in the 'doc' folder.
-
-RDNZL also supports Nikodemus Siivola's HYPERDOC, see
-<http://common-lisp.net/project/hyperdoc/> and
-<http://www.cliki.net/hyperdoc>.
\ No newline at end of file
+Installation
+------------
+
+First, put the file 'RDNZL.dll' somewhere where the foreign language
+interface of your Lisp can find it. A safe bet is to put it in the
+folder where your Lisp image starts up.
+
+Probably the easiest way to install RDNZL is to LOAD the file
+'load.lisp' which comes with the distribution. Evaluate a form like
+
+ (load "c:/path/to/rdnzl/load.lisp")
+
+or use the facilities of your IDE to LOAD this file.
+
+This should compile and load RDNZL on most Common Lisp
+implementations.
+
+As an alternative you can use ASDF, RDNZL comes with an ASDF system
+definition file 'rdnzl.asd'.
+
+
+Documentation
+-------------
+
+Complete documentation for RDNZL can be found in the 'doc' folder.
+
+RDNZL also supports Nikodemus Siivola's HYPERDOC, see
+<http://common-lisp.net/project/hyperdoc/> and
+<http://www.cliki.net/hyperdoc>.
--- /project/rdnzl/cvsroot/RDNZL/adapter.lisp 2005/07/08 18:45:33 1.2
+++ /project/rdnzl/cvsroot/RDNZL/adapter.lisp 2006/02/01 01:00:56 1.3
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/adapter.lisp,v 1.2 2005/07/08 18:45:33 eweitz Exp $
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/adapter.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
-;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved.
+;;; Copyright (c) 2004-2006, 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
--- /project/rdnzl/cvsroot/RDNZL/arrays.lisp 2005/07/08 18:45:33 1.2
+++ /project/rdnzl/cvsroot/RDNZL/arrays.lisp 2006/02/01 01:00:56 1.3
@@ -1,119 +1,119 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/arrays.lisp,v 1.2 2005/07/08 18:45:33 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; Utility functions for arrays and enumerations
-
-(in-package :rdnzl)
-
-(enable-rdnzl-syntax)
-
-(defmacro do-rdnzl-array ((var array-form &optional result) &body body)
- "ARRAY-FORM should be a form which evaluates to a CONTAINER
-structure wrapping a .NET array of rank 1. BODY will be evaluated
-with VAR bound to each element of this array \(as a CONTAINER) in
-turn. Finally, the result of evaluating the form RESULT is returned."
- (with-unique-names (array length i)
- ;; this can later be optimized by iterating directly through an
- ;; 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]))
- (dotimes (,i ,length)
- (let ((,var (get-array-element ,array ,i)))
- , at body))
- ,result)))
-
-(defun aref* (array &rest subscripts)
- "Returns the element of the .NET array ARRAY \(a CONTAINER) with the
-subscripts SUBSCRIPTS. Similar to AREF."
- (let* ((element-type [%AssemblyQualifiedName [GetElementType [GetType array]]])
- (value (apply #`GetValue array subscripts)))
- (unbox (cast* value element-type))))
-
-(defun (setf aref*) (new-value array &rest subscripts)
- "Sets the element of the .NET array ARRAY \(a CONTAINER) with the
-subscripts SUBSCRIPTS to the new value NEW-VALUE. Similar to \(SETF
-AREF)."
- (apply #`SetValue array new-value subscripts)
- new-value)
-
-(defun make-array-type (base-type dimensions)
- "Synthesizes a .NET array type with base type BASE-TYPE \(a
-CONTAINER) and DIMENSIONS dimensions."
- (let* ((base-type-name (get-object-as-string base-type))
- (array-type-name (format nil "~A[~V,,,',A]~A" base-type-name (1- dimensions) ""
- (subseq [%AssemblyQualifiedName base-type]
- (length base-type-name)))))
- (make-type-from-name array-type-name)))
-
-(defun list-to-rdnzl-array (list &optional (base-type (make-type-from-name "System.Object")))
- "Creates and returns a .NET array of base type BASE-TYPE \(a
-CONTAINER or a string) and rank 1 with the elements from the Lisp list
-LIST."
- (when (stringp base-type)
- (setq base-type (make-type-from-name (resolve-type-name base-type))))
- (let* ((length (length list))
- ;; this is equivalent to calling NEW (see import.lisp)
- (new-array (invoke-constructor (make-array-type base-type 1)
- length)))
- (loop for element in list
- for i from 0
- do (setf (aref* new-array i)
- (ensure-container element)))
- new-array))
-
-(defun rdnzl-array-to-list (array)
- "Converts a .NET array ARRAY of rank 1 to a Lisp list with the same
-elements."
- (let (list)
- (do-rdnzl-array (element array)
- (push element list))
- (nreverse list)))
-
-(defun enum-to-integer (enum)
- "Converts the .NET object ENUM of type System.Enum to a Lisp
-integer. This is a destructive operation on ENUM."
- (unbox (cast* enum "System.Int32")))
-
-(defun integer-to-enum (number type)
- "Converts the Lisp integer NUMBER to a .NET System.Enum object of
-type TYPE \(a string or a CONTAINER)."
- (when (stringp type)
- (setq type (make-type-from-name (resolve-type-name type))))
- (cast [System.Enum.ToObject type number]
- type))
-
-(defun or-enums (&rest enums)
- "Combines several .NET objects of type System.Enum with a logical or
-and returns the result. All arguments must be of the same .NET type."
- (let ((type-name [%AssemblyQualifiedName [GetType (first enums)]]))
- (integer-to-enum
- (apply #'logior (mapcar #'enum-to-integer enums)) type-name)))
-
-(disable-rdnzl-syntax)
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/arrays.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; Utility functions for arrays and enumerations
+
+(in-package :rdnzl)
+
+(enable-rdnzl-syntax)
+
+(defmacro do-rdnzl-array ((var array-form &optional result) &body body)
+ "ARRAY-FORM should be a form which evaluates to a CONTAINER
+structure wrapping a .NET array of rank 1. BODY will be evaluated
+with VAR bound to each element of this array \(as a CONTAINER) in
+turn. Finally, the result of evaluating the form RESULT is returned."
+ (with-unique-names (array length i)
+ ;; this can later be optimized by iterating directly through an
+ ;; 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]))
+ (dotimes (,i ,length)
+ (let ((,var (get-array-element ,array ,i)))
+ , at body))
+ ,result)))
+
+(defun aref* (array &rest subscripts)
+ "Returns the element of the .NET array ARRAY \(a CONTAINER) with the
+subscripts SUBSCRIPTS. Similar to AREF."
+ (let* ((element-type [%AssemblyQualifiedName [GetElementType [GetType array]]])
+ (value (apply #`GetValue array subscripts)))
+ (unbox (cast* value element-type))))
+
+(defun (setf aref*) (new-value array &rest subscripts)
+ "Sets the element of the .NET array ARRAY \(a CONTAINER) with the
+subscripts SUBSCRIPTS to the new value NEW-VALUE. Similar to \(SETF
+AREF)."
+ (apply #`SetValue array new-value subscripts)
+ new-value)
+
+(defun make-array-type (base-type dimensions)
+ "Synthesizes a .NET array type with base type BASE-TYPE \(a
+CONTAINER) and DIMENSIONS dimensions."
+ (let* ((base-type-name (get-object-as-string base-type))
+ (array-type-name (format nil "~A[~V,,,',A]~A" base-type-name (1- dimensions) ""
+ (subseq [%AssemblyQualifiedName base-type]
+ (length base-type-name)))))
+ (make-type-from-name array-type-name)))
+
+(defun list-to-rdnzl-array (list &optional (base-type (make-type-from-name "System.Object")))
+ "Creates and returns a .NET array of base type BASE-TYPE \(a
+CONTAINER or a string) and rank 1 with the elements from the Lisp list
+LIST."
+ (when (stringp base-type)
+ (setq base-type (make-type-from-name (resolve-type-name base-type))))
+ (let* ((length (length list))
+ ;; this is equivalent to calling NEW (see import.lisp)
+ (new-array (invoke-constructor (make-array-type base-type 1)
+ length)))
+ (loop for element in list
+ for i from 0
+ do (setf (aref* new-array i)
+ (ensure-container element)))
+ new-array))
+
+(defun rdnzl-array-to-list (array)
+ "Converts a .NET array ARRAY of rank 1 to a Lisp list with the same
+elements."
+ (let (list)
+ (do-rdnzl-array (element array)
+ (push element list))
+ (nreverse list)))
+
+(defun enum-to-integer (enum)
+ "Converts the .NET object ENUM of type System.Enum to a Lisp
+integer. This is a destructive operation on ENUM."
+ (unbox (cast* enum "System.Int32")))
+
+(defun integer-to-enum (number type)
+ "Converts the Lisp integer NUMBER to a .NET System.Enum object of
+type TYPE \(a string or a CONTAINER)."
+ (when (stringp type)
+ (setq type (make-type-from-name (resolve-type-name type))))
+ (cast [System.Enum.ToObject type number]
+ type))
+
+(defun or-enums (&rest enums)
+ "Combines several .NET objects of type System.Enum with a logical or
+and returns the result. All arguments must be of the same .NET type."
+ (let ((type-name [%AssemblyQualifiedName [GetType (first enums)]]))
+ (integer-to-enum
+ (apply #'logior (mapcar #'enum-to-integer enums)) type-name)))
+
+(disable-rdnzl-syntax)
--- /project/rdnzl/cvsroot/RDNZL/container.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/container.lisp 2006/02/01 01:00:56 1.3
@@ -1,450 +1,456 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/container.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; Definition of CONTAINER structure and various functions to deal
-;;; with .NET objects.
-
-(in-package :rdnzl)
-
-(defstruct (container
- (:conc-name nil)
- ;; Corman Lisp doesn't know :PRINT-OBJECT
- (:print-function print-container))
- "Simple structure to wrap a pointer to a DotNetContainer object."
- (pointer nil :read-only t)
- (refp nil))
-
-(defun print-container (container stream depth)
- "Prints an unreadable representation of a CONTAINER structure to the
-stream STREAM."
- (declare (ignore depth))
- (print-unreadable-object (container stream :type t :identity nil)
- (let ((pointer (pointer container)))
- (unless (ffi-pointer-p pointer)
- (error "~S is not an FFI pointer" pointer))
- (format stream "~A #x~X"
- (if (%dot-net-container-is-null pointer)
- "NULL"
- ;; show name of type
- (get-type-name container))
- ;; show pointer address
- (ffi-pointer-address pointer))))
- container)
-
-(define-condition rdnzl-error (simple-error)
- ((exception :initarg :exception
- :reader rdnzl-error-exception))
- (:report (lambda (condition stream)
- (format stream "~?"
- (simple-condition-format-control condition)
- (simple-condition-format-arguments condition))))
- (:documentation "An error of this type is signaled whenever an
-exception occured during a call into .NET. The EXCEPTION slot of this
-error object holds a reference \(a CONTAINER) to the corresponding
-.NET error object."))
-
-(setf (documentation 'rdnzl-error-exception 'function)
- "Returns the .NET error object \(as a CONTAINER) which was
-responsible for this error.")
-
-(defun ref (object)
- "Makes a pass-by-reference type out of OBJECT and returns OBJECT.
-If OBJECT is not a CONTAINER it'll be boxed first \(see BOX). This
-function makes only sense if OBJECT is used as an argument to INVOKE!"
- (cond ((container-p object)
- (%ref-dot-net-container-type (pointer object))
- (setf (refp object) t)
- object)
- (t
- (ref (box object)))))
-
-(defun unref (container)
- "Resets CONTAINER to have the underlying type again. Assumes that
-REF was applied to CONTAINER before. Returns CONTAINER."
- (%unref-dot-net-container-type (pointer container))
- (setf (refp container) nil)
- container)
-
-(defmacro rdnzl-handler-case (form &rest clauses)
- "Like HANDLER-CASE but only for conditions of type RDNZL-ERROR. The
-typespecs are either strings \(naming a .NET error type) or of the
-form \(OR string-1 ... string-n). A :NO-ERROR clause is also
-allowed."
- (with-unique-names (e exception)
- `(handler-case ,form
- (rdnzl-error (,e)
- (let ((,exception (rdnzl-error-exception ,e)))
- (cond
- ,@(loop for (typespec var-list . forms) in clauses
- for exception-var = (or (first var-list) (gensym))
- for typespec-list = (cond ((eq typespec :no-error) nil)
- ((stringp typespec)
- (list typespec))
- ((and (consp typespec)
- (eq (first typespec) 'or))
- (rest typespec))
- (t (error "Illegal typespec ~S in RDNZL-HANDLER-CASE"
- typespec)))
- collect `((or ,@(mapcar (lambda (typespec)
- `(invoke (make-type-from-name (resolve-type-name ,typespec))
- "IsAssignableFrom"
- (invoke ,exception "GetType")))
- typespec-list))
- (let ((,exception-var ,exception))
- (declare (ignorable ,exception-var))
- , at forms)))
- (t (error ,e)))))
- ,@(let ((no-error-clause (find :no-error clauses
- :key #'first
- :test #'eq)))
- (and no-error-clause (list no-error-clause))))))
-
-(defun maybe-free-container-pointer (object)
- "This function is to be invoked whenever a CONTAINER structure is
-finalized by the garbage collector."
- (when (container-p object)
- (%free-dot-net-container (pointer object))))
-
-(defmacro wrap-with-container (form)
- "Evaluates FORM and wraps the result with a CONTAINER structure.
-Also makes sure the corresponding DotNetContainer object is garbage
-collected. NIL is returned if FORM returns a NULL pointer."
- (with-unique-names (block-name container pointer)
- `(block ,block-name
- (let (,container ,pointer)
- (unwind-protect
- (progn
- (setq ,pointer ,form)
- (when (ffi-null-pointer-p ,pointer)
- (warn "Returning NIL for NULL FFI pointer.")
- (return-from ,block-name nil))
- (setq ,container
- (make-container :pointer ,pointer))
- ,container)
- (when ,container
- (flag-for-finalization ,container #'maybe-free-container-pointer)))))))
-
-(defun make-type-from-name (name)
- "Returns the .NET type with the name NAME - uses the static function
-Type::GetType."
- (wrap-with-container
- (ffi-call-with-foreign-string* %make-type-from-name
- name)))
-
-(defun get-object-as-string (container)
- "Get a string representation of the object denoted by CONTAINER.
-Uses 'ToString' internally."
- (ffi-get-call-by-ref-string %get-dot-net-container-object-as-string
- (pointer container)
- %get-dot-net-container-object-string-length))
-
-(defun get-type-name (container)
- "Get the name of the type of the object denoted by CONTAINER. Uses
-'FullName' internally."
- (ffi-get-call-by-ref-string %get-dot-net-container-type-as-string
- (pointer container)
- %get-dot-net-container-type-string-length))
-
-(defun box* (object)
- "Like BOX but returns the raw pointer."
- (typecase object
- ((signed-byte 32)
- (%make-dot-net-container-from-int object))
- ((signed-byte 64)
- ;; this is due to a limitation of LispWorks: we have to pass the
- ;; argument as a string
- (ffi-call-with-foreign-string* %make-dot-net-container-from-long
- (with-standard-io-syntax ()
- (princ-to-string object))))
- (string
- (ffi-call-with-foreign-string* %make-dot-net-container-from-string object))
- (character
- (%make-dot-net-container-from-char object))
- (double-float
- (%make-dot-net-container-from-double object))
- (float
- (%make-dot-net-container-from-float object))
- (pathname
- (box* (namestring object)))
- (boolean
- (%make-dot-net-container-from-boolean object))
- (otherwise
- (error "Don't know how to convert object ~S of type ~A to a .NET object."
- object (type-of object)))))
-
-(defun box (object)
- "If object is a `native' Lisp object which we know how to convert
-return a corresponding DotNetContainer object. Otherwise raise an
-error."
- (wrap-with-container (box* object)))
-
-(defun ensure-container (object)
- "If OBJECT isn't already a CONTAINER then box it."
- (cond
- ((container-p object) object)
- (t (box object))))
-
-(defun unbox (container)
- "If CONTAINER is of a known .NET type which we know how to convert
-return the corresponding `native' Lisp object. Otherwise just return
-the container."
- (let ((type-name (get-type-name container)))
- (cond ((string= type-name "System.String")
- (get-object-as-string container))
- ((string= type-name "System.Char")
- (%get-dot-net-container-char-value (pointer container)))
- ((string= type-name "System.Int32")
- (%get-dot-net-container-int-value (pointer container)))
- ((string= type-name "System.Int64")
- (with-standard-io-syntax
- (read-from-string (get-object-as-string container))))
- ((string= type-name "System.Boolean")
- (%get-dot-net-container-boolean-value (pointer container)))
- ((string= type-name "System.Double")
- (%get-dot-net-container-double-value (pointer container)))
- ((string= type-name "System.Single")
- (%get-dot-net-container-single-value (pointer container)))
- (t container))))
-
-(defmacro get-invocation-result (form)
- "Evaluates FORM which is supposed to return a pointer to an
-InvocationResult object. Tries to convert the result into a known
-Lisp type, otherwise returns a CONTAINER structure."
- (with-unique-names (block-name invocation-result container)
- `(block ,block-name
- (let (,invocation-result ,container)
- (unwind-protect
- (progn
- (setq ,invocation-result ,form)
- (when (%invocation-result-is-void ,invocation-result)
- ;; return keyword :VOID if the result was void
- (return-from ,block-name :void))
- ;; first create a CONTAINER so we can be sure the
- ;; corresponding .NET object will be garbage-collected
- (setq ,container
- (wrap-with-container
- (%get-dot-net-container-from-invocation-result ,invocation-result)))
- (when (%invocation-result-is-exception ,invocation-result)
- (error 'rdnzl-error
- :exception ,container
- :format-control ".NET error (~A): ~A"
- :format-arguments (list (get-type-name ,container)
- (property ,container "Message")))))
- (when ,invocation-result
- ;; now free the InvocationResult object which wrapped the
- ;; result we were interested in
- (%free-invocation-result ,invocation-result)))
- (when (%dot-net-container-is-null (pointer ,container))
- (warn "Returning NULL object from .NET call")
- (return-from ,block-name (values nil t)))
- ;; try to convert some known types to native Lisp types
- (unbox ,container)))))
-
-(defmacro ffi-call-with-foreign-string (function name &rest other-args)
- "Like FFI-CALL-WITH-FOREIGN-STRING* but handles the returned
-InvocationResult object and accepts an arbitrary number of arguments
-greater than one."
- `(get-invocation-result
- (ffi-call-with-foreign-string* ,function
- ,name
- (list , at other-args))))
-
-(defmacro ffi-call-with-args (function object name args)
- "Like FFI-CALL-WITH-ARGS* but OBJECT is assumed to be a CONTAINER
-structure while each element of ARGS can be a native Lisp object or
-such a structure. The result of calling FUNCTION is assumed to be a
-pointer to an InvocationResult which is handled by
-GET-INVOCATION-RESULT."
- (with-rebinding (object)
- (with-unique-names (pointer)
- `(let ((,pointer (pointer ,object)))
- (when (%dot-net-container-is-null ,pointer)
- (error "Trying to call function ~S with NULL object ~S."
- ',function ,object))
- (get-invocation-result
- (ffi-call-with-args* ,function
- ,pointer
- ,name
- ,args))))))
-
-;; generic functions and TYPECASE are avoided below to make delivered
-;; images smaller
-
-(defun invoke (object method-name &rest args)
- "Invokes the method named METHOD-NAME \(a string). If OBJECT is a
-CONTAINER then the method is supposed to be an instance method of this
-object. If OBJECT is a string then the method is supposed to be a
-static method of the type named OBJECT. ARGS (either CONTAINER
-structures or Lisp objects which can be converted) are the arguments
-to this method."
- (let ((result
- (cond ((container-p object)
- (ffi-call-with-args %invoke-instance-member
- object
- method-name
- args))
- ((stringp object)
- (ffi-call-with-args %invoke-static-member
- (make-type-from-name (resolve-type-name object))
- method-name
- args))
- (t (error "Don't know how to invoke ~A on ~S." method-name object)))))
- ;; if some of the arguments were pass-by-reference reset them to
- ;; their underlying types
- (dolist (arg args)
- (when (and (container-p arg)
- (refp arg))
- (unref arg)))
- result))
-
-(defun property (object property-name &rest args)
- "Returns the property named PROPERTY-NAME \(a string). If OBJECT is
-a CONTAINER then the property is supposed to be an instance property
-of this object. If OBJECT is a string then the property is supposed
-to be a static property of the type named OBJECT. ARGS (either
-CONTAINER structures or Lisp objects which can be converted) are the
-indexes to this property."
- (cond ((container-p object)
- (ffi-call-with-args %get-instance-property-value
- object
- property-name
- args))
- ((stringp object)
- (ffi-call-with-args %get-static-property-value
- (make-type-from-name (resolve-type-name object))
- property-name
- args))
- (t (error "Don't know how to get property ~A of ~S." property-name object))))
-
-(defun (setf property) (new-value object property-name &rest args)
- "Sets the property named PROPERTY-NAME \(a string) to the new value
-NEW-VALUE. If OBJECT is a CONTAINER then the property is supposed to
-be an instance property of this object. If OBJECT is a string then
-the property is supposed to be a static property of the type named
-OBJECT. ARGS (either CONTAINER structures or Lisp objects which can
-be converted) are the indexes to this property."
- (cond ((container-p object)
- (ffi-call-with-args %set-instance-property-value
- object
- property-name
- (cons new-value args)))
- ((stringp object)
- (ffi-call-with-args %set-static-property-value
- (make-type-from-name (resolve-type-name object))
- property-name
- (cons new-value args)))
- (t (error "Don't know how to set property ~A of ~S." property-name object)))
- new-value)
-
-(defun field (object field-name)
- "Returns the field named FIELD-NAME \(a string). If OBJECT is a
-CONTAINER then the field is supposed to be an instance field of this
-object. If OBJECT is a string then the field is supposed to be a
-static field of the type named OBJECT."
- (cond ((container-p object)
- (ffi-call-with-foreign-string %get-instance-field-value
- field-name
- object))
- ((stringp object)
- (ffi-call-with-foreign-string %get-static-field-value
- field-name
- (make-type-from-name (resolve-type-name object))))
- (t (error "Don't know how to get field ~A of ~S." field-name object))))
-
-(defun (setf field) (new-value object field-name)
- "Sets the field named FIELD-NAME \(a string) to the new value
-NEW-VALUE. If OBJECT is a CONTAINER then the field is supposed to be
-an instance field of this object. If OBJECT is a string then the
-field is supposed to be a static field of the type named OBJECT."
- (cond ((container-p object)
- (ffi-call-with-foreign-string %set-instance-field-value
- field-name
- object
- new-value))
- ((stringp object)
- (ffi-call-with-foreign-string %set-static-field-value
- field-name
- (make-type-from-name (resolve-type-name object))
- new-value))
- (t (error "Don't know how to set field ~A of ~S." field-name object)))
- new-value)
-
[509 lines skipped]
--- /project/rdnzl/cvsroot/RDNZL/direct.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/direct.lisp 2006/02/01 01:00:56 1.3
@@ -1,297 +1,297 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/direct.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; Interface for "direct calls" into .NET
-
-(in-package :rdnzl)
-
-(enable-rdnzl-syntax)
-
-(defun find-interface-method (interfaces method-name arg-types binding-attr)
- "A Lisp version of findInterfaceMethod - see InvokeMember.cpp."
- (do-rdnzl-array (interface interfaces)
- (named-when (method-info [GetMethod interface method-name binding-attr
- (make-null-object "System.Reflection.Binder")
- arg-types
- (make-null-object "System.Reflection.ParameterModifier[]")])
- (return-from find-interface-method method-info))
- (named-when (method-info
- (find-interface-method [GetInterfaces interface] method-name arg-types binding-attr))
- (return-from find-interface-method method-info))))
-
-(defun find-method* (type method-name arg-types binding-attr)
- "A Lisp version of findMethod - see InvokeMember.cpp."
- (or [GetMethod type method-name binding-attr
- (make-null-object "System.Reflection.Binder")
- arg-types
- (make-null-object "System.Reflection.ParameterModifier[]")]
- (and [%IsInterface type]
- (or (find-interface-method [GetInterfaces type] method-name arg-types binding-attr)
- (find-method* (make-type-from-name "System.Object") method-name arg-types binding-attr)))))
-
-(defun find-instance-method (method-name arg-type-names)
- "Finds and returns a MethodInfo object \(or NIL) corresponding to
-the instance method with the name METHOD-NAME \(a string) and the
-signature ARG-TYPE-NAMES \(a list of strings naming types). Note that
-the first element of ARG-TYPE-NAMES represents the type to which the
-method belongs."
- (let ((arg-types (mapcar (lambda (arg-type-name)
- (make-type-from-name
- (resolve-type-name arg-type-name)))
- arg-type-names)))
- (find-method* (first arg-types)
- method-name
- (list-to-rdnzl-array (rest arg-types)
- "System.Type")
- (or-enums [$System.Reflection.BindingFlags.Instance]
- [$System.Reflection.BindingFlags.Public]))))
-
-(defun find-static-method (method-name type-name arg-type-names)
- "Finds and returns a MethodInfo object \(or NIL) corresponding to
-the static method of the type named TYPE-NAME \(a string) with the
-name METHOD-NAME \(a string) and the signature ARG-TYPE-NAMES \(a list
-of strings naming types)."
- (let ((arg-types (mapcar (lambda (arg-type-name)
- (make-type-from-name
- (resolve-type-name arg-type-name)))
- arg-type-names)))
- (find-method* (make-type-from-name (resolve-type-name type-name))
- method-name
- (list-to-rdnzl-array arg-types
- "System.Type")
- (or-enums [$System.Reflection.BindingFlags.Static]
- [$System.Reflection.BindingFlags.Public]))))
-
-(defun find-property (type property-name arg-types binding-attr)
- "Finds a PropertyInfo object. See corresponding code in
-Property.cpp."
- [GetProperty type property-name binding-attr
- (make-null-object "System.Reflection.Binder")
- (make-null-object "System.Type")
- arg-types
- (make-null-object "System.Reflection.ParameterModifier[]")])
-
-(defun find-instance-property (property-name arg-type-names)
- "Finds and returns a PropertyInfo object \(or NIL) corresponding to
-the instance property with the name PROPERTY-NAME \(a string) and the
-signature ARG-TYPE-NAMES \(a list of strings naming types). Note that
-the first element of ARG-TYPE-NAMES represents the type to which the
-property belongs."
- (let ((arg-types (mapcar (lambda (arg-type-name)
- (make-type-from-name
- (resolve-type-name arg-type-name)))
- arg-type-names)))
- (find-property (first arg-types)
- property-name
- (list-to-rdnzl-array (rest arg-types)
- "System.Type")
- (or-enums [$System.Reflection.BindingFlags.Instance]
- [$System.Reflection.BindingFlags.Public]))))
-
-(defun find-static-property (property-name type-name arg-type-names)
- "Finds and returns a PropertyInfo object \(or NIL) corresponding to
-the static property of the type named TYPE-NAME \(a string) with the
-name PROPERTY-NAME \(a string) and the signature ARG-TYPE-NAMES \(a
-list of strings naming types)."
- (let ((arg-types (mapcar (lambda (arg-type-name)
- (make-type-from-name
- (resolve-type-name arg-type-name)))
- arg-type-names)))
- (find-property type-name
- property-name
- (list-to-rdnzl-array arg-types
- "System.Type")
- (or-enums [$System.Reflection.BindingFlags.Static]
- [$System.Reflection.BindingFlags.Public]))))
-
-(defun find-field (type field-name binding-attr)
- "Finds a FieldInfo object. See corresponding code in Field.cpp."
- [GetField type field-name binding-attr])
-
-(defun find-instance-field (field-name type-name)
- "Finds and returns a FieldInfo object \(or NIL) corresponding to the
-instance field with the name FIELD-NAME \(a string). TYPE-NAME \(a
-string) names the type to which the field belongs."
- (find-field (make-type-from-name (resolve-type-name type-name))
- field-name
- (or-enums [$System.Reflection.BindingFlags.Instance]
- [$System.Reflection.BindingFlags.Public])))
-
-(defun find-static-field (field-name type-name)
- "Finds and returns a FieldInfo object \(or NIL) corresponding to the
-static field with the name FIELD-NAME \(a string). TYPE-NAME \(a
-string) names the type to which the field belongs."
- (find-field (make-type-from-name (resolve-type-name type-name))
- field-name
- (or-enums [$System.Reflection.BindingFlags.Static]
- [$System.Reflection.BindingFlags.Public])))
-
-(defmacro define-rdnzl-call (lisp-name
- (&key (dotnet-name (unmangle-name lisp-name))
- type-name
- (member-kind :method)
- doc-string)
- args)
- "Defines a Lisp function named by the function name LISP-NAME which
-can directly \(without the need to search via Reflection) invoke a
-.NET method, or get/set the value of a .NET property or field.
-DOTNET-NAME is the name of the .NET member, TYPE-NAME is the name of a
-.NET type and should only be supplied if a static member is to be
-interfaced. MEMBER-KIND if one of :METHOD, :PROPERTY, or :FIELD.
-DOC-STRING is the documentation string of the resulting Lisp
-function."
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (create-direct-call
- ',lisp-name
- (setf (gethash ',lisp-name *direct-definitions*)
- (list ,member-kind ,dotnet-name ,type-name
- (list ,@(loop for (nil arg-type-name) in args
- collect arg-type-name)))))
- (setf (documentation ',lisp-name 'function)
- ,(or doc-string
- (format nil "~:[Instance~;Static~] ~A ~A of .NET type ~A
-with Lisp lambda list (~{~A~^ ~})"
- type-name
- (ecase member-kind
- ((:method) "method")
- ((:property) "property")
- ((:field) "field"))
- dotnet-name
- (or type-name (second (first args)))
- (loop for (arg-name nil) in args
- collect arg-name))))
- ',lisp-name))
-
-(defun create-direct-call (lisp-name other-args)
- "Called by DEFINE-RDNZL-CALL \(and also by REDEFINE-DIRECT-CALLS) to
-actually create the function definition for LISP-NAME based on the
-necessary data \(which is simply a transformation of the arguments to
-DEFINE-RDNZL-CALL) in OTHER-ARGS."
- (destructuring-bind (member-kind dotnet-name type-name arg-type-names)
- other-args
- (ecase member-kind
- ((:method)
- (cond (type-name
- (let ((method-info (find-static-method dotnet-name type-name arg-type-names)))
- (unless method-info
- (error "Static method ~A(~{~A~^, ~}) for .NET type ~A not found"
- dotnet-name arg-type-names type-name))
- (setf (fdefinition lisp-name)
- (lambda (&rest args)
- (ffi-call-with-args %invoke-static-member-directly
- method-info
- nil
- args)))))
- (t
- (let ((method-info (find-instance-method dotnet-name arg-type-names)))
- (unless method-info
- (error "Instance method ~A(~{~A~^, ~}) for .NET type ~A not found"
- dotnet-name (rest arg-type-names) (first arg-type-names)))
- (setf (fdefinition lisp-name)
- (lambda (&rest args)
- (ffi-call-with-args %invoke-instance-member-directly
- method-info
- nil
- args)))))))
- ((:property)
- (cond (type-name
- (let ((property-info (find-static-property dotnet-name type-name arg-type-names)))
- (unless property-info
- (error "Static property ~A(~{~A~^, ~}) for .NET type ~A not found"
- dotnet-name arg-type-names type-name))
- (setf (fdefinition lisp-name)
- (if (consp lisp-name)
- (lambda (new-value &rest other-args)
- (ffi-call-with-args %set-static-property-value-directly
- property-info
- nil
- (cons new-value other-args))
- new-value)
- (lambda (&rest args)
- (ffi-call-with-args %get-static-property-value-directly
- property-info
- nil
- args))))))
- (t
- (let ((property-info (find-instance-property dotnet-name arg-type-names)))
- (unless property-info
- (error "Instance property ~A(~{~A~^, ~}) for .NET type ~A not found"
- dotnet-name (rest arg-type-names) (first arg-type-names)))
- (setf (fdefinition lisp-name)
- (if (consp lisp-name)
- (lambda (new-value &rest other-args)
- (ffi-call-with-args %set-instance-property-value-directly
- property-info
- nil
- (cons new-value other-args))
- new-value)
- (lambda (&rest args)
- (ffi-call-with-args %get-instance-property-value-directly
- property-info
- nil
- args))))))))
- ((:field)
- (cond (type-name
- (let ((field-info (find-static-field dotnet-name type-name)))
- (unless field-info
- (error "Static field ~A for .NET type ~A not found"
- dotnet-name type-name))
- (setf (fdefinition lisp-name)
- (if (consp lisp-name)
- (lambda (new-value)
- (ffi-call-with-foreign-string %set-static-field-value-directly
- nil
- field-info
- new-value)
- new-value)
- (lambda ()
- (ffi-call-with-foreign-string %get-static-field-value-directly
- nil
- field-info))))))
- (t
- (let ((field-info (find-instance-field dotnet-name (first arg-type-names))))
- (unless field-info
- (error "Instance field ~A for .NET type ~A not found"
- dotnet-name (first arg-type-names)))
- (setf (fdefinition lisp-name)
- (if (consp lisp-name)
- (lambda (new-value object)
- (ffi-call-with-foreign-string %set-instance-field-value-directly
- nil
- field-info
- object
- new-value)
- new-value)
- (lambda (object)
- (ffi-call-with-foreign-string %get-instance-field-value-directly
- nil
- field-info
- object)))))))))))
-
-(disable-rdnzl-syntax)
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/direct.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; Interface for "direct calls" into .NET
+
+(in-package :rdnzl)
+
+(enable-rdnzl-syntax)
+
+(defun find-interface-method (interfaces method-name arg-types binding-attr)
+ "A Lisp version of findInterfaceMethod - see InvokeMember.cpp."
+ (do-rdnzl-array (interface interfaces)
+ (named-when (method-info [GetMethod interface method-name binding-attr
+ (make-null-object "System.Reflection.Binder")
+ arg-types
+ (make-null-object "System.Reflection.ParameterModifier[]")])
+ (return-from find-interface-method method-info))
+ (named-when (method-info
+ (find-interface-method [GetInterfaces interface] method-name arg-types binding-attr))
+ (return-from find-interface-method method-info))))
+
+(defun find-method* (type method-name arg-types binding-attr)
+ "A Lisp version of findMethod - see InvokeMember.cpp."
+ (or [GetMethod type method-name binding-attr
+ (make-null-object "System.Reflection.Binder")
+ arg-types
+ (make-null-object "System.Reflection.ParameterModifier[]")]
+ (and [%IsInterface type]
+ (or (find-interface-method [GetInterfaces type] method-name arg-types binding-attr)
+ (find-method* (make-type-from-name "System.Object") method-name arg-types binding-attr)))))
+
+(defun find-instance-method (method-name arg-type-names)
+ "Finds and returns a MethodInfo object \(or NIL) corresponding to
+the instance method with the name METHOD-NAME \(a string) and the
+signature ARG-TYPE-NAMES \(a list of strings naming types). Note that
+the first element of ARG-TYPE-NAMES represents the type to which the
+method belongs."
+ (let ((arg-types (mapcar (lambda (arg-type-name)
+ (make-type-from-name
+ (resolve-type-name arg-type-name)))
+ arg-type-names)))
+ (find-method* (first arg-types)
+ method-name
+ (list-to-rdnzl-array (rest arg-types)
+ "System.Type")
+ (or-enums [$System.Reflection.BindingFlags.Instance]
+ [$System.Reflection.BindingFlags.Public]))))
+
+(defun find-static-method (method-name type-name arg-type-names)
+ "Finds and returns a MethodInfo object \(or NIL) corresponding to
+the static method of the type named TYPE-NAME \(a string) with the
+name METHOD-NAME \(a string) and the signature ARG-TYPE-NAMES \(a list
+of strings naming types)."
+ (let ((arg-types (mapcar (lambda (arg-type-name)
+ (make-type-from-name
+ (resolve-type-name arg-type-name)))
+ arg-type-names)))
+ (find-method* (make-type-from-name (resolve-type-name type-name))
+ method-name
+ (list-to-rdnzl-array arg-types
+ "System.Type")
+ (or-enums [$System.Reflection.BindingFlags.Static]
+ [$System.Reflection.BindingFlags.Public]))))
+
+(defun find-property (type property-name arg-types binding-attr)
+ "Finds a PropertyInfo object. See corresponding code in
+Property.cpp."
+ [GetProperty type property-name binding-attr
+ (make-null-object "System.Reflection.Binder")
+ (make-null-object "System.Type")
+ arg-types
+ (make-null-object "System.Reflection.ParameterModifier[]")])
+
+(defun find-instance-property (property-name arg-type-names)
[197 lines skipped]
--- /project/rdnzl/cvsroot/RDNZL/ffi.lisp 2006/01/13 07:06:28 1.3
+++ /project/rdnzl/cvsroot/RDNZL/ffi.lisp 2006/02/01 01:00:56 1.4
@@ -1,337 +1,336 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/ffi.lisp,v 1.3 2006/01/13 07:06:28 eweitz Exp $
-
-;;; Copyright (c) 2004-2006, 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.
-
-;;; FFI definitions for all functions exported by RDNZL.dll. See the
-;;; C++ source code for details.
-
-(in-package :rdnzl)
-
-;; load the C++ library which interfaces with the CLR
-(ffi-register-module "RDNZL.dll" :rdnzl)
-
-(defmacro ffi-define-function (c-name arg-list result-type)
- "Like FFI-DEFINE-FUNCTION* but automatically creates the Lisp name
-from the C name. A name like \"invokeMethod\" is mapped to
-\"%INVOKE-METHOD\"."
- `(ffi-define-function* (,(intern
- (concatenate 'string "%" (mangle-name c-name))
- :rdnzl)
- ,c-name)
- ,arg-list
- ,result-type))
-
-(ffi-define-function "DllEnsureInit"
- ()
- ffi-void)
-
-(ffi-define-function "DllForceTerm"
- ()
- ffi-void)
-
-(defun dll-ensure-init ()
- "Wrapper for DllEnsureInit which makes sure the function is called
-only once."
- (unless *dll-initialized*
- (%dll-ensure-init)
- (setq *dll-initialized* t)))
-
-(defun dll-force-term ()
- "Wrapper for DllForceTerm which makes sure the function is only
-called after DllEnsureInit has been called."
- (when *dll-initialized*
- (%dll-force-term)
- (setq *dll-initialized* nil)))
-
-(ffi-define-function "invokeInstanceMember"
- ((method-name ffi-const-string)
- (target ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "invokeInstanceMemberDirectly"
- ((method-info ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "invokeStaticMember"
- ((method-name ffi-const-string)
- (type ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "invokeStaticMemberDirectly"
- ((method-info ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getInstanceFieldValue"
- ((field-name ffi-const-string)
- (target ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getStaticFieldValue"
- ((field-name ffi-const-string)
- (type ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setInstanceFieldValue"
- ((field-name ffi-const-string)
- (target ffi-void-pointer)
- (new-value ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setStaticFieldValue"
- ((field-name ffi-const-string)
- (type ffi-void-pointer)
- (new-value ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getInstanceFieldValueDirectly"
- ((field-info ffi-void-pointer)
- (target ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getStaticFieldValueDirectly"
- ((field-info ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setInstanceFieldValueDirectly"
- ((field-info ffi-void-pointer)
- (target ffi-void-pointer)
- (new-value ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setStaticFieldValueDirectly"
- ((field-info ffi-void-pointer)
- (new-value ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getInstancePropertyValue"
- ((property-name ffi-const-string)
- (target ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setInstancePropertyValue"
- ((property-name ffi-const-string)
- (target ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getStaticPropertyValue"
- ((property-name ffi-const-string)
- (type ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setStaticPropertyValue"
- ((property-name ffi-const-string)
- (type ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getInstancePropertyValueDirectly"
- ((property-info ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setInstancePropertyValueDirectly"
- ((property-info ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getStaticPropertyValueDirectly"
- ((property-info ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setStaticPropertyValueDirectly"
- ((property-info ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "refDotNetContainerType"
- ((ptr ffi-void-pointer))
- ffi-void)
-
-(ffi-define-function "unrefDotNetContainerType"
- ((ptr ffi-void-pointer))
- ffi-void)
-
-(ffi-define-function "freeDotNetContainer"
- ((ptr ffi-void-pointer))
- ffi-void)
-
-(ffi-define-function "DotNetContainerIsNull"
- ((ptr ffi-void-pointer))
- ffi-boolean)
-
-(ffi-define-function "makeTypedNullDotNetContainer"
- ((ptr ffi-const-string))
- ffi-void-pointer)
-
-(ffi-define-function "InvocationResultIsVoid"
- ((ptr ffi-void-pointer))
- ffi-boolean)
-
-(ffi-define-function "freeInvocationResult"
- ((ptr ffi-void-pointer))
- ffi-void)
-
-(ffi-define-function "getDotNetContainerFromInvocationResult"
- ((ptr ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getDotNetContainerTypeStringLength"
- ((ptr ffi-void-pointer))
- ffi-integer)
-
-(ffi-define-function "getDotNetContainerTypeAsString"
- ((ptr ffi-void-pointer)
- (s ffi-void-pointer))
- ffi-void)
-
-(ffi-define-function "setDotNetContainerTypeFromString"
- ((type ffi-const-string)
- (ptr ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "getDotNetContainerObjectStringLength"
- ((ptr ffi-void-pointer))
- ffi-integer)
-
-(ffi-define-function "getDotNetContainerObjectAsString"
- ((ptr ffi-void-pointer)
- (s ffi-void-pointer))
- ffi-void)
-
-(ffi-define-function "getDotNetContainerIntValue"
- ((ptr ffi-void-pointer))
- ffi-integer)
-
-(ffi-define-function "getDotNetContainerCharValue"
- ((ptr ffi-void-pointer))
- ffi-wide-char)
-
-(ffi-define-function "getDotNetContainerBooleanValue"
- ((ptr ffi-void-pointer))
- ffi-boolean)
-
-(ffi-define-function "getDotNetContainerDoubleValue"
- ((ptr ffi-void-pointer))
- ffi-double)
-
-(ffi-define-function "getDotNetContainerSingleValue"
- ((ptr ffi-void-pointer))
- ffi-float)
-
-(ffi-define-function "makeTypeFromName"
- ((type ffi-const-string))
- ffi-void-pointer)
-
-(ffi-define-function "makeDotNetContainerFromChar"
- ((c ffi-wide-char))
- ffi-void-pointer)
-
-(ffi-define-function "makeDotNetContainerFromString"
- ((s ffi-const-string))
- ffi-void-pointer)
-
-(ffi-define-function "makeDotNetContainerFromBoolean"
- ((b ffi-boolean))
- ffi-void-pointer)
-
-(ffi-define-function "makeDotNetContainerFromInt"
- ((n ffi-integer))
- ffi-void-pointer)
-
-(ffi-define-function "makeDotNetContainerFromLong"
- ((s ffi-const-string))
- ffi-void-pointer)
-
-(ffi-define-function "makeDotNetContainerFromFloat"
- ((n ffi-float))
- ffi-void-pointer)
-
-(ffi-define-function "makeDotNetContainerFromDouble"
- ((n ffi-double))
- ffi-void-pointer)
-
-(ffi-define-function "getArrayElement"
- ((ptr ffi-void-pointer)
- (index ffi-integer))
- ffi-void-pointer)
-
-(ffi-define-function "InvocationResultIsException"
- ((ptr ffi-void-pointer))
- ffi-boolean)
-
-(ffi-define-function "invokeConstructor"
- ((type ffi-void-pointer)
- (nargs ffi-integer)
- (args ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-function "setFunctionPointers"
- ((fp1 ffi-void-pointer)
- (fp2 ffi-void-pointer))
- ffi-void)
-
-(ffi-define-function "buildDelegateType"
- ((type-name ffi-const-string)
- (return-type ffi-void-pointer)
- (arg-types ffi-void-pointer))
- ffi-void-pointer)
-
-(ffi-define-callable
- (LispCallback ffi-void-pointer)
- ((index ffi-integer)
- (args ffi-void-pointer))
- (declare (ignore types))
- ;; here the actual callback, the Lisp closure, is called - see
- ;; adapter.lisp
- (funcall (gethash index *callback-hash*) args))
-
-(ffi-define-callable
- (ReleaseDelegateAdapter ffi-void)
- ((index ffi-integer))
- ;; remove entry from hash table if CLR is done with it
- (remhash index *callback-hash*))
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/ffi.lisp,v 1.4 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; FFI definitions for all functions exported by RDNZL.dll. See the
+;;; C++ source code for details.
+
+(in-package :rdnzl)
+
+;; load the C++ library which interfaces with the CLR
+(ffi-register-module "RDNZL.dll" :rdnzl)
+
+(defmacro ffi-define-function (c-name arg-list result-type)
+ "Like FFI-DEFINE-FUNCTION* but automatically creates the Lisp name
+from the C name. A name like \"invokeMethod\" is mapped to
+\"%INVOKE-METHOD\"."
+ `(ffi-define-function* (,(intern
+ (concatenate 'string "%" (mangle-name c-name))
+ :rdnzl)
+ ,c-name)
+ ,arg-list
+ ,result-type))
+
+(ffi-define-function "DllEnsureInit"
+ ()
+ ffi-void)
+
+(ffi-define-function "DllForceTerm"
+ ()
+ ffi-void)
+
+(defun dll-ensure-init ()
+ "Wrapper for DllEnsureInit which makes sure the function is called
+only once."
+ (unless *dll-initialized*
[276 lines skipped]
--- /project/rdnzl/cvsroot/RDNZL/import.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/import.lisp 2006/02/01 01:00:56 1.3
@@ -1,193 +1,193 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/import.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; Importing types and assemblies, initialization.
-
-(in-package :rdnzl)
-
-(enable-rdnzl-syntax)
-
-(defun import-type (type &optional assembly)
- "Imports the .NET type TYPE, i.e. registers its name as one that can
-be abbreviated \(see USE-NAMESPACE) and maybe creates a mapping from
-its short name to its assembly-qualified name. If TYPE is a string
-and ASSEMBLY is NIL then the function will try to create the type from
-the string with the static method System.Type::GetType. If TYPE is a
-string and ASSEMBLY is an assembly \(a CONTAINER) then instead the
-instance method System.Reflection.Assembly::GetType will be used. If
-TYPE is already a .NET object \(i.e. a CONTAINER) then the function
-will just register its name. If ASSEMBLY is a true value then the
-name will also be mapped to its assembly-qualified name. In all cases
-the type itself \(as a CONTAINER) will be returned."
- (cond ((container-p type)
- (setf (gethash [%FullName type] *type-hash*)
- (cond (assembly [%AssemblyQualifiedName type])
- (t t)))
- type)
- ((stringp type)
- (import-type (cond (assembly
- (or [GetType assembly type]
- (error "Type with name ~S not found in assembly ~S."
- type [%FullName assembly])))
- (t
- (let ((imported-type (make-type-from-name type)))
- (when (%dot-net-container-is-null (pointer imported-type))
- (error "Type with name ~S not found."
- type))
- imported-type)))
- assembly))
- (t (error "Don't know how to import type ~S." type))))
-
-(defun new (type &rest other-args)
- "Creates a new .NET object \(a CONTAINER) of the type TYPE. Calls
-the constructor determined by OTHER-ARGS \(a list of Lisp object
-and/or CONTAINERs), i.e. by the corresponding signature. TYPE can be
-a string \(naming the type) or a CONTAINER \(representing the type).
-If TYPE is a delegate then the second argument to NEW must be a Lisp
-closure with a correspoding signature."
- (cond ((stringp type)
- (apply #'new
- (make-type-from-name (resolve-type-name type))
- other-args))
- ((container-p type)
- (cond ([IsAssignableFrom (make-type-from-name "System.Delegate") type]
- ;; it's a delegate
- (let* ((method-info [GetMethod type "Invoke"])
- (adapter (make-adapter (first other-args)
- [%ReturnType method-info]
- (mapcar #`%ParameterType
- (rdnzl-array-to-list [GetParameters method-info])))))
- (invoke-constructor type
- adapter
- [GetFunctionPointer [%MethodHandle [GetMethod [GetType adapter]
- "InvokeClosure"]]])))
- (t (apply #'invoke-constructor
- type
- other-args))))
- (t (error "Don't know how to make a new ~S." type))))
-
-(defun load-assembly (name)
- "Loads and returns the assembly with the name NAME \(a string), uses
-LoadWithPartialName."
- [System.Reflection.Assembly.LoadWithPartialName name])
-
-(defun import-assembly (assembly)
- "Imports all public types of the assembly ASSEMBLY \(a string or a
-CONTAINER). If ASSEMBLY is a string then the assembly is first loaded
-with LOAD-ASSEMBLY. Returns ASSEMBLY as a CONTAINER."
- (cond ((container-p assembly)
- (do-rdnzl-array (type [GetTypes assembly])
- (when [%IsPublic type]
- (import-type type)))
- assembly)
- ((stringp assembly)
- (import-assembly (load-assembly assembly)))
- (t (error "Don't know how to import assembly ~S." assembly))))
-
-(defun import-types (assembly-name &rest type-names)
- "Loads the assembly named ASSEMBLY-NAME and imports \(see function
-IMPORT-TYPE) all types listed from this assembly. The assembly name
-is prepended to the type names before importing them. All arguments
-should be strings."
- (let ((assembly (or (load-assembly assembly-name)
- (error "Assembly ~S not found" assembly-name))))
- (dolist (type-name type-names)
- (import-type (concatenate 'string
- assembly-name
- "."
- type-name)
- assembly))))
-
-(defun reset-cached-data ()
- "Resets all relevant global special variables to their initial value,
-thereby releasing pointers to DotNetContainer objects if necessary.
-Also removes all direct call definitions."
- (setq *callback-counter* 0
- *delegate-counter* 0)
- (clrhash *callback-hash*)
- (clrhash *signature-hash*)
- (loop for function-name being the hash-keys in *direct-definitions*
- do (fmakunbound function-name)))
-
-(defun init-rdnzl ()
- "Initializes RDNZL. This function must be called once before RDNZL
-is used."
- ;; see <http://msdn.microsoft.com/library/en-us/vcmex/html/vcconconvertingmanagedextensionsforcprojectsfrompureintermediatelanguagetomixedmode.asp?frame=true>
- (dll-ensure-init)
- ;; inform the DelegateAdapter class about where the Lisp callbacks
- ;; are located
- (%set-function-pointers (ffi-make-pointer 'LispCallback)
- (ffi-make-pointer 'ReleaseDelegateAdapter))
- ;; reset to a sane state
- (reset-cached-data)
- (reimport-types)
- (redefine-direct-calls)
- ;; see comment for DLL-ENSURE-INIT above
- (register-exit-function #'dll-force-term "Close DLL")
- (values))
-
-(defun shutdown-rdnzl (&optional no-gc)
- "Prepares RDNZL for delivery or image saving. After calling this
-function RDNZL can't be used anymore unless INIT-RDNZL is called
-again. If NO-GC is NIL \(the default) a full garbage collection is
-also performed."
- (reset-cached-data)
- (dll-force-term)
- (unless no-gc
- (full-gc))
- (values))
-
-(defun reimport-types ()
- "Loops through all imported types and tries to associate them with
-the correct assembly. Only relevant for delivery and saved images."
- (let ((assembly-hash (make-hash-table :test #'equal)))
- (loop for type-name being the hash-keys in *type-hash*
- using (hash-value assembly-qualified-name)
- ;; only do this for types which need the assembly-qualified
- ;; name
- when (stringp assembly-qualified-name)
- do (let ((assembly-name (find-partial-assembly-name assembly-qualified-name)))
- (import-type type-name
- (or (gethash assembly-name assembly-hash)
- (setf (gethash assembly-name assembly-hash)
- (load-assembly assembly-name))))))))
-
-(defun redefine-direct-calls ()
- "Loops through all direct call definition which have been stored in
-*DIRECT-DEFINITIONS* and re-animates them. Only relevant for delivery
-and saved images."
- (loop for function-name being the hash-keys in *direct-definitions*
- using (hash-value function-data)
- do (create-direct-call function-name function-data)))
-
-;; when loading this file initialize RDNZL
-(eval-when (:load-toplevel :execute)
- (init-rdnzl))
-
-(disable-rdnzl-syntax)
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/import.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; Importing types and assemblies, initialization.
+
+(in-package :rdnzl)
+
+(enable-rdnzl-syntax)
+
+(defun import-type (type &optional assembly)
+ "Imports the .NET type TYPE, i.e. registers its name as one that can
+be abbreviated \(see USE-NAMESPACE) and maybe creates a mapping from
+its short name to its assembly-qualified name. If TYPE is a string
+and ASSEMBLY is NIL then the function will try to create the type from
+the string with the static method System.Type::GetType. If TYPE is a
+string and ASSEMBLY is an assembly \(a CONTAINER) then instead the
+instance method System.Reflection.Assembly::GetType will be used. If
+TYPE is already a .NET object \(i.e. a CONTAINER) then the function
+will just register its name. If ASSEMBLY is a true value then the
+name will also be mapped to its assembly-qualified name. In all cases
+the type itself \(as a CONTAINER) will be returned."
+ (cond ((container-p type)
+ (setf (gethash [%FullName type] *type-hash*)
+ (cond (assembly [%AssemblyQualifiedName type])
+ (t t)))
+ type)
+ ((stringp type)
+ (import-type (cond (assembly
+ (or [GetType assembly type]
+ (error "Type with name ~S not found in assembly ~S."
+ type [%FullName assembly])))
+ (t
+ (let ((imported-type (make-type-from-name type)))
+ (when (%dot-net-container-is-null (pointer imported-type))
+ (error "Type with name ~S not found."
+ type))
+ imported-type)))
+ assembly))
+ (t (error "Don't know how to import type ~S." type))))
+
+(defun new (type &rest other-args)
+ "Creates a new .NET object \(a CONTAINER) of the type TYPE. Calls
+the constructor determined by OTHER-ARGS \(a list of Lisp object
+and/or CONTAINERs), i.e. by the corresponding signature. TYPE can be
+a string \(naming the type) or a CONTAINER \(representing the type).
+If TYPE is a delegate then the second argument to NEW must be a Lisp
+closure with a correspoding signature."
+ (cond ((stringp type)
+ (apply #'new
+ (make-type-from-name (resolve-type-name type))
+ other-args))
+ ((container-p type)
+ (cond ([IsAssignableFrom (make-type-from-name "System.Delegate") type]
+ ;; it's a delegate
+ (let* ((method-info [GetMethod type "Invoke"])
+ (adapter (make-adapter (first other-args)
+ [%ReturnType method-info]
+ (mapcar #`%ParameterType
+ (rdnzl-array-to-list [GetParameters method-info])))))
+ (invoke-constructor type
+ adapter
+ [GetFunctionPointer [%MethodHandle [GetMethod [GetType adapter]
+ "InvokeClosure"]]])))
+ (t (apply #'invoke-constructor
+ type
+ other-args))))
+ (t (error "Don't know how to make a new ~S." type))))
+
+(defun load-assembly (name)
+ "Loads and returns the assembly with the name NAME \(a string), uses
+LoadWithPartialName."
+ [System.Reflection.Assembly.LoadWithPartialName name])
+
+(defun import-assembly (assembly)
+ "Imports all public types of the assembly ASSEMBLY \(a string or a
+CONTAINER). If ASSEMBLY is a string then the assembly is first loaded
+with LOAD-ASSEMBLY. Returns ASSEMBLY as a CONTAINER."
+ (cond ((container-p assembly)
+ (do-rdnzl-array (type [GetTypes assembly])
+ (when [%IsPublic type]
+ (import-type type)))
+ assembly)
+ ((stringp assembly)
+ (import-assembly (load-assembly assembly)))
+ (t (error "Don't know how to import assembly ~S." assembly))))
+
+(defun import-types (assembly-name &rest type-names)
+ "Loads the assembly named ASSEMBLY-NAME and imports \(see function
+IMPORT-TYPE) all types listed from this assembly. The assembly name
+is prepended to the type names before importing them. All arguments
+should be strings."
+ (let ((assembly (or (load-assembly assembly-name)
+ (error "Assembly ~S not found" assembly-name))))
+ (dolist (type-name type-names)
+ (import-type (concatenate 'string
+ assembly-name
+ "."
+ type-name)
+ assembly))))
+
+(defun reset-cached-data ()
+ "Resets all relevant global special variables to their initial value,
+thereby releasing pointers to DotNetContainer objects if necessary.
+Also removes all direct call definitions."
+ (setq *callback-counter* 0
+ *delegate-counter* 0)
+ (clrhash *callback-hash*)
+ (clrhash *signature-hash*)
+ (loop for function-name being the hash-keys in *direct-definitions*
+ do (fmakunbound function-name)))
+
+(defun init-rdnzl ()
+ "Initializes RDNZL. This function must be called once before RDNZL
+is used."
+ ;; see <http://msdn.microsoft.com/library/en-us/vcmex/html/vcconconvertingmanagedextensionsforcprojectsfrompureintermediatelanguagetomixedmode.asp?frame=true>
+ (dll-ensure-init)
+ ;; inform the DelegateAdapter class about where the Lisp callbacks
+ ;; are located
+ (%set-function-pointers (ffi-make-pointer 'LispCallback)
+ (ffi-make-pointer 'ReleaseDelegateAdapter))
+ ;; reset to a sane state
+ (reset-cached-data)
+ (reimport-types)
+ (redefine-direct-calls)
+ ;; see comment for DLL-ENSURE-INIT above
+ (register-exit-function #'dll-force-term "Close DLL")
+ (values))
+
+(defun shutdown-rdnzl (&optional no-gc)
+ "Prepares RDNZL for delivery or image saving. After calling this
+function RDNZL can't be used anymore unless INIT-RDNZL is called
+again. If NO-GC is NIL \(the default) a full garbage collection is
+also performed."
+ (reset-cached-data)
+ (dll-force-term)
+ (unless no-gc
+ (full-gc))
+ (values))
+
+(defun reimport-types ()
+ "Loops through all imported types and tries to associate them with
+the correct assembly. Only relevant for delivery and saved images."
+ (let ((assembly-hash (make-hash-table :test #'equal)))
+ (loop for type-name being the hash-keys in *type-hash*
+ using (hash-value assembly-qualified-name)
+ ;; only do this for types which need the assembly-qualified
+ ;; name
+ when (stringp assembly-qualified-name)
+ do (let ((assembly-name (find-partial-assembly-name assembly-qualified-name)))
+ (import-type type-name
+ (or (gethash assembly-name assembly-hash)
+ (setf (gethash assembly-name assembly-hash)
+ (load-assembly assembly-name))))))))
+
+(defun redefine-direct-calls ()
+ "Loops through all direct call definition which have been stored in
+*DIRECT-DEFINITIONS* and re-animates them. Only relevant for delivery
+and saved images."
+ (loop for function-name being the hash-keys in *direct-definitions*
+ using (hash-value function-data)
+ do (create-direct-call function-name function-data)))
+
+;; when loading this file initialize RDNZL
+(eval-when (:load-toplevel :execute)
+ (init-rdnzl))
+
+(disable-rdnzl-syntax)
--- /project/rdnzl/cvsroot/RDNZL/load.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/load.lisp 2006/02/01 01:00:56 1.3
@@ -1,72 +1,73 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/load.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; Load this file to compile and load all of RDNZL - see README.txt
-;;; and the doc folder for details.
-
-(in-package :cl-user)
-
-(let ((rdnzl-base-directory
- (make-pathname :name nil :type nil :version nil
- :defaults (parse-namestring *load-truename*))))
- (let (must-compile)
- #+:cormanlisp (declare (ignore must-compile))
- (dolist (file '("packages"
- "specials"
- "util"
- #+:allegro "port-acl"
- #+:cormanlisp "port-ccl"
- #+:clisp "port-clisp"
- #+:lispworks "port-lw"
- "ffi"
- "container"
- "reader"
- "arrays"
- "adapter"
- "import"
- "direct"))
- (let ((pathname (make-pathname :name file :type "lisp" :version nil
- :defaults rdnzl-base-directory)))
- ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD
- ;; will yield compiled functions anyway
- #-:cormanlisp
- (let ((compiled-pathname (compile-file-pathname pathname)))
- (unless (and (not must-compile)
- (probe-file compiled-pathname)
- (< (file-write-date pathname)
- (file-write-date compiled-pathname)))
- (setq must-compile t)
- (compile-file pathname))
- (setq pathname compiled-pathname))
- (load pathname)))))
-
-
-
-
-
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/load.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; Load this file to compile and load all of RDNZL - see README.txt
+;;; and the doc folder for details.
+
+(in-package :cl-user)
+
+(let ((rdnzl-base-directory
+ (make-pathname :name nil :type nil :version nil
+ :defaults (parse-namestring *load-truename*))))
+ (let (must-compile)
+ #+:cormanlisp (declare (ignore must-compile))
+ (dolist (file '("packages"
+ "specials"
+ "util"
+ #+:allegro "port-acl"
+ #+:cormanlisp "port-ccl"
+ #+:clisp "port-clisp"
+ #+:lispworks "port-lw"
+ #+:sbcl "port-sbcl"
+ "ffi"
+ "container"
+ "reader"
+ "arrays"
+ "adapter"
+ "import"
+ "direct"))
+ (let ((pathname (make-pathname :name file :type "lisp" :version nil
+ :defaults rdnzl-base-directory)))
+ ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD
+ ;; will yield compiled functions anyway
+ #-:cormanlisp
+ (let ((compiled-pathname (compile-file-pathname pathname)))
+ (unless (and (not must-compile)
+ (probe-file compiled-pathname)
+ (< (file-write-date pathname)
+ (file-write-date compiled-pathname)))
+ (setq must-compile t)
+ (compile-file pathname))
+ (setq pathname compiled-pathname))
+ (load pathname)))))
+
+
+
+
+
--- /project/rdnzl/cvsroot/RDNZL/packages.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/packages.lisp 2006/02/01 01:00:56 1.3
@@ -1,68 +1,74 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/packages.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; Definition of the "RDNZL" package.
-
-(in-package :cl-user)
-
-;; Corman Lisp has problems with uninterned symbols like #:aref*
-(defpackage :rdnzl
- (:use :cl)
- (:export :aref*
- :box
- :cast
- :container-p
- :define-rdnzl-call
- :disable-rdnzl-syntax
- :do-rdnzl-array
- :enable-rdnzl-syntax
- :enum-to-integer
- :field
- :import-assembly
- :import-type
- :import-types
- :integer-to-enum
- :invoke
- :init-rdnzl
- :load-assembly
- :list-to-rdnzl-array
- :make-null-object
- :new
- :or-enums
- :property
- :ref
- :rdnzl-array-to-list
- :rdnzl-error
- :rdnzl-error-exception
- :rdnzl-handler-case
- :shutdown-rdnzl
- :unbox
- :unuse-all-namespaces
- :unuse-namespace
- :use-namespace))
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/packages.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; Definition of the "RDNZL" package.
+
+(in-package :cl-user)
+
+;; Corman Lisp has problems with uninterned symbols like #:aref*
+(defpackage :rdnzl
+ (:use :cl)
+ #+:sbcl (:shadow :defconstant)
+ (:export :aref*
+ :box
+ :cast
+ :container-p
+ :define-rdnzl-call
+ :disable-rdnzl-syntax
+ :do-rdnzl-array
+ :enable-rdnzl-syntax
+ :enum-to-integer
+ :field
+ :import-assembly
+ :import-type
+ :import-types
+ :integer-to-enum
+ :invoke
+ :init-rdnzl
+ :load-assembly
+ :list-to-rdnzl-array
+ :make-null-object
+ :new
+ :or-enums
+ :property
+ :ref
+ :rdnzl-array-to-list
+ :rdnzl-error
+ :rdnzl-error-exception
+ :rdnzl-handler-case
+ :shutdown-rdnzl
+ :unbox
+ :unuse-all-namespaces
+ :unuse-namespace
+ :use-namespace))
+
+(defpackage :rdnzl-user
+ (:use :cl :rdnzl)
+ (:documentation "This package is intended for playing around
+with RDNZL."))
\ No newline at end of file
--- /project/rdnzl/cvsroot/RDNZL/port-acl.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/port-acl.lisp 2006/02/01 01:00:56 1.3
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-acl.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-acl.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
-;;; Copyright (c) 2004-2005, Charles A. Cox, Dr. Edmund Weitz. All rights reserved.
+;;; Copyright (c) 2004-2006, Charles A. Cox, 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
@@ -131,9 +131,10 @@
(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."
+ "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."
(flet ((arg-spec (arg-list)
(mapcar #'(lambda (name-and-type)
(destructuring-bind (name type) name-and-type
@@ -150,9 +151,9 @@
(defmacro ffi-define-callable ((c-name result-type)
arg-list
&body body)
- "Defines a Lisp which can be called from C as 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."
+ "Defines a Lisp 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."
(declare (ignore result-type))
`(progn
(ff:defun-foreign-callable ,c-name
@@ -274,5 +275,5 @@
sys:*exit-cleanup-forms*))
(defun full-gc ()
- "Invoke a full garbage collection."
+ "Invokes a full garbage collection."
(excl:gc t))
--- /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp 2006/02/01 01:00:56 1.3
@@ -1,282 +1,283 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; Corman-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."
- (ct:cpointerp object))
-
-(defun ffi-null-pointer-p (pointer)
- "Returns whether the FFI pointer POINTER is a null pointer."
- (ct:cpointer-null pointer))
-
-(defun ffi-pointer-address (pointer)
- "Returns the address of the FFI pointer POINTER."
- (ct:cpointer-value pointer))
-
-(defun ffi-make-pointer (name)
- "Returns an FFI pointer to the address specified by the name NAME."
- (ct:get-callback-procinst name))
-
-(defun ffi-map-type (type-name)
- "Maps type names like FFI-INTEGER to their corresponding names in
-the LispWorks FLI."
- (ecase type-name
- (ffi-void :void)
- (ffi-void-pointer '(:void *))
- (ffi-const-string '(:void *))
- (ffi-integer :long)
- (ffi-boolean :long-bool)
- (ffi-wide-char :unsigned-short)
- (ffi-float :single-float)
- (ffi-double :double-float)))
-
-(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 (eq result-type 'ffi-wide-char)
- (find 'ffi-wide-char arg-list :key #'second :test #'eq))
- ;; define a wrapper if one of the args and/or the return type
- ;; is a __wchar_t because Corman Lisp doesn't handle this
- ;; type automatically
- (with-unique-names (internal-name result)
- `(progn
- (ct:defun-dll ,internal-name
- ,(mapcar (lambda (name-and-type)
- (destructuring-bind (name type) name-and-type
- (list name (ffi-map-type type))))
- arg-list)
- :return-type ,(ffi-map-type result-type)
- :linkage-type :c
- :library-name ,*dll-path*
- :entry-name ,c-name)
- (defun ,lisp-name ,(mapcar #'first arg-list)
- (let ((,result (,internal-name ,@(loop for (name type) in arg-list
- when (eq type 'ffi-wide-char)
- collect `(char-code ,name)
- else
- collect name))))
- ,(if (eq result-type 'ffi-wide-char)
- ;; only use lower octet...
- `(code-char (logand ,result 255))
- result))))))
- (t
- `(ct:defun-dll ,lisp-name
- ,(mapcar (lambda (name-and-type)
- (destructuring-bind (name type) name-and-type
- (list name (ffi-map-type type))))
- arg-list)
- :return-type ,(ffi-map-type result-type)
- :linkage-type :c
- :library-name ,*dll-path*
- :entry-name ,c-name))))
-
-(defmacro ffi-define-callable ((c-name result-type)
- arg-list
- &body body)
- "Defines a Lisp which can be called from C as 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."
- (declare (ignore result-type))
- `(ct:defun-direct-c-callback ,c-name
- ,(mapcar (lambda (name-and-type)
- (destructuring-bind (name type) name-and-type
- (list name (ffi-map-type type))))
- arg-list)
- , at body))
-
-(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))
- ,temp)
- (unwind-protect
- (progn
- (setq ,temp (ct:malloc (* 2 (1+ ,length))))
- (,function ,object ,temp)
- (copy-seq (ct:unicode-to-lisp-string ,temp)))
- (when ,temp
- (ct:free ,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)
- ` (let* ((,length (length ,other-args))
- (,arg-pointers (make-array ,length :initial-element nil))
- ,foreign-string)
- (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
- `(progn
- (setq ,foreign-string (ct:lisp-string-to-unicode ,string))
- (apply #',function ,foreign-string ,ffi-arg-pointers)))
- (t
- `(apply #',function ,ffi-arg-pointers))))
- (when ,foreign-string
- (ct:free ,foreign-string))
- ;; 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))
- ,ffi-arg-pointers
- ,foreign-name)
- (unwind-protect
- (progn
- (setq ,ffi-arg-pointers (ct:malloc (* ,length (ct:sizeof '(:void *)))))
- (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 (setf (ct:cref ((:void *) *) ,ffi-arg-pointers ,i)
- ,arg-pointer))
- ,(cond (name
- `(progn
- (setq ,foreign-name (ct:lisp-string-to-unicode ,name))
- (,function ,foreign-name
- ,object
- ,length
- ,ffi-arg-pointers)))
- (t
- `(,function ,object
- ,length
- ,ffi-arg-pointers))))
- (when ,ffi-arg-pointers
- (ct:free ,ffi-arg-pointers))
- (when ,foreign-name
- (ct:free ,foreign-name))
- ;; 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."
- (ccl:register-finalization 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 Corman Lisp
- (declare (ignore function name)))
-
-(defun full-gc ()
- "Invoke a full garbage collection."
- (ccl:gc 3))
-
-(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)
- :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)))
-
-;; Corman's WITH-STANDARD-IO-SYNTAX doesn't work correctly so we fix
-;; it here for our purposes
-
-(defvar *standard-readtable* (copy-readtable nil))
-(defvar *standard-pprint-dispatch* (copy-pprint-dispatch nil))
-
-(defmacro with-standard-io-syntax (&body body)
- `(let ((*package* (find-package :user))
- (*print-array* t)
- (*print-base* 10)
- (*print-case* :upcase)
- (*print-circle* nil)
- (*print-escape* t)
- (*print-gensym* t)
- (*print-length* nil)
- (*print-level* nil)
- (*print-lines* nil)
- (*print-miser-width* nil)
- (*print-pprint-dispatch* *standard-pprint-dispatch*)
- (*print-pretty* nil)
- (*print-radix* nil)
- (*print-readably* nil)
- (*print-right-margin* nil)
- (*read-base* 10)
- (*read-default-float-format* 'single-float)
- (*read-eval* t)
- (*read-suppress* nil)
- (*readtable* *standard-readtable*))
- , at body))
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; Corman-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."
+ (ct:cpointerp object))
+
+(defun ffi-null-pointer-p (pointer)
+ "Returns whether the FFI pointer POINTER is a null pointer."
+ (ct:cpointer-null pointer))
+
+(defun ffi-pointer-address (pointer)
+ "Returns the address of the FFI pointer POINTER."
+ (ct:cpointer-value pointer))
+
+(defun ffi-make-pointer (name)
+ "Returns an FFI pointer to the address specified by the name NAME."
+ (ct:get-callback-procinst name))
+
+(defun ffi-map-type (type-name)
+ "Maps type names like FFI-INTEGER to their corresponding names in
+the LispWorks FLI."
+ (ecase type-name
+ (ffi-void :void)
+ (ffi-void-pointer '(:void *))
+ (ffi-const-string '(:void *))
+ (ffi-integer :long)
+ (ffi-boolean :long-bool)
+ (ffi-wide-char :unsigned-short)
+ (ffi-float :single-float)
+ (ffi-double :double-float)))
+
+(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 (eq result-type 'ffi-wide-char)
+ (find 'ffi-wide-char arg-list :key #'second :test #'eq))
+ ;; define a wrapper if one of the args and/or the return type
+ ;; is a __wchar_t because Corman Lisp doesn't handle this
+ ;; type automatically
+ (with-unique-names (internal-name result)
+ `(progn
+ (ct:defun-dll ,internal-name
+ ,(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (ffi-map-type type))))
+ arg-list)
+ :return-type ,(ffi-map-type result-type)
+ :linkage-type :c
+ :library-name ,*dll-path*
+ :entry-name ,c-name)
+ (defun ,lisp-name ,(mapcar #'first arg-list)
+ (let ((,result (,internal-name ,@(loop for (name type) in arg-list
+ when (eq type 'ffi-wide-char)
+ collect `(char-code ,name)
+ else
+ collect name))))
+ ,(if (eq result-type 'ffi-wide-char)
+ ;; only use lower octet...
+ `(code-char (logand ,result 255))
+ result))))))
+ (t
+ `(ct:defun-dll ,lisp-name
+ ,(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (ffi-map-type type))))
+ arg-list)
+ :return-type ,(ffi-map-type result-type)
+ :linkage-type :c
+ :library-name ,*dll-path*
+ :entry-name ,c-name))))
+
[168 lines skipped]
--- /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp 2006/02/01 01:00:56 1.3
@@ -1,254 +1,254 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, Vasilis Margioulas, 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.
-
-;;; CLISP-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) 'ffi:foreign-address))
-
-(defun ffi-null-pointer-p (pointer)
- "Returns whether the FFI pointer POINTER is a null pointer."
- (null pointer))
-
-(defun ffi-pointer-address (pointer)
- "Returns the address of the FFI pointer POINTER."
- (ffi:foreign-address-unsigned pointer))
-
-(defun ffi-make-pointer (name)
- "Returns an FFI pointer to the address specified by the name NAME."
- (get-function-pointer name))
-
-(defun ffi-map-type (type-name)
- "Maps type names like FFI-INTEGER to their corresponding names in
-the CLISP FFI."
- (ecase type-name
- (ffi-void nil)
- (ffi-void-pointer 'ffi:c-pointer)
- (ffi-const-string 'ffi:c-pointer)
- (ffi-integer 'ffi:int)
- (ffi-boolean 'ffi:boolean)
- (ffi-wide-char 'ffi:uint16)
- (ffi-float 'ffi:single-float)
- (ffi-double 'ffi:double-float)))
-
-(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 (eq result-type 'ffi-wide-char)
- (find 'ffi-wide-char arg-list :key #'second :test #'eq))
- ;; define a wrapper if one of the args and/or the return type
- ;; is a __wchar_t because CLISP doesn't handle this
- ;; type automatically
- (with-unique-names (internal-name result)
- `(progn
- (ffi:def-call-out ,internal-name
- (:name ,c-name)
- (:arguments ,@(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)
- `((:return-type ,(ffi-map-type result-type))))
- (:language :stdc)
- (:library ,*dll-path*))
- (defun ,lisp-name ,(mapcar #'first arg-list)
- (let ((,result (,internal-name ,@(loop for (name type) in arg-list
- when (eq type 'ffi-wide-char)
- collect `(char-code ,name)
- else
- collect name))))
- ,(if (eq result-type 'ffi-wide-char)
- `(code-char ,result)
- result))))))
- (t
- `(ffi:def-call-out ,lisp-name
- (:name ,c-name)
- (:arguments ,@(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)
- `((:return-type ,(ffi-map-type result-type))))
- (:language :stdc)
- (:library ,*dll-path*)))))
-
-(defgeneric get-function-pointer (name))
-
-(defmacro ffi-define-callable ((c-name result-type)
- arg-list
- &body body)
- "Defines a Lisp which can be called from C as 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."
- (with-unique-names (foreign-function)
- `(progn
- (defun ,c-name ,(mapcar #'first arg-list)
- , at body)
-
- (let ((,foreign-function (ffi:allocate-deep
- '(ffi:c-function
- (:language :stdc-stdcall)
- (:arguments ,@(mapcar (lambda (name-and-type)
- (destructuring-bind (name type) name-and-type
- (list name (ffi-map-type type))))
- arg-list))
- (:return-type ,(ffi-map-type result-type)))
- nil)))
-
- (defmethod get-function-pointer ((name (eql ',c-name)))
- (ffi:with-c-place (f-function ,foreign-function)
- (unless f-function
- (setf f-function #',c-name))
- (ffi:foreign-address f-function)))))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defmacro with-unicode-string ((var lisp-string) &body body)
- (with-unique-names (str-len ubyte16-array)
- `(let ((,str-len (length ,lisp-string)))
- (ffi:with-c-var (,ubyte16-array `(ffi:c-array-max ffi:uint16 ,(1+ ,str-len))
- (map 'vector #'char-code ,lisp-string))
- (let ((,var (ffi:c-var-address ,ubyte16-array)))
- , at body))))))
-
-(defun unicode-string-to-lisp (ubyte16-array)
- (map 'string #'code-char ubyte16-array))
-
-(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-c-var (,temp `(ffi:c-array-max ffi:uint16 ,(1+ ,length)) #())
- (,function ,object (ffi:c-var-address ,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-c-var
- (,ffi-arg-pointers `(ffi:c-array ffi:c-pointer ,,length)
- (apply #'vector
- (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))))
- collect ,arg-pointer)))
- ,(cond (name
- `(with-unicode-string (,foreign-name ,name)
- (,function ,foreign-name
- ,object
- ,length
- (ffi:c-var-address ,ffi-arg-pointers))))
- (t
- `(,function ,object
- ,length
- (ffi:c-var-address ,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."
- (ext:finalize 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 CLISP
- (declare (ignore function name)))
-
-(defun full-gc ()
- "Invoke a full garbage collection."
- (ext:gc))
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, Vasilis Margioulas, 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.
+
+;;; CLISP-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) 'ffi:foreign-address))
+
+(defun ffi-null-pointer-p (pointer)
+ "Returns whether the FFI pointer POINTER is a null pointer."
+ (null pointer))
+
+(defun ffi-pointer-address (pointer)
+ "Returns the address of the FFI pointer POINTER."
+ (ffi:foreign-address-unsigned pointer))
+
+(defun ffi-make-pointer (name)
+ "Returns an FFI pointer to the address specified by the name NAME."
+ (get-function-pointer name))
+
+(defun ffi-map-type (type-name)
+ "Maps type names like FFI-INTEGER to their corresponding names in
+the CLISP FFI."
+ (ecase type-name
+ (ffi-void nil)
+ (ffi-void-pointer 'ffi:c-pointer)
+ (ffi-const-string 'ffi:c-pointer)
+ (ffi-integer 'ffi:int)
+ (ffi-boolean 'ffi:boolean)
+ (ffi-wide-char 'ffi:uint16)
+ (ffi-float 'ffi:single-float)
+ (ffi-double 'ffi:double-float)))
+
+(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 (eq result-type 'ffi-wide-char)
+ (find 'ffi-wide-char arg-list :key #'second :test #'eq))
+ ;; define a wrapper if one of the args and/or the return type
+ ;; is a __wchar_t because CLISP doesn't handle this
+ ;; type automatically
+ (with-unique-names (internal-name result)
+ `(progn
+ (ffi:def-call-out ,internal-name
+ (:name ,c-name)
+ (:arguments ,@(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)
+ `((:return-type ,(ffi-map-type result-type))))
+ (:language :stdc)
+ (:library ,*dll-path*))
+ (defun ,lisp-name ,(mapcar #'first arg-list)
+ (let ((,result (,internal-name ,@(loop for (name type) in arg-list
+ when (eq type 'ffi-wide-char)
+ collect `(char-code ,name)
+ else
+ collect name))))
+ ,(if (eq result-type 'ffi-wide-char)
+ `(code-char ,result)
+ result))))))
+ (t
+ `(ffi:def-call-out ,lisp-name
+ (:name ,c-name)
+ (:arguments ,@(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)
+ `((:return-type ,(ffi-map-type result-type))))
+ (:language :stdc)
+ (:library ,*dll-path*)))))
+
+(defgeneric get-function-pointer (name))
+
+(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."
+ (with-unique-names (foreign-function)
+ `(progn
+ (defun ,c-name ,(mapcar #'first arg-list)
+ , at body)
+
+ (let ((,foreign-function (ffi:allocate-deep
+ '(ffi:c-function
+ (:language :stdc-stdcall)
+ (:arguments ,@(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (ffi-map-type type))))
+ arg-list))
+ (:return-type ,(ffi-map-type result-type)))
+ nil)))
+
+ (defmethod get-function-pointer ((name (eql ',c-name)))
+ (ffi:with-c-place (f-function ,foreign-function)
+ (unless f-function
+ (setf f-function #',c-name))
[111 lines skipped]
--- /project/rdnzl/cvsroot/RDNZL/port-lw.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/port-lw.lisp 2006/02/01 01:00:56 1.3
@@ -1,213 +1,214 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-lw.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; LispWorks-specific definitions
-
-(in-package :rdnzl)
-
-(defvar *module-name* nil
- "Holds the last module name defined by FFI-REGISTER-MODULE. This is
-only needed for LispWorks.")
-
-(defmacro ffi-register-module (path &optional (module-name path))
- "Loads a C library designated by PATH. Optionally \(for LispWorks)
-registers this library under the name MODULE-NAME."
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (fli:register-module ,module-name
- :real-name ,path)
- (setq *module-name* ,module-name)))
-
-(defun ffi-pointer-p (object)
- "Tests whether OBJECT is an FFI pointer."
- (fli:pointerp object))
-
-(defun ffi-null-pointer-p (pointer)
- "Returns whether the FFI pointer POINTER is a null pointer."
- (fli:null-pointer-p pointer))
-
-(defun ffi-pointer-address (pointer)
- "Returns the address of the FFI pointer POINTER."
- (fli:pointer-address pointer))
-
-(defun ffi-make-pointer (name)
- "Returns an FFI pointer to the address specified by the name NAME."
- (fli:make-pointer :symbol-name (symbol-name name)))
-
-(defun ffi-map-type (type-name)
- "Maps type names like FFI-INTEGER to their corresponding names in
-the LispWorks FLI."
- (ecase type-name
- (ffi-void :void)
- (ffi-void-pointer :pointer)
- (ffi-const-string '(:reference-pass (:ef-wc-string
- :external-format :unicode)))
- (ffi-integer :int)
- (ffi-boolean :boolean)
- (ffi-wide-char :wchar-t)
- (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."
- `(fli:define-foreign-function
- (,lisp-name ,c-name)
- ,(mapcar (lambda (name-and-type)
- (destructuring-bind (name type) name-and-type
- (list name (ffi-map-type type))))
- arg-list)
- :result-type ,(ffi-map-type result-type)
- :calling-convention :cdecl
- ;; use the last module that was registered
- ,@(when *module-name*
- (list :module *module-name*))))
-
-(defmacro ffi-define-callable ((c-name result-type)
- arg-list
- &body body)
- "Defines a Lisp which can be called from C as 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."
-`(fli:define-foreign-callable
- (,(symbol-name c-name) :result-type ,(ffi-map-type result-type)
- :calling-convention :cdecl)
- ,(mapcar (lambda (name-and-type)
- (destructuring-bind (name type) name-and-type
- (list name (ffi-map-type type))))
- arg-list)
- , at body))
-
-(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)))
- (fli:with-dynamic-foreign-objects ()
- (let ((,temp (fli:allocate-dynamic-foreign-object :type :wchar-t
- :nelems (1+ ,length))))
- (,function ,object ,temp)
- (fli:convert-from-foreign-string ,temp :external-format :unicode)))))))
-
-(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)
- `(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
- `(apply #',function ,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)
- (declare (ignorable foreign-name element-count byte-count))
- ` (let* ((,length (length ,args))
- (,arg-pointers (make-array ,length :initial-element nil)))
- (unwind-protect
- (fli:with-dynamic-foreign-objects ()
- (let ((,ffi-arg-pointers (fli:allocate-dynamic-foreign-object :type :pointer
- :nelems ,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 (setf (fli:dereference ,ffi-arg-pointers :index ,i)
- ,arg-pointer))
- (,function ,@(if name (list name) nil)
- ,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))))))))
-
-;; register MAYBE-FREE-CONTAINER-POINTER as a finalization
-;; function - needed for LispWorks
-(hcl:add-special-free-action 'maybe-free-container-pointer)
-
-(defun flag-for-finalization (object &optional function)
- "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT
-is removed by GC."
- ;; LispWorks can ignore FUNCTION because it was registered globally
- ;; above
- (declare (ignore function))
- (hcl:flag-special-free-action object))
-
-(defvar *exit-function-registered* nil
- "Whether LW:DEFINE-ACTION was already called for DllForceTerm.")
-
-(defun register-exit-function (function &optional name)
- "Makes sure the function FUNCTION \(with no arguments) is called
-before the Lisp images exits."
- (unless *exit-function-registered*
- (lw:define-action "When quitting image"
- name
- function
- :once)
- (setq *exit-function-registered* t)))
-
-(defun full-gc ()
- "Invoke a full garbage collection."
- (hcl:mark-and-sweep 3))
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-lw.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; LispWorks-specific definitions
+
+(in-package :rdnzl)
+
+(defvar *module-name* nil
+ "Holds the last module name defined by FFI-REGISTER-MODULE.
+This is only needed for LispWorks.")
+
+(defmacro ffi-register-module (path &optional (module-name path))
+ "Loads a C library designated by PATH. Optionally \(for
+LispWorks) registers this library under the name MODULE-NAME."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (fli:register-module ,module-name
+ :real-name ,path)
+ (setq *module-name* ,module-name)))
+
+(defun ffi-pointer-p (object)
+ "Tests whether OBJECT is an FFI pointer."
+ (fli:pointerp object))
+
+(defun ffi-null-pointer-p (pointer)
+ "Returns whether the FFI pointer POINTER is a null pointer."
+ (fli:null-pointer-p pointer))
+
+(defun ffi-pointer-address (pointer)
+ "Returns the address of the FFI pointer POINTER."
+ (fli:pointer-address pointer))
+
+(defun ffi-make-pointer (name)
+ "Returns an FFI pointer to the address specified by the name NAME."
+ (fli:make-pointer :symbol-name (symbol-name name)))
+
+(defun ffi-map-type (type-name)
+ "Maps type names like FFI-INTEGER to their corresponding names in
+the LispWorks FLI."
+ (ecase type-name
+ (ffi-void :void)
+ (ffi-void-pointer :pointer)
+ (ffi-const-string '(:reference-pass (:ef-wc-string
+ :external-format :unicode)))
+ (ffi-integer :int)
+ (ffi-boolean :boolean)
+ (ffi-wide-char :wchar-t)
+ (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."
+ `(fli:define-foreign-function
+ (,lisp-name ,c-name)
+ ,(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (ffi-map-type type))))
+ arg-list)
+ :result-type ,(ffi-map-type result-type)
+ :calling-convention :cdecl
+ ;; use the last module that was registered
+ ,@(when *module-name*
+ (list :module *module-name*))))
+
+(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."
+`(fli:define-foreign-callable
+ (,(symbol-name c-name) :result-type ,(ffi-map-type result-type)
+ :calling-convention :cdecl)
+ ,(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (ffi-map-type type))))
+ arg-list)
+ , at body))
+
+(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)))
+ (fli:with-dynamic-foreign-objects ()
+ (let ((,temp (fli:allocate-dynamic-foreign-object :type :wchar-t
+ :nelems (1+ ,length))))
+ (,function ,object ,temp)
+ (fli:convert-from-foreign-string ,temp :external-format :unicode)))))))
+
+(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)
+ `(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
+ `(apply #',function ,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)
+ (declare (ignorable foreign-name element-count byte-count))
+ ` (let* ((,length (length ,args))
+ (,arg-pointers (make-array ,length :initial-element nil)))
+ (unwind-protect
+ (fli:with-dynamic-foreign-objects ()
+ (let ((,ffi-arg-pointers (fli:allocate-dynamic-foreign-object :type :pointer
+ :nelems ,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 (setf (fli:dereference ,ffi-arg-pointers :index ,i)
+ ,arg-pointer))
+ (,function ,@(if name (list name) nil)
+ ,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))
[30 lines skipped]
--- /project/rdnzl/cvsroot/RDNZL/rdnzl.asd 2006/01/13 07:06:28 1.3
+++ /project/rdnzl/cvsroot/RDNZL/rdnzl.asd 2006/02/01 01:00:56 1.4
@@ -1,56 +1,57 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.3 2006/01/13 07:06:28 eweitz Exp $
-
-;;; Copyright (c) 2004, 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.
-
-;;; System definition for ASDF - see <http://www.cliki.net/asdf>
-
-(in-package :cl-user)
-
-(defpackage #:rdnzl.system
- (:use #:cl
- #:asdf))
-
-(in-package #:rdnzl.system)
-
-(defsystem #:rdnzl
- :serial t
- :version "0.8.0"
- :components ((:file "packages")
- (:file "specials")
- (:file "util")
- #+:allegro (:file "port-acl") ; AllegroCL-specific stuff here
- #+:cormanlisp (:file "port-ccl") ; Corman-specific stuff here
- #+:clisp (:file "port-clisp") ; CLISP-specific stuff here
- #+:lispworks (:file "port-lw") ; LispWorks-specific stuff here
- (:file "ffi")
- (:file "container")
- (:file "reader")
- (:file "arrays")
- (:file "adapter")
- (:file "import")
- (:file "direct")))
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.4 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004, 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.
+
+;;; System definition for ASDF - see <http://www.cliki.net/asdf>
+
+(in-package :cl-user)
+
+(defpackage #:rdnzl.system
+ (:use #:cl
+ #:asdf))
+
+(in-package #:rdnzl.system)
+
+(defsystem #:rdnzl
+ :serial t
+ :version "0.9.0"
+ :components ((:file "packages")
+ (:file "specials")
+ (:file "util")
+ #+:allegro (:file "port-acl") ; AllegroCL-specific stuff here
+ #+:cormanlisp (:file "port-ccl") ; Corman-specific stuff here
+ #+:clisp (:file "port-clisp") ; CLISP-specific stuff here
+ #+:lispworks (:file "port-lw") ; LispWorks-specific stuff here
+ #+:sbcl (:file "port-sbcl") ; SBCL-specific stuff here
+ (:file "ffi")
+ (:file "container")
+ (:file "reader")
+ (:file "arrays")
+ (:file "adapter")
+ (:file "import")
+ (:file "direct")))
--- /project/rdnzl/cvsroot/RDNZL/reader.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/reader.lisp 2006/02/01 01:00:56 1.3
@@ -1,260 +1,260 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/reader.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; This file defines the special reader syntax for .NET calls.
-
-(in-package :rdnzl)
-
-(define-condition rdnzl-reader-error (simple-condition reader-error)
- ()
- (:report (lambda (condition stream)
- (format stream "RDNZL reader error: ~?"
- (simple-condition-format-control condition)
- (simple-condition-format-arguments condition))))
- (:documentation "A reader error which can be signalled by ERROR."))
-
-(defmacro signal-reader-error (stream format-control &rest format-arguments)
- "Like ERROR but signals a SIMPLE-READER-ERROR for the stream
-STREAM."
- `(error 'rdnzl-reader-error
- :stream ,stream
- :format-control ,format-control
- :format-arguments (list , at format-arguments)))
-
-(defun read-rdnzl-token (stream)
- "Tries to emulate how the Lisp reader reads a token with standard
-syntax but is case-sensitive. Returns a string."
- (let ((collector (make-array 0
- :element-type 'character
- :fill-pointer t
- :adjustable t))
- in-multiple-escape-p
- in-single-escape-p
- char-seen-p)
- (loop
- (let ((char (peek-char nil stream nil nil t)))
- (cond (in-multiple-escape-p
- ;; in multiple escape mode, read everything as is but
- ;; don't accept EOF
- (unless char
- (signal-reader-error stream
- "End of file while in multiple~
-escape mode \(i.e. after pipe character)."))
- (read-char stream nil nil t)
- (cond ((char= char #\|)
- ;; end of multiple escape mode
- (setq in-multiple-escape-p nil))
- (t
- (vector-push-extend char collector))))
- (in-single-escape-p
- ;; single escape mode, i.e. last char was backslash -
- ;; read next char as is but don't accept EOF
- (unless char
- (signal-reader-error stream
- "End of file while in single~
-escape mode \(i.e. after backslash character)."))
- (setq in-single-escape-p nil)
- (read-char stream nil nil t)
- (vector-push-extend char collector))
- ((null char)
- ;; EOF - return what has been read so far
- (return-from read-rdnzl-token collector))
- ((and (not char-seen-p)
- (whitespacep char))
- ;; skip whitespace after #\[
- (read-char stream nil nil t))
- ((char= char #\|)
- ;; switch to multiple escape mode
- (setq in-multiple-escape-p t
- char-seen-p t)
- (read-char stream nil nil t))
- ((char= char #\\)
- ;; switch to single escape mode
- (setq in-single-escape-p t
- char-seen-p t)
- (read-char stream nil nil t))
- ((or (whitespacep char)
- (member char '(#\" #\' #\( #\) #\[ #\] #\, #\; #\`)
- :test #'char=))
- ;; whitespace or terminating macro character, stop
- ;; parsing this token
- (return-from read-rdnzl-token collector))
- (t
- ;; otherwise just consume the character
- (setq char-seen-p t)
- (read-char stream nil nil t)
- (vector-push-extend char collector)))))))
-
-(defun read-and-parse-rdnzl-token (stream)
- "Reads a token like \"%Environment.UserName\" with READ-RDNZL-TOKEN
-and dissects it into its parts \(type name and member name) if
-necessary. Also returns the corresponding function \(INVOKE,
-PROPERTY, or FIELD) from container.lisp."
- (let ((token (read-rdnzl-token stream))
- (function-name 'invoke))
- (when (string= token "")
- (signal-reader-error stream
- "Empty token after #\[ character."))
- (when (and (= (length token) 1)
- (member (char token 0) '(#\% #\$ #\+ #\-)
- :test #'char=))
- (signal-reader-error stream
- "Illegal token \"~C\" after #\[ character."
- token))
- (let ((first-char (char token 0)))
- (case first-char
- ((#\%)
- ;; first char #\% means property
- (setf function-name 'property
- token (subseq token 1)))
- ((#\$)
- ;; first char #\$ means field
- (setf function-name 'field
- token (subseq token 1)))
- ((#\+)
- ;; first char #\+ adds "add_"
- (setf token (concatenate 'string "add_"
- (subseq token 1))))
- ((#\-)
- ;; first char #\- adds "remove_"
- (setf token (concatenate 'string "remove_"
- (subseq token 1))))))
- ;; find last dot (if any) in token
- (let ((dot-pos (position #\. token :test #'char= :from-end t)))
- (cond (dot-pos
- ;; if there is a dot we have a static invocation and the
- ;; part before the dot is the type name
- (when (= dot-pos (1- (length token)))
- (signal-reader-error stream
- "Dot at end of token."))
- (let ((type-name (subseq token 0 dot-pos))
- (member-name (subseq token (1+ dot-pos))))
- (values member-name function-name type-name)))
- (t
- ;; otherwise it's an instance invocation
- (values token function-name))))))
-
-
-(defun rdnzl-list-reader (stream char)
- (declare (ignore char))
- "The reader function for the RDNZL \[] notation."
- ;; read the first token after the opening bracket with
- ;; READ-RDNZL-TOKEN
- (multiple-value-bind (member-name function-name type-name)
- (read-and-parse-rdnzl-token stream)
- ;; now read rest until #\]
- (let ((args (read-delimited-list #\] stream t)))
- (cond (type-name
- ;; static invocation
- (list* function-name type-name member-name args))
- (t
- ;; instance invocation
- (unless args
- ;; we always need at least one argument - the object
- ;; instance itself
- (signal-reader-error stream
- "Missing arguments after token \"~A~A\"."
- (case function-name
- ((invoke) "")
- ((property) "%")
- ((field) "$"))
- member-name))
- (list* function-name (first args) member-name (rest args)))))))
-
-(defun rdnzl-function-reader (stream char arg)
- "The reader function for the RDNZL #` notation. Always returns a
-function object."
- (declare (ignore char arg))
- (cond ((char= #\( (peek-char nil stream t nil t))
- ;; starts with a left parenthesis, so we expect #`(SETF ...)
- (read-char stream t nil t)
- (let ((symbol (read stream t nil t)))
- (unless (eq symbol 'setf)
- (signal-reader-error stream
- "Expected CL:SETF after \"#`(\""))
- (multiple-value-bind (member-name function-name type-name)
- (read-and-parse-rdnzl-token stream)
- (unless (char= #\) (peek-char t stream t nil t))
- (signal-reader-error stream
- "Expected #\) after \"#`(CL:SETF ~A\"."
- (if type-name
- (concatenate 'string type-name "." member-name)
- member-name)))
- (read-char stream t nil t)
- (cond (type-name
- `(lambda (new-value &rest args)
- (apply #'(setf ,function-name)
- new-value ,type-name ,member-name args)))
- (t
- `(lambda (new-value object &rest args)
- (apply #'(setf ,function-name)
- new-value object ,member-name args)))))))
- (t
- (multiple-value-bind (member-name function-name type-name)
- (read-and-parse-rdnzl-token stream)
- (cond (type-name
- `(lambda (&rest args)
- (apply #',function-name
- ,type-name ,member-name args)))
- (t
- `(lambda (object &rest args)
- (apply #',function-name
- object ,member-name args))))))))
-
-(defun %enable-rdnzl-syntax ()
- "Internal function used to enable reader syntax and store current
-readtable on stack."
- (push *readtable*
- *previous-readtables*)
- (setq *readtable* (copy-readtable))
- (set-syntax-from-char #\] #\) *readtable*)
- ;; make #\[ non-terminating
- (set-macro-character #\[
- #'rdnzl-list-reader)
- (set-dispatch-macro-character #\# #\` #'rdnzl-function-reader)
- (values))
-
-(defun %disable-rdnzl-syntax ()
- "Internal function used to restore previous readtable."
- (if *previous-readtables*
- (setq *readtable* (pop *previous-readtables*))
- (setq *readtable* (copy-readtable nil)))
- (values))
-
-(defmacro enable-rdnzl-syntax ()
- "Enables RDNZL reader syntax."
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (%enable-rdnzl-syntax)))
-
-(defmacro disable-rdnzl-syntax ()
- "Restores the readtable which was active before the last call to
-ENABLE-RDNZL-SYNTAX. If there was no such call, the standard readtable
-is used."
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (%disable-rdnzl-syntax)))
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/reader.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; This file defines the special reader syntax for .NET calls.
+
+(in-package :rdnzl)
+
+(define-condition rdnzl-reader-error (simple-condition reader-error)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "RDNZL reader error: ~?"
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition))))
+ (:documentation "A reader error which can be signalled by ERROR."))
+
+(defmacro signal-reader-error (stream format-control &rest format-arguments)
+ "Like ERROR but signals a SIMPLE-READER-ERROR for the stream
+STREAM."
+ `(error 'rdnzl-reader-error
+ :stream ,stream
+ :format-control ,format-control
+ :format-arguments (list , at format-arguments)))
+
+(defun read-rdnzl-token (stream)
+ "Tries to emulate how the Lisp reader reads a token with standard
+syntax but is case-sensitive. Returns a string."
+ (let ((collector (make-array 0
+ :element-type 'character
+ :fill-pointer t
+ :adjustable t))
+ in-multiple-escape-p
+ in-single-escape-p
+ char-seen-p)
+ (loop
+ (let ((char (peek-char nil stream nil nil t)))
+ (cond (in-multiple-escape-p
+ ;; in multiple escape mode, read everything as is but
+ ;; don't accept EOF
+ (unless char
+ (signal-reader-error stream
+ "End of file while in multiple~
+escape mode \(i.e. after pipe character)."))
+ (read-char stream nil nil t)
+ (cond ((char= char #\|)
+ ;; end of multiple escape mode
+ (setq in-multiple-escape-p nil))
+ (t
+ (vector-push-extend char collector))))
+ (in-single-escape-p
+ ;; single escape mode, i.e. last char was backslash -
+ ;; read next char as is but don't accept EOF
+ (unless char
+ (signal-reader-error stream
+ "End of file while in single~
+escape mode \(i.e. after backslash character)."))
+ (setq in-single-escape-p nil)
+ (read-char stream nil nil t)
+ (vector-push-extend char collector))
+ ((null char)
+ ;; EOF - return what has been read so far
+ (return-from read-rdnzl-token collector))
+ ((and (not char-seen-p)
+ (whitespacep char))
+ ;; skip whitespace after #\[
+ (read-char stream nil nil t))
+ ((char= char #\|)
+ ;; switch to multiple escape mode
+ (setq in-multiple-escape-p t
+ char-seen-p t)
+ (read-char stream nil nil t))
+ ((char= char #\\)
+ ;; switch to single escape mode
+ (setq in-single-escape-p t
+ char-seen-p t)
+ (read-char stream nil nil t))
+ ((or (whitespacep char)
+ (member char '(#\" #\' #\( #\) #\[ #\] #\, #\; #\`)
+ :test #'char=))
+ ;; whitespace or terminating macro character, stop
+ ;; parsing this token
+ (return-from read-rdnzl-token collector))
+ (t
+ ;; otherwise just consume the character
+ (setq char-seen-p t)
+ (read-char stream nil nil t)
+ (vector-push-extend char collector)))))))
+
+(defun read-and-parse-rdnzl-token (stream)
+ "Reads a token like \"%Environment.UserName\" with READ-RDNZL-TOKEN
+and dissects it into its parts \(type name and member name) if
+necessary. Also returns the corresponding function \(INVOKE,
+PROPERTY, or FIELD) from container.lisp."
+ (let ((token (read-rdnzl-token stream))
+ (function-name 'invoke))
+ (when (string= token "")
+ (signal-reader-error stream
+ "Empty token after #\[ character."))
+ (when (and (= (length token) 1)
+ (member (char token 0) '(#\% #\$ #\+ #\-)
+ :test #'char=))
+ (signal-reader-error stream
+ "Illegal token \"~C\" after #\[ character."
+ token))
+ (let ((first-char (char token 0)))
+ (case first-char
+ ((#\%)
+ ;; first char #\% means property
+ (setf function-name 'property
+ token (subseq token 1)))
+ ((#\$)
+ ;; first char #\$ means field
[123 lines skipped]
--- /project/rdnzl/cvsroot/RDNZL/specials.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/specials.lisp 2006/02/01 01:00:56 1.3
@@ -1,99 +1,106 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/specials.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
-
-;;; Copyright (c) 2004-2005, 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.
-
-;;; Global special variables (and constants) used by RDNZL.
-
-(in-package :rdnzl)
-
-(defvar *used-namespaces* nil
- "A list of namespaces which are `used.' See USE-NAMESPACE and
-related functions.")
-
-(defvar *dll-initialized* nil
- "Whether RDNZL.dll was initialized with DllEnsureInit.")
-
-(defconstant +private-assembly-name+ "RDNZLPrivateAssembly"
- "The name of the assembly which is generated at run time to create
-subtypes of DelegateAdapter.")
-
-(defvar *callback-counter* 0
- "The index of the last closure from which a delegate was created -
-or 0 if no delegate has been created yet. Used as a key in the
-*CALLBACK-HASH* hash table.")
-
-(defvar *callback-hash* (make-hash-table)
- "A hash table which maps integers to closures used as delegates -
-see the instance variable indexIntoLisp in DelegateAdapter.cpp.")
-
-(defvar *delegate-counter* 0
- "Counter used to make sure each subtype of DelegateAdapter has a
-unique name.")
-
-(defvar *signature-hash* (make-hash-table :test #'equal)
- "A hash table which maps delegate signatures to subtypes of
-DelegateAdapter so that we only create one such subtype for each
-signature.")
-
-(defvar *type-hash* (make-hash-table :test #'equal)
- "A hash table which maps short type names of `imported' types to
-fully qualified type names \(or to T if the type can be retrieved by
-Type::GetType without a fully qualified name).")
-
-(defvar *direct-definitions* (make-hash-table :test #'equal)
- "Maps function names \(for direct calls) to data structures which
-can be used to re-construct the function.")
-
-(defconstant +whitespace-char-list+
- '(#\Space #\Tab #\Linefeed #\Newline #\Return #\Page)
- "A list of all characters which are considered to be whitespace.")
-
-(defvar *previous-readtables* nil
- "A stack which holds the previous readtables that have been pushed
-here by ENABLE-RDNZL-SYNTAX.")
-
-(pushnew :rdnzl *features*)
-
-;; stuff for Nikodemus Siivola's HYPERDOC
-;; see <http://common-lisp.net/project/hyperdoc/>
-;; and <http://www.cliki.net/hyperdoc>
-
-(defvar *hyperdoc-base-uri* "http://weitz.de/rdnzl/")
-
-(let ((exported-symbols-alist
- (loop for symbol being the external-symbols of :rdnzl
- collect (cons symbol
- (concatenate 'string
- "#"
- (string-downcase symbol))))))
- (defun hyperdoc-lookup (symbol type)
- (declare (ignore type))
- (cdr (assoc symbol
- exported-symbols-alist
- :test #'eq))))
-
\ No newline at end of file
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/specials.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
+
+;;; Copyright (c) 2004-2006, 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.
+
+;;; Global special variables (and constants) used by RDNZL.
+
+(in-package :rdnzl)
+
+#+:sbcl
+(defmacro defconstant (name form &optional documentation)
+ ;; see <http://www.sbcl.org/manual/Defining-Constants.html>
+ `(cl:defconstant ,name
+ (cond ((boundp ',name) (symbol-value ',name))
+ (t ,form))
+ ,@(and documentation (list documentation))))
+
+(defvar *used-namespaces* nil
+ "A list of namespaces which are `used.' See USE-NAMESPACE and
+related functions.")
+
+(defvar *dll-initialized* nil
+ "Whether RDNZL.dll was initialized with DllEnsureInit.")
+
+(defconstant +private-assembly-name+ "RDNZLPrivateAssembly"
+ "The name of the assembly which is generated at run time to create
+subtypes of DelegateAdapter.")
+
+(defvar *callback-counter* 0
+ "The index of the last closure from which a delegate was created -
+or 0 if no delegate has been created yet. Used as a key in the
+*CALLBACK-HASH* hash table.")
+
+(defvar *callback-hash* (make-hash-table)
+ "A hash table which maps integers to closures used as delegates -
+see the instance variable indexIntoLisp in DelegateAdapter.cpp.")
+
+(defvar *delegate-counter* 0
+ "Counter used to make sure each subtype of DelegateAdapter has a
+unique name.")
+
+(defvar *signature-hash* (make-hash-table :test #'equal)
+ "A hash table which maps delegate signatures to subtypes of
+DelegateAdapter so that we only create one such subtype for each
+signature.")
+
+(defvar *type-hash* (make-hash-table :test #'equal)
+ "A hash table which maps short type names of `imported' types to
+fully qualified type names \(or to T if the type can be retrieved by
+Type::GetType without a fully qualified name).")
+
+(defvar *direct-definitions* (make-hash-table :test #'equal)
+ "Maps function names \(for direct calls) to data structures which
+can be used to re-construct the function.")
+
+(defconstant +whitespace-char-list+
+ '(#\Space #\Tab #\Linefeed #\Newline #\Return #\Page)
+ "A list of all characters which are considered to be whitespace.")
+
+(defvar *previous-readtables* nil
+ "A stack which holds the previous readtables that have been pushed
+here by ENABLE-RDNZL-SYNTAX.")
+
+(pushnew :rdnzl *features*)
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see <http://common-lisp.net/project/hyperdoc/>
+;; and <http://www.cliki.net/hyperdoc>
+
+(defvar *hyperdoc-base-uri* "http://weitz.de/rdnzl/")
+
+(let ((exported-symbols-alist
+ (loop for symbol being the external-symbols of :rdnzl
+ collect (cons symbol
+ (concatenate 'string
+ "#"
+ (string-downcase symbol))))))
+ (defun hyperdoc-lookup (symbol type)
+ (declare (ignore type))
+ (cdr (assoc symbol
+ exported-symbols-alist
+ :test #'eq))))
--- /project/rdnzl/cvsroot/RDNZL/util.lisp 2005/07/08 18:45:34 1.2
+++ /project/rdnzl/cvsroot/RDNZL/util.lisp 2006/02/01 01:00:56 1.3
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
-;;; $Header: /project/rdnzl/cvsroot/RDNZL/util.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $
+;;; $Header: /project/rdnzl/cvsroot/RDNZL/util.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $
-;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved.
+;;; Copyright (c) 2004-2006, 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
--- /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp 2006/02/01 01:00:57 NONE
+++ /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp 2006/02/01 01:00:57 1.1
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp,v 1.1 2006/02/01 01:00:56 eweitz Exp $
;;; Copyright (c) 2004-2006, 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.
;;; SBCL-specific definitions
(in-package :rdnzl)
(defconstant +ffi-pointer-size+
#.(/ (sb-alien:alien-size sb-alien:system-area-pointer) 8)
"The size of a pointer in octets.")
(defmacro ffi-register-module (path &optional (module-name path))
"Loads a C library designated by PATH."
(declare (ignore module-name))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-alien:load-shared-object ,path)))
(defun ffi-pointer-p (object)
"Tests whether OBJECT is an FFI pointer."
(sb-sys:system-area-pointer-p object))
(defun ffi-null-pointer-p (pointer)
"Returns whether the FFI pointer POINTER is a null pointer."
(zerop (sb-sys:sap-int pointer)))
(defun ffi-pointer-address (pointer)
"Returns the address of the FFI pointer POINTER."
(sb-sys:sap-int pointer))
(defun ffi-map-type (type-name)
"Maps type names like FFI-INTEGER to their corresponding names in
the LispWorks FLI."
(ecase type-name
(ffi-void 'sb-alien:void)
(ffi-void-pointer 'sb-alien:system-area-pointer)
(ffi-const-string 'sb-alien:system-area-pointer)
(ffi-integer 'sb-alien:int)
(ffi-wide-char 'sb-alien:unsigned-short)
(ffi-float 'sb-alien:single-float)
(ffi-double 'sb-alien:double-float)))
(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 ((eq result-type 'ffi-boolean)
(with-unique-names (inner-fn)
`(progn
(ffi-define-function* (,inner-fn ,c-name)
,arg-list
ffi-integer)
(defun ,lisp-name ,(mapcar #'first arg-list)
(not (zerop (,inner-fn ,@(mapcar #'first arg-list))))))))
((find 'ffi-boolean arg-list :key #'second)
(with-unique-names (inner-fn)
`(progn
(ffi-define-function* (,inner-fn ,c-name)
,(mapcar (lambda (name-and-type)
(destructuring-bind (name type) name-and-type
(if (eq type 'ffi-boolean)
(list name 'ffi-integer)
name-and-type)))
arg-list)
,result-type)
(defun ,lisp-name ,(mapcar #'first arg-list)
(,inner-fn ,@(mapcar (lambda (name-and-type)
(destructuring-bind (name type) name-and-type
(if (eq type 'ffi-boolean)
`(if ,name 1 0)
name)))
arg-list))))))
(t `(sb-alien:define-alien-routine
(,c-name ,lisp-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)))))
(defvar *callbacks* (make-hash-table)
"A hash table which maps symbols \(function names) to
callbacks.")
(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."
`(setf (gethash ',c-name *callbacks*)
(sb-alien:alien-sap
(sb-alien::alien-lambda ,(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)
, at body))))
(defun ffi-make-pointer (name)
"Returns an FFI pointer to the \(callback) address specified by
the name NAME."
(gethash name *callbacks*))
(defun ffi-alloc (size)
"Allocates an `alien' of size SIZE octets and returns a pointer
to it. Must be freed with FFI-FREE afterwards."
(sb-alien:alien-sap
(sb-alien:make-alien (sb-alien:unsigned 8) size)))
(defun ffi-free (pointer)
"Frees space that was allocated with FFI-ALLOC."
(sb-alien:free-alien
(sb-alien:sap-alien pointer (* (sb-alien:unsigned 8)))))
(defun ffi-convert-from-foreign-ucs-2-string (pointer size)
"Converts the foreign UCS-2 string pointed to by POINTER of
size SIZE octets to a Lisp string."
(with-output-to-string (out)
(loop for i from 0 below size by 2
do (write-char (code-char
(+ (sb-sys:sap-ref-8 pointer i)
(ash (sb-sys:sap-ref-8 pointer (1+ i)) 8)))
out))))
(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 (* 2 (,length-function ,object)))
,temp)
(unwind-protect
(progn
(setq ,temp (ffi-alloc (+ 2 ,length)))
(,function ,object ,temp)
(ffi-convert-from-foreign-ucs-2-string ,temp ,length))
(when ,temp
(ffi-free ,temp)))))))
(defmacro with-ucs-2-string ((var lisp-string) &body body)
"Converts the Lisp string LISP-STRING to a foreign string using
UCS-2 encoding and evaluates BODY with VAR bound to this foreign
string."
(with-unique-names (size char char-code i)
`(let (,var)
(unwind-protect
(let ((,size (* 2 (length ,lisp-string))))
(setq ,var (ffi-alloc (+ 2 ,size)))
(loop for ,i from 0 by 2
for ,char across ,lisp-string
for ,char-code = (char-code ,char)
do (setf (sb-sys:sap-ref-8 ,var ,i) (ldb (byte 8 0) ,char-code)
(sb-sys:sap-ref-8 ,var (1+ ,i)) (ldb (byte 8 8) ,char-code)))
(setf (sb-sys:sap-ref-8 ,var ,size) 0
(sb-sys:sap-ref-8 ,var (1+ ,size)) 0)
, at body)
(when ,var
(ffi-free ,var))))))
(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-ucs-2-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 j
arg-pointer foreign-name)
(declare (ignorable foreign-name))
`(let* ((,length (length ,args))
(,arg-pointers (make-array ,length :initial-element nil))
,ffi-arg-pointers)
(unwind-protect
(progn
(setq ,ffi-arg-pointers
(ffi-alloc
(* ,length +ffi-pointer-size+)))
(loop for ,arg in ,args
for ,i from 0
for ,j from 0 by +ffi-pointer-size+
for ,arg-pointer = (cond
((container-p ,arg) (pointer ,arg))
(t (setf (aref ,arg-pointers ,i)
(box* ,arg))))
do (setf (sb-sys:sap-ref-sap ,ffi-arg-pointers ,j)
,arg-pointer))
,(cond (name
`(with-ucs-2-string (,foreign-name ,name)
(,function ,foreign-name
,object
,length
,ffi-arg-pointers)))
(t `(,function ,object
,length
,ffi-arg-pointers))))
(when ,ffi-arg-pointers
(ffi-free ,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 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 SBCL
(declare (ignore function name)))
(defun full-gc ()
"Invokes a full garbage collection."
(sb-ext:gc :full t))
More information about the Rdnzl-cvs
mailing list