[rdnzl-cvs] r5 - in trunk/rdnzl: . doc examples
eweitz at common-lisp.net
eweitz at common-lisp.net
Wed Apr 30 08:28:05 UTC 2008
Author: eweitz
Date: Wed Apr 30 04:28:03 2008
New Revision: 5
Added:
trunk/rdnzl/CHANGELOG.txt (contents, props changed)
trunk/rdnzl/RDNZL.dll (contents, props changed)
trunk/rdnzl/README.txt (contents, props changed)
trunk/rdnzl/adapter.lisp (contents, props changed)
trunk/rdnzl/arrays.lisp (contents, props changed)
trunk/rdnzl/container.lisp (contents, props changed)
trunk/rdnzl/direct.lisp (contents, props changed)
trunk/rdnzl/doc/
trunk/rdnzl/doc/apropos.png (contents, props changed)
trunk/rdnzl/doc/box.png (contents, props changed)
trunk/rdnzl/doc/box2.png (contents, props changed)
trunk/rdnzl/doc/index.html (contents, props changed)
trunk/rdnzl/examples/
trunk/rdnzl/examples/AproposGui.cs (contents, props changed)
trunk/rdnzl/examples/AproposGui.dll (contents, props changed)
trunk/rdnzl/examples/Callback.cs (contents, props changed)
trunk/rdnzl/examples/Callback.dll (contents, props changed)
trunk/rdnzl/examples/apropos.lisp (contents, props changed)
trunk/rdnzl/examples/apropos2.lisp (contents, props changed)
trunk/rdnzl/examples/callback.lisp (contents, props changed)
trunk/rdnzl/examples/deliver-acl.lisp (contents, props changed)
trunk/rdnzl/examples/deliver-ccl.lisp (contents, props changed)
trunk/rdnzl/examples/deliver-lw.lisp (contents, props changed)
trunk/rdnzl/examples/example.xls (contents, props changed)
trunk/rdnzl/examples/excel.lisp (contents, props changed)
trunk/rdnzl/examples/messagebox.lisp (contents, props changed)
trunk/rdnzl/examples/url.lisp (contents, props changed)
trunk/rdnzl/ffi.lisp (contents, props changed)
trunk/rdnzl/import.lisp (contents, props changed)
trunk/rdnzl/load.lisp (contents, props changed)
trunk/rdnzl/packages.lisp (contents, props changed)
trunk/rdnzl/port-acl.lisp (contents, props changed)
trunk/rdnzl/port-ccl.lisp (contents, props changed)
trunk/rdnzl/port-clisp.lisp (contents, props changed)
trunk/rdnzl/port-ecl.lisp (contents, props changed)
trunk/rdnzl/port-lw.lisp (contents, props changed)
trunk/rdnzl/port-sbcl.lisp (contents, props changed)
trunk/rdnzl/rdnzl.asd (contents, props changed)
trunk/rdnzl/reader.lisp (contents, props changed)
trunk/rdnzl/specials.lisp (contents, props changed)
trunk/rdnzl/util.lisp (contents, props changed)
Log:
Import 0.12.2
Added: trunk/rdnzl/CHANGELOG.txt
==============================================================================
--- (empty file)
+++ trunk/rdnzl/CHANGELOG.txt Wed Apr 30 04:28:03 2008
@@ -0,0 +1,174 @@
+Version 0.12.2
+2008-03-25
+Added section about generic types to documentation (thanks to Iver Odin Kvello)
+Added link to DataGridView example code by Matthew O'Connor
+
+Version 0.12.1
+2008-02-19
+Now based on DLL version 0.7.1 which fixes <http://common-lisp.net/pipermail/rdnzl-devel/2008-February/000198.html>
+
+Version 0.12.0
+2008-02-14
+Now based on DLL version 0.7.0 which fixes <http://common-lisp.net/pipermail/rdnzl-devel/2008-February/000184.html>
+Added tests for callbacks in examples folder
+Integrated Iver Odin Kvello's code for generic types (see <http://common-lisp.net/pipermail/rdnzl-devel/2008-February/000193.html>)
+
+Version 0.11.2
+2008-01-26
+Increased value of *FFI-ARGS-SIZE* from 10 to 20 (see <http://common-lisp.net/pipermail/rdnzl-devel/2008-January/000177.html>)
+
+Version 0.11.1
+2007-12-30
+Fixed bug in Excel example
+
+Version 0.11.0
+2007-05-18
+Added COPY-CONTAINER (patch by Iver Odin Kvello)
+Modified CAST to work with types loaded with LoadFrom (patch by Iver Odin Kvello)
+Updated DLL to version 0.6.0
+
+Version 0.10.9
+2007-04-27
+Fixed bug in IMPORT-ASSEMBLY (patch by Iver Odin Kvello)
+Added link to example by Richard Fateman
+
+Version 0.10.8
+2006-10-17
+AllegroCL: clean up external-format initialization (Charles A. Cox)
+AllgeroCL: enable RDNZL to run without locking out the rest of Lisp (Charles A. Cox)
+
+Version 0.10.7
+2006-09-27
+Added FFI-MAKE-NULL-POINTER to all ports
+Reset Lisp callback pointers on exit (suggested by Michael Goffioul)
+Updated DLL to version 0.5.2
+
+Version 0.10.6
+2006-09-15
+Updated DLL to version 0.5.1
+
+Version 0.10.5
+2006-09-14
+Fixed bug in reader syntax (reported by Michael Goffioul)
+
+Version 0.10.4
+2006-09-04
+Fixed typo in apropos.lisp (reported by Dean O'Connor)
+
+Version 0.10.3
+2006-08-25
+Added Excel example
+Fixed bug in AREF*
+Changed package handling in system definition (thanks to Christophe Rhodes)
+
+Version 0.10.2
+2006-08-10
+More DSPEC definitions for LispWorks
+
+Version 0.10.1
+2006-08-10
+DSPEC definitions for LispWorks
+
+Version 0.10.0
+2006-06-12
+ECL port (provided by Michael Goffioul)
+
+Version 0.9.5
+2006-05-24
+Fixed delivery scripts and IMPORT statement for LW
+
+Version 0.9.4
+2006-02-18
+Fixed LW SINGLE-FLOAT issues (detective work by Dan Muller)
+
+Version 0.9.3
+2006-02-17
+Added *COERCE-DOUBLE-FLOATS-TO-SINGLE*
+
+Version 0.9.2
+2006-02-13
+One can now call static methods from specific assemblies (thanks to Jim Sokoloff)
+
+Version 0.9.1
+2006-02-01
+Added missing WIDE-CHAR support for SBCL/Win32
+
+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)
+Updated to DLL version 0.5.0
+
+Version 0.7.1
+2005-11-21
+Updated to DLL version 0.4.1
+
+Version 0.7.0
+2005-07-08
+In WRAP-CLOSURE, prevent callbacks from being able to throw over .NET stack frames (Charles A. Cox)
+Modify UNMANGLE-NAME to work in case-preserving readtable-case mode (Charles A. Cox)
+Don't redefine in util.lisp what's already there (for LispWorks)
+
+Version 0.6.1
+2005-01-03
+Make sure SETF accessors in direct.lisp return NEW-VALUE (sigh...)
+
+Version 0.6.0
+2005-01-03
+Support for "direct calls"
+Fixed typo (forgot RESOLVE-TYPE-NAME) in FIELD
+Fixed thinko in OR-ENUMS
+Make sure SETF accessors in container.lisp return NEW-VALUE
+
+Version 0.5.1
+2004-12-28
+Make delivery examples for CCL and LW self-contained like Charley's AllegroCL example
+
+Version 0.5.0
+2004-12-28
+Corman Lisp port now works (thanks to Roger Corman)
+Added delivery examples for AllegroCL (by Charles A. Cox) and Corman Lisp
+
+Version 0.4.5
+2004-12-27
+Cosmetic changes in AproposGUI.cs
+
+Version 0.4.4
+2004-12-24
+Added correct external encoding to :EF-WC-STRING type in port-lw.lisp (caught by Francisco Rivera)
+Changed some code examples from LW to AllegroCL
+
+Version 0.4.3
+2004-12-23
+Argh!!! Version 0.4.2 included a defective DLL due to a typo
+
+Version 0.4.2
+2004-12-23
+Added better support for System.Single (thanks to Vasilis Margioulas)
+
+Version 0.4.1
+2004-12-22
+Some cleanup in docs
+All text files now have DOS line endings
+[Re-sync with my CVS tree (laptop was broken while 0.4.0 was released)]
+
+Version 0.4.0
+2004-12-21
+Preliminary CLISP port (provided by Vasilis Margioulas)
+CRLF output for AllegroCL (thanks to Charles A. Cox)
+[Some files have wrong CVS headers - this'll be fixed in the next version]
+
+Version 0.3.0
+2004-12-18
+Port to AllegroCL (provided by Charles A. Cox)
+
+Version 0.2.0
+2004-12-17
+Added proper handling of pass-by-reference calls (thanks again to Pedro Pinto)
+
+Version 0.1.0
+2004-12-16
+Initial public release
Added: trunk/rdnzl/RDNZL.dll
==============================================================================
Binary file. No diff available.
Added: trunk/rdnzl/README.txt
==============================================================================
--- (empty file)
+++ trunk/rdnzl/README.txt Wed Apr 30 04:28:03 2008
@@ -0,0 +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>.
Added: trunk/rdnzl/adapter.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/adapter.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,109 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/adapter.lisp,v 1.30 2008/01/26 22:28:30 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+(in-package :rdnzl)
+
+(enable-rdnzl-syntax)
+
+(defun wrap-closure (closure return-type arg-types)
+ "Generates and returns a wrapper for the Lisp function CLOSURE such
+that it can be used as a .NET delegate with the return type
+RETURN-TYPE and argument types as in the array ARG-TYPE-ARRAY. Both
+RETURN-TYPE and ARG-TYPE-ARRAY are DOT-NET-OBJECTs."
+ (let ((arg-type-names (map 'vector #`%AssemblyQualifiedName arg-types))
+ ;; remember if the delegate doesn't return a result
+ (void-result-p [Equals return-type
+ (make-type-from-name "System.Void")]))
+ ;; wrapper starts here
+ (lambda (args-pointer &aux completed)
+ (unwind-protect
+ (prog1
+ (let ((i 0)
+ args)
+ ;; loop through the array of arguments and cast each one
+ ;; to the expected type, convert to native Lisp types if
+ ;; appropriate
+ (do-rdnzl-array (arg (wrap-with-container args-pointer))
+ (cast* arg (aref arg-type-names i))
+ (incf i)
+ (push (unbox arg) args))
+ ;; call the actual function
+ (let ((result (apply closure (nreverse args))))
+ (pointer
+ (cond (void-result-p
+ ;; return a dummy System.Void object in case
+ ;; the delegate doesn't return anything
+ (make-null-object* "System.Void"))
+ (t
+ ;; otherwise wrap the result
+ (ensure-container result))))))
+ (setq completed t))
+ ;; block throw attempts
+ (unless completed
+ (labels ((block-throw (&aux (block t))
+ (unwind-protect
+ (restart-case
+ (error "Cannot safely throw over a .NET -> Lisp callback.")
+ (continue-throw ()
+ :report "Continue throw anyway."
+ (setq block nil)))
+ (when block
+ (block-throw)))))
+ (block-throw)))))))
+
+(defun make-adapter (closure return-type arg-types)
+ "Creates, if necessary, a subtype of DelegateAdapter \(see C++ code)
+matching the signature determined by RETURN-TYPE \(a CONTAINER) and
+ARG-TYPES \(a list of CONTAINERs). Then creates and returns a new
+instance of this type which is used to wrap the Lisp closure CLOSURE."
+ (let* ((arg-type-array (list-to-rdnzl-array arg-types
+ (make-type-from-name "System.Type")))
+ ;; the signature is a tupel of the return type's name and the
+ ;; names of the argument types
+ (signature (mapcar #`%AssemblyQualifiedName
+ (cons return-type arg-types)))
+ ;; first check if we have already cached a type for this
+ ;; signature, otherwise create it (via a call into RDNZL.dll)
+ (delegate-type (or (gethash signature *signature-hash*)
+ (setf (gethash signature *signature-hash*)
+ (build-delegate-type (format nil "_LispCallback_~A"
+ (incf *delegate-counter*))
+ return-type
+ arg-type-array)))))
+ (let ((delegate-instance (new delegate-type)))
+ ;; initialize the new instance by informing it about the index
+ ;; number of this callback
+ [init delegate-instance (incf *callback-counter*)]
+ ;; wrap the Lisp closure with the code for argument marshalling
+ ;; and store it using the same index number
+ (setf (gethash *callback-counter* *callback-hash*)
+ (wrap-closure closure return-type arg-types))
+ delegate-instance)))
+
+(disable-rdnzl-syntax)
Added: trunk/rdnzl/arrays.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/arrays.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,119 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/arrays.lisp,v 1.29 2008/02/14 10:33:51 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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 (property ,array "Length")))
+ (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)))
+ ;; VALUE might be NULL pointer, so check for NIL before unboxing
+ (and value (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, a string, or a tree of strings) and rank 1 with the
+elements from the Lisp list LIST."
+ (when (or (stringp base-type)
+ (consp 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 (nreverse list))
+ (push element 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 (or (stringp type)(consp 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)
Added: trunk/rdnzl/container.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/container.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,531 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/container.lisp,v 1.52 2008/02/14 11:38:45 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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)
+ (:copier 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))
+ ;; generic types denoted by trees
+ ((consp typespec) (list 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
+ #-:sbcl
+ (flag-for-finalization ,container
+ #'maybe-free-container-pointer)
+ #+:sbcl
+ (sb-ext:finalize ,container
+ (lambda ()
+ (%free-dot-net-container ,pointer)))))))))
+
+(defun make-type-from-name (name)
+ "Returns the .NET type with the name NAME - uses the static function
+Type::GetType. If NAME is a tree of strings, it is interpreted as a
+generic type using Type::GetType on each `leaf' type and producing the
+type using Type::MakeGenericType."
+ (cond ((stringp name)
+ (wrap-with-container
+ (ffi-call-with-foreign-string* %make-type-from-name
+ name)))
+ (t (let* ((types (mapcar #'make-type-from-name name))
+ (base-type (car types))
+ (parameter-types (cdr types)))
+ (invoke base-type "MakeGenericType"
+ (list-to-rdnzl-array parameter-types "System.Type"))))))
+
+(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
+ (cond (*coerce-double-floats-to-single*
+ (%make-dot-net-container-from-float object))
+ (t
+ (%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))))))
+
+(defun make-type-from-assembly-and-name (assembly name)
+ "Returns the .NET type with the name NAME from a specific assembly.
+If NAME is a tree, it is assumed a generic type is requested, but the
+type parameters are resolved normally."
+ (let* ((base-name (if (stringp name)
+ name
+ (concatenate 'string (car name)
+ (format nil "`~D" (length (cdr name))))))
+ (base-type
+ (ffi-call-with-args %invoke-instance-member
+ assembly "GetType" (list base-name))))
+ (cond ((stringp name) base-type)
+ (t (let ((parameter-types (mapcar #'make-type-from-name
+ (mapcar #'resolve-type-name (rest name)))))
+ (invoke base-type "MakeGenericType"
+ (list-to-rdnzl-array parameter-types "System.Type")))))))
+
+;; 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 which will be looked up using
+System.Type::GetType. If OBJECT is a tree of strings, then the method
+should be a static method of the generic type named OBJECT, with ARGS
+being the parameters of the type. Otherwise, OBJECT should be a pair
+where the first element is a CONTAINER representing an assembly and
+the second element is a string \(or a tree of strings) denoting a type
+\(possibly generic), for which METHOD-NAME denotes a static method
+\(which will be looked up in that specific assembly). 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))
+ ((or (stringp object)
+ (and (consp object)
+ (stringp (car object))))
+ (ffi-call-with-args %invoke-static-member
+ (make-type-from-name (resolve-type-name object))
+ method-name
+ args))
+ ((and (consp object)
+ (container-p (car object))
+ (or (stringp (cdr object))
+ (consp (cdr object))))
+ (ffi-call-with-args %invoke-static-member
+ (make-type-from-assembly-and-name (car object) (cdr 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))
+ ((or (stringp object)
+ (consp 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)))
+ ((or (stringp object)
+ (consp 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))
+ ((or (stringp object)
+ (consp 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))
+ ((or (stringp object)(consp 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)
+
+(defun invoke-constructor (type &rest args)
+ "Invokes the constructor \(corresponding to the signature determined
+by ARGS) of the .NET type TYPE \(a CONTAINER). ARGS (either CONTAINER
+structures or Lisp objects which can be converted) are the arguments
+to this constructor."
+ (ffi-call-with-args %invoke-constructor
+ type
+ nil
+ args))
+
+(defun get-array-element (array index)
+ "Shortcut for fast access to elements of .NET arrays with rank 1.
+Used only internally by DO-RDNZL-ARRAY."
+ (get-invocation-result
+ (%get-array-element (pointer array)
+ index)))
+
+(defun cast* (container type-name)
+ "Like CAST but doesn't try to resolve TYPE-NAME. TYPE-NAME must be
+a string."
+ (ffi-call-with-foreign-string %set-dot-net-container-type-from-string
+ type-name
+ container)
+ container)
+
+(defun cast-to-type-object (container type)
+ "Like CAST, but assumes TYPE is a TYPE object. Unlike CAST*, will
+work with types loaded in a LoadFrom context."
+ (ffi-call-with-foreign-string %set-dot-net-container-type-from-container
+ nil
+ type
+ container)
+ container)
+
+(defun cast (container type)
+ "Changes the type of the DotNetContainer object represented by
+CONTAINER to TYPE \(a string, tree of strings, or a CONTAINER).
+Returns CONTAINER."
+ (cond ((stringp type) (cast* container (resolve-type-name type)))
+ ((consp type)
+ (cast-to-type-object container
+ (make-type-from-name (resolve-type-name type))))
+ (t (cast-to-type-object container type))))
+
+(defun copy-container (container)
+ "Creates and returns a copy of the DotNetContainer object
+representend by CONTAINTER."
+ (wrap-with-container
+ (%copy-dot-net-container (pointer container))))
+
+(defun make-null-object* (type-name)
+ "Creates a NULL DotNetContainer with the type named by the string
+TYPE-NAME."
+ (wrap-with-container
+ (ffi-call-with-foreign-string* %make-typed-null-dot-net-container
+ type-name)))
+
+(defun make-null-object (type-name)
+ "Like MAKE-NULL-OBJECT* but resolves TYPE-NAME first."
+ (cond ((stringp type-name)
+ (make-null-object* (resolve-type-name type-name)))
+ (t (make-null-object*
+ (property
+ (make-type-from-name
+ (resolve-type-name type-name))
+ "AssemblyQualifiedName")))))
+
+
+(defun build-delegate-type (type-name return-type arg-type-array)
+ "Build a subtype of DelegateAdapter \(see C++ code) with the
+corresponding signature. TYPE-NAME \(a string) will be the name of
+the new type, the other two arguments are CONTAINERs."
+ (wrap-with-container
+ (ffi-call-with-foreign-string* %build-delegate-type
+ type-name
+ (list return-type
+ arg-type-array))))
\ No newline at end of file
Added: trunk/rdnzl/direct.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/direct.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,301 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/direct.lisp,v 1.12 2008/01/26 22:28:30 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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))))
+ #+:lispworks
+ ;; record location of definition for IDE
+ (dspec:record-definition '(define-rdnzl-call ,lisp-name)
+ (dspec:location))
+ ',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)
Added: trunk/rdnzl/doc/apropos.png
==============================================================================
Binary file. No diff available.
Added: trunk/rdnzl/doc/box.png
==============================================================================
Binary file. No diff available.
Added: trunk/rdnzl/doc/box2.png
==============================================================================
Binary file. No diff available.
Added: trunk/rdnzl/doc/index.html
==============================================================================
--- (empty file)
+++ trunk/rdnzl/doc/index.html Wed Apr 30 04:28:03 2008
@@ -0,0 +1,1259 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <title>RDNZL - A .NET layer for Common Lisp</title>
+ <style type="text/css">
+ pre { padding:5px; background-color:#e0e0e0 }
+ h3, h4 { text-decoration: underline; }
+ a { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; }
+ a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
+ a.none { text-decoration: none; padding: 0; }
+ a.none:visited { text-decoration: none; padding: 0; }
+ a.none:hover { text-decoration: none; border: none; padding: 0; }
+ a.none:focus { text-decoration: none; border: none; padding: 0; }
+ a.noborder { text-decoration: none; padding: 0; }
+ a.noborder:visited { text-decoration: none; padding: 0; }
+ a.noborder:hover { text-decoration: none; border: none; padding: 0; }
+ a.noborder:focus { text-decoration: none; border: none; padding: 0; }
+ pre.none { padding:5px; background-color:#ffffff }
+ </style>
+</head>
+
+<body bgcolor=white>
+
+<h2>RDNZL - A .NET layer for Common Lisp</h2>
+
+<blockquote>
+<br> <br><h3><a name=abstract class=none>Abstract</a></h3>
+
+<a href="http://globalia.net/donlope/fz/songs/RDNZL.html">RDNZL</a> (pronounced "Redunzl") enables Common Lisp applications to interact with <a href="http://en.wikipedia.org/wiki/Microsoft_.NET_Framework">.NET</a>
+libraries. It's more or less a foreign function interface for .NET
+languages like <a href="http://en.wikipedia.org/wiki/C_Sharp_programming_language">C#</a> built atop the C foreign function interface.
+
+<p>
+
+RDNZL comes with a <a
+href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
+license</a> so you can basically do with it whatever you want.
+
+<p>
+<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/rdnzl.tar.gz">http://weitz.de/files/rdnzl.tar.gz</a>.
+
+</blockquote>
+
+<center>
+<a class=none alt="Apropos Example" title="Apropos Example" href="#apropos"><img src="apropos.png" border=0 width=624 height=411></a>
+</center>
+
+<br> <br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+ <li><a href="#examples">Examples</a>
+ <li><a href="#download">Download and installation</a>
+ <li><a href="#mail">Support and mailing lists</a>
+ <li><a href="#implementations">Supported Lisp implementations</a>
+ <li><a href="#dictionary">The RDNZL dictionary</a>
+ <ol>
+ <li><a href="#objects">Representation and creation of .NET objects</a>
+ <ol>
+ <li><a href="#container-p"><code>container-p</code></a>
+ <li><a href="#box"><code>box</code></a>
+ <li><a href="#unbox"><code>unbox</code></a>
+ <li><a href="#new"><code>new</code></a>
+ <li><a href="#cast"><code>cast</code></a>
+ <li><a href="#copy-container"><code>copy-container</code></a>
+ <li><a href="#make-null-object"><code>make-null-object</code></a>
+ <li><a href="#*coerce-double-floats-to-single*"><code>*coerce-double-floats-to-single*</code></a>
+ </ol>
+ <li><a href="#methods">Accessing .NET methods, properties, and fields</a>
+ <ol>
+ <li><a href="#invoke"><code>invoke</code></a>
+ <li><a href="#property"><code>property</code></a>
+ <li><a href="#field"><code>field</code></a>
+ <li><a href="#ref"><code>ref</code></a>
+ </ol>
+ <li><a href="#arrays">Arrays and enumerations</a>
+ <ol>
+ <li><a href="#aref*"><code>aref*</code></a>
+ <li><a href="#do-rdnzl-array"><code>do-rdnzl-array</code></a>
+ <li><a href="#list-to-rdnzl-array"><code>list-to-rdnzl-array</code></a>
+ <li><a href="#rdnzl-array-to-list"><code>rdnzl-array-to-list</code></a>
+ <li><a href="#integer-to-enum"><code>integer-to-enum</code></a>
+ <li><a href="#enum-to-integer"><code>enum-to-integer</code></a>
+ <li><a href="#or-enums"><code>or-enums</code></a>
+ </ol>
+ <li><a href="#exceptions">Handling of .NET exceptions</a>
+ <ol>
+ <li><a href="#rdnzl-error"><code>rdnzl-error</code></a>
+ <li><a href="#rdnzl-error-exception"><code>rdnzl-error-exception</code></a>
+ <li><a href="#rdnzl-handler-case"><code>rdnzl-handler-case</code></a>
+ </ol>
+ <li><a href="#types">Type names and assemblies</a>
+ <ol>
+ <li><a href="#import-type"><code>import-type</code></a>
+ <li><a href="#load-assembly"><code>load-assembly</code></a>
+ <li><a href="#import-assembly"><code>import-assembly</code></a>
+ <li><a href="#import-types"><code>import-types</code></a>
+ <li><a href="#use-namespace"><code>use-namespace</code></a>
+ <li><a href="#unuse-namespace"><code>unuse-namespace</code></a>
+ <li><a href="#unuse-all-namespaces"><code>unuse-all-namespaces</code></a>
+ </ol>
+ <li><a href="#reader">Special reader syntax</a>
+ <ol>
+ <li><a href="#enable-rdnzl-syntax"><code>enable-rdnzl-syntax</code></a>
+ <li><a href="#disable-rdnzl-syntax"><code>disable-rdnzl-syntax</code></a>
+ </ol>
+ <li><a href="#direct">Direct calls</a>
+ <ol>
+ <li><a href="#define-rdnzl-call"><code>define-rdnzl-call</code></a>
+ </ol>
+ <li><a href="#delivery">Saving images and application delivery</a>
+ <ol>
+ <li><a href="#shutdown-rdnzl"><code>shutdown-rdnzl</code></a>
+ <li><a href="#init-rdnzl"><code>init-rdnzl</code></a>
+ </ol>
+ </ol>
+ <li><a href="#generic">Generic types</a>
+ <li><a href="#details">Implementation details and things to watch out for</a>
+ <li><a href="#ack">Acknowledgements</a>
+</ol>
+
+<br> <br><h3><a class=none name="examples">Examples</a></h3>
+
+Here's a short example session (using <a href="#implementations">AllegroCL</a>):
+
+<pre>
+<img alt="The Message Box" title="The Message Box" align=right border=0 vspace=10 hspace=10 width=185 height=100 src="box.png">CL-USER 1 > <a class=noborder href="#download">(load "/home/lisp/RDNZL/load.lisp")</a>
+<font color=orange>; Loading C:\home\lisp\RDNZL\load.lisp
+; Fast loading C:\home\lisp\RDNZL\packages.fasl
+; Fast loading C:\home\lisp\RDNZL\specials.fasl
+; Fast loading C:\home\lisp\RDNZL\util.fasl
+; Fast loading C:\home\lisp\RDNZL\port-acl.fasl
+; Fast loading from bundle code\IORDEFS.fasl.
+; Fast loading from bundle code\EFMACS.fasl.
+; Fast loading C:\home\lisp\RDNZL\ffi.fasl
+; Foreign loading RDNZL.dll.
+; Fast loading C:\home\lisp\RDNZL\container.fasl
+; Fast loading C:\home\lisp\RDNZL\reader.fasl
+; Fast loading C:\home\lisp\RDNZL\arrays.fasl
+; Fast loading C:\home\lisp\RDNZL\adapter.fasl
+; Fast loading C:\home\lisp\RDNZL\import.fasl</font>
+T
+CL-USER 2 > (in-package :rdnzl-user)
+#<The RDNZL-USER package>
+RDNZL-USER 3 > (<a class=noborder href="#enable-rdnzl-syntax">enable-rdnzl-syntax</a>)
+RDNZL-USER 4 > (<a class=noborder href="#import-types">import-types</a> "System.Windows.Forms"
+ "MessageBox" "MessageBoxButtons" "DialogResult")
+NIL
+RDNZL-USER 5 > (<a class=noborder href="#use-namespace">use-namespace</a> "System.Windows.Forms")
+RDNZL-USER 6 > (defun message-box (text &optional (caption "RDNZL"))
+ <font color=orange>;; check if the "OK" button was pressed</font>
+ [Equals [MessageBox.Show text caption
+ <font color=orange>;; we want the message box to have "OK" and "Cancel" buttons</font>
+ [$MessageBoxButtons.OKCancel]]
+ [$DialogResult.OK]])
+MESSAGE-BOX
+RDNZL-USER 7 > (message-box "Hello World!") <font color=orange>;; user presses "OK" button</font>
+T
+RDNZL-USER 8 > (message-box "Hello World!") <font color=orange>;; user presses "Cancel" button</font>
+NIL
+</pre>
+
+(Note: All examples shown here are included in the <code>examples</code> folder of the distribution.)
+<p>
+For a more interesting example which interacts with custom .NET code
+and demonstrates callbacks into Lisp consider the .NET library
+<code>AproposGUI.dll</code> (put it into your Lisp's application folder or <a href="http://common-lisp.net/pipermail/rdnzl-devel/2008-February/000192.html">use this technique</a>) created
+with this C# code:
+
+<pre>
+// compile this with:
+// csc.exe /target:library AproposGui.cs
+
+using System;
+using System.Collections;
+using System.ComponentModel;
+using System.Drawing;
+using System.Data;
+using System.Windows.Forms;
+
+namespace AproposGUI {
+ public class AproposControl : System.Windows.Forms.UserControl {
+ public System.Windows.Forms.TextBox textBox;
+ public System.Windows.Forms.TextBox listBox;
+ private System.Windows.Forms.Label label;
+ public System.Windows.Forms.Label title;
+ private delegate string callback(string input);
+
+ private System.ComponentModel.Container components = null;
+
+ public AproposControl() {
+ InitializeComponent();
+ }
+
+ protected override void Dispose(bool disposing) {
+ if (disposing) {
+ if (components != null)
+ components.Dispose();
+ }
+ base.Dispose(disposing);
+ }
+
+ private void InitializeComponent() {
+ this.textBox = new System.Windows.Forms.TextBox();
+ this.listBox = new System.Windows.Forms.TextBox();
+ this.label = new System.Windows.Forms.Label();
+ this.title = new System.Windows.Forms.Label();
+ this.SuspendLayout();
+
+ this.textBox.Location = new System.Drawing.Point(16, 344);
+ this.textBox.Name = "textBox";
+ this.textBox.Size = new System.Drawing.Size(584, 20);
+ this.textBox.TabIndex = 0;
+ this.textBox.Text = "";
+
+ this.listBox.Location = new System.Drawing.Point(16, 56);
+ this.listBox.Multiline = true;
+ this.listBox.Name = "listBox";
+ this.listBox.ReadOnly = true;
+ this.listBox.ScrollBars = System.Windows.Forms.ScrollBars.Vertical;
+ this.listBox.Size = new System.Drawing.Size(584, 248);
+ this.listBox.TabIndex = 1;
+ this.listBox.Text = "";
+
+ this.label.Location = new System.Drawing.Point(24, 312);
+ this.label.Name = "label";
+ this.label.Size = new System.Drawing.Size(576, 23);
+ this.label.TabIndex = 2;
+ this.label.Text = "Enter text below and press RETURN";
+ this.label.TextAlign = System.Drawing.ContentAlignment.MiddleCenter;
+
+ this.title.Font = new System.Drawing.Font("Microsoft Sans Serif", 12F, System.Drawing.FontStyle.Bold, System.Drawing.GraphicsUnit.Point, ((System.Byte)(0)));
+ this.title.Location = new System.Drawing.Point(24, 16);
+ this.title.Name = "title";
+ this.title.Size = new System.Drawing.Size(568, 24);
+ this.title.TabIndex = 3;
+ this.title.Text = "RDNZL Apropos Demo";
+ this.title.TextAlign = System.Drawing.ContentAlignment.MiddleCenter;
+
+ this.Controls.Add(this.title);
+ this.Controls.Add(this.label);
+ this.Controls.Add(this.listBox);
+ this.Controls.Add(this.textBox);
+ this.Name = "MainControl";
+ this.Size = new System.Drawing.Size(616, 384);
+ this.ResumeLayout(false);
+ }
+ }
+}
+</pre>
+
+Now load <a class=none name="apropos"><code>examples/apropos.lisp</code></a> which looks like this:
+
+<pre>
+<img alt="Another Message Box" title="Another Message Box" align=right border=0 vspace=10 hspace=10 width=308 height=100 src="box2.png">(in-package :rdnzl)
+
+(<a class=noborder href="#enable-rdnzl-syntax">enable-rdnzl-syntax</a>)
+
+(<a class=noborder href="#import-types">import-types</a> "System.Windows.Forms"
+ "Application" "DockStyle" "Form" "MessageBox" "KeyPressEventHandler" "TextBox")
+
+(import-types "AproposGUI"
+ "AproposControl")
+
+(<a class=noborder href="#use-namespace">use-namespace</a> "System.Windows.Forms")
+(use-namespace "AproposGUI")
+
+(defun copy-to-clipboard (text-box)
+ (let ((selection-start [%SelectionStart text-box])
+ (selection-length [%SelectionLength text-box])
+ (text-length [%Length (box [%Text text-box])]))
+ (setf [%SelectionStart text-box] 0
+ [%SelectionLength text-box] text-length)
+ [Copy text-box]
+ (setf [%SelectionStart text-box] selection-start
+ [%SelectionLength text-box] selection-length)))
+
+(let (message-shown)
+ (defun fill-list-box (object event)
+ (when (char= [%KeyChar event] #\Return)
+ (<a class=noborder href="#cast">cast</a> object "TextBox")
+ (let* ((input-string [%Text object])
+ (input-length (length input-string)))
+ (when (plusp input-length)
+ (let ((apropos-text
+ (with-output-to-string (*standard-output*)
+ (apropos input-string)))
+ (list-box [$listBox (cast [%Parent object] "AproposControl")]))
+ (setf [%Text list-box] apropos-text)
+ (copy-to-clipboard list-box)
+ (unless message-shown
+ [MessageBox.Show "The output of APROPOS has been copied to the clipboard."
+ "RDNZL"]
+ (setq message-shown t)))
+ (setf [%SelectionStart object] 0
+ [%SelectionLength object] input-length))))))
+
+(defun run-apropos-form ()
+ (let* ((control (new "AproposControl"))
+ (form (new "Form")))
+ (setf [%Dock control] [$DockStyle.Fill]
+ [%ClientSize form] [%ClientSize control]
+ [%Text form] "RDNZL Apropos Demo"
+ [%Text [$title control]]
+ (format nil "RDNZL Apropos Demo (~A)"
+ (lisp-implementation-type)))
+ [+KeyPress [$textBox control]
+ (new "KeyPressEventHandler" #'fill-list-box)]
+ [Add [%Controls form] control]
+ [Application.Run form]))
+
+(<a class=noborder href="#disable-rdnzl-syntax">disable-rdnzl-syntax</a>)
+</pre>
+
+and evaluate <code>(RUN-APROPOS-FORM)</code>. If you want to try this
+several times, start the function in its own thread. In AllegroCL or LispWorks
+that'd be:
+
+<pre>
+(mp:process-run-function "apropos" #+:lispworks nil #'run-apropos-form)
+</pre>
+
+The next example shows how easy it is to access web pages using the
+.NET standard library:
+
+<pre>
+RDNZL-USER 9 > (<a class=noborder href="#import-types">import-types</a> "System" "Net.WebClient")
+NIL
+RDNZL-USER 10 > (defun download-url (url)
+ (let ((web-client (new "System.Net.WebClient")))
+ [GetString (new "System.Text.ASCIIEncoding")
+ [DownloadData web-client url]]))
+DOWNLOAD-URL
+RDNZL-USER 11 > (download-url "http://nanook.agharta.de/")
+"<HTML>
+<HEAD>
+<META HTTP-EQUIV=\"refresh\" CONTENT=\"5;URL=http://www.weitz.de/\">
+</HEAD>
+<BODY><center>
+<table border=3 bordercolor=green cellpadding=5 cellspacing=5><tr><td align=center>
+<pre>
+Linux nanook 2.6.7 #1 Thu Jul 22 01:01:58 CEST 2004 i686 GNU/Linux
+
+ 01:23:23 up 100 days, 19:43, 0 users, load average: 0.00, 0.00, 0.00
+
+</pre>
+ </td></tr></table></center>
+
+</BODY>
+</HTML>
+"
+</pre>
+
+A bit more evolved:
+
+<pre>
+RDNZL-USER 12 > (<a class=noborder href="#import-types">import-types</a> "System" "Net.WebException")
+NIL
+RDNZL-USER 13 > (<a class=noborder href="#use-namespace">use-namespace</a> "System.Net")
+RDNZL-USER 14 > (defun download-url (url)
+ (<a class=noborder href="#rdnzl-handler-case">rdnzl-handler-case</a>
+ (let ((web-client (new "WebClient")))
+ [GetString (new "System.Text.ASCIIEncoding")
+ [DownloadData web-client url]])
+ ("WebException" (e)
+ (warn "Ooops, probably a typo: ~A" [%Message e])
+ nil)))
+DOWNLOAD-URL
+RDNZL-USER 15 > (download-url "http://nanook.aharta.de/")
+Warning: Ooops, probably a typo:
+ The underlying connection was closed: The remote name could not be resolved.
+NIL
+</pre>
+
+This'll also work with https URLs.
+<p>
+The last example
+shows <a href="http://office.microsoft.com/">Microsoft Office</a>
+automation - it extracts values from an Excel spreadsheet. (You'll
+obviously need to have a copy of Office on your machine if you want to
+try this yourself.)
+
+<pre>
+RDNZL-USER 16 > (<a class=noborder href="#import-types">import-types</a> "Microsoft.Office.Interop.Excel" "ApplicationClass" "WorkbookClass" "Worksheet")
+NIL
+
+RDNZL-USER 17 > (<a class=noborder href="#use-namespace">use-namespace</a> "Microsoft.Office.Interop.Excel")
+
+RDNZL-USER 18 > (defconstant +missing+ [$System.Reflection.Missing.Value])
++MISSING+
+
+RDNZL-USER 19 > (defun get-excel-range (file-name range)
+ (let* ((app (new "ApplicationClass"))
+ (workbooks [%Workbooks app])
+ (workbook (<a class=noborder href="#cast">cast</a> [Open workbooks file-name
+ +missing+ nil +missing+
+ +missing+ +missing+ +missing+
+ +missing+ +missing+ +missing+
+ +missing+ +missing+ +missing+
+ +missing+ +missing+]
+ "WorkbookClass"))
+ (worksheets [%Worksheets workbook])
+ (sheet (cast [get_Item worksheets 1] "Worksheet"))
+ (range [get_Range sheet range +missing+]))
+ (cast [%Value2 [%Cells range]] "System.Array")))
+GET-EXCEL-RANGE
+
+RDNZL-USER 20 > (defun convert-range-array-to-lists (range-array)
+ (loop for row from 1 to [GetLength range-array 0]
+ collect (loop for col from 1 to [GetLength range-array 1]
+ collect [ToString (<a class=noborder href="#aref*">aref*</a> range-array row col)])))
+CONVERT-RANGE-ARRAY-TO-LISTS
+
+RDNZL-USER 21 > (defun range-contents (&key (range "A1:C4")
+ <font color=orange>;; see "examples" folder for a definition of PROMPT-FOR-FILE</font>
+ (file-name (prompt-for-file "Select an Excel file")))
+ (convert-range-array-to-lists
+ (get-excel-range file-name range)))
+RANGE-CONTENTS
+
+RDNZL-USER 22 > (pprint
+ (range-contents :file-name "c:\\home\\lisp\\RDNZL\\examples\\example.xls"))
+
+(("Last name" "First name" "Superhero")
+ ("Kent" "Clark" "Superman")
+ ("Wayne" "Bruce" "Batman")
+ ("Parker" "Peter" "Spiderman"))
+</pre>
+
+(This is an adapted version of a <a href="http://www.c-sharpcorner.com/winforms/ExcelReadMG.asp">C# example from Michael Gold</a>.)
+
+<p>
+For a much cooler and more sophisticated example of what can be done
+with RDNZL see Michael
+Goffioul's <a
+href="http://sourceforge.net/forum/forum.php?forum_id=609266">Lisp
+shell</a>
+(see <a
+href="http://sourceforge.net/project/showfiles.php?group_id=30035">ECL's
+Sourceforge project page</a> for binaries and source code).
+<p>
+See
+also <a href="http://www.cs.berkeley.edu/~fateman/speech-lisp/outline.lisp">this
+code</a> by <a href="http://www.cs.berkeley.edu/~fateman/">Richard
+Fateman</a> that displays some of the possibilities for using RDNZL
+for a drop-down menu cascade showing Lisp trees or
+these <a href="http://common-lisp.net/pipermail/rdnzl-devel/2008-March/000213.html">two</a> <a href="http://common-lisp.net/pipermail/rdnzl-devel/2008-March/000222.html">examples</a>
+for DataGridViews by Matthew O'Connor.
+
+<br> <br><h3><a class=none name="download">Download and installation</a></h3>
+
+RDNZL together with this documentation can be downloaded from
+<a href="http://weitz.de/files/rdnzl.tar.gz">http://weitz.de/files/rdnzl.tar.gz</a>, the current version is 0.12.2. It
+doesn't depend on any other Lisp libraries. The C++ source for the
+shared library <code>RDNZL.dll</code> can be downloaded separately from
+<a
+href="http://weitz.de/files/rdnzl-cpp.tar.gz">http://weitz.de/files/rdnzl-cpp.tar.gz</a> (current version is 0.7.1),
+but you don't need this archive to deploy RDNZL
+- <code>rdnzl.tar.gz</code> already contains <code>RDNZL.dll</code>.
+Note that the <a
+href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=rdnzl">CVS
+repository at common-lisp.net</a> is usually <em>not</em> in sync with the current release
+version!
+<p>
+Before you load RDNZL make sure you have the <a href="http://msdn.microsoft.com/netframework/downloads/framework1_1/">.NET framework</a> installed.
+Then move the file <code>RDNZL.dll</code> to a location where your Lisp's FFI will
+find it - the folder where your Lisp executable is located is
+generally a good place for that.
+<p>
+Now, to compile and load RDNZL just <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_load.htm"><code>LOAD</code></a> the file <code>load.lisp</code> - that's
+all. (Or alternatively use <a href="http://www.cliki.net/asdf">ASDF</a> if you like - RDNZL comes with a
+system definition for ASDF.)
+<p>
+Oh, and - for the moment - <em>don't</em>
+use <a href="http://common-lisp.net/project/slime/">SLIME</a> together
+with LispWorks when loading RDNZL -
+see <a
+href="http://common-lisp.net/pipermail/slime-devel/2004-December/002876.html">this
+message</a> for an explanation.
+
+
+<br> <br><h3><a name="mail" class=none>Support and mailing lists</a></h3>
+
+For questions, bug reports, feature requests, improvements, or patches
+please use the <a
+href="http://common-lisp.net/mailman/listinfo/rdnzl-devel">rdnzl-devel
+mailing list</a>. If you want to be notified about future releases,
+subscribe to the <a
+href="http://common-lisp.net/mailman/listinfo/rdnzl-announce">rdnzl-announce
+mailing list</a>. These mailing lists and the CVS repository were made available thanks to
+the services of <a href="http://common-lisp.net/">common-lisp.net</a>.
+<p>
+If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>.
+
+<br> <br><h3><a class=none name="implementations">Supported Lisp implementations</a></h3>
+
+RDNZL is currently targeted at Microsoft Windows. There are <a href="http://en.wikipedia.org/wiki/Microsoft_.NET_Framework#Alternative_implementations">other
+implementations</a> of the CLR runtime for other operating systems but to
+port the "glue" library <code>RDNZL.dll</code> you'll need something similar to
+Microsoft's "<a href="http://en.wikipedia.org/wiki/Managed_C_Plus_Plus">Managed C++</a>" which can mix managed and unmanaged code.
+I'll gladly accepts patches to make RDNZL work on other platforms.
+<p>
+The current status for the main Win32 Common Lisp implementations is
+as follows:
+<ul>
+<li><a href="http://www.cormanlisp.com/">Corman Common Lisp</a>: Corman Lisp is fully supported thanks to the help of Roger Corman.
+
+<li><a href="http://ecls.sourceforge.net/">ECL</a>: RDNZL has been ported to ECL by Michael Goffioul.
+
+<li><a href="http://www.franz.com/products/allegrocl/">Franz AllegroCL</a>: AllegroCL is fully supported thanks to the efforts of Charles A. Cox from Franz Inc.
+
+<li><a href="http://clisp.cons.org/">GNU CLISP</a>: RDNZL has been ported to CLISP by Vasilis Margioulas. However, the port currently has some GC issues - it only works for simple, non-callback cases. This is probably due to missing MP support.
+
+<li><a href="http://www.lispworks.com/">LispWorks</a>: LispWorks is fully supported.
+
+<li><a href="http://www.sbcl.org/">SBCL</a>: Experimental support for the "port in progress" of SBCL to Win32. Based on the <a href="http://prdownloads.sourceforge.net/sbcl/sbcl-0.9.9-x86-win32-binary.tar.bz2?download">0.9.9 binary release</a>. The <a href="#apropos"><code>APROPOS</code> example</a> doesn't work, most likely because SBCL/Win32 doesn't have MP yet.
+
+</ul>
+All implementation-specific parts of RDNZL are located in files called
+<code>port-acl.lisp</code>, <code>port-ccl.lisp</code>, <code>port-lw.lisp</code>, and so on. If you want to port RDNZL to
+another Lisp, it should suffice to just create the corresponding
+<code>port-xx.lisp</code> file for your implementation.
+
+
+<br> <br><h3><a class=none name="dictionary">The RDNZL dictionary</a></h3>
+
+<h4><a class=none name="objects">Representation and creation of .NET objects</a></h4>
+
+.NET objects are represented as <em>containers</em> and are printed like this
+
+<pre>
+#<RDNZL::CONTAINER System.Object #xAE28E0>
+</pre>
+
+where <code>System.Object</code> is the name of the .NET type of this
+object and <code>#xAE28E0</code> is the hexadecimal representation of a C pointer
+that won't change during the lifetime of this object. (Internally
+containers are implemented as structures but this might change in
+future versions so you shouldn't rely on it.)
+<p>
+Note that each container has a .NET type that can be manipulated
+independently from its object - see <a href="#cast"><code>CAST</code></a>.
+<p>
+As long as a container is accessible in Lisp its underlying .NET
+object won't be garbage-collected in the CLR.
+<p>
+Whenever a RDNZL function accepts .NET objects as arguments (except
+for the first argument of <a href="#invoke"><code>INVOKE</code></a>, <a href="#property"><code>PROPERTY</code></a>, and <a href="#field"><code>FIELD</code></a>) you can also
+provide the corresponding "native" Lisp objects as long as they can be
+converted to .NET objects by the function <a href="#box"><code>BOX</code></a>. On the other hand, if
+a RDNZL function returns a .NET object, it will be automatically
+translated to a Lisp object by <a href="#unbox"><code>UNBOX</code></a> if possible. If a RDNZL function
+call doesn't return a result (i.e. if its return type is <code>System.Void</code>),
+then the keyword <code>:VOID</code> is returned. If a <code>NULL</code> object is returned,
+RDNZL returns <code>NIL</code> and <code>T</code> as a second return value because otherwise
+there'd be no difference from returning a false boolean value.
+
+
+<p><br>[Function]
+<br><a class=none name="container-p"><b>container-p</b> <i> object </i> => <i> generalized-boolean</i></a>
+
+<blockquote><br>
+Returns <em>true</em> if <code><i>object</i></code> is a container, <code>NIL</code> otherwise.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="box"><b>box</b> <i> object </i> => <i> container</i></a>
+
+<blockquote><br>
+Converts Lisp objects to containers wrapping a
+corresponding .NET object if possible, otherwise an error is
+signaled. Currently the following conversions are implemented:
+
+<p>
+<table border=1 cellspacing=1 cellpadding=3>
+<tr><th>Lisp type </th><th> .NET type </th><th> Remark</th></tr>
+<tr><td><code>(signed-byte 32)</code> </td><td> <code>System.Int32</code></td><td></td></tr>
+<tr><td><code>(signed-byte 64)</code> </td><td> <code>System.Int64</code> </td><td> Only integers which aren't <code>(SIGNED-BYTE 32)</code>.</td></tr>
+<tr><td><code>character</code> </td><td> <code>System.Char</code></td><td></td></tr>
+<tr><td><code>string</code> </td><td> <code>System.String</code></td><td></td></tr>
+<tr><td><code>pathname</code> </td><td> <code>System.String</code> </td><td> The <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_n.htm#namestring">namestring</a> of the pathname is used.</td></tr>
+<tr><td><code>double-float</code> </td><td> <code>System.Double</code></td><td>See <a href="#*coerce-double-floats-to-single*"><code>*COERCE-DOUBLE-FLOATS-TO-SINGLE*</code>.</a></td></tr>
+<tr><td><code>float</code> </td><td> <code>System.Single</code></td><td> Only floating point numbers which aren't <code>DOUBLE-FLOAT</code>.</td></tr>
+<tr><td><code>boolean</code> </td><td> <code>System.Boolean</code></td><td></td></tr>
+</table>
+
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="unbox"><b>unbox</b> <i> container </i> => <i> object</i></a>
+
+<blockquote><br>
+Converts .NET objects wrapped in a container to a corresponding Lisp
+object if possible, otherwise <code><i>container</i></code> is returned ummodified. Currently the following conversions are implemented:
+<p>
+<table border=1 cellspacing=1 cellpadding=3>
+<tr><th>.NET type </th><th> Lisp type</th></tr>
+<tr><td><code>System.Int32</code> </td><td> <code>integer</code></td></tr>
+<tr><td><code>System.Int64</code> </td><td> <code>integer</code></td></tr>
+<tr><td><code>System.Char</code> </td><td> <code>character</code></td></tr>
+<tr><td><code>System.String</code> </td><td> <code>string</code></td></tr>
+<tr><td><code>System.Double </code> </td><td> <code>double-float</code></td></tr>
+<tr><td><code>System.Single </code> </td><td> <code>float</code></td></tr>
+<tr><td><code>System.Boolean</code> </td><td> <code>boolean</code></td></tr>
+</table>
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="new"><b>new</b> <i> type <tt>&rest</tt> args </i> => <i> new-instance</i></a>
+
+<blockquote><br>
+Creates and return a new instance of the .NET type <code><i>type</i></code>. Chooses the
+constructor based on the signature determined by <code><i>args</i></code>. <code><i>type</i></code> can either
+be a container representing a .NET type or a string naming the type.
+<p>
+If <code><i>type</i></code> is a delegate type, then there should be exactly one more
+argument to <code>NEW</code> and it must be a Lisp closure with a corresponding
+signature. This is how callbacks from .NET into Lisp are implemented. (See the <a href="#apropos">second example</a> above and look for <code>KeyPressEventHandler</code>.)
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="cast"><b>cast</b> <i> container type </i> => <i> container</i></a>
+
+<blockquote><br> Changes the type of the .NET object represented
+by <code><i>container</i></code> to <code><i>type</i></code> (a string
+naming the type, a tree of strings for generic types, or a container
+representing the type). Returns <code><i>container</i></code>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="copy-container"><b>copy-container</b> <i> container </i> => <i> container'</i></a>
+
+<blockquote><br> Creates and returns a copy of the .NET object represented
+by <code><i>container</i></code>. Useful for keeping a reference to
+the object with the original type preserved when
+using <a href="#cast"><code>CAST</code></a> - see discussion <a href="http://common-lisp.net/pipermail/rdnzl-devel/2007-April/000143.html">here</a>.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="make-null-object"><b>make-null-object</b> <i> type-name </i> => <i> container</i></a>
+
+<blockquote><br>
+Returns a new NULL .NET object of the type named by the string <code><i>type-name</i></code>.
+</blockquote>
+
+
+<p><br>[Special variable]
+<br><a class=none name="*coerce-double-floats-to-single*"><b>*coerce-double-floats-to-single*</b></a>
+
+<blockquote><br> If the value of this variable is <em>true</em>,
+then <a href="#box"><code>BOX</code></a> will convert a
+Lisp <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/t_short_.htm#double-float"><code>DOUBLE-FLOAT</code></a>
+value to <code>System.Single</code>. This is mainly interesting for
+LispWorks, where Lisp floats are always <code>DOUBLE-FLOAT</code>.
+</blockquote>
+
+
+<h4><a class=none name="methods">Accessing .NET methods, properties, and fields</a></h4>
+
+This section describes the "low-level" access to .NET class members. See the <a href="#reader">section about the special reader syntax</a> for another approach.
+
+<p><br>[Function]
+<br><a class=none name="invoke"><b>invoke</b> <i> object method-name <tt>&rest</tt> other-args </i> => <i> result</i></a>
+
+<blockquote><br>
+Invokes the public .NET method named by the string <code><i>method-name</i></code>. If <code><i>object</i></code> is a
+container, then the method is supposed to be an instance method of this
+object. If <code><i>object</i></code> is a string, then the method is supposed to be a
+static method of the type named <code><i>object</i></code> which will be looked up using
+<code>System.Type::GetType</code>. If <code><i>object</i></code> is a tree of strings, then the method
+should be a static method of the generic type named <code><i>object</i></code>, with <code><i>other-args</i></code>
+being the parameters of the type. Otherwise, <code><i>object</i></code> should be a pair
+where the first element is a container representing an assembly and
+the second element is a string (or a tree of strings) denoting a type
+(possibly generic), for which <code><i>method-name</i></code> denotes a static method
+(which will be looked up in that specific assembly). <code><i>other-args</i></code> (either
+<code><i>container</i></code> structures or Lisp objects which can be
+converted) are the arguments to this method.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="property"><b>property</b> <i> object property-name <tt>&rest</tt> indexes </i> => <i> property-value</i></a>
+<br><tt>(setf (</tt><b>property</b> <i> object <tt>&rest</tt> indexes) new-value)</i>
+
+<blockquote><br>
+Gets or sets the public .NET property named by the string
+<code><i>property-name</i></code>. If <code><i>object</i></code> is a container, an instance property is
+accessed. If <code><i>object</i></code> is a string, the static property of the type named
+by this string is accessed.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="field"><b>field</b> <i> object field-name </i> => <i> field-value</i></a>
+<br><tt>(setf (</tt><b>field</b> <i> object) new-value)</i>
+
+<blockquote><br>
+Gets or sets the public .NET field named by the string <code><i>field-name</i></code>. If
+<code><i>object</i></code> is a container, an instance field is accessed. If <code><i>object</i></code> is a
+string, the static field of the type named by this string is accessed.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="ref"><b>ref</b> <i>object</i> => <i> container</i></a>
+
+<blockquote><br>
+
+Makes a <em>pass-by-reference</em> type out of
+<code><i>object</i></code> and returns <code><i>object</i></code>. If
+<code><i>object</i></code> is not a <a href="#objects">container</a>,
+it'll be <a href="#box">boxed</a> first. This function makes only
+sense if <code><i>object</i></code> is used as an argument to <a
+href="#invoke"><code>INVOKE</code></a>! (And after <a href="#invoke"><code>INVOKE</code></a> has been
+called <code><i>object</i></code> will be reset to its underlying type so you have to
+re-apply <code>REF</code> if you want to use it as a pass-by-reference argument in
+another .NET call.) Note that while this is kind of tedious it
+corresponds to the C# semantics.
+<p>
+Here's an example: If you have a .NET class defined like this (in C#)
+<pre>
+public class Class1 {
+ public static void foo (ref int a) {
+ a++;
+ }
+}
+</pre>
+then you can do this (see <a href="#reader">below</a> for the reader syntax) in Lisp
+<pre>
+RDNZL-USER(16): (let ((a (<a class=noborder href="#box">box</a> 41)))
+ [Class1.foo (<a class=noborder href="#ref">ref</a> a)]
+ (<a class=noborder href="#unbox">unbox</a> a))
+42
+</pre>
+
+while the evaluation of <code>[Class1.foo 41]</code> (or <code>[Class1.foo (<a href="#box">box</a> 41)]</code> which is equivalent) will signal an error because the
+method won't even be found - the signature of <code>foo</code> is <code>(System.Int32&)</code>, not <code>(System.Int32)</code>.
+</blockquote>
+
+<h4><a class=none name="arrays">Arrays and enumerations</a></h4>
+
+This section assembles some convenience functions for .NET arrays and
+enumerations.
+
+<p><br>[Accessor]
+<br><a class=none name="aref*"><b>aref*</b> <i> array <tt>&rest</tt> subscripts </i> => <i> value</i></a>
+<br><tt>(setf (</tt><b>aref*</b> <i> array <tt>&rest</tt> subscripts) new-value)</i>
+
+<blockquote><br>
+Gets or sets the element of the .NET array <code><i>array</i></code> with the
+subscripts <code><i>subscripts</i></code>.
+</blockquote>
+
+
+<p><br>[Macro]
+<br><a class=none name="do-rdnzl-array"><b>do-rdnzl-array</b> <i> (var array-form <tt>&optional</tt> result) <tt>&body</tt> body </i> => <i> value*</i></a>
+
+<blockquote><br>
+<code><i>array-form</i></code> should be a form which evaluates to a <a href="#objects">container</a> wrapping a
+.NET array of rank 1. The <code><i>body</i></code> will be evaluated with <code><i>var</i></code> bound to
+each element of this array in turn. Finally, the result of evaluating
+the form <code><i>result</i></code> is returned.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="list-to-rdnzl-array"><b>list-to-rdnzl-array</b> <i> list <tt>&optional</tt> base-type </i> => <i> array</i></a>
+
+<blockquote><br> Creates and returns a .NET array of base
+type <code><i>base-type</i></code> and rank 1 with the elements
+from the Lisp
+list <code><i>list</i></code>. <code><i>base-type</i></code> can be a
+container representing a .NET type, a string naming the type, or a
+tree of strings. The default for <code><i>base-type</i></code> is the
+.NET root type <code>System.Object</code>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="rdnzl-array-to-list"><b>rdnzl-array-to-list</b> <i> array </i> => <i> list</i></a>
+
+<blockquote><br>
+Converts a .NET array <code><i>array</i></code> of rank 1 to a Lisp list with the same
+elements.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="integer-to-enum"><b>integer-to-enum</b> <i> number type </i> => <i> enum</i></a>
+
+<blockquote><br>
+Converts the Lisp integer <code><i>number</i></code> to a .NET <code>System.Enum</code> object of
+type <code><i>type</i></code> (a string naming the type or a container representing the type).
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="enum-to-integer"><b>enum-to-integer</b> <i> enum </i> => <i> number</i></a>
+
+<blockquote><br>
+Converts the .NET object <code><i>enum</i></code> of type <code>System.Enum</code> to a Lisp integer. This is a destructive operation on <code><i>enum</i></code>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="or-enums"><b>or-enums</b> <i> <tt>&rest</tt> enums </i> => <i> enum</i></a>
+
+<blockquote><br>
+Combines several .NET objects of type System.Enum with a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logand.htm#logior">bit-wise logical <em>or</em></a>
+and returns the result. All arguments must be of the same .NET type
+and there must be at least one argument.
+</blockquote>
+
+
+<h4><a class=none name="exceptions">Handling of .NET exceptions</a></h4>
+
+.NET exceptions are propagated to Lisp as described below.
+
+<p><br>[Condition type]
+<br><a class=none name="rdnzl-error"><b>rdnzl-error</b></a>
+
+<blockquote><br>
+Exceptions raised during .NET calls are signaled in Lisp as errors of this type.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="rdnzl-error-exception"><b>rdnzl-error-exception</b> <i> condition </i> => <i> exception</i></a>
+
+<blockquote><br>
+If <code><i>condition</i></code> is an error of type <a href="#rdnzl-error"><code>RDNZL-ERROR</code></a>, then this function will
+return the .NET exception object that was actually raised.
+</blockquote>
+
+<p><br>[Macro]
+<br><a class=none name="rdnzl-handler-case"><b>rdnzl-handler-case</b> <i>form <tt>&rest</tt> clauses</i> => <i>result*</i></a>
+
+<blockquote><br>
+Like <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/m_hand_1.htm"><code>HANDLER-CASE</code></a>
+but only for conditions of type <a
+href="#rdnzl-error"><code>RDNZL-ERROR</code></a>. The typespecs are
+either strings (naming a .NET error type) or of the form <code>(OR string-<i>1</i> ... string-<i>n</i>)</code>. A <code>:NO-ERROR</code> clause is also allowed.
+</blockquote>
+
+<h4><a class=none name="types">Type names and assemblies</a></h4>
+
+Whenever a RDNZL function accepts a string as a type name you usually
+have to provide the full <em>assembly-qualified name</em> of that type (with
+the exception of types in <code>mscorlib.dll</code>), i.e. something like
+
+<pre>
+"System.Windows.Forms.Button, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089"
+</pre>
+
+This is boring and error-prone, so RDNZL provides two ways to make it
+easier for you: You can <a href="#import-type"><em>import types</em></a> and you can <a href="#use-namespace"><em>use namespaces</em></a>.
+<p>
+If you import a type, RDNZL internally remembers its assembly-qualified
+name and you can now use its <em>full name</em> (like
+<code>"System.Windows.Forms.Button"</code>) instead.
+<p>
+If this is still too long for you, you can <em>use</em> namespaces to further
+abbreviate type names. So, if you are using the namespace
+<code>"System.Windows.Forms"</code>, you can just call the type <code>"Button"</code>. Note that
+this'll only work for imported types, though.
+
+<p><br>[Function]
+<br><a class=none name="import-type"><b>import-type</b> <i> type <tt>&optional</tt> assembly </i> => <i> type'</i></a>
+
+<blockquote><br>
+Imports the .NET type <code><i>type</i></code>, i.e. registers its name as one that can be
+abbreviated (see <a href="#use-namespace"><code>USE-NAMESPACE</code></a>) and creates a mapping from its short
+name to its assembly-qualified name (if necessary). If <code><i>type</i></code> is a
+string and <code><i>assembly</i></code> is <code>NIL</code>, then the function will try to create the
+type from the string with the static .NET method <code>System.Type::GetType</code>.
+If <code><i>type</i></code> is a string and <code><i>assembly</i></code> is a container representing an
+assembly, then instead the .NET instance method
+<code>System.Reflection.Assembly::GetType</code> will be used. If <code><i>type</i></code> is already
+a .NET object (i.e. a <a href="#objects">container</a>), then the function will just register
+its name. If <code><i>assembly</i></code> is a <em>true</em> 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.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="load-assembly"><b>load-assembly</b> <i> name </i> => <i> assembly</i></a>
+
+<blockquote><br>
+Loads and returns the assembly with the name <code><i>name</i></code> (a string), uses the
+static .NET method <code>System.Reflection.Assembly::LoadWithPartialName</code>
+internally.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="import-assembly"><b>import-assembly</b> <i> assembly </i> => <i> assembly'</i></a>
+
+<blockquote><br>
+Imports all public types of the assembly <code><i>assembly</i></code> (a string or a
+container). If <code><i>assembly</i></code> is a string, then the assembly is first loaded
+with <a href="#load-assembly"><code>LOAD-ASSEMBLY</code></a>. Returns <code><i>assembly</i></code> as a container.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="import-types"><b>import-types</b> <i> assembly-name <tt>&rest</tt> type-names </i> => <i><tt>NIL</tt></i></a>
+
+<blockquote><br>
+This is a shortcut. It loads the assembly named by the string <code><i>assembly-name</i></code> and
+imports all types listed from this assembly. The assembly name is
+prepended to the type names before importing them. All arguments
+should be strings.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="use-namespace"><b>use-namespace</b> <i> namespace </i> => |</a>
+
+<blockquote><br>
+Adds the .NET namespace <code><i>namespace</i></code>
+(a string) to the list of namespaces that will be prefixed when trying
+to resolve a type name. After calling this function
+<code><i>namespace</i></code> will be the first entry in this list
+unless it has already been there. <code><i>namespace</i></code> must
+not end with a dot because a dot will be prepended automatically.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="unuse-namespace"><b>unuse-namespace</b> <i> namespace </i> => |</a>
+
+<blockquote><br>
+Removes the .NET namespace <code><i>namespace</i></code> (a string) from the list of
+namespaces that will be prefixed when trying to resolve a type name.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="unuse-all-namespaces"><b>unuse-all-namespaces</b> <i> </i> => |</a>
+
+<blockquote><br>
+Removes all entries from the list of namespaces that will be prefixed
+when trying to resolve a type name.
+</blockquote>
+
+
+<h4><a class=none name="reader">Special reader syntax</a></h4>
+
+In order to make entering .NET forms easier RDNZL provides a modified
+read syntax which consists of two parts.
+<p>
+First, the left and right bracket characters are modified to be
+<a href="http://www.lispworks.com/documentation/HyperSpec/Body/02_b.htm">terminating macro characters</a>. A form like
+
+<pre>
+[IsSubclassOf type other-type]
+</pre>
+
+is read as follows: Directly following the left bracket should be a
+symbol (<code>IsSubclassOf</code> in this example) which is read as if the standard
+readtable was used (except for the special role of the brackets) but
+<em>with case preserved</em>. The rest (<code>type other-type</code> in this case) is read
+up to the closing bracket by <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_del.htm#read-delimited-list"><code>READ-DELIMITED-LIST</code></a>. This results in a call
+to <a href="#invoke"><code>INVOKE</code></a> like this:
+<pre>
+(<a class=noborder href="#invoke">invoke</a> type "IsSubclassOf" other-type)
+</pre>
+If the symbol starts with a percent or dollar, sign then it is removed
+and the result is a call to <a href="#property"><code>PROPERTY</code></a> or <a href="#field"><code>FIELD</code></a> respectively:
+
+<pre>
+[%IsInterface type] => (<a class=noborder href="#property">property</a> type "IsInterface")
+[$textBox control] => (<a class=noborder href="#field">field</a> control "textBox")
+</pre>
+
+If the symbol contains a dot, then in all three cases this'll result in
+a static invocation where the part before the (last) dot is used as the name
+of the type:
+
+<pre>
+[System.Environment.Exit] => (<a class=noborder href="#invoke">invoke</a> "System.Environment" "Exit")
+[%System.Environment.UserName] => (<a class=noborder href="#property">property</a> "System.Environment" "UserName")
+[$OpCodes.Switch] => (<a class=noborder href="#field">field</a> "Opcodes" "Switch")
+</pre>
+
+If the symbol starts with a plus or minus sign, then this sign is replaced
+with <code>"add_"</code> or <code>"remove_"</code> respectively. This is the convention used to
+add or remove event handlers:
+
+<pre>
+[+KeyPress text-box (<a class=noborder href="#new">new</a> "KeyPressEventHandler" #'reply)] => (<a class=noborder href="#invoke">invoke</a> text-box "add_KeyPress" (<a class=noborder href="#new">new</a> "KeyPressEventHandler" #'reply))
+</pre>
+
+The second syntax change is the addition of a new dispatch character
+to the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/02_dh.htm"><code>#</code> (sharpsign) reader macro</a>, namely <code>`</code> (backquote). This is
+intended to be used similarly to <a href="http://www.lispworks.com/documentation/HyperSpec/Body/02_dhb.htm"><code>#'</code></a> but with the syntax described
+above, i.e. you can write things like
+
+<pre>
+(mapcar #`%CanFocus list-of-forms)
+(apply #`GetMethod method-info other-args)
+(funcall #`(setf $textBox) new-text-box control)
+</pre>
+
+Note that this dispatch character also recognizes <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_name">function names</a> of
+the form <code>(SETF <i>symbol</i>)</code>.
+The RDNZL source code contains more examples of using this modified
+syntax.
+<p>
+Read <a href="http://www.tfeb.org/lisp/obscurities.html#RDL">Tim Bradshaw's article</a>
+ about the implications
+of a reader syntax as described above.
+
+
+<p><br>[Macro]
+<br><a class=none name="enable-rdnzl-syntax"><b>enable-rdnzl-syntax</b> <i> </i> => |</a>
+
+<blockquote><br>
+Enables RDNZL reader syntax. After loading RDNZL this reader syntax is by default <em>not</em> enabled.
+</blockquote>
+
+<p><br>[Macro]
+<br><a class=none name="disable-rdnzl-syntax"><b>disable-rdnzl-syntax</b> <i> </i> => |</a>
+
+<blockquote><br>
+Restores the readtable which was active before the last call to
+<a href="#enable-rdnzl-syntax"><code>ENABLE-RDNZL-SYNTAX</code></a>. If there was no such call, the standard readtable
+is used.
+</blockquote>
+
+<h4><a class=none name="direct">Direct calls</a></h4>
+
+Usually, each time you call into .NET via <a
+href="#invoke"><code>INVOKE</code></a>, <a
+href="#property"><code>PROPERTY</code></a>, or <a
+href="#field"><code>FIELD</code></a> RDNZL will have to search for the
+corresponding .NET member via reflection. This can be avoided by
+defining <em>direct calls</em> via <a
+href="#define-rdnzl-call"><code>DEFINE-RDNZL-CALL</code></a>. For example, instead of calling
+<pre>
+(invoke "System.Math" "Max" 3.5 3.6)
+</pre>
+you'd first define a function <code>DOTNET-MAX</code> like this
+<pre>
+(define-rdnzl-call dotnet-max
+ (:dotnet-name "Max"
+ :type-name "System.Math")
+ ((x "System.Double")
+ (y "System.Double")))
+</pre>
+and then call it as if it were a normal Lisp function (no need for the pesky <a href="#reader">reader syntax</a>):
+<pre>
+(dotnet-max 3.5 3.6)
+</pre>
+Experiments with AllegroCL and LispWorks show that in the example above you'll safe about half the execution time and half the consing if you use a direct call instead of <a href="#invoke"><code>INVOKE</code></a>. (It's still faster to call <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_max_m.htm">MAX</a>, though... :)
+<p>
+The file <code>examples/apropos2.lisp</code> shows how you'd code the <a href="#apropos"><code>APROPOS</code> example</a> with direct calls.
+
+<p><br>[Macro]
+<br><a class=none name="define-rdnzl-call"><b>define-rdnzl-call</b> <i> lisp-name (<tt>&key</tt> member-kind dotnet-name type-name doc-string) args</i> => <i> lisp-name </i></a>
+
+<blockquote><br>
+Defines a Lisp function named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_name">function name</a> <code><i>lisp-name</i></code> which invokes the .NET member named by the string <code><i>dotnet-name</i></code>. <code><i>member-kind</i></code> must be one of the keywords <code>:METHOD</code>, <code>:PROPERTY</code>, or <code>:FIELD</code> and obviously determines whether a method, a property, or a field is to be invoked - the default is <code>:METHOD</code>. If <code><i>type-name</i></code> is <code>NIL</code> (which is the default), an instance member is invoked, otherwise <code><i>type-name</i></code> should be a string naming a .NET type and a static member of this type is invoked instead. <code><i>doc-string</i></code>, if provided, should be a string, namely the documentation string for the Lisp function which is created. If <code><i>doc-string</i></code> is <code>NIL</code> (which is the default), a generic documentation string will be created.
+<p>
+If <code><i>dotnet-name</i></code> is <code>NIL</code> (which is the default), then the name of the .NET member will be created from <code><i>lisp-name</i></code> be the following rules:
+Take the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_2.htm">symbol name</a> of <code><i>lisp-name</i></code> and if it does <em>not</em> consist solely of hyphens and single-case letters, just return it. Otherwise remove the hyphens and downcase all letters except for the first one and those that follow a hyphen - these are upcased. If lisp-name is a list <code>(SETF <i>symbol</i>)</code>, then we use <code><i>symbol</i></code> instead of <code><i>lisp-name</i></code>. Here are some examples (note that the package doesn't matter):
+<p>
+<table border=1 cellspacing=1 cellpadding=3>
+<tr><th><code><i>lisp-name</i></code> </th><th> <code><i>dotnet-name</i></code></th></tr>
+<tr><td><code>|Foo|</code> </td><td> <code>"Foo"</code></td></tr>
+<tr><td><code>FOO</code> </td><td> <code>"Foo"</code></td></tr>
+<tr><td><code>HELP-ME</code> </td><td> <code>"HelpMe"</code></td></tr>
+<tr><td><code>(SETF TEXT-BOX)</code> </td><td> <code>"TextBox"</code></td></tr>
+</table>
+
+<p>
+Finally, <code><i>args</i></code> describes the arguments to the
+newly-created function. It is a list of pairs
+<code>(ARG-NAME TYPE-NAME)</code> where <code>ARG-NAME</code> is
+a symbol naming the argument and <code>TYPE-NAME</code> is a string
+naming the .NET type of the argument. Note that for instance members
+the type of the first argument is the .NET type the member belongs to
+- this is <em>not</em> the case for static members.
+<p>
+For properties and fields, <code><i>lisp-name</i></code> can also be a
+list <code>(SETF <i>symbol</i>)</code> in which case a setter function
+for the corresponding property or field is generated. Note that the
+parameter for the new value is <em>not</em> part of the signature described by <code><i>args</i></code>.
+<p>
+Note: Currently (version 0.6.0) there are some issues with direct
+calls and Corman Lisp, so you shouldn't use <a
+href="#define-rdnzl-call"><code>DEFINE-RDNZL-CALL</code></a> with CCL
+(or you could help fixing these problems).
+
+</blockquote>
+
+<h4><a class=none name="delivery">Saving images and application delivery</a></h4>
+
+It is possible to save images with RDNZL loaded or to deliver RDNZL
+executables. However, you have to watch out for certain things: Make
+sure that no references to .NET objects remain in the image and
+finally call <a href="#shutdown-rdnzl"><code>SHUTDOWN-RDNZL</code></a> prior to saving or delivering.
+<p>
+If you restart the image or start the executable, make sure to call
+<a href="#init-rdnzl"><code>INIT-RDNZL</code></a> before accessing any RDNZL functionality. That should do
+the trick.
+<p>
+The <code>examples</code> directory of the RDNZL distribution contains sample
+delivery files for AllegroCL, Corman Lisp, and LispWorks to demonstrate this.
+
+<p><br>[Function]
+<br><a class=none name="shutdown-rdnzl"><b>shutdown-rdnzl</b> <i> <tt>&optional</tt> no-gc </i> => |</a>
+
+<blockquote><br>
+Prepares RDNZL for delivery or image saving. After calling this
+function RDNZL can't be used anymore unless <a href="#init-rdnzl"><code>INIT-RDNZL</code></a> is called
+again. If <code><i>no-gc</i></code> is <code>NIL</code> (the default), a full garbage collection is
+also performed.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="init-rdnzl"><b>init-rdnzl</b> <i> </i> => |</a>
+
+<blockquote><br>
+Initializes RDNZL. This function must be called once before RDNZL is
+used. It is automatically called when you load RDNZL.
+</blockquote>
+
+<br> <br><h3><a class=none name="generic">Generic types</a></h3>
+
+In summary, refer to a generic type with type arguments filled with a
+list of type names like
+
+<pre>
+("System.Collections.Generic.List" "System.Int32")
+</pre>
+
+<h4>Motivation</h4>
+
+The name of a generic type, when 'closed' with type arguments so it is
+instantiable, is of the form
+
+<pre>
+Basetype´arity[ParameterType1, ..., ParameterTypeN]
+</pre>
+
+and type names of this form can in general be used in all contexts
+like the argument to <a href="#new"><code>NEW</code></a> and so forth.
+However, for this type to be found, all the parameter types must
+either lie in the same assembly as the base type or their names must
+be assembly-qualified. Furthermore, the full 'path' to each type
+would have to be specified even if their namespaces had been imported
+with <a href="#use-namespace"><code>USE-NAMESPACE</code></a> making
+this a bit unpractical.
+<p>
+To solve this, all functions that accept a string as a typename
+argument will also accept a list of typenames (including sublists for
+when type arguments are themselves generic types) where these lists
+represent generic types with their parameters. Also, since the length
+of the list is enough to determine the arity of the type, the
+<code>´arity</code>-part of the type-name can be dropped. Each
+type name element of the list will have its name resolved in the
+imported namespaces.
+<p>
+The upshot is that one can instantiate the type with full name
+<pre>
+System.Func`2[[System.Int32, mscorlib, Version=2.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089],
+ [System.Int32, mscorlib, Version=2.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089]],
+System.Core, Version=3.5.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089
+</pre>
+using
+<pre>
+(<a href="#import-assembly" class=noborder>import-assembly</a> "mscorlib") <font color=orange>; Int32 lives here</font>
+(import-assembly "System.Core") <font color=orange>; Func (of diverse arities) lives here</font>
+(<a href="#use-namespace" class=noborder>use-namespace</a> "System")
+(<a href="#new" class=noborder>new</a> '("Func" "Int32" "Int32") #'1+)
+</pre>
+
+<br> <br><h3><a class=none name="details">Implementation details and things to watch out for</a></h3>
+
+The first implementation of RDNZL (which I <a href="http://weitz.de/RDNZL.htm">demoed</a> <a href="http://weitz.de/files/RDNZL.zip">in</a> <a href="http://weitz.de/files/RDNZL.pps">Amsterdam</a>) used
+the <a href="http://www.cliki.net/AMOP">MOP</a> to map .NET types to CLOS classes. I have removed this code
+in favor of a simpler approach because using the MOP results in a lot
+of overhead at runtime and doesn't work well with application
+delivery. In fact, a lot of the design decisions in RDNZL are based on the
+fact that I want to be able to easily deliver small executables. If it were just for speed and/or convenience, RDNZL would look differently.
+<p>
+If you're concerned about speed, keep in mind that calls into .NET are
+expensive because a lot of marshalling of arguments is happening
+behind the scenes and the system deploys the .NET reflection API at
+runtime. It is advisable to keep interaction between .NET and Lisp out
+of tight loops, i.e. to implement such loops either fully in Lisp or
+fully in .NET.
+<p>
+If you want to know more about the way methods are
+looked up in RDNZL, read <a href="http://www.rivendell.ws/dot-scheme/scheme-workshop-2003-paper.pdf">Pedro Pinto's paper</a>
+about the implementation of <a href="http://www.rivendell.ws/dot-scheme/">Dot-Scheme</a> the basics of which apply to
+RDNZL as well.
+<p>
+The garbage collectors of Lisp and .NET should generally be able to
+co-exist without problems. However, with delegates there's a potential
+problem. Consider this example (from Pedro Pinto):
+<pre>
+(let ((button (<a class=noborder href="#new">new</a> "System.Windows.Form.Button")))
+ [+Click button (new "System.EventHandler"
+ (lambda (sender event-args)
+ (declare (ignore sender event-args))
+ (setf [%Text button] "Clicked!")))])
+</pre>
+Now, RDNZL keeps a reference to <code>BUTTON</code> which is closed over by the
+event-handler defined above and thus the .NET garbage collector won't
+be able to get rid of the button. As a result it can't release the
+event handlers of this button either and thus the Lisp garbage
+collector won't be notified that the closure is no longer
+used. Currently, the only way to avoid these problems with cyclic
+references is: "So don't do that!"
+<p>
+If .NET calls back into Lisp from a "foreign" thread (one that wasn't
+created by Lisp), this'll not work in some implementations.
+Specifically, <a
+href="http://common-lisp.net/pipermail/rdnzl-devel/2006-January/000048.html">as
+Dominic Robinson has pointed out</a>, there might be GC issues in this
+case.
+See <a href="http://weitz.de/lw-callbacks/">here</a>
+and <a
+href="http://common-lisp.net/pipermail/rdnzl-devel/2005-December/000044.html">here</a>
+for possible workarounds for LispWorks 4.4.x (not needed for LispWorks 5.0 and higher).
+<p>
+About the name: It was pretty clear to me from the beginning that the
+name of the library should be "<a
+href="http://globalia.net/donlope/fz/songs/RDNZL.html">RDNZL</a>."
+However, I'm not sure what this acronym exactly stands for. Surely, "L" is
+for "Lisp" and "DN" is for "DotNet". The rest? You'll figure it out... :)
+
+<br> <br><h3><a class=none name="ack">Acknowledgements</a></h3>
+
+RDNZL owes very much to Pedro Pinto's <a href="http://www.rivendell.ws/dot-scheme/">Dot-Scheme</a> project, especially
+as far as the C++ part is concerned. In fact, I couldn't have written
+RDNZL without studying (and partly copying) the Dot-Scheme
+implementation. Pedro was also very helpful during the development of
+RDNZL and answered a couple of dumb questions of mine. Thank you very
+much! (All errors in RDNZL are mine, of course.)
+<p>
+Thanks to Charles A. Cox for the port of RDNZL to AllegroCL. Thanks to
+Vasilis Margioulas for the CLISP port. Thanks to Roger Corman for his
+help with the CCL port. Thanks to Michael Goffioul for the ECL port.
+Thanks to Franz Inc. (and particularly Jans Aasman) for supporting the
+development of RDNZL. Thanks to Iver Odin Kvello for numerous fixes
+and additions.
+<p>
+$Header: /usr/local/cvsrep/rdnzl/doc/index.html,v 1.102 2008/03/25 17:06:25 edi Exp $
+<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
+
+</body>
+</html>
+
Added: trunk/rdnzl/examples/AproposGui.cs
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/AproposGui.cs Wed Apr 30 04:28:03 2008
@@ -0,0 +1,107 @@
+// $Header: /usr/local/cvsrep/rdnzl/examples/AproposGui.cs,v 1.10 2008/02/14 11:38:49 edi Exp $
+
+// Copyright (c) 2004-2008, 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.
+
+// compile this with:
+// csc.exe /target:library AproposGui.cs
+// and put the resulting DLL into your Lisp's application folder
+
+using System;
+using System.Collections;
+using System.ComponentModel;
+using System.Drawing;
+using System.Data;
+using System.Windows.Forms;
+
+namespace AproposGUI {
+ public class AproposControl : System.Windows.Forms.UserControl {
+ public System.Windows.Forms.TextBox textBox;
+ public System.Windows.Forms.TextBox listBox;
+ private System.Windows.Forms.Label label;
+ public System.Windows.Forms.Label title;
+
+ private System.ComponentModel.Container components = null;
+
+ public AproposControl() {
+ InitializeComponent();
+ }
+
+ protected override void Dispose(bool disposing) {
+ if (disposing) {
+ if (components != null)
+ components.Dispose();
+ }
+ base.Dispose(disposing);
+ }
+
+ private void InitializeComponent() {
+ this.textBox = new System.Windows.Forms.TextBox();
+ this.listBox = new System.Windows.Forms.TextBox();
+ this.label = new System.Windows.Forms.Label();
+ this.title = new System.Windows.Forms.Label();
+ this.SuspendLayout();
+
+ this.textBox.Location = new System.Drawing.Point(16, 344);
+ this.textBox.Name = "textBox";
+ this.textBox.Size = new System.Drawing.Size(584, 20);
+ this.textBox.TabIndex = 0;
+ this.textBox.Text = "";
+
+ this.listBox.Location = new System.Drawing.Point(16, 56);
+ this.listBox.Multiline = true;
+ this.listBox.Name = "listBox";
+ this.listBox.ReadOnly = true;
+ this.listBox.ScrollBars = System.Windows.Forms.ScrollBars.Vertical;
+ this.listBox.Size = new System.Drawing.Size(584, 248);
+ this.listBox.TabIndex = 1;
+ this.listBox.Text = "";
+
+ this.label.Location = new System.Drawing.Point(24, 312);
+ this.label.Name = "label";
+ this.label.Size = new System.Drawing.Size(576, 23);
+ this.label.TabIndex = 2;
+ this.label.Text = "Enter text below and press RETURN";
+ this.label.TextAlign = System.Drawing.ContentAlignment.MiddleCenter;
+
+ this.title.Font = new System.Drawing.Font("Microsoft Sans Serif", 12F, System.Drawing.FontStyle.Bold, System.Drawing.GraphicsUnit.Point, ((System.Byte)(0)));
+ this.title.Location = new System.Drawing.Point(24, 16);
+ this.title.Name = "title";
+ this.title.Size = new System.Drawing.Size(568, 24);
+ this.title.TabIndex = 3;
+ this.title.Text = "RDNZL Apropos Demo";
+ this.title.TextAlign = System.Drawing.ContentAlignment.MiddleCenter;
+
+ this.Controls.Add(this.title);
+ this.Controls.Add(this.label);
+ this.Controls.Add(this.listBox);
+ this.Controls.Add(this.textBox);
+ this.Name = "MainControl";
+ this.Size = new System.Drawing.Size(616, 384);
+ this.ResumeLayout(false);
+ }
+ }
+}
Added: trunk/rdnzl/examples/AproposGui.dll
==============================================================================
Binary file. No diff available.
Added: trunk/rdnzl/examples/Callback.cs
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/Callback.cs Wed Apr 30 04:28:03 2008
@@ -0,0 +1,38 @@
+// $Header: /usr/local/cvsrep/rdnzl/examples/Callback.cs,v 1.1 2008/02/14 11:38:49 edi Exp $
+
+// Copyright (c) 2008, 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.
+
+// compile this with:
+// csc.exe /target:library Callback.cs
+// and put the resulting DLL into your Lisp's application folder
+
+using System;
+
+namespace Callback {
+ public delegate Int32 int32Callback (String input);
+ public delegate String stringCallback (Int32 input);
+}
Added: trunk/rdnzl/examples/Callback.dll
==============================================================================
Binary file. No diff available.
Added: trunk/rdnzl/examples/apropos.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/apropos.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,88 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/apropos.lisp,v 1.12 2008/02/14 11:38:49 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+(in-package :rdnzl-user)
+
+(enable-rdnzl-syntax)
+
+(import-types "System.Windows.Forms"
+ "Application" "DockStyle" "Form" "MessageBox" "KeyPressEventHandler" "TextBox")
+
+(import-types "AproposGUI"
+ "AproposControl")
+
+(use-namespace "System.Windows.Forms")
+(use-namespace "AproposGUI")
+
+(defun copy-to-clipboard (text-box)
+ (let ((selection-start [%SelectionStart text-box])
+ (selection-length [%SelectionLength text-box])
+ (text-length [%Length (box [%Text text-box])]))
+ (setf [%SelectionStart text-box] 0
+ [%SelectionLength text-box] text-length)
+ [Copy text-box]
+ (setf [%SelectionStart text-box] selection-start
+ [%SelectionLength text-box] selection-length)))
+
+(let (message-shown)
+ (defun fill-list-box (object event)
+ (when (char= [%KeyChar event] #\Return)
+ (cast object "TextBox")
+ (let* ((input-string [%Text object])
+ (input-length (length input-string)))
+ (when (plusp input-length)
+ (let ((apropos-text
+ (with-output-to-string (*standard-output*)
+ (apropos input-string)))
+ (list-box [$listBox (cast [%Parent object] "AproposControl")]))
+ #+(or :cormanlisp :ecl) (setq apropos-text (lf-to-crlf apropos-text))
+ (setf [%Text list-box] apropos-text)
+ (copy-to-clipboard list-box)
+ (unless message-shown
+ [MessageBox.Show "The output of APROPOS has been copied to the clipboard."
+ "RDNZL"]
+ (setq message-shown t)))
+ (setf [%SelectionStart object] 0
+ [%SelectionLength object] input-length))))))
+
+(defun run-apropos-form ()
+ (let* ((control (new "AproposControl"))
+ (form (new "Form")))
+ (setf [%Dock control] [$DockStyle.Fill]
+ [%ClientSize form] [%ClientSize control]
+ [%Text form] "RDNZL Apropos Demo"
+ [%Text [$title control]]
+ (format nil "RDNZL Apropos Demo (~A)"
+ (lisp-implementation-type)))
+ [+KeyPress [$textBox control]
+ (new "KeyPressEventHandler" #'fill-list-box)]
+ [Add [%Controls form] control]
+ [Application.Run form]))
+
+(disable-rdnzl-syntax)
\ No newline at end of file
Added: trunk/rdnzl/examples/apropos2.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/apropos2.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,199 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/apropos2.lisp,v 1.10 2008/01/26 22:28:35 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+;;; same as apropos.lisp but using "direct calls"
+
+(in-package :rdnzl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; wrapped in EVAL-WHEN because these must be available when the
+ ;; direct calls are defined
+ (import-types "System.Windows.Forms"
+ "Application" "Control" "Control+ControlCollection" "DockStyle" "Form"
+ "MessageBox" "KeyPressEventArgs" "KeyPressEventHandler" "TextBox")
+
+ (import-types "AproposGUI"
+ "AproposControl")
+
+ (use-namespace "System.Windows.Forms")
+ (use-namespace "AproposGUI"))
+
+;; an instance property
+(define-rdnzl-call controls
+ (:member-kind :property)
+ ((control "Control")))
+
+;; we can't use the standard name here because LENGTH is an external
+;; symbol of the COMMON-LISP package
+(define-rdnzl-call string-length
+ (:member-kind :property
+ :dotnet-name "Length")
+ ((string "System.String")))
+
+(define-rdnzl-call text
+ (:member-kind :property)
+ ((control "Control")))
+
+;; a setter function for an instance property
+(define-rdnzl-call (setf text)
+ (:member-kind :property)
+ ((control "Control")))
+
+(define-rdnzl-call (setf dock)
+ (:member-kind :property)
+ ((control "Control")))
+
+(define-rdnzl-call client-size
+ (:member-kind :property)
+ ((control "Control")))
+
+(define-rdnzl-call (setf client-size)
+ (:member-kind :property)
+ ((control "Control")))
+
+(define-rdnzl-call selection-start
+ (:member-kind :property)
+ ((text-box "TextBox")))
+
+(define-rdnzl-call (setf selection-start)
+ (:member-kind :property)
+ ((text-box "TextBox")))
+
+(define-rdnzl-call selection-length
+ (:member-kind :property)
+ ((text-box "TextBox")))
+
+(define-rdnzl-call (setf selection-length)
+ (:member-kind :property)
+ ((text-box "TextBox")))
+
+(define-rdnzl-call parent
+ (:member-kind :property)
+ ((string "TextBox")))
+
+;; an instance method
+(define-rdnzl-call copy
+ ()
+ ((text-box "TextBox")))
+
+(define-rdnzl-call key-char
+ (:member-kind :property)
+ ((event "KeyPressEventArgs")))
+
+;; an instance field (which should have been called "Title" instead of
+;; "title")
+(define-rdnzl-call title
+ (:member-kind :field
+ :dotnet-name "title")
+ ((control "AproposControl")))
+
+(define-rdnzl-call list-box
+ (:member-kind :field
+ :dotnet-name "listBox")
+ ((control "AproposControl")))
+
+(define-rdnzl-call text-box
+ (:member-kind :field
+ :dotnet-name "textBox")
+ ((control "AproposControl")))
+
+(define-rdnzl-call add
+ ()
+ ((collection "Control+ControlCollection")
+ (control "Control")))
+
+;; a static method of the .NET type MessageBox
+(define-rdnzl-call show
+ (:type-name "MessageBox")
+ ((text "System.String")
+ (caption "System.String")))
+
+(define-rdnzl-call run-form
+ (:type-name "Application"
+ ;; renamed because deliver-xx.lisp already contains a RUN
+ ;; function
+ :dotnet-name "Run")
+ ((form "Form")))
+
+;; a static field of the .NET type DockStyle (which is an enumeration)
+(define-rdnzl-call dock-style/fill
+ (:member-kind :field
+ :dotnet-name "Fill"
+ :type-name "DockStyle")
+ ())
+
+(define-rdnzl-call add-key-press
+ (:dotnet-name "add_KeyPress")
+ ((text-box "TextBox")
+ (handler "KeyPressEventHandler")))
+
+(defun copy-to-clipboard (text-box)
+ (let ((selection-start (selection-start text-box))
+ (selection-length (selection-length text-box))
+ (text-length (string-length (box (text text-box)))))
+ (setf (selection-start text-box) 0
+ (selection-length text-box) text-length)
+ (copy text-box)
+ (setf (selection-start text-box) selection-start
+ (selection-length text-box) selection-length)))
+
+(let (message-shown)
+ (defun fill-list-box (object event)
+ (when (char= (key-char event) #\Return)
+ (cast object "TextBox")
+ (let* ((input-string (text object))
+ (input-length (length input-string)))
+ (when (plusp input-length)
+ (let ((apropos-text
+ (with-output-to-string (*standard-output*)
+ (apropos input-string)))
+ (list-box (list-box (cast (parent object) "AproposControl"))))
+ #+(or :cormanlisp :ecl) (setq apropos-text (lf-to-crlf apropos-text))
+ (setf (text list-box) apropos-text)
+ (copy-to-clipboard list-box)
+ (unless message-shown
+ (show "The output of APROPOS has been copied to the clipboard."
+ "RDNZL")
+ (setq message-shown t)))
+ (setf (selection-start object) 0
+ (selection-length object) input-length))))))
+
+(defun run-apropos-form ()
+ (let* ((control (new "AproposControl"))
+ (form (new "Form")))
+ (setf (dock control) (dock-style/fill)
+ (client-size form) (client-size control)
+ (text form) "RDNZL Apropos Demo"
+ (text (title control))
+ (format nil "RDNZL Apropos Demo (~A)"
+ (lisp-implementation-type)))
+ (add-key-press (text-box control)
+ (new "KeyPressEventHandler" #'fill-list-box))
+ (add (controls form) control)
+ (run-form form)))
\ No newline at end of file
Added: trunk/rdnzl/examples/callback.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/callback.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,49 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/callback.lisp,v 1.9 2008/02/14 11:38:49 edi Exp $
+
+;;; Copyright (c) 2008, 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 is a simple test for callbacks - see <http://common-lisp.net/pipermail/rdnzl-devel/2008-February/000184.html>
+
+(in-package :rdnzl-user)
+
+(enable-rdnzl-syntax)
+
+(import-types "Callback"
+ "int32Callback" "stringCallback")
+
+(use-namespace "Callback")
+
+(defun test-int32-callback (string)
+ (let ((callback (new "int32Callback" (lambda (string) (length string)))))
+ (invoke callback "Invoke" string)))
+
+(defun test-string-callback (int)
+ (let ((callback (new "stringCallback" (lambda (int) (format nil "~R" int)))))
+ (invoke callback "Invoke" int)))
+
+(disable-rdnzl-syntax)
\ No newline at end of file
Added: trunk/rdnzl/examples/deliver-acl.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/deliver-acl.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,70 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/deliver-acl.lisp,v 1.8 2008/01/26 22:28:35 edi Exp $
+
+;;; Copyright (c) 2004-2008, Charles A. Cox. 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.
+
+;;; Example: How to deliver a RDNZL application with AllegroCL
+
+(in-package :cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :res))
+
+(defparameter *rdnzl-directory*
+ ;; assume this file is in examples/ subdirectory
+ (merge-pathnames #p".."
+ (make-pathname :name nil
+ :type nil
+ :version nil
+ :defaults *load-truename*)))
+
+;; make sure RDNZL is loaded so that we can compile apropos.lisp
+;; (better to use provide/require for this?)
+(unless (find-package ':rdnzl)
+ (load (merge-pathnames #p"load.lisp" *rdnzl-directory*)))
+
+(let ((*default-pathname-defaults* *rdnzl-directory*))
+ (generate-application
+ "apropos" ; application name
+ (merge-pathnames #p"examples/apropos/") ; application directory
+ ;; list of files to load in the image being built
+ (list (merge-pathnames #p"load.lisp")
+ (merge-pathnames (compile-file #p"examples/apropos.lisp")))
+ ;; extra files used at runtime
+ :application-files (list (merge-pathnames #p"rdnzl.dll")
+ (merge-pathnames #p"examples/AproposGui.dll"))
+ :discard-compiler t
+ :allow-existing-directory t
+ :post-load-form '(rdnzl:shutdown-rdnzl)
+ :restart-app-function '(lambda ()
+ (rdnzl:init-rdnzl)
+ (rdnzl-user::run-apropos-form)
+ (exit)))
+
+ (win:set-default-command-line-arguments #p"examples/apropos/apropos.exe"
+ ;; suppress console
+ '("+c")))
Added: trunk/rdnzl/examples/deliver-ccl.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/deliver-ccl.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,83 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/deliver-ccl.lisp,v 1.9 2008/01/26 22:28:35 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+;;; Example: How to deliver a RDNZL application with Corman Common Lisp
+
+;;; Usage: Start clconsole.exe and from there
+;;; (LOAD "/path/to/RDNZL/examples/deliver-ccl.lisp")
+
+(in-package :cl-user)
+
+(defun copy-file (from to)
+ (let ((element-type '(unsigned-byte 8)))
+ (with-open-file (in from
+ :element-type element-type)
+ (with-open-file (out to
+ :direction :output
+ :if-exists :supersede
+ :element-type element-type)
+ (loop for byte = (read-byte in nil nil)
+ while byte
+ do (write-byte byte out))))))
+
+(defparameter *rdnzl-directory*
+ ;; assume this file is in examples/ subdirectory
+ (make-pathname :name nil
+ :type nil
+ :version nil
+ :directory (butlast (pathname-directory *load-truename*))
+ :defaults *load-truename*))
+
+(setf (ccl:current-directory) *rdnzl-directory*)
+
+(load "load.lisp")
+(load "examples/apropos.lisp")
+
+(defun main ()
+ (rdnzl:init-rdnzl)
+ (rdnzl-user::run-apropos-form)
+ (shutdown-rdnzl))
+
+(rdnzl:shutdown-rdnzl)
+
+(let ((target-dir
+ (merge-pathnames "examples/apropos/" *rdnzl-directory*)))
+ (defun target-path (file-name)
+ (merge-pathnames file-name target-dir)))
+
+(copy-file "RDNZL.dll" (ensure-directories-exist
+ (target-path "RDNZL.dll")))
+(copy-file "examples/AproposGUI.dll" (target-path "AproposGUI.dll"))
+(copy-file (concatenate 'string ccl:*cormanlisp-server-directory* "\\msvcr70.dll")
+ (target-path "msvcr70.dll"))
+
+(ccl:save-application (namestring (target-path "apropos.exe"))
+ #'main
+ :console nil
+ :static t)
\ No newline at end of file
Added: trunk/rdnzl/examples/deliver-lw.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/deliver-lw.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,97 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/deliver-lw.lisp,v 1.10 2008/01/26 22:28:36 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+;;; Example: How to deliver a RDNZL application with LispWorks
+
+;;; Usage: Open up a console window and execute somthing like this:
+;;; "C:\Program Files\LispWorks\lispworks-4450.exe" -init "C:\path\to\RDNZL\examples\deliver-lw.lisp"
+
+(in-package :cl-user)
+
+(defun copy-file (from to)
+ (let ((element-type '(unsigned-byte 8))
+ (buffer-size 8192))
+ (with-open-file (in from
+ :element-type element-type)
+ (with-open-file (out to
+ :direction :output
+ :if-exists :supersede
+ :element-type element-type)
+ (let ((buf (make-array buffer-size
+ :element-type element-type)))
+ (loop
+ (let ((pos (read-sequence buf in)))
+ (when (zerop pos) (return))
+ (write-sequence buf out :end pos))))))))
+(compile 'copy-file)
+
+(defparameter *rdnzl-directory*
+ ;; assume this file is in examples/ subdirectory
+ (merge-pathnames #p".."
+ (make-pathname :name nil
+ :type nil
+ :version nil
+ :defaults *load-truename*)))
+
+(hcl:change-directory *rdnzl-directory*)
+(load "load.lisp")
+(load (compile-file "examples/apropos.lisp"))
+
+(defun run ()
+ (rdnzl:init-rdnzl)
+ (rdnzl-user::run-apropos-form)
+ 0)
+(compile 'run)
+
+(rdnzl:shutdown-rdnzl)
+
+(defparameter *target-directory*
+ (merge-pathnames "examples/apropos/" *rdnzl-directory*))
+
+(defun target-path (file-name)
+ (merge-pathnames file-name *target-directory*))
+(compile 'target-path)
+
+(copy-file "RDNZL.dll" (ensure-directories-exist
+ (target-path "RDNZL.dll")))
+(copy-file "examples/AproposGUI.dll" (target-path "AproposGUI.dll"))
+
+(hcl:change-directory *target-directory*)
+
+(lw:deliver #'run "apropos"
+ ;; we could use 5 here but then APROPOS wouldn't make much
+ ;; sense... :)
+ 4
+ :compact t
+ :redefine-compiler-p nil
+ :keep-symbol-names '(rdnzl::LispCallback rdnzl::ReleaseDelegateAdapter)
+ :keep-lisp-reader t
+ :console :input)
+
+(quit)
\ No newline at end of file
Added: trunk/rdnzl/examples/example.xls
==============================================================================
Binary file. No diff available.
Added: trunk/rdnzl/examples/excel.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/excel.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,104 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/excel.lisp,v 1.6 2008/01/26 22:28:36 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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 example is an adapted version of the code found at
+;;; <http://www.c-sharpcorner.com/winforms/ExcelReadMG.asp>.
+;;; It was tested with Microsoft Office 2003.
+
+;;; Note: LOAD this file, before you COMPILE-FILE it.
+
+(in-package :rdnzl-user)
+
+(enable-rdnzl-syntax)
+
+(import-types "System.Windows.Forms" "DialogResult" "OpenFileDialog")
+(import-types "Microsoft.Office.Interop.Excel" "ApplicationClass" "WorkbookClass" "Worksheet")
+
+(use-namespace "Microsoft.Office.Interop.Excel")
+(use-namespace "System.Windows.Forms")
+
+(defvar *this-file* (load-time-value
+ (or #.*compile-file-pathname* *load-pathname*))
+ "The pathname of the file \(`test.lisp') where this variable was
+defined.")
+
+(defconstant +missing+ [$System.Reflection.Missing.Value]
+ "Represents missing arguments.")
+
+(defconstant +dialog-ok+ [$DialogResult.OK]
+ "Returned by `OpenFileDialog' if the user confirmed the dialog.")
+
+(defconstant +initial-directory+
+ (load-time-value
+ (namestring (make-pathname :name nil :type nil
+ :defaults *this-file*))))
+
+(defconstant +initial-filename+
+ (load-time-value
+ (namestring (make-pathname :name "example" :type "xls"
+ :defaults *this-file*))))
+
+(defun prompt-for-file (title)
+ (let ((dialog (new "OpenFileDialog")))
+ (setf [%InitialDirectory dialog] +initial-directory+
+ [%Filter dialog]
+ "Microsoft Excel files (*.xls)|*.xls|All files (*.*)|*.*"
+ [%FileName dialog]
+ +initial-filename+
+ [%Title dialog] title)
+ (and [Equals [ShowDialog dialog] +dialog-ok+]
+ [%FileName dialog])))
+
+(defun get-excel-range (file-name range)
+ (let* ((app (new "ApplicationClass"))
+ (workbooks [%Workbooks app])
+ (workbook (cast [Open workbooks file-name
+ +missing+ nil +missing+
+ +missing+ +missing+ +missing+
+ +missing+ +missing+ +missing+
+ +missing+ +missing+ +missing+
+ +missing+ +missing+]
+ "WorkbookClass"))
+ (worksheets [%Worksheets workbook])
+ (sheet (cast [get_Item worksheets 1] "Worksheet"))
+ (range [get_Range sheet range +missing+]))
+ (prog1 (cast [%Value2 [%Cells range]] "System.Array")
+ [Quit app])))
+
+(defun convert-range-array-to-lists (range-array)
+ (loop for row from 1 to [GetLength range-array 0]
+ collect (loop for col from 1 to [GetLength range-array 1]
+ collect [ToString (aref* range-array row col)])))
+
+(defun range-contents (&key (file-name (prompt-for-file "Select an Excel file"))
+ (range "A1:C4"))
+ (convert-range-array-to-lists
+ (get-excel-range file-name range)))
+
+(disable-rdnzl-syntax)
\ No newline at end of file
Added: trunk/rdnzl/examples/messagebox.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/messagebox.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,45 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/messagebox.lisp,v 1.9 2008/01/26 22:28:36 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+(in-package :rdnzl-user)
+
+(enable-rdnzl-syntax)
+
+(import-types "System.Windows.Forms"
+ "MessageBox" "MessageBoxButtons" "DialogResult")
+
+(use-namespace "System.Windows.Forms")
+
+(defun message-box (text &optional (caption "RDNZL"))
+ [Equals [MessageBox.Show text caption
+ ;; we want the message box to have "OK" and "Cancel" buttons
+ [$MessageBoxButtons.OKCancel]]
+ [$DialogResult.OK]])
+
+(disable-rdnzl-syntax)
Added: trunk/rdnzl/examples/url.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/examples/url.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,47 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/examples/url.lisp,v 1.10 2008/01/26 22:28:36 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+(in-package :rdnzl-user)
+
+(enable-rdnzl-syntax)
+
+(import-types "System" "Net.WebClient" "Net.WebException")
+
+(use-namespace "System.Net")
+
+(defun download-url (url)
+ (rdnzl-handler-case
+ (let ((web-client (new "WebClient")))
+ [GetString (new "System.Text.ASCIIEncoding")
+ [DownloadData web-client url]])
+ ("WebException" (e)
+ (warn "Ooops, probably a typo: ~A" [%Message e])
+ nil)))
+
+(disable-rdnzl-syntax)
\ No newline at end of file
Added: trunk/rdnzl/ffi.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/ffi.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,343 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/ffi.lisp,v 1.34 2008/01/26 22:28:30 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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* (,(make-lisp-name c-name)
+ ,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 "setDotNetContainerTypeFromContainer"
+ ((type ffi-void-pointer)
+ (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 "copyDotNetContainer"
+ ((ptr ffi-void-pointer))
+ 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))
+ ;; 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*))
Added: trunk/rdnzl/import.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/import.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,199 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/import.lisp,v 1.59 2008/02/14 10:33:51 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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 ((or (stringp type)
+ (consp 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)))
+ 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")
+ ;; set Lisp callback pointers back to NULL before the image exits
+ (register-exit-function (lambda ()
+ (%set-function-pointers (ffi-make-null-pointer)
+ (ffi-make-null-pointer)))
+ "Clear Lisp callbacks")
+ (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)
Added: trunk/rdnzl/load.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/load.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,74 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/load.lisp,v 1.20 2008/01/26 22:28:31 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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"
+ #+:ecl "port-ecl"
+ #+: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)))))
+
+
+
+
+
Added: trunk/rdnzl/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/packages.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,77 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/packages.lisp,v 1.32 2008/01/26 22:28:31 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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 :*coerce-double-floats-to-single*
+ :aref*
+ :box
+ :cast
+ :container-p
+ :copy-container
+ :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
+ #+(or :cormanlisp :ecl) :lf-to-crlf
+ :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
Added: trunk/rdnzl/port-acl.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/port-acl.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,284 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/port-acl.lisp,v 1.18 2008/01/26 22:28:31 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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
+;;; 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.
+
+;;; AllegroCL-specific definitions
+
+(in-package :rdnzl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :foreign))
+
+;; This variable should really evaluate to ':fat-le, but the fat-le
+;; external-format was left out of the Allegro CL distribution by
+;; mistake. A patch will be available, but a workaround is to use the
+;; equivalent "rdnzl-fat" external-format, the definition of which is
+;; included below.
+(defparameter *wchar-external-format* '(e-crlf :rdnzl-fat))
+
+;; Begin rdnzl-fat definition.
+(in-package :excl)
+
+(def-external-format :rdnzl-fat :nulls 2 :width 2)
+
+(def-char-to-octets-macro :rdnzl-fat (char state
+ &key put-next-octet external-format)
+ (declare (ignore external-format state))
+ `(let ((code (char-code ,char)))
+ (,put-next-octet (ldb (byte 8 0) code))
+ (,put-next-octet (ldb (byte 8 8) code))))
+
+(def-octets-to-char-macro :rdnzl-fat (state-loc &key get-next-octet external-format
+ octets-count-loc unget-octets)
+ (declare (ignore external-format state-loc unget-octets))
+ `(code-char (+ ,get-next-octet
+ (progn (incf ,octets-count-loc)
+ (ash ,get-next-octet 8)))))
+
+;; force auto-compilation. Suppress the unnecessary notes.
+(with-output-to-string (*system-messages*)
+ (string-to-octets "foo" :external-format :rdnzl-fat))
+
+(in-package :rdnzl)
+;; End rdnzl-fat definition.
+
+(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)
+ (load ,path)))
+
+(defgeneric ffi-pointer-p (object)
+ (:documentation "Tests whether OBJECT is an FFI pointer."))
+
+(defmethod ffi-pointer-p ((object ff:foreign-pointer))
+ t)
+
+(defmethod ffi-pointer-p ((object integer))
+ t)
+
+(defmethod ffi-pointer-p ((object t))
+ nil)
+
+(defgeneric ffi-null-pointer-p (pointer)
+ (:documentation
+ "Returns whether the FFI pointer POINTER is a null pointer."))
+
+(defmethod ffi-null-pointer-p ((pointer (eql 0)))
+ t)
+
+(defmethod ffi-null-pointer-p ((pointer ff:foreign-pointer))
+ (eql 0 (ff:foreign-pointer-address pointer)))
+
+(defmethod ffi-null-pointer-p ((pointer t))
+ nil)
+
+(defgeneric ffi-pointer-address (pointer)
+ (:documentation "Returns the address of the FFI pointer POINTER."))
+
+(defmethod ffi-pointer-address ((pointer ff:foreign-pointer))
+ (ff:foreign-pointer-address pointer))
+
+(defmethod ffi-pointer-address ((pointer integer))
+ pointer)
+
+(defun ffi-make-pointer (name)
+ "Returns an FFI pointer to the address specified by the name NAME.
+Allegro CL Note: Use only for foreign-callable symbols."
+ (ff:register-foreign-callable name :reuse t))
+
+(defun ffi-make-null-pointer ()
+ "Returns an FFI NULL pointer."
+ 0)
+
+(defun ffi-map-type (type-name)
+ "Maps type names like FFI-INTEGER to their corresponding names in
+the Allegro CL FLI."
+ (ecase type-name
+ (ffi-void '(:void))
+ (ffi-void-pointer '((* :void)))
+ (ffi-const-string '((* :void)))
+ (ffi-integer '(:int))
+ (ffi-boolean '(:int boolean))
+ (ffi-wide-char '(:unsigned-short))
+ (ffi-float '(:float))
+ (ffi-double '(:double))))
+
+(excl:def-fwrapper wchar_t-retval (x)
+ (code-char (excl:call-next-fwrapper)))
+
+(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."
+ (flet ((arg-spec (arg-list)
+ (mapcar #'(lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (cons name (ffi-map-type type))))
+ arg-list)))
+ `(progn
+ (ff:def-foreign-call (,lisp-name ,c-name) ,(arg-spec arg-list)
+ :returning ,(ffi-map-type result-type)
+ :strings-convert t
+ :release-heap :when-ok
+ :convention ':c)
+ ,@(when (eq result-type 'ffi-wide-char)
+ `((excl:fwrap ',lisp-name 'wchar_t-wrapper 'wchar_t-retval))))))
+
+(defmacro ffi-define-callable ((c-name result-type)
+ arg-list
+ &body body)
+ "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
+ ,(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (car (ffi-map-type type)))))
+ arg-list)
+ ;; the following is overridden by Windows Allegro CL
+ ;; (declare (:unwind nil))
+ , at body)
+ (ff:register-foreign-callable ',c-name ':reuse t)))
+
+(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)))
+ (excl::with-dynamic-extent-usb8-array (,temp (* 2 (1+ ,length)))
+ (,function ,object ,temp)
+ (excl:octets-to-string
+ ,temp
+ :external-format *wchar-external-format*))))))
+
+(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
+ `(excl:with-native-string
+ (,foreign-string ,string
+ :external-format *wchar-external-format*)
+ (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))))))))
+
+(defconstant *ffi-args-size* 20)
+
+(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 element-count byte-count)
+ (declare (ignorable foreign-name element-count byte-count))
+ ` (let* ((,length (length ,args))
+ (,arg-pointers (make-array ,length :initial-element nil)))
+ (unwind-protect
+ (ff:with-stack-fobject (,ffi-arg-pointers
+ '(:array (* :void) ,*ffi-args-size*))
+ (when (> ,length ,*ffi-args-size*)
+ (error "Need more coding here..."))
+ (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 (ff:fslot-value ,ffi-arg-pointers ,i)
+ ,arg-pointer))
+ ,(cond (name
+ `(excl:with-native-string
+ (,foreign-name
+ ,name
+ :external-format *wchar-external-format*)
+ (,function ,foreign-name
+ ,object
+ ,length
+ ,ffi-arg-pointers)))
+ (t
+ `(,function ,object
+ ,length
+ ,ffi-arg-pointers))))
+ ;; all .NET elements that were solely created (by BOX*)
+ ;; for this FFI call are immediately freed
+ (dotimes (,i ,length)
+ (named-when (,arg-pointer (aref ,arg-pointers ,i))
+ (%free-dot-net-container ,arg-pointer))))))))
+
+(defun flag-for-finalization (object &optional function)
+ "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT
+is removed by GC."
+ (excl:schedule-finalization object function))
+
+(defmacro register-exit-function (function &optional name)
+ "Makes sure the function FUNCTION \(with no arguments) is called
+before the Lisp images exits."
+ (declare (ignore name))
+ `(push
+ ',(list 'funcall function)
+ sys:*exit-cleanup-forms*))
+
+(defun full-gc ()
+ "Invokes a full garbage collection."
+ (excl:gc t))
Added: trunk/rdnzl/port-ccl.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/port-ccl.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,286 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/port-ccl.lisp,v 1.29 2008/01/26 22:28:31 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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-make-null-pointer ()
+ "Returns an FFI NULL pointer."
+ (ct:create-foreign-ptr))
+
+(defun ffi-map-type (type-name)
+ "Maps type names like FFI-INTEGER to their corresponding names in
+the Corman Lisp FFI."
+ (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 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."
+ (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 ()
+ "Invokes a full garbage collection."
+ (ccl:gc 3))
+
+(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))
Added: trunk/rdnzl/port-clisp.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/port-clisp.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,254 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/port-clisp.lisp,v 1.12 2008/01/26 22:28:31 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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))
+ (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 ()
+ "Invokes a full garbage collection."
+ (ext:gc))
Added: trunk/rdnzl/port-ecl.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/port-ecl.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,257 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/port-ecl.lisp,v 1.5 2008/01/26 22:28:31 edi Exp $
+
+;;; Copyright (c) 2004-2008, Vasilis Margioulas, Michael Goffioul, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; ECL-specific definitions
+
+(in-package :rdnzl)
+
+(defvar *dll-path* nil
+ "The name of RDNZL.dll.")
+
+(defmacro ffi-register-module (dll-path &optional module-name)
+ "Store the DLL name provided by the argument DLL-PATH."
+ (declare (ignore module-name))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq *dll-path* ,dll-path)))
+
+(defun ffi-pointer-p (object)
+ "Tests whether OBJECT is an FFI pointer."
+ (eql (type-of object) 'si::foreign-data))
+
+(defun ffi-null-pointer-p (pointer)
+ "Returns whether the FFI pointer POINTER is a null pointer."
+ (ffi:null-pointer-p pointer))
+
+(defun ffi-pointer-address (pointer)
+ "Returns the address of the FFI pointer POINTER."
+ (ffi:pointer-address pointer))
+
+(defun ffi-make-pointer (name)
+ "Returns an FFI pointer to the address specified by the name NAME."
+ (ffi:callback name))
+
+(defun ffi-make-null-pointer ()
+ "Returns an FFI NULL pointer."
+ (si:allocate-foreign-data :void 0))
+
+(defun ffi-map-type (type-name)
+ "Maps type names like FFI-INTEGER to their corresponding names in
+the ECL FFI."
+ (ecase type-name
+ (ffi-void :void)
+ (ffi-void-pointer :pointer-void)
+ (ffi-const-string '(* :unsigned-short))
+ (ffi-integer :int)
+ (ffi-boolean :byte)
+ (ffi-wide-char :unsigned-short)
+ (ffi-float :float)
+ (ffi-double :double)))
+
+(defmacro ffi-define-function* ((lisp-name c-name)
+ arg-list
+ result-type)
+ "Defines a Lisp function LISP-NAME which acts as an interface
+to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE)
+pairs. All types are supposed to be symbols mappable by
+FFI-MAP-TYPE above."
+ (cond ((or (member result-type '(ffi-wide-char ffi-boolean))
+ (find 'ffi-wide-char arg-list :key #'second :test #'eq)
+ (find 'ffi-boolean arg-list :key #'second :test #'eq))
+ ;; define a wrapper if one of the args and/or the return type
+ ;; is a __wchar_t because ECL doesn't handle this
+ ;; type automatically
+ (with-unique-names (internal-name result)
+ `(progn
+ (ffi:def-function (,c-name ,internal-name)
+ ,(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (ffi-map-type type))))
+ arg-list)
+ ,@(when (ffi-map-type result-type)
+ `(:returning ,(ffi-map-type result-type)))
+ :module ,*dll-path*)
+ (defun ,lisp-name ,(mapcar #'first arg-list)
+ (let ((,result (,internal-name ,@(loop for (name type) in arg-list
+ if (eq type 'ffi-wide-char)
+ collect `(char-code ,name)
+ else if (eq type 'ffi-boolean)
+ collect `(if ,name 1 0)
+ else
+ collect name))))
+ ,(cond ((eq result-type 'ffi-wide-char)
+ `(code-char ,result))
+ ((eq result-type 'ffi-boolean)
+ `(if (= ,result 0) nil t))
+ (t result)))))))
+ (t
+ `(ffi:def-function (,c-name ,lisp-name)
+ ,(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (ffi-map-type type))))
+ arg-list)
+ ,@(when (ffi-map-type result-type)
+ `(:returning ,(ffi-map-type result-type)))
+ :module ,*dll-path*))))
+
+(defmacro ffi-define-callable ((c-name result-type)
+ arg-list
+ &body body)
+ "Defines a Lisp function which can be called from C.
+ARG-LIST is a list of \(NAME TYPE) pairs. All types are supposed
+to be symbols mappable by FFI-MAP-TYPE above."
+ `(ffi:defcallback ,c-name ,(ffi-map-type result-type)
+ ,(mapcar (lambda (name-and-type)
+ (destructuring-bind (name type) name-and-type
+ (list name (ffi-map-type type))))
+ arg-list)
+ , at body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro with-unicode-string ((var lisp-string) &body body)
+ (with-unique-names (str-len k)
+ `(let* ((,str-len (length ,lisp-string)))
+ (ffi:with-foreign-object (,var `(:array :unsigned-short ,(1+ ,str-len)))
+ (loop for ,k below ,str-len
+ do (si::foreign-data-set-elt ,var (* 2 ,k) :unsigned-short (char-code (char ,lisp-string ,k))))
+ (si::foreign-data-set-elt ,var (* 2 ,str-len) :unsigned-short 0)
+ , at body)))))
+
+(defun unicode-string-to-lisp (ubyte16-array)
+ (let ((char-list (loop for k from 0
+ for uc = (si::foreign-data-ref-elt ubyte16-array (* 2 k) :unsigned-short)
+ while (/= uc 0) collect (code-char uc))))
+ (coerce char-list 'string)))
+
+(defmacro ffi-get-call-by-ref-string (function object length-function)
+ "Calls the foreign function FUNCTION. FUNCTION is supposed to call
+a C function f with the signature void f\(..., __wchar_t *s) where s
+is a result string which is returned by this macro. OBJECT is the
+first argument given to f. Prior to calling f the length of the
+result string s is obtained by evaluating \(LENGTH-FUNCTION OBJECT)."
+ (with-rebinding (object)
+ (with-unique-names (length temp)
+ `(let* ((,length (,length-function ,object)))
+ (ffi:with-foreign-object (,temp `(:array :unsigned-short ,(1+ ,length)))
+ (,function ,object ,temp)
+ (unicode-string-to-lisp ,temp))))))
+
+(defmacro ffi-call-with-foreign-string* (function string &optional other-args)
+ "Applies the foreign function FUNCTION to the string STRING and
+OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native'
+Lisp objects) is converted to a foreign array prior to calling
+FUNCTION. STRING may be NIL which means that this argument is skipped
+\(i.e. the macro actually needs a better name)."
+ (with-rebinding (other-args)
+ (with-unique-names (length arg-pointers ffi-arg-pointers arg i
+ arg-pointer foreign-string)
+ (declare (ignorable foreign-string))
+ `(let* ((,length (length ,other-args))
+ (,arg-pointers (make-array ,length :initial-element nil)))
+ (unwind-protect
+ (let ((,ffi-arg-pointers
+ (loop for ,arg in ,other-args
+ for ,i from 0
+ for ,arg-pointer = (cond
+ ((container-p ,arg) (pointer ,arg))
+ (t (setf (aref ,arg-pointers ,i)
+ (box* ,arg))))
+ collect ,arg-pointer)))
+ ,(cond (string
+ `(with-unicode-string (,foreign-string ,string)
+ (apply #',function ,foreign-string ,ffi-arg-pointers)))
+ (t
+ `(apply #',function ,ffi-arg-pointers))))
+ ;; all .NET elements that were solely created (by BOX*)
+ ;; for this FFI call are immediately freed
+ (dotimes (,i ,length)
+ (named-when (,arg-pointer (aref ,arg-pointers ,i))
+ (%free-dot-net-container ,arg-pointer))))))))
+
+(defmacro ffi-call-with-args* (function object name args)
+ "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a
+list of CONTAINER structures or `native' Lisp objects) is converted to
+a foreign array prior to calling FUNCTION. If NAME is not NIL, then
+it should be a string and the first argument to FUNCTION will be the
+corresponding foreign string."
+ (with-rebinding (args)
+ (with-unique-names (length arg-pointers ffi-arg-pointers arg i
+ arg-pointer foreign-name)
+ `(let* ((,length (length ,args))
+ (,arg-pointers (make-array ,length :initial-element nil)))
+ (unwind-protect
+ (progn
+ (ffi:with-foreign-object (,ffi-arg-pointers `(:array :pointer-void ,,length))
+ (loop for ,arg in ,args
+ for ,i from 0
+ for ,arg-pointer = (cond
+ ((container-p ,arg) (pointer ,arg))
+ (t (setf (aref ,arg-pointers ,i)
+ (box* ,arg))))
+ do (si::foreign-data-set-elt ,ffi-arg-pointers (* 4 ,i) :pointer-void ,arg-pointer))
+ ,(cond (name
+ `(with-unicode-string (,foreign-name ,name)
+ (,function ,foreign-name
+ ,object
+ ,length
+ ,ffi-arg-pointers)))
+ (t `(,function ,object
+ ,length
+ ,ffi-arg-pointers)))))
+ ;; all .NET elements that were solely created (by BOX*)
+ ;; for this FFI call are immediately freed
+ (dotimes (,i ,length)
+ (named-when (,arg-pointer (aref ,arg-pointers ,i))
+ (%free-dot-net-container ,arg-pointer))))))))
+
+(defun flag-for-finalization (object &optional function)
+ "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT
+is removed by GC."
+ ;; don't know how to do that in ECL
+ (declare (ignore object function)))
+
+(defun register-exit-function (function &optional name)
+ "Makes sure the function FUNCTION \(with no arguments) is called
+before the Lisp images exits."
+ ;; don't know how to do that in ECL
+ (declare (ignore function name)))
+
+(defun full-gc ()
+ "Invokes a full garbage collection."
+ (si::gc t))
+
+(defun lf-to-crlf (string)
+ "Add #\Return before each #\Newline in STRING."
+ (loop with new-string = (make-array (+ (length string) (count #\Newline string))
+ :element-type 'character
+ :fill-pointer 0)
+ for c across string
+ when (char= c #\Newline)
+ do (vector-push-extend #\Return new-string)
+ do (vector-push-extend c new-string)
+ finally (return new-string)))
Added: trunk/rdnzl/port-lw.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/port-lw.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,230 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/port-lw.lisp,v 1.42 2008/01/26 22:28:31 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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-make-null-pointer ()
+ "Returns an FFI NULL pointer."
+ fli:*null-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 :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 :lisp-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
+ :language :ansi-c
+ ;; 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))
+ (%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.")
+
+(defmacro 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 ()
+ "Invokes a full garbage collection."
+ (hcl:mark-and-sweep 3))
+
+;; help the LispWorks IDE to find definitions
+(dspec:define-form-parser ffi-define-function (c-name)
+ `(,ffi-define-function ,(make-lisp-name c-name)))
+
+(dspec:define-dspec-alias ffi-define-function (name)
+ `(fli:define-foreign-function ,name))
+
+(dspec:define-form-parser define-rdnzl-call (name)
+ `(,define-rdnzl-call ,name))
+
+(dspec:define-dspec-alias define-rdnzl-call (name)
+ `(defun ,name))
Added: trunk/rdnzl/port-sbcl.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/port-sbcl.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,309 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/port-sbcl.lisp,v 1.15 2008/01/26 22:28:31 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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 SBCL FFI."
+ (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)
+ ;; only needed for WIDE-CHAR fake below
+ (ffi-unsigned-short '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."
+ ;; there's a more elegant way to do this - see the code in
+ ;; `port-clisp.lisp'
+ (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))))))))
+ ((eq result-type 'ffi-wide-char)
+ (with-unique-names (inner-fn)
+ `(progn
+ (ffi-define-function* (,inner-fn ,c-name)
+ ,arg-list
+ ffi-unsigned-short)
+ (defun ,lisp-name ,(mapcar #'first arg-list)
+ (code-char (,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))))))
+ ((find 'ffi-wide-char 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-wide-char)
+ (list name 'ffi-unsigned-short)
+ 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-wide-char)
+ `(char-code ,name)
+ 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-make-null-pointer ()
+ "Returns an FFI NULL pointer."
+ (sb-sys:int-sap 0))
+
+(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))
Added: trunk/rdnzl/rdnzl.asd
==============================================================================
--- (empty file)
+++ trunk/rdnzl/rdnzl.asd Wed Apr 30 04:28:03 2008
@@ -0,0 +1,50 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/rdnzl.asd,v 1.50 2008/03/25 17:06:23 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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>
+
+(asdf:defsystem :rdnzl
+ :serial t
+ :version "0.12.2"
+ :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
+ #+:ecl (:file "port-ecl") ; ECL-specific stuff here
+ #+:lispworks (:file "port-lw") ; LispWorks-specific stuff here
+ #+:sbcl (:file "port-sbcl") ; SBCL-specific stuff here
+ (:file "ffi")
+ (:file "container")
+ (:file "reader")
+ (:file "arrays")
+ (:file "adapter")
+ (:file "import")
+ (:file "direct")))
Added: trunk/rdnzl/reader.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/reader.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,268 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/reader.lisp,v 1.20 2008/01/26 22:28:32 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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))
+ (prepend nil)
+ (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
+ (setq function-name 'property
+ token (subseq token 1)))
+ ((#\$)
+ ;; first char #\$ means field
+ (setq function-name 'field
+ token (subseq token 1)))
+ ((#\+)
+ ;; first char #\+ adds "add_"
+ (setq token (subseq token 1)
+ prepend "add_"))
+ ((#\-)
+ ;; first char #\- adds "remove_"
+ (setq token (subseq token 1)
+ prepend "remove_"))))
+ ;; 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 (if prepend
+ (concatenate 'string prepend member-name)
+ member-name)
+ function-name
+ type-name)))
+ (t
+ ;; otherwise it's an instance invocation
+ (values (if prepend
+ (concatenate 'string prepend token)
+ 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)))
Added: trunk/rdnzl/specials.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/specials.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,112 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/specials.lisp,v 1.29 2008/01/26 22:28:32 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.")
+
+(defvar *coerce-double-floats-to-single* nil
+ "If this is true, then BOX will convert a Lisp DOUBLE-FLOAT
+value to System.Single. This is mainly interesting for
+LispWorks, where Lisp floats are always DOUBLE-FLOAT.")
+
+(pushnew :rdnzl *features*)
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see <http://common-lisp.net/project/hyperdoc/>
+;; and <http://www.cliki.net/hyperdoc>
+;; also used by LW-ADD-ONS
+
+(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))))
Added: trunk/rdnzl/util.lisp
==============================================================================
--- (empty file)
+++ trunk/rdnzl/util.lisp Wed Apr 30 04:28:03 2008
@@ -0,0 +1,247 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/rdnzl/util.lisp,v 1.27 2008/02/14 10:33:51 edi Exp $
+
+;;; Copyright (c) 2004-2008, 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.
+
+;;; Several utility functions.
+
+(in-package :rdnzl)
+
+#+:lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import 'lw:with-unique-names))
+
+#-:lispworks
+(defmacro with-unique-names ((&rest bindings) &body body)
+ "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
+
+Executes a series of forms with each VAR bound to a fresh,
+uninterned symbol. The uninterned symbol is as if returned by a call
+to GENSYM with the string denoted by X - or, if X is not supplied, the
+string denoted by VAR - as argument.
+
+The variable bindings created are lexical unless special declarations
+are specified. The scopes of the name bindings and declarations do not
+include the Xs.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+ ;; reference implementation posted to comp.lang.lisp as
+ ;; <cy3bshuf30f.fsf at ljosa.com> by Vebjorn Ljosa - see also
+ ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+ `(let ,(mapcar #'(lambda (binding)
+ (check-type binding (or cons symbol))
+ (if (consp binding)
+ (destructuring-bind (var x) binding
+ (check-type var symbol)
+ `(,var (gensym ,(etypecase x
+ (symbol (symbol-name x))
+ (character (string x))
+ (string x)))))
+ `(,binding (gensym ,(symbol-name binding)))))
+ bindings)
+ , at body))
+
+#+:lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (macro-function 'with-rebinding)
+ (macro-function 'lw:rebinding)))
+
+#-:lispworks
+(defmacro with-rebinding (bindings &body body)
+ "WITH-REBINDING ( { var | (var prefix) }* ) form*
+
+Evaluates a series of forms in the lexical environment that is
+formed by adding the binding of each VAR to a fresh, uninterned
+symbol, and the binding of that fresh, uninterned symbol to VAR's
+original value, i.e., its value in the current lexical environment.
+
+The uninterned symbol is created as if by a call to GENSYM with the
+string denoted by PREFIX - or, if PREFIX is not supplied, the string
+denoted by VAR - as argument.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+ ;; reference implementation posted to comp.lang.lisp as
+ ;; <cy3wv0fya0p.fsf at ljosa.com> by Vebjorn Ljosa - see also
+ ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+ (loop for binding in bindings
+ for var = (if (consp binding) (car binding) binding)
+ for name = (gensym)
+ collect `(,name ,var) into renames
+ collect ``(,,var ,,name) into temps
+ finally (return `(let ,renames
+ (with-unique-names ,bindings
+ `(let (,, at temps)
+ ,, at body))))))
+
+(defun starts-with (string sub-string)
+ "Returns true if the string STRING starts with the string
+SUB-STRING."
+ (let ((mismatch (mismatch string sub-string :test #'char-equal)))
+ (or (null mismatch)
+ (>= mismatch (length sub-string)))))
+
+(defmacro named-when ((var form) &body body)
+ "Executes BODY if FORM evaluates to a true value. During the
+execution of BODY VAR is bound to the value returned by FORM."
+ `(let ((,var ,form))
+ (when ,var
+ , at body)))
+
+(defun use-namespace (namespace)
+ "Adds the .NET namespace NAMESPACE \(a string) to the list of
+namespaces that will be prefixed when trying to resolve a type name.
+After calling this function NAMESPACE will be the first entry in this
+list unless it has already been there."
+ (pushnew (concatenate 'string namespace ".")
+ *used-namespaces*
+ :test #'string=)
+ (values))
+
+(defun unuse-namespace (namespace)
+ "Removes the .NET namespace NAMESPACE \(a string) from the list of
+namespaces that will be prefixed when trying to resolve a type name."
+ (setq *used-namespaces*
+ (delete (concatenate 'string namespace ".")
+ *used-namespaces*
+ :test #'string=))
+ (values))
+
+(defun unuse-all-namespaces ()
+ "Removes all entries from the list of namespaces that will be
+prefixed when trying to resolve a type name."
+ (setq *used-namespaces* nil)
+ (values))
+
+(defun resolve-type-name (name)
+ "If NAME is a string which names a type which has been previously
+imported via IMPORT-TYPE, then return its assembly-qualified name. If
+a type named NAME can't be found directly, then also try the `used'
+namespaces. If NAME is a tree of strings, interpret this as a generic
+type and resolve each leaf as above, except that for the first \(base)
+type the suffix giving the number of parameters is added
+automatically"
+ (cond ((stringp name)
+ (loop for namespace in (cons "" *used-namespaces*)
+ for full-name = (concatenate 'string namespace name)
+ for hashed-name = (gethash full-name *type-hash*)
+ when hashed-name
+ do (return (cond ((stringp hashed-name) hashed-name)
+ (t full-name)))
+ finally (return name)))
+ (t (let ((first-type-name
+ (concatenate 'string (car name)
+ (format nil "`~D" (length (rest name))))))
+ (mapcar #'resolve-type-name (cons first-type-name (rest name)))))))
+
+(defun mangle-name (string)
+ "Converts the string STRING into another string with case determined
+by the current readtable-case and where a hyphen is inserted whenever
+the case changes from lower to upper, e.g. \"myCoolFoo\" becomes
+\"MY-COOL-FOO\"."
+ (symbol-name
+ (read-from-string
+ (with-output-to-string (out)
+ (loop for last-char = #\. then char
+ for char across string
+ when (and (lower-case-p last-char)
+ (upper-case-p char))
+ do (write-char #\- out)
+ do (write-char (char-downcase char) out))))))
+
+(defun make-lisp-name (c-name)
+ "Makes a Lisp name \(a symbol in the RDNZL package) from a C name."
+ (intern (concatenate 'string "%" (mangle-name c-name)) :rdnzl))
+
+(defun unmangle-name* (string)
+ "STRING is assumed to be a string consisting solely of single-case
+letters and hyphens. This function will return a string with all
+hyphens removed and all characters downcased except for the first one
+and those following a hyphen - these are upcased."
+ (with-output-to-string (out)
+ (loop with upcase = t
+ for c across string
+ do (cond ((char= c #\-)
+ (setq upcase t))
+ (upcase
+ (write-char (char-upcase c) out)
+ (setq upcase nil))
+ (t
+ (write-char (char-downcase c) out))))))
+
+(defun unmangle-name (function-name)
+ "FUNCTION-NAME is assumed to be a function name, i.e. a symbol
+or a cons of the form \(SETF symbol). If the symbol name of this
+symbol consists solely of single-case letters appropriate for the
+current readtable-case and hyphens then UNMANGLE-NAME* is applied
+to it, otherwise the symbol name itself is returned. Note that
+the return value is always a symbol even if the argument was a
+cons."
+ (let* ((symbol (cond ((consp function-name)
+ (second function-name))
+ (t function-name)))
+ (symbol-name (symbol-name symbol)))
+ (let ((case-test (case (readtable-case *readtable*)
+ ((:upcase :invert) #'upper-case-p)
+ (t #'lower-case-p))))
+ (cond ((every (lambda (c)
+ (or (funcall case-test c)
+ (char= c #\-)))
+ symbol-name)
+ (unmangle-name* symbol-name))
+ (t symbol-name)))))
+
+(defun find-partial-assembly-name (type-name)
+ "Tries to extract the partial assembly name from the
+assembly-qualified type name TYPE-NAME."
+ (let ((length (length type-name)))
+ (flet ((find-comma (start)
+ "Finds the position of the first comma within TYPE-NAME
+\(starting from position START) which is not preceded by a backslash."
+ (loop for i = start then (1+ pos)
+ for pos = (and (< i length)
+ (position #\, type-name :test #'char= :start i))
+ while (and pos
+ (plusp pos)
+ (char= (char type-name (1- pos)) #\\))
+ finally (return pos))))
+ (let* ((first-comma (find-comma 0))
+ ;; now skip spaces
+ (non-space (and first-comma
+ (position #\Space type-name :test #'char/= :start (1+ first-comma))))
+ (second-comma (and non-space
+ (find-comma non-space))))
+ (or (and second-comma
+ (> second-comma non-space)
+ (subseq type-name non-space second-comma))
+ (error "Couldn't find partial assembly name in ~S" type-name))))))
+
+(defun whitespacep (chr)
+ "Tests whether a character is whitespace."
+ (member chr +whitespace-char-list+ :test #'char=))
+
More information about the Rdnzl-cvs
mailing list