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))) + ,@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)) + ,@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 ,@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%22%3EBSD-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/%5C%22%3E; +</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%22%3ELisp +shell</a> +(see <a +href="http://sourceforge.net/project/showfiles.php?group_id=30035%22%3EECL%27s +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%22%3Ehttp://weitz.de/files/rdnzl-cpp....</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%22%3ECVS +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%22%3E... +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%22%3Erdnzl-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%22%3Erdnzl-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-fl...<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%22%3E<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%22%3Ea... +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%22%3E...</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%22%3ERDNZL</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)) + ,@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) + ,@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*)) + ,@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) + ,@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))) + ,@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) + ,@body)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-unicode-string ((var lisp-string) &body body) + (with-unique-names (str-len k) + `(let* ((,str-len (length ,lisp-string))) + (ffi:with-foreign-object (,var `(:array :unsigned-short ,(1+ ,str-len))) + (loop for ,k below ,str-len + do (si::foreign-data-set-elt ,var (* 2 ,k) :unsigned-short (char-code (char ,lisp-string ,k)))) + (si::foreign-data-set-elt ,var (* 2 ,str-len) :unsigned-short 0) + ,@body))))) + +(defun unicode-string-to-lisp (ubyte16-array) + (let ((char-list (loop for k from 0 + for uc = (si::foreign-data-ref-elt ubyte16-array (* 2 k) :unsigned-short) + while (/= uc 0) collect (code-char uc)))) + (coerce char-list 'string))) + +(defmacro ffi-get-call-by-ref-string (function object length-function) + "Calls the foreign function FUNCTION. FUNCTION is supposed to call +a C function f with the signature void f(..., __wchar_t *s) where s +is a result string which is returned by this macro. OBJECT is the +first argument given to f. Prior to calling f the length of the +result string s is obtained by evaluating (LENGTH-FUNCTION OBJECT)." + (with-rebinding (object) + (with-unique-names (length temp) + `(let* ((,length (,length-function ,object))) + (ffi:with-foreign-object (,temp `(:array :unsigned-short ,(1+ ,length))) + (,function ,object ,temp) + (unicode-string-to-lisp ,temp)))))) + +(defmacro ffi-call-with-foreign-string* (function string &optional other-args) + "Applies the foreign function FUNCTION to the string STRING and +OTHER-ARGS. OTHER-ARGS (a list of CONTAINER structures or `native' +Lisp objects) is converted to a foreign array prior to calling +FUNCTION. STRING may be NIL which means that this argument is skipped +(i.e. the macro actually needs a better name)." + (with-rebinding (other-args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i + arg-pointer foreign-string) + (declare (ignorable foreign-string)) + `(let* ((,length (length ,other-args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (let ((,ffi-arg-pointers + (loop for ,arg in ,other-args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (string + `(with-unicode-string (,foreign-string ,string) + (apply #',function ,foreign-string ,ffi-arg-pointers))) + (t + `(apply #',function ,ffi-arg-pointers)))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defmacro ffi-call-with-args* (function object name args) + "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS (a +list of CONTAINER structures or `native' Lisp objects) is converted to +a foreign array prior to calling FUNCTION. If NAME is not NIL, then +it should be a string and the first argument to FUNCTION will be the +corresponding foreign string." + (with-rebinding (args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i + arg-pointer foreign-name) + `(let* ((,length (length ,args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (progn + (ffi:with-foreign-object (,ffi-arg-pointers `(:array :pointer-void ,,length)) + (loop for ,arg in ,args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + do (si::foreign-data-set-elt ,ffi-arg-pointers (* 4 ,i) :pointer-void ,arg-pointer)) + ,(cond (name + `(with-unicode-string (,foreign-name ,name) + (,function ,foreign-name + ,object + ,length + ,ffi-arg-pointers))) + (t `(,function ,object + ,length + ,ffi-arg-pointers))))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defun flag-for-finalization (object &optional function) + "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT +is removed by GC." + ;; don't know how to do that in ECL + (declare (ignore object function))) + +(defun register-exit-function (function &optional name) + "Makes sure the function FUNCTION (with no arguments) is called +before the Lisp images exits." + ;; don't know how to do that in ECL + (declare (ignore function name))) + +(defun full-gc () + "Invokes a full garbage collection." + (si::gc t)) + +(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) + ,@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) + ,@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) + ,@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 ,@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@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) + ,@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@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 (,,@temps) + ,,@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 + ,@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=)) +