Update of /project/rdnzl/cvsroot/RDNZL In directory common-lisp:/tmp/cvs-serv4420

Modified Files: CHANGELOG.txt RDNZL.dll README.txt adapter.lisp arrays.lisp container.lisp direct.lisp ffi.lisp import.lisp load.lisp packages.lisp port-acl.lisp port-ccl.lisp port-clisp.lisp port-lw.lisp rdnzl.asd reader.lisp specials.lisp util.lisp Added Files: port-sbcl.lisp Log Message: 0.9.0 release

--- /project/rdnzl/cvsroot/RDNZL/CHANGELOG.txt 2006/01/13 07:06:28 1.4 +++ /project/rdnzl/cvsroot/RDNZL/CHANGELOG.txt 2006/02/01 01:00:56 1.5 @@ -1,3 +1,7 @@ +Version 0.9.0 +2006-02-01 +Experimental support for SBCL/Win32 + Version 0.8.0 2006-01-13 Fix mechanism which releases delegate adapters (thanks to Dominic Robinson) Binary files /project/rdnzl/cvsroot/RDNZL/RDNZL.dll 2005/11/21 14:03:40 1.2 and /project/rdnzl/cvsroot/RDNZL/RDNZL.dll 2006/02/01 01:00:56 1.3 differ --- /project/rdnzl/cvsroot/RDNZL/README.txt 2005/01/03 00:55:40 1.1.1.1 +++ /project/rdnzl/cvsroot/RDNZL/README.txt 2006/02/01 01:00:56 1.2 @@ -1,29 +1,29 @@ -Installation ------------- - -First, put the file 'RDNZL.dll' somewhere where the foreign language -interface of your Lisp can find it. A safe bet is to put it in the -folder where your Lisp image starts up. - -Probably the easiest way to install RDNZL is to LOAD the file -'load.lisp' which comes with the distribution. Evaluate a form like - - (load "c:/path/to/rdnzl/load.lisp") - -or use the facilities of your IDE to LOAD this file. - -This should compile and load RDNZL on most Common Lisp -implementations. - -As an alternative you can use ASDF, RDNZL comes with an ASDF system -definition file 'rdnzl.asd'. - - -Documentation -------------- - -Complete documentation for RDNZL can be found in the 'doc' folder. - -RDNZL also supports Nikodemus Siivola's HYPERDOC, see -http://common-lisp.net/project/hyperdoc/ and -http://www.cliki.net/hyperdoc. \ No newline at end of file +Installation +------------ + +First, put the file 'RDNZL.dll' somewhere where the foreign language +interface of your Lisp can find it. A safe bet is to put it in the +folder where your Lisp image starts up. + +Probably the easiest way to install RDNZL is to LOAD the file +'load.lisp' which comes with the distribution. Evaluate a form like + + (load "c:/path/to/rdnzl/load.lisp") + +or use the facilities of your IDE to LOAD this file. + +This should compile and load RDNZL on most Common Lisp +implementations. + +As an alternative you can use ASDF, RDNZL comes with an ASDF system +definition file 'rdnzl.asd'. + + +Documentation +------------- + +Complete documentation for RDNZL can be found in the 'doc' folder. + +RDNZL also supports Nikodemus Siivola's HYPERDOC, see +http://common-lisp.net/project/hyperdoc/ and +http://www.cliki.net/hyperdoc. --- /project/rdnzl/cvsroot/RDNZL/adapter.lisp 2005/07/08 18:45:33 1.2 +++ /project/rdnzl/cvsroot/RDNZL/adapter.lisp 2006/02/01 01:00:56 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/adapter.lisp,v 1.2 2005/07/08 18:45:33 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/adapter.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $

-;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions --- /project/rdnzl/cvsroot/RDNZL/arrays.lisp 2005/07/08 18:45:33 1.2 +++ /project/rdnzl/cvsroot/RDNZL/arrays.lisp 2006/02/01 01:00:56 1.3 @@ -1,119 +1,119 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/arrays.lisp,v 1.2 2005/07/08 18:45:33 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; Utility functions for arrays and enumerations - -(in-package :rdnzl) - -(enable-rdnzl-syntax) - -(defmacro do-rdnzl-array ((var array-form &optional result) &body body) - "ARRAY-FORM should be a form which evaluates to a CONTAINER -structure wrapping a .NET array of rank 1. BODY will be evaluated -with VAR bound to each element of this array (as a CONTAINER) in -turn. Finally, the result of evaluating the form RESULT is returned." - (with-unique-names (array length i) - ;; this can later be optimized by iterating directly through an - ;; FFI array so we don't have the expensive call to INVOKE on each - ;; iteration - but we don't do that now - `(let* ((,array ,array-form) - (,length [%Length ,array])) - (dotimes (,i ,length) - (let ((,var (get-array-element ,array ,i))) - ,@body)) - ,result))) - -(defun aref* (array &rest subscripts) - "Returns the element of the .NET array ARRAY (a CONTAINER) with the -subscripts SUBSCRIPTS. Similar to AREF." - (let* ((element-type [%AssemblyQualifiedName [GetElementType [GetType array]]]) - (value (apply #`GetValue array subscripts))) - (unbox (cast* value element-type)))) - -(defun (setf aref*) (new-value array &rest subscripts) - "Sets the element of the .NET array ARRAY (a CONTAINER) with the -subscripts SUBSCRIPTS to the new value NEW-VALUE. Similar to (SETF -AREF)." - (apply #`SetValue array new-value subscripts) - new-value) - -(defun make-array-type (base-type dimensions) - "Synthesizes a .NET array type with base type BASE-TYPE (a -CONTAINER) and DIMENSIONS dimensions." - (let* ((base-type-name (get-object-as-string base-type)) - (array-type-name (format nil "~A[~V,,,',A]~A" base-type-name (1- dimensions) "" - (subseq [%AssemblyQualifiedName base-type] - (length base-type-name))))) - (make-type-from-name array-type-name))) - -(defun list-to-rdnzl-array (list &optional (base-type (make-type-from-name "System.Object"))) - "Creates and returns a .NET array of base type BASE-TYPE (a -CONTAINER or a string) and rank 1 with the elements from the Lisp list -LIST." - (when (stringp base-type) - (setq base-type (make-type-from-name (resolve-type-name base-type)))) - (let* ((length (length list)) - ;; this is equivalent to calling NEW (see import.lisp) - (new-array (invoke-constructor (make-array-type base-type 1) - length))) - (loop for element in list - for i from 0 - do (setf (aref* new-array i) - (ensure-container element))) - new-array)) - -(defun rdnzl-array-to-list (array) - "Converts a .NET array ARRAY of rank 1 to a Lisp list with the same -elements." - (let (list) - (do-rdnzl-array (element array) - (push element list)) - (nreverse list))) - -(defun enum-to-integer (enum) - "Converts the .NET object ENUM of type System.Enum to a Lisp -integer. This is a destructive operation on ENUM." - (unbox (cast* enum "System.Int32"))) - -(defun integer-to-enum (number type) - "Converts the Lisp integer NUMBER to a .NET System.Enum object of -type TYPE (a string or a CONTAINER)." - (when (stringp type) - (setq type (make-type-from-name (resolve-type-name type)))) - (cast [System.Enum.ToObject type number] - type)) - -(defun or-enums (&rest enums) - "Combines several .NET objects of type System.Enum with a logical or -and returns the result. All arguments must be of the same .NET type." - (let ((type-name [%AssemblyQualifiedName [GetType (first enums)]])) - (integer-to-enum - (apply #'logior (mapcar #'enum-to-integer enums)) type-name))) - -(disable-rdnzl-syntax) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/arrays.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Utility functions for arrays and enumerations + +(in-package :rdnzl) + +(enable-rdnzl-syntax) + +(defmacro do-rdnzl-array ((var array-form &optional result) &body body) + "ARRAY-FORM should be a form which evaluates to a CONTAINER +structure wrapping a .NET array of rank 1. BODY will be evaluated +with VAR bound to each element of this array (as a CONTAINER) in +turn. Finally, the result of evaluating the form RESULT is returned." + (with-unique-names (array length i) + ;; this can later be optimized by iterating directly through an + ;; FFI array so we don't have the expensive call to INVOKE on each + ;; iteration - but we don't do that now + `(let* ((,array ,array-form) + (,length [%Length ,array])) + (dotimes (,i ,length) + (let ((,var (get-array-element ,array ,i))) + ,@body)) + ,result))) + +(defun aref* (array &rest subscripts) + "Returns the element of the .NET array ARRAY (a CONTAINER) with the +subscripts SUBSCRIPTS. Similar to AREF." + (let* ((element-type [%AssemblyQualifiedName [GetElementType [GetType array]]]) + (value (apply #`GetValue array subscripts))) + (unbox (cast* value element-type)))) + +(defun (setf aref*) (new-value array &rest subscripts) + "Sets the element of the .NET array ARRAY (a CONTAINER) with the +subscripts SUBSCRIPTS to the new value NEW-VALUE. Similar to (SETF +AREF)." + (apply #`SetValue array new-value subscripts) + new-value) + +(defun make-array-type (base-type dimensions) + "Synthesizes a .NET array type with base type BASE-TYPE (a +CONTAINER) and DIMENSIONS dimensions." + (let* ((base-type-name (get-object-as-string base-type)) + (array-type-name (format nil "~A[~V,,,',A]~A" base-type-name (1- dimensions) "" + (subseq [%AssemblyQualifiedName base-type] + (length base-type-name))))) + (make-type-from-name array-type-name))) + +(defun list-to-rdnzl-array (list &optional (base-type (make-type-from-name "System.Object"))) + "Creates and returns a .NET array of base type BASE-TYPE (a +CONTAINER or a string) and rank 1 with the elements from the Lisp list +LIST." + (when (stringp base-type) + (setq base-type (make-type-from-name (resolve-type-name base-type)))) + (let* ((length (length list)) + ;; this is equivalent to calling NEW (see import.lisp) + (new-array (invoke-constructor (make-array-type base-type 1) + length))) + (loop for element in list + for i from 0 + do (setf (aref* new-array i) + (ensure-container element))) + new-array)) + +(defun rdnzl-array-to-list (array) + "Converts a .NET array ARRAY of rank 1 to a Lisp list with the same +elements." + (let (list) + (do-rdnzl-array (element array) + (push element list)) + (nreverse list))) + +(defun enum-to-integer (enum) + "Converts the .NET object ENUM of type System.Enum to a Lisp +integer. This is a destructive operation on ENUM." + (unbox (cast* enum "System.Int32"))) + +(defun integer-to-enum (number type) + "Converts the Lisp integer NUMBER to a .NET System.Enum object of +type TYPE (a string or a CONTAINER)." + (when (stringp type) + (setq type (make-type-from-name (resolve-type-name type)))) + (cast [System.Enum.ToObject type number] + type)) + +(defun or-enums (&rest enums) + "Combines several .NET objects of type System.Enum with a logical or +and returns the result. All arguments must be of the same .NET type." + (let ((type-name [%AssemblyQualifiedName [GetType (first enums)]])) + (integer-to-enum + (apply #'logior (mapcar #'enum-to-integer enums)) type-name))) + +(disable-rdnzl-syntax) --- /project/rdnzl/cvsroot/RDNZL/container.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/container.lisp 2006/02/01 01:00:56 1.3 @@ -1,450 +1,456 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/container.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; Definition of CONTAINER structure and various functions to deal -;;; with .NET objects. - -(in-package :rdnzl) - -(defstruct (container - (:conc-name nil) - ;; Corman Lisp doesn't know :PRINT-OBJECT - (:print-function print-container)) - "Simple structure to wrap a pointer to a DotNetContainer object." - (pointer nil :read-only t) - (refp nil)) - -(defun print-container (container stream depth) - "Prints an unreadable representation of a CONTAINER structure to the -stream STREAM." - (declare (ignore depth)) - (print-unreadable-object (container stream :type t :identity nil) - (let ((pointer (pointer container))) - (unless (ffi-pointer-p pointer) - (error "~S is not an FFI pointer" pointer)) - (format stream "~A #x~X" - (if (%dot-net-container-is-null pointer) - "NULL" - ;; show name of type - (get-type-name container)) - ;; show pointer address - (ffi-pointer-address pointer)))) - container) - -(define-condition rdnzl-error (simple-error) - ((exception :initarg :exception - :reader rdnzl-error-exception)) - (:report (lambda (condition stream) - (format stream "~?" - (simple-condition-format-control condition) - (simple-condition-format-arguments condition)))) - (:documentation "An error of this type is signaled whenever an -exception occured during a call into .NET. The EXCEPTION slot of this -error object holds a reference (a CONTAINER) to the corresponding -.NET error object.")) - -(setf (documentation 'rdnzl-error-exception 'function) - "Returns the .NET error object (as a CONTAINER) which was -responsible for this error.") - -(defun ref (object) - "Makes a pass-by-reference type out of OBJECT and returns OBJECT. -If OBJECT is not a CONTAINER it'll be boxed first (see BOX). This -function makes only sense if OBJECT is used as an argument to INVOKE!" - (cond ((container-p object) - (%ref-dot-net-container-type (pointer object)) - (setf (refp object) t) - object) - (t - (ref (box object))))) - -(defun unref (container) - "Resets CONTAINER to have the underlying type again. Assumes that -REF was applied to CONTAINER before. Returns CONTAINER." - (%unref-dot-net-container-type (pointer container)) - (setf (refp container) nil) - container) - -(defmacro rdnzl-handler-case (form &rest clauses) - "Like HANDLER-CASE but only for conditions of type RDNZL-ERROR. The -typespecs are either strings (naming a .NET error type) or of the -form (OR string-1 ... string-n). A :NO-ERROR clause is also -allowed." - (with-unique-names (e exception) - `(handler-case ,form - (rdnzl-error (,e) - (let ((,exception (rdnzl-error-exception ,e))) - (cond - ,@(loop for (typespec var-list . forms) in clauses - for exception-var = (or (first var-list) (gensym)) - for typespec-list = (cond ((eq typespec :no-error) nil) - ((stringp typespec) - (list typespec)) - ((and (consp typespec) - (eq (first typespec) 'or)) - (rest typespec)) - (t (error "Illegal typespec ~S in RDNZL-HANDLER-CASE" - typespec))) - collect `((or ,@(mapcar (lambda (typespec) - `(invoke (make-type-from-name (resolve-type-name ,typespec)) - "IsAssignableFrom" - (invoke ,exception "GetType"))) - typespec-list)) - (let ((,exception-var ,exception)) - (declare (ignorable ,exception-var)) - ,@forms))) - (t (error ,e))))) - ,@(let ((no-error-clause (find :no-error clauses - :key #'first - :test #'eq))) - (and no-error-clause (list no-error-clause)))))) - -(defun maybe-free-container-pointer (object) - "This function is to be invoked whenever a CONTAINER structure is -finalized by the garbage collector." - (when (container-p object) - (%free-dot-net-container (pointer object)))) - -(defmacro wrap-with-container (form) - "Evaluates FORM and wraps the result with a CONTAINER structure. -Also makes sure the corresponding DotNetContainer object is garbage -collected. NIL is returned if FORM returns a NULL pointer." - (with-unique-names (block-name container pointer) - `(block ,block-name - (let (,container ,pointer) - (unwind-protect - (progn - (setq ,pointer ,form) - (when (ffi-null-pointer-p ,pointer) - (warn "Returning NIL for NULL FFI pointer.") - (return-from ,block-name nil)) - (setq ,container - (make-container :pointer ,pointer)) - ,container) - (when ,container - (flag-for-finalization ,container #'maybe-free-container-pointer))))))) - -(defun make-type-from-name (name) - "Returns the .NET type with the name NAME - uses the static function -Type::GetType." - (wrap-with-container - (ffi-call-with-foreign-string* %make-type-from-name - name))) - -(defun get-object-as-string (container) - "Get a string representation of the object denoted by CONTAINER. -Uses 'ToString' internally." - (ffi-get-call-by-ref-string %get-dot-net-container-object-as-string - (pointer container) - %get-dot-net-container-object-string-length)) - -(defun get-type-name (container) - "Get the name of the type of the object denoted by CONTAINER. Uses -'FullName' internally." - (ffi-get-call-by-ref-string %get-dot-net-container-type-as-string - (pointer container) - %get-dot-net-container-type-string-length)) - -(defun box* (object) - "Like BOX but returns the raw pointer." - (typecase object - ((signed-byte 32) - (%make-dot-net-container-from-int object)) - ((signed-byte 64) - ;; this is due to a limitation of LispWorks: we have to pass the - ;; argument as a string - (ffi-call-with-foreign-string* %make-dot-net-container-from-long - (with-standard-io-syntax () - (princ-to-string object)))) - (string - (ffi-call-with-foreign-string* %make-dot-net-container-from-string object)) - (character - (%make-dot-net-container-from-char object)) - (double-float - (%make-dot-net-container-from-double object)) - (float - (%make-dot-net-container-from-float object)) - (pathname - (box* (namestring object))) - (boolean - (%make-dot-net-container-from-boolean object)) - (otherwise - (error "Don't know how to convert object ~S of type ~A to a .NET object." - object (type-of object))))) - -(defun box (object) - "If object is a `native' Lisp object which we know how to convert -return a corresponding DotNetContainer object. Otherwise raise an -error." - (wrap-with-container (box* object))) - -(defun ensure-container (object) - "If OBJECT isn't already a CONTAINER then box it." - (cond - ((container-p object) object) - (t (box object)))) - -(defun unbox (container) - "If CONTAINER is of a known .NET type which we know how to convert -return the corresponding `native' Lisp object. Otherwise just return -the container." - (let ((type-name (get-type-name container))) - (cond ((string= type-name "System.String") - (get-object-as-string container)) - ((string= type-name "System.Char") - (%get-dot-net-container-char-value (pointer container))) - ((string= type-name "System.Int32") - (%get-dot-net-container-int-value (pointer container))) - ((string= type-name "System.Int64") - (with-standard-io-syntax - (read-from-string (get-object-as-string container)))) - ((string= type-name "System.Boolean") - (%get-dot-net-container-boolean-value (pointer container))) - ((string= type-name "System.Double") - (%get-dot-net-container-double-value (pointer container))) - ((string= type-name "System.Single") - (%get-dot-net-container-single-value (pointer container))) - (t container)))) - -(defmacro get-invocation-result (form) - "Evaluates FORM which is supposed to return a pointer to an -InvocationResult object. Tries to convert the result into a known -Lisp type, otherwise returns a CONTAINER structure." - (with-unique-names (block-name invocation-result container) - `(block ,block-name - (let (,invocation-result ,container) - (unwind-protect - (progn - (setq ,invocation-result ,form) - (when (%invocation-result-is-void ,invocation-result) - ;; return keyword :VOID if the result was void - (return-from ,block-name :void)) - ;; first create a CONTAINER so we can be sure the - ;; corresponding .NET object will be garbage-collected - (setq ,container - (wrap-with-container - (%get-dot-net-container-from-invocation-result ,invocation-result))) - (when (%invocation-result-is-exception ,invocation-result) - (error 'rdnzl-error - :exception ,container - :format-control ".NET error (~A): ~A" - :format-arguments (list (get-type-name ,container) - (property ,container "Message"))))) - (when ,invocation-result - ;; now free the InvocationResult object which wrapped the - ;; result we were interested in - (%free-invocation-result ,invocation-result))) - (when (%dot-net-container-is-null (pointer ,container)) - (warn "Returning NULL object from .NET call") - (return-from ,block-name (values nil t))) - ;; try to convert some known types to native Lisp types - (unbox ,container))))) - -(defmacro ffi-call-with-foreign-string (function name &rest other-args) - "Like FFI-CALL-WITH-FOREIGN-STRING* but handles the returned -InvocationResult object and accepts an arbitrary number of arguments -greater than one." - `(get-invocation-result - (ffi-call-with-foreign-string* ,function - ,name - (list ,@other-args)))) - -(defmacro ffi-call-with-args (function object name args) - "Like FFI-CALL-WITH-ARGS* but OBJECT is assumed to be a CONTAINER -structure while each element of ARGS can be a native Lisp object or -such a structure. The result of calling FUNCTION is assumed to be a -pointer to an InvocationResult which is handled by -GET-INVOCATION-RESULT." - (with-rebinding (object) - (with-unique-names (pointer) - `(let ((,pointer (pointer ,object))) - (when (%dot-net-container-is-null ,pointer) - (error "Trying to call function ~S with NULL object ~S." - ',function ,object)) - (get-invocation-result - (ffi-call-with-args* ,function - ,pointer - ,name - ,args)))))) - -;; generic functions and TYPECASE are avoided below to make delivered -;; images smaller - -(defun invoke (object method-name &rest args) - "Invokes the method named METHOD-NAME (a string). If OBJECT is a -CONTAINER then the method is supposed to be an instance method of this -object. If OBJECT is a string then the method is supposed to be a -static method of the type named OBJECT. ARGS (either CONTAINER -structures or Lisp objects which can be converted) are the arguments -to this method." - (let ((result - (cond ((container-p object) - (ffi-call-with-args %invoke-instance-member - object - method-name - args)) - ((stringp object) - (ffi-call-with-args %invoke-static-member - (make-type-from-name (resolve-type-name object)) - method-name - args)) - (t (error "Don't know how to invoke ~A on ~S." method-name object))))) - ;; if some of the arguments were pass-by-reference reset them to - ;; their underlying types - (dolist (arg args) - (when (and (container-p arg) - (refp arg)) - (unref arg))) - result)) - -(defun property (object property-name &rest args) - "Returns the property named PROPERTY-NAME (a string). If OBJECT is -a CONTAINER then the property is supposed to be an instance property -of this object. If OBJECT is a string then the property is supposed -to be a static property of the type named OBJECT. ARGS (either -CONTAINER structures or Lisp objects which can be converted) are the -indexes to this property." - (cond ((container-p object) - (ffi-call-with-args %get-instance-property-value - object - property-name - args)) - ((stringp object) - (ffi-call-with-args %get-static-property-value - (make-type-from-name (resolve-type-name object)) - property-name - args)) - (t (error "Don't know how to get property ~A of ~S." property-name object)))) - -(defun (setf property) (new-value object property-name &rest args) - "Sets the property named PROPERTY-NAME (a string) to the new value -NEW-VALUE. If OBJECT is a CONTAINER then the property is supposed to -be an instance property of this object. If OBJECT is a string then -the property is supposed to be a static property of the type named -OBJECT. ARGS (either CONTAINER structures or Lisp objects which can -be converted) are the indexes to this property." - (cond ((container-p object) - (ffi-call-with-args %set-instance-property-value - object - property-name - (cons new-value args))) - ((stringp object) - (ffi-call-with-args %set-static-property-value - (make-type-from-name (resolve-type-name object)) - property-name - (cons new-value args))) - (t (error "Don't know how to set property ~A of ~S." property-name object))) - new-value) - -(defun field (object field-name) - "Returns the field named FIELD-NAME (a string). If OBJECT is a -CONTAINER then the field is supposed to be an instance field of this -object. If OBJECT is a string then the field is supposed to be a -static field of the type named OBJECT." - (cond ((container-p object) - (ffi-call-with-foreign-string %get-instance-field-value - field-name - object)) - ((stringp object) - (ffi-call-with-foreign-string %get-static-field-value - field-name - (make-type-from-name (resolve-type-name object)))) - (t (error "Don't know how to get field ~A of ~S." field-name object)))) - -(defun (setf field) (new-value object field-name) - "Sets the field named FIELD-NAME (a string) to the new value -NEW-VALUE. If OBJECT is a CONTAINER then the field is supposed to be -an instance field of this object. If OBJECT is a string then the -field is supposed to be a static field of the type named OBJECT." - (cond ((container-p object) - (ffi-call-with-foreign-string %set-instance-field-value - field-name - object - new-value)) - ((stringp object) - (ffi-call-with-foreign-string %set-static-field-value - field-name - (make-type-from-name (resolve-type-name object)) - new-value)) - (t (error "Don't know how to set field ~A of ~S." field-name object))) - new-value) -

[509 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/direct.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/direct.lisp 2006/02/01 01:00:56 1.3 @@ -1,297 +1,297 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/direct.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; Interface for "direct calls" into .NET - -(in-package :rdnzl) - -(enable-rdnzl-syntax) - -(defun find-interface-method (interfaces method-name arg-types binding-attr) - "A Lisp version of findInterfaceMethod - see InvokeMember.cpp." - (do-rdnzl-array (interface interfaces) - (named-when (method-info [GetMethod interface method-name binding-attr - (make-null-object "System.Reflection.Binder") - arg-types - (make-null-object "System.Reflection.ParameterModifier[]")]) - (return-from find-interface-method method-info)) - (named-when (method-info - (find-interface-method [GetInterfaces interface] method-name arg-types binding-attr)) - (return-from find-interface-method method-info)))) - -(defun find-method* (type method-name arg-types binding-attr) - "A Lisp version of findMethod - see InvokeMember.cpp." - (or [GetMethod type method-name binding-attr - (make-null-object "System.Reflection.Binder") - arg-types - (make-null-object "System.Reflection.ParameterModifier[]")] - (and [%IsInterface type] - (or (find-interface-method [GetInterfaces type] method-name arg-types binding-attr) - (find-method* (make-type-from-name "System.Object") method-name arg-types binding-attr))))) - -(defun find-instance-method (method-name arg-type-names) - "Finds and returns a MethodInfo object (or NIL) corresponding to -the instance method with the name METHOD-NAME (a string) and the -signature ARG-TYPE-NAMES (a list of strings naming types). Note that -the first element of ARG-TYPE-NAMES represents the type to which the -method belongs." - (let ((arg-types (mapcar (lambda (arg-type-name) - (make-type-from-name - (resolve-type-name arg-type-name))) - arg-type-names))) - (find-method* (first arg-types) - method-name - (list-to-rdnzl-array (rest arg-types) - "System.Type") - (or-enums [$System.Reflection.BindingFlags.Instance] - [$System.Reflection.BindingFlags.Public])))) - -(defun find-static-method (method-name type-name arg-type-names) - "Finds and returns a MethodInfo object (or NIL) corresponding to -the static method of the type named TYPE-NAME (a string) with the -name METHOD-NAME (a string) and the signature ARG-TYPE-NAMES (a list -of strings naming types)." - (let ((arg-types (mapcar (lambda (arg-type-name) - (make-type-from-name - (resolve-type-name arg-type-name))) - arg-type-names))) - (find-method* (make-type-from-name (resolve-type-name type-name)) - method-name - (list-to-rdnzl-array arg-types - "System.Type") - (or-enums [$System.Reflection.BindingFlags.Static] - [$System.Reflection.BindingFlags.Public])))) - -(defun find-property (type property-name arg-types binding-attr) - "Finds a PropertyInfo object. See corresponding code in -Property.cpp." - [GetProperty type property-name binding-attr - (make-null-object "System.Reflection.Binder") - (make-null-object "System.Type") - arg-types - (make-null-object "System.Reflection.ParameterModifier[]")]) - -(defun find-instance-property (property-name arg-type-names) - "Finds and returns a PropertyInfo object (or NIL) corresponding to -the instance property with the name PROPERTY-NAME (a string) and the -signature ARG-TYPE-NAMES (a list of strings naming types). Note that -the first element of ARG-TYPE-NAMES represents the type to which the -property belongs." - (let ((arg-types (mapcar (lambda (arg-type-name) - (make-type-from-name - (resolve-type-name arg-type-name))) - arg-type-names))) - (find-property (first arg-types) - property-name - (list-to-rdnzl-array (rest arg-types) - "System.Type") - (or-enums [$System.Reflection.BindingFlags.Instance] - [$System.Reflection.BindingFlags.Public])))) - -(defun find-static-property (property-name type-name arg-type-names) - "Finds and returns a PropertyInfo object (or NIL) corresponding to -the static property of the type named TYPE-NAME (a string) with the -name PROPERTY-NAME (a string) and the signature ARG-TYPE-NAMES (a -list of strings naming types)." - (let ((arg-types (mapcar (lambda (arg-type-name) - (make-type-from-name - (resolve-type-name arg-type-name))) - arg-type-names))) - (find-property type-name - property-name - (list-to-rdnzl-array arg-types - "System.Type") - (or-enums [$System.Reflection.BindingFlags.Static] - [$System.Reflection.BindingFlags.Public])))) - -(defun find-field (type field-name binding-attr) - "Finds a FieldInfo object. See corresponding code in Field.cpp." - [GetField type field-name binding-attr]) - -(defun find-instance-field (field-name type-name) - "Finds and returns a FieldInfo object (or NIL) corresponding to the -instance field with the name FIELD-NAME (a string). TYPE-NAME (a -string) names the type to which the field belongs." - (find-field (make-type-from-name (resolve-type-name type-name)) - field-name - (or-enums [$System.Reflection.BindingFlags.Instance] - [$System.Reflection.BindingFlags.Public]))) - -(defun find-static-field (field-name type-name) - "Finds and returns a FieldInfo object (or NIL) corresponding to the -static field with the name FIELD-NAME (a string). TYPE-NAME (a -string) names the type to which the field belongs." - (find-field (make-type-from-name (resolve-type-name type-name)) - field-name - (or-enums [$System.Reflection.BindingFlags.Static] - [$System.Reflection.BindingFlags.Public]))) - -(defmacro define-rdnzl-call (lisp-name - (&key (dotnet-name (unmangle-name lisp-name)) - type-name - (member-kind :method) - doc-string) - args) - "Defines a Lisp function named by the function name LISP-NAME which -can directly (without the need to search via Reflection) invoke a -.NET method, or get/set the value of a .NET property or field. -DOTNET-NAME is the name of the .NET member, TYPE-NAME is the name of a -.NET type and should only be supplied if a static member is to be -interfaced. MEMBER-KIND if one of :METHOD, :PROPERTY, or :FIELD. -DOC-STRING is the documentation string of the resulting Lisp -function." - `(eval-when (:compile-toplevel :load-toplevel :execute) - (create-direct-call - ',lisp-name - (setf (gethash ',lisp-name *direct-definitions*) - (list ,member-kind ,dotnet-name ,type-name - (list ,@(loop for (nil arg-type-name) in args - collect arg-type-name))))) - (setf (documentation ',lisp-name 'function) - ,(or doc-string - (format nil "~:[Instance~;Static~] ~A ~A of .NET type ~A -with Lisp lambda list (~{~A~^ ~})" - type-name - (ecase member-kind - ((:method) "method") - ((:property) "property") - ((:field) "field")) - dotnet-name - (or type-name (second (first args))) - (loop for (arg-name nil) in args - collect arg-name)))) - ',lisp-name)) - -(defun create-direct-call (lisp-name other-args) - "Called by DEFINE-RDNZL-CALL (and also by REDEFINE-DIRECT-CALLS) to -actually create the function definition for LISP-NAME based on the -necessary data (which is simply a transformation of the arguments to -DEFINE-RDNZL-CALL) in OTHER-ARGS." - (destructuring-bind (member-kind dotnet-name type-name arg-type-names) - other-args - (ecase member-kind - ((:method) - (cond (type-name - (let ((method-info (find-static-method dotnet-name type-name arg-type-names))) - (unless method-info - (error "Static method ~A(~{~A~^, ~}) for .NET type ~A not found" - dotnet-name arg-type-names type-name)) - (setf (fdefinition lisp-name) - (lambda (&rest args) - (ffi-call-with-args %invoke-static-member-directly - method-info - nil - args))))) - (t - (let ((method-info (find-instance-method dotnet-name arg-type-names))) - (unless method-info - (error "Instance method ~A(~{~A~^, ~}) for .NET type ~A not found" - dotnet-name (rest arg-type-names) (first arg-type-names))) - (setf (fdefinition lisp-name) - (lambda (&rest args) - (ffi-call-with-args %invoke-instance-member-directly - method-info - nil - args))))))) - ((:property) - (cond (type-name - (let ((property-info (find-static-property dotnet-name type-name arg-type-names))) - (unless property-info - (error "Static property ~A(~{~A~^, ~}) for .NET type ~A not found" - dotnet-name arg-type-names type-name)) - (setf (fdefinition lisp-name) - (if (consp lisp-name) - (lambda (new-value &rest other-args) - (ffi-call-with-args %set-static-property-value-directly - property-info - nil - (cons new-value other-args)) - new-value) - (lambda (&rest args) - (ffi-call-with-args %get-static-property-value-directly - property-info - nil - args)))))) - (t - (let ((property-info (find-instance-property dotnet-name arg-type-names))) - (unless property-info - (error "Instance property ~A(~{~A~^, ~}) for .NET type ~A not found" - dotnet-name (rest arg-type-names) (first arg-type-names))) - (setf (fdefinition lisp-name) - (if (consp lisp-name) - (lambda (new-value &rest other-args) - (ffi-call-with-args %set-instance-property-value-directly - property-info - nil - (cons new-value other-args)) - new-value) - (lambda (&rest args) - (ffi-call-with-args %get-instance-property-value-directly - property-info - nil - args)))))))) - ((:field) - (cond (type-name - (let ((field-info (find-static-field dotnet-name type-name))) - (unless field-info - (error "Static field ~A for .NET type ~A not found" - dotnet-name type-name)) - (setf (fdefinition lisp-name) - (if (consp lisp-name) - (lambda (new-value) - (ffi-call-with-foreign-string %set-static-field-value-directly - nil - field-info - new-value) - new-value) - (lambda () - (ffi-call-with-foreign-string %get-static-field-value-directly - nil - field-info)))))) - (t - (let ((field-info (find-instance-field dotnet-name (first arg-type-names)))) - (unless field-info - (error "Instance field ~A for .NET type ~A not found" - dotnet-name (first arg-type-names))) - (setf (fdefinition lisp-name) - (if (consp lisp-name) - (lambda (new-value object) - (ffi-call-with-foreign-string %set-instance-field-value-directly - nil - field-info - object - new-value) - new-value) - (lambda (object) - (ffi-call-with-foreign-string %get-instance-field-value-directly - nil - field-info - object))))))))))) - -(disable-rdnzl-syntax) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/direct.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Interface for "direct calls" into .NET + +(in-package :rdnzl) + +(enable-rdnzl-syntax) + +(defun find-interface-method (interfaces method-name arg-types binding-attr) + "A Lisp version of findInterfaceMethod - see InvokeMember.cpp." + (do-rdnzl-array (interface interfaces) + (named-when (method-info [GetMethod interface method-name binding-attr + (make-null-object "System.Reflection.Binder") + arg-types + (make-null-object "System.Reflection.ParameterModifier[]")]) + (return-from find-interface-method method-info)) + (named-when (method-info + (find-interface-method [GetInterfaces interface] method-name arg-types binding-attr)) + (return-from find-interface-method method-info)))) + +(defun find-method* (type method-name arg-types binding-attr) + "A Lisp version of findMethod - see InvokeMember.cpp." + (or [GetMethod type method-name binding-attr + (make-null-object "System.Reflection.Binder") + arg-types + (make-null-object "System.Reflection.ParameterModifier[]")] + (and [%IsInterface type] + (or (find-interface-method [GetInterfaces type] method-name arg-types binding-attr) + (find-method* (make-type-from-name "System.Object") method-name arg-types binding-attr))))) + +(defun find-instance-method (method-name arg-type-names) + "Finds and returns a MethodInfo object (or NIL) corresponding to +the instance method with the name METHOD-NAME (a string) and the +signature ARG-TYPE-NAMES (a list of strings naming types). Note that +the first element of ARG-TYPE-NAMES represents the type to which the +method belongs." + (let ((arg-types (mapcar (lambda (arg-type-name) + (make-type-from-name + (resolve-type-name arg-type-name))) + arg-type-names))) + (find-method* (first arg-types) + method-name + (list-to-rdnzl-array (rest arg-types) + "System.Type") + (or-enums [$System.Reflection.BindingFlags.Instance] + [$System.Reflection.BindingFlags.Public])))) + +(defun find-static-method (method-name type-name arg-type-names) + "Finds and returns a MethodInfo object (or NIL) corresponding to +the static method of the type named TYPE-NAME (a string) with the +name METHOD-NAME (a string) and the signature ARG-TYPE-NAMES (a list +of strings naming types)." + (let ((arg-types (mapcar (lambda (arg-type-name) + (make-type-from-name + (resolve-type-name arg-type-name))) + arg-type-names))) + (find-method* (make-type-from-name (resolve-type-name type-name)) + method-name + (list-to-rdnzl-array arg-types + "System.Type") + (or-enums [$System.Reflection.BindingFlags.Static] + [$System.Reflection.BindingFlags.Public])))) + +(defun find-property (type property-name arg-types binding-attr) + "Finds a PropertyInfo object. See corresponding code in +Property.cpp." + [GetProperty type property-name binding-attr + (make-null-object "System.Reflection.Binder") + (make-null-object "System.Type") + arg-types + (make-null-object "System.Reflection.ParameterModifier[]")]) + +(defun find-instance-property (property-name arg-type-names)

[197 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/ffi.lisp 2006/01/13 07:06:28 1.3 +++ /project/rdnzl/cvsroot/RDNZL/ffi.lisp 2006/02/01 01:00:56 1.4 @@ -1,337 +1,336 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/ffi.lisp,v 1.3 2006/01/13 07:06:28 eweitz Exp $ - -;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; FFI definitions for all functions exported by RDNZL.dll. See the -;;; C++ source code for details. - -(in-package :rdnzl) - -;; load the C++ library which interfaces with the CLR -(ffi-register-module "RDNZL.dll" :rdnzl) - -(defmacro ffi-define-function (c-name arg-list result-type) - "Like FFI-DEFINE-FUNCTION* but automatically creates the Lisp name -from the C name. A name like "invokeMethod" is mapped to -"%INVOKE-METHOD"." - `(ffi-define-function* (,(intern - (concatenate 'string "%" (mangle-name c-name)) - :rdnzl) - ,c-name) - ,arg-list - ,result-type)) - -(ffi-define-function "DllEnsureInit" - () - ffi-void) - -(ffi-define-function "DllForceTerm" - () - ffi-void) - -(defun dll-ensure-init () - "Wrapper for DllEnsureInit which makes sure the function is called -only once." - (unless *dll-initialized* - (%dll-ensure-init) - (setq *dll-initialized* t))) - -(defun dll-force-term () - "Wrapper for DllForceTerm which makes sure the function is only -called after DllEnsureInit has been called." - (when *dll-initialized* - (%dll-force-term) - (setq *dll-initialized* nil))) - -(ffi-define-function "invokeInstanceMember" - ((method-name ffi-const-string) - (target ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "invokeInstanceMemberDirectly" - ((method-info ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "invokeStaticMember" - ((method-name ffi-const-string) - (type ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "invokeStaticMemberDirectly" - ((method-info ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getInstanceFieldValue" - ((field-name ffi-const-string) - (target ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getStaticFieldValue" - ((field-name ffi-const-string) - (type ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setInstanceFieldValue" - ((field-name ffi-const-string) - (target ffi-void-pointer) - (new-value ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setStaticFieldValue" - ((field-name ffi-const-string) - (type ffi-void-pointer) - (new-value ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getInstanceFieldValueDirectly" - ((field-info ffi-void-pointer) - (target ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getStaticFieldValueDirectly" - ((field-info ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setInstanceFieldValueDirectly" - ((field-info ffi-void-pointer) - (target ffi-void-pointer) - (new-value ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setStaticFieldValueDirectly" - ((field-info ffi-void-pointer) - (new-value ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getInstancePropertyValue" - ((property-name ffi-const-string) - (target ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setInstancePropertyValue" - ((property-name ffi-const-string) - (target ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getStaticPropertyValue" - ((property-name ffi-const-string) - (type ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setStaticPropertyValue" - ((property-name ffi-const-string) - (type ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getInstancePropertyValueDirectly" - ((property-info ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setInstancePropertyValueDirectly" - ((property-info ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getStaticPropertyValueDirectly" - ((property-info ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setStaticPropertyValueDirectly" - ((property-info ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "refDotNetContainerType" - ((ptr ffi-void-pointer)) - ffi-void) - -(ffi-define-function "unrefDotNetContainerType" - ((ptr ffi-void-pointer)) - ffi-void) - -(ffi-define-function "freeDotNetContainer" - ((ptr ffi-void-pointer)) - ffi-void) - -(ffi-define-function "DotNetContainerIsNull" - ((ptr ffi-void-pointer)) - ffi-boolean) - -(ffi-define-function "makeTypedNullDotNetContainer" - ((ptr ffi-const-string)) - ffi-void-pointer) - -(ffi-define-function "InvocationResultIsVoid" - ((ptr ffi-void-pointer)) - ffi-boolean) - -(ffi-define-function "freeInvocationResult" - ((ptr ffi-void-pointer)) - ffi-void) - -(ffi-define-function "getDotNetContainerFromInvocationResult" - ((ptr ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getDotNetContainerTypeStringLength" - ((ptr ffi-void-pointer)) - ffi-integer) - -(ffi-define-function "getDotNetContainerTypeAsString" - ((ptr ffi-void-pointer) - (s ffi-void-pointer)) - ffi-void) - -(ffi-define-function "setDotNetContainerTypeFromString" - ((type ffi-const-string) - (ptr ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "getDotNetContainerObjectStringLength" - ((ptr ffi-void-pointer)) - ffi-integer) - -(ffi-define-function "getDotNetContainerObjectAsString" - ((ptr ffi-void-pointer) - (s ffi-void-pointer)) - ffi-void) - -(ffi-define-function "getDotNetContainerIntValue" - ((ptr ffi-void-pointer)) - ffi-integer) - -(ffi-define-function "getDotNetContainerCharValue" - ((ptr ffi-void-pointer)) - ffi-wide-char) - -(ffi-define-function "getDotNetContainerBooleanValue" - ((ptr ffi-void-pointer)) - ffi-boolean) - -(ffi-define-function "getDotNetContainerDoubleValue" - ((ptr ffi-void-pointer)) - ffi-double) - -(ffi-define-function "getDotNetContainerSingleValue" - ((ptr ffi-void-pointer)) - ffi-float) - -(ffi-define-function "makeTypeFromName" - ((type ffi-const-string)) - ffi-void-pointer) - -(ffi-define-function "makeDotNetContainerFromChar" - ((c ffi-wide-char)) - ffi-void-pointer) - -(ffi-define-function "makeDotNetContainerFromString" - ((s ffi-const-string)) - ffi-void-pointer) - -(ffi-define-function "makeDotNetContainerFromBoolean" - ((b ffi-boolean)) - ffi-void-pointer) - -(ffi-define-function "makeDotNetContainerFromInt" - ((n ffi-integer)) - ffi-void-pointer) - -(ffi-define-function "makeDotNetContainerFromLong" - ((s ffi-const-string)) - ffi-void-pointer) - -(ffi-define-function "makeDotNetContainerFromFloat" - ((n ffi-float)) - ffi-void-pointer) - -(ffi-define-function "makeDotNetContainerFromDouble" - ((n ffi-double)) - ffi-void-pointer) - -(ffi-define-function "getArrayElement" - ((ptr ffi-void-pointer) - (index ffi-integer)) - ffi-void-pointer) - -(ffi-define-function "InvocationResultIsException" - ((ptr ffi-void-pointer)) - ffi-boolean) - -(ffi-define-function "invokeConstructor" - ((type ffi-void-pointer) - (nargs ffi-integer) - (args ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-function "setFunctionPointers" - ((fp1 ffi-void-pointer) - (fp2 ffi-void-pointer)) - ffi-void) - -(ffi-define-function "buildDelegateType" - ((type-name ffi-const-string) - (return-type ffi-void-pointer) - (arg-types ffi-void-pointer)) - ffi-void-pointer) - -(ffi-define-callable - (LispCallback ffi-void-pointer) - ((index ffi-integer) - (args ffi-void-pointer)) - (declare (ignore types)) - ;; here the actual callback, the Lisp closure, is called - see - ;; adapter.lisp - (funcall (gethash index *callback-hash*) args)) - -(ffi-define-callable - (ReleaseDelegateAdapter ffi-void) - ((index ffi-integer)) - ;; remove entry from hash table if CLR is done with it - (remhash index *callback-hash*)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/ffi.lisp,v 1.4 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; FFI definitions for all functions exported by RDNZL.dll. See the +;;; C++ source code for details. + +(in-package :rdnzl) + +;; load the C++ library which interfaces with the CLR +(ffi-register-module "RDNZL.dll" :rdnzl) + +(defmacro ffi-define-function (c-name arg-list result-type) + "Like FFI-DEFINE-FUNCTION* but automatically creates the Lisp name +from the C name. A name like "invokeMethod" is mapped to +"%INVOKE-METHOD"." + `(ffi-define-function* (,(intern + (concatenate 'string "%" (mangle-name c-name)) + :rdnzl) + ,c-name) + ,arg-list + ,result-type)) + +(ffi-define-function "DllEnsureInit" + () + ffi-void) + +(ffi-define-function "DllForceTerm" + () + ffi-void) + +(defun dll-ensure-init () + "Wrapper for DllEnsureInit which makes sure the function is called +only once." + (unless *dll-initialized*

[276 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/import.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/import.lisp 2006/02/01 01:00:56 1.3 @@ -1,193 +1,193 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/import.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; Importing types and assemblies, initialization. - -(in-package :rdnzl) - -(enable-rdnzl-syntax) - -(defun import-type (type &optional assembly) - "Imports the .NET type TYPE, i.e. registers its name as one that can -be abbreviated (see USE-NAMESPACE) and maybe creates a mapping from -its short name to its assembly-qualified name. If TYPE is a string -and ASSEMBLY is NIL then the function will try to create the type from -the string with the static method System.Type::GetType. If TYPE is a -string and ASSEMBLY is an assembly (a CONTAINER) then instead the -instance method System.Reflection.Assembly::GetType will be used. If -TYPE is already a .NET object (i.e. a CONTAINER) then the function -will just register its name. If ASSEMBLY is a true value then the -name will also be mapped to its assembly-qualified name. In all cases -the type itself (as a CONTAINER) will be returned." - (cond ((container-p type) - (setf (gethash [%FullName type] *type-hash*) - (cond (assembly [%AssemblyQualifiedName type]) - (t t))) - type) - ((stringp type) - (import-type (cond (assembly - (or [GetType assembly type] - (error "Type with name ~S not found in assembly ~S." - type [%FullName assembly]))) - (t - (let ((imported-type (make-type-from-name type))) - (when (%dot-net-container-is-null (pointer imported-type)) - (error "Type with name ~S not found." - type)) - imported-type))) - assembly)) - (t (error "Don't know how to import type ~S." type)))) - -(defun new (type &rest other-args) - "Creates a new .NET object (a CONTAINER) of the type TYPE. Calls -the constructor determined by OTHER-ARGS (a list of Lisp object -and/or CONTAINERs), i.e. by the corresponding signature. TYPE can be -a string (naming the type) or a CONTAINER (representing the type). -If TYPE is a delegate then the second argument to NEW must be a Lisp -closure with a correspoding signature." - (cond ((stringp type) - (apply #'new - (make-type-from-name (resolve-type-name type)) - other-args)) - ((container-p type) - (cond ([IsAssignableFrom (make-type-from-name "System.Delegate") type] - ;; it's a delegate - (let* ((method-info [GetMethod type "Invoke"]) - (adapter (make-adapter (first other-args) - [%ReturnType method-info] - (mapcar #`%ParameterType - (rdnzl-array-to-list [GetParameters method-info]))))) - (invoke-constructor type - adapter - [GetFunctionPointer [%MethodHandle [GetMethod [GetType adapter] - "InvokeClosure"]]]))) - (t (apply #'invoke-constructor - type - other-args)))) - (t (error "Don't know how to make a new ~S." type)))) - -(defun load-assembly (name) - "Loads and returns the assembly with the name NAME (a string), uses -LoadWithPartialName." - [System.Reflection.Assembly.LoadWithPartialName name]) - -(defun import-assembly (assembly) - "Imports all public types of the assembly ASSEMBLY (a string or a -CONTAINER). If ASSEMBLY is a string then the assembly is first loaded -with LOAD-ASSEMBLY. Returns ASSEMBLY as a CONTAINER." - (cond ((container-p assembly) - (do-rdnzl-array (type [GetTypes assembly]) - (when [%IsPublic type] - (import-type type))) - assembly) - ((stringp assembly) - (import-assembly (load-assembly assembly))) - (t (error "Don't know how to import assembly ~S." assembly)))) - -(defun import-types (assembly-name &rest type-names) - "Loads the assembly named ASSEMBLY-NAME and imports (see function -IMPORT-TYPE) all types listed from this assembly. The assembly name -is prepended to the type names before importing them. All arguments -should be strings." - (let ((assembly (or (load-assembly assembly-name) - (error "Assembly ~S not found" assembly-name)))) - (dolist (type-name type-names) - (import-type (concatenate 'string - assembly-name - "." - type-name) - assembly)))) - -(defun reset-cached-data () - "Resets all relevant global special variables to their initial value, -thereby releasing pointers to DotNetContainer objects if necessary. -Also removes all direct call definitions." - (setq *callback-counter* 0 - *delegate-counter* 0) - (clrhash *callback-hash*) - (clrhash *signature-hash*) - (loop for function-name being the hash-keys in *direct-definitions* - do (fmakunbound function-name))) - -(defun init-rdnzl () - "Initializes RDNZL. This function must be called once before RDNZL -is used." - ;; see http://msdn.microsoft.com/library/en-us/vcmex/html/vcconconvertingmanagedextensionsforcprojectsfrompureintermediatelanguagetomixedmode.asp?frame=true - (dll-ensure-init) - ;; inform the DelegateAdapter class about where the Lisp callbacks - ;; are located - (%set-function-pointers (ffi-make-pointer 'LispCallback) - (ffi-make-pointer 'ReleaseDelegateAdapter)) - ;; reset to a sane state - (reset-cached-data) - (reimport-types) - (redefine-direct-calls) - ;; see comment for DLL-ENSURE-INIT above - (register-exit-function #'dll-force-term "Close DLL") - (values)) - -(defun shutdown-rdnzl (&optional no-gc) - "Prepares RDNZL for delivery or image saving. After calling this -function RDNZL can't be used anymore unless INIT-RDNZL is called -again. If NO-GC is NIL (the default) a full garbage collection is -also performed." - (reset-cached-data) - (dll-force-term) - (unless no-gc - (full-gc)) - (values)) - -(defun reimport-types () - "Loops through all imported types and tries to associate them with -the correct assembly. Only relevant for delivery and saved images." - (let ((assembly-hash (make-hash-table :test #'equal))) - (loop for type-name being the hash-keys in *type-hash* - using (hash-value assembly-qualified-name) - ;; only do this for types which need the assembly-qualified - ;; name - when (stringp assembly-qualified-name) - do (let ((assembly-name (find-partial-assembly-name assembly-qualified-name))) - (import-type type-name - (or (gethash assembly-name assembly-hash) - (setf (gethash assembly-name assembly-hash) - (load-assembly assembly-name)))))))) - -(defun redefine-direct-calls () - "Loops through all direct call definition which have been stored in -*DIRECT-DEFINITIONS* and re-animates them. Only relevant for delivery -and saved images." - (loop for function-name being the hash-keys in *direct-definitions* - using (hash-value function-data) - do (create-direct-call function-name function-data))) - -;; when loading this file initialize RDNZL -(eval-when (:load-toplevel :execute) - (init-rdnzl)) - -(disable-rdnzl-syntax) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/import.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Importing types and assemblies, initialization. + +(in-package :rdnzl) + +(enable-rdnzl-syntax) + +(defun import-type (type &optional assembly) + "Imports the .NET type TYPE, i.e. registers its name as one that can +be abbreviated (see USE-NAMESPACE) and maybe creates a mapping from +its short name to its assembly-qualified name. If TYPE is a string +and ASSEMBLY is NIL then the function will try to create the type from +the string with the static method System.Type::GetType. If TYPE is a +string and ASSEMBLY is an assembly (a CONTAINER) then instead the +instance method System.Reflection.Assembly::GetType will be used. If +TYPE is already a .NET object (i.e. a CONTAINER) then the function +will just register its name. If ASSEMBLY is a true value then the +name will also be mapped to its assembly-qualified name. In all cases +the type itself (as a CONTAINER) will be returned." + (cond ((container-p type) + (setf (gethash [%FullName type] *type-hash*) + (cond (assembly [%AssemblyQualifiedName type]) + (t t))) + type) + ((stringp type) + (import-type (cond (assembly + (or [GetType assembly type] + (error "Type with name ~S not found in assembly ~S." + type [%FullName assembly]))) + (t + (let ((imported-type (make-type-from-name type))) + (when (%dot-net-container-is-null (pointer imported-type)) + (error "Type with name ~S not found." + type)) + imported-type))) + assembly)) + (t (error "Don't know how to import type ~S." type)))) + +(defun new (type &rest other-args) + "Creates a new .NET object (a CONTAINER) of the type TYPE. Calls +the constructor determined by OTHER-ARGS (a list of Lisp object +and/or CONTAINERs), i.e. by the corresponding signature. TYPE can be +a string (naming the type) or a CONTAINER (representing the type). +If TYPE is a delegate then the second argument to NEW must be a Lisp +closure with a correspoding signature." + (cond ((stringp type) + (apply #'new + (make-type-from-name (resolve-type-name type)) + other-args)) + ((container-p type) + (cond ([IsAssignableFrom (make-type-from-name "System.Delegate") type] + ;; it's a delegate + (let* ((method-info [GetMethod type "Invoke"]) + (adapter (make-adapter (first other-args) + [%ReturnType method-info] + (mapcar #`%ParameterType + (rdnzl-array-to-list [GetParameters method-info]))))) + (invoke-constructor type + adapter + [GetFunctionPointer [%MethodHandle [GetMethod [GetType adapter] + "InvokeClosure"]]]))) + (t (apply #'invoke-constructor + type + other-args)))) + (t (error "Don't know how to make a new ~S." type)))) + +(defun load-assembly (name) + "Loads and returns the assembly with the name NAME (a string), uses +LoadWithPartialName." + [System.Reflection.Assembly.LoadWithPartialName name]) + +(defun import-assembly (assembly) + "Imports all public types of the assembly ASSEMBLY (a string or a +CONTAINER). If ASSEMBLY is a string then the assembly is first loaded +with LOAD-ASSEMBLY. Returns ASSEMBLY as a CONTAINER." + (cond ((container-p assembly) + (do-rdnzl-array (type [GetTypes assembly]) + (when [%IsPublic type] + (import-type type))) + assembly) + ((stringp assembly) + (import-assembly (load-assembly assembly))) + (t (error "Don't know how to import assembly ~S." assembly)))) + +(defun import-types (assembly-name &rest type-names) + "Loads the assembly named ASSEMBLY-NAME and imports (see function +IMPORT-TYPE) all types listed from this assembly. The assembly name +is prepended to the type names before importing them. All arguments +should be strings." + (let ((assembly (or (load-assembly assembly-name) + (error "Assembly ~S not found" assembly-name)))) + (dolist (type-name type-names) + (import-type (concatenate 'string + assembly-name + "." + type-name) + assembly)))) + +(defun reset-cached-data () + "Resets all relevant global special variables to their initial value, +thereby releasing pointers to DotNetContainer objects if necessary. +Also removes all direct call definitions." + (setq *callback-counter* 0 + *delegate-counter* 0) + (clrhash *callback-hash*) + (clrhash *signature-hash*) + (loop for function-name being the hash-keys in *direct-definitions* + do (fmakunbound function-name))) + +(defun init-rdnzl () + "Initializes RDNZL. This function must be called once before RDNZL +is used." + ;; see http://msdn.microsoft.com/library/en-us/vcmex/html/vcconconvertingmanagedextensionsforcprojectsfrompureintermediatelanguagetomixedmode.asp?frame=true + (dll-ensure-init) + ;; inform the DelegateAdapter class about where the Lisp callbacks + ;; are located + (%set-function-pointers (ffi-make-pointer 'LispCallback) + (ffi-make-pointer 'ReleaseDelegateAdapter)) + ;; reset to a sane state + (reset-cached-data) + (reimport-types) + (redefine-direct-calls) + ;; see comment for DLL-ENSURE-INIT above + (register-exit-function #'dll-force-term "Close DLL") + (values)) + +(defun shutdown-rdnzl (&optional no-gc) + "Prepares RDNZL for delivery or image saving. After calling this +function RDNZL can't be used anymore unless INIT-RDNZL is called +again. If NO-GC is NIL (the default) a full garbage collection is +also performed." + (reset-cached-data) + (dll-force-term) + (unless no-gc + (full-gc)) + (values)) + +(defun reimport-types () + "Loops through all imported types and tries to associate them with +the correct assembly. Only relevant for delivery and saved images." + (let ((assembly-hash (make-hash-table :test #'equal))) + (loop for type-name being the hash-keys in *type-hash* + using (hash-value assembly-qualified-name) + ;; only do this for types which need the assembly-qualified + ;; name + when (stringp assembly-qualified-name) + do (let ((assembly-name (find-partial-assembly-name assembly-qualified-name))) + (import-type type-name + (or (gethash assembly-name assembly-hash) + (setf (gethash assembly-name assembly-hash) + (load-assembly assembly-name)))))))) + +(defun redefine-direct-calls () + "Loops through all direct call definition which have been stored in +*DIRECT-DEFINITIONS* and re-animates them. Only relevant for delivery +and saved images." + (loop for function-name being the hash-keys in *direct-definitions* + using (hash-value function-data) + do (create-direct-call function-name function-data))) + +;; when loading this file initialize RDNZL +(eval-when (:load-toplevel :execute) + (init-rdnzl)) + +(disable-rdnzl-syntax) --- /project/rdnzl/cvsroot/RDNZL/load.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/load.lisp 2006/02/01 01:00:56 1.3 @@ -1,72 +1,73 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/load.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; Load this file to compile and load all of RDNZL - see README.txt -;;; and the doc folder for details. - -(in-package :cl-user) - -(let ((rdnzl-base-directory - (make-pathname :name nil :type nil :version nil - :defaults (parse-namestring *load-truename*)))) - (let (must-compile) - #+:cormanlisp (declare (ignore must-compile)) - (dolist (file '("packages" - "specials" - "util" - #+:allegro "port-acl" - #+:cormanlisp "port-ccl" - #+:clisp "port-clisp" - #+:lispworks "port-lw" - "ffi" - "container" - "reader" - "arrays" - "adapter" - "import" - "direct")) - (let ((pathname (make-pathname :name file :type "lisp" :version nil - :defaults rdnzl-base-directory))) - ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD - ;; will yield compiled functions anyway - #-:cormanlisp - (let ((compiled-pathname (compile-file-pathname pathname))) - (unless (and (not must-compile) - (probe-file compiled-pathname) - (< (file-write-date pathname) - (file-write-date compiled-pathname))) - (setq must-compile t) - (compile-file pathname)) - (setq pathname compiled-pathname)) - (load pathname))))) - - - - - +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/load.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Load this file to compile and load all of RDNZL - see README.txt +;;; and the doc folder for details. + +(in-package :cl-user) + +(let ((rdnzl-base-directory + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*)))) + (let (must-compile) + #+:cormanlisp (declare (ignore must-compile)) + (dolist (file '("packages" + "specials" + "util" + #+:allegro "port-acl" + #+:cormanlisp "port-ccl" + #+:clisp "port-clisp" + #+:lispworks "port-lw" + #+:sbcl "port-sbcl" + "ffi" + "container" + "reader" + "arrays" + "adapter" + "import" + "direct")) + (let ((pathname (make-pathname :name file :type "lisp" :version nil + :defaults rdnzl-base-directory))) + ;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD + ;; will yield compiled functions anyway + #-:cormanlisp + (let ((compiled-pathname (compile-file-pathname pathname))) + (unless (and (not must-compile) + (probe-file compiled-pathname) + (< (file-write-date pathname) + (file-write-date compiled-pathname))) + (setq must-compile t) + (compile-file pathname)) + (setq pathname compiled-pathname)) + (load pathname))))) + + + + + --- /project/rdnzl/cvsroot/RDNZL/packages.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/packages.lisp 2006/02/01 01:00:56 1.3 @@ -1,68 +1,74 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/packages.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; Definition of the "RDNZL" package. - -(in-package :cl-user) - -;; Corman Lisp has problems with uninterned symbols like #:aref* -(defpackage :rdnzl - (:use :cl) - (:export :aref* - :box - :cast - :container-p - :define-rdnzl-call - :disable-rdnzl-syntax - :do-rdnzl-array - :enable-rdnzl-syntax - :enum-to-integer - :field - :import-assembly - :import-type - :import-types - :integer-to-enum - :invoke - :init-rdnzl - :load-assembly - :list-to-rdnzl-array - :make-null-object - :new - :or-enums - :property - :ref - :rdnzl-array-to-list - :rdnzl-error - :rdnzl-error-exception - :rdnzl-handler-case - :shutdown-rdnzl - :unbox - :unuse-all-namespaces - :unuse-namespace - :use-namespace)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/packages.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Definition of the "RDNZL" package. + +(in-package :cl-user) + +;; Corman Lisp has problems with uninterned symbols like #:aref* +(defpackage :rdnzl + (:use :cl) + #+:sbcl (:shadow :defconstant) + (:export :aref* + :box + :cast + :container-p + :define-rdnzl-call + :disable-rdnzl-syntax + :do-rdnzl-array + :enable-rdnzl-syntax + :enum-to-integer + :field + :import-assembly + :import-type + :import-types + :integer-to-enum + :invoke + :init-rdnzl + :load-assembly + :list-to-rdnzl-array + :make-null-object + :new + :or-enums + :property + :ref + :rdnzl-array-to-list + :rdnzl-error + :rdnzl-error-exception + :rdnzl-handler-case + :shutdown-rdnzl + :unbox + :unuse-all-namespaces + :unuse-namespace + :use-namespace)) + +(defpackage :rdnzl-user + (:use :cl :rdnzl) + (:documentation "This package is intended for playing around +with RDNZL.")) \ No newline at end of file --- /project/rdnzl/cvsroot/RDNZL/port-acl.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/port-acl.lisp 2006/02/01 01:00:56 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-acl.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-acl.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $

-;;; Copyright (c) 2004-2005, Charles A. Cox, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2004-2006, Charles A. Cox, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions @@ -131,9 +131,10 @@ (defmacro ffi-define-function* ((lisp-name c-name) arg-list result-type) - "Defines a Lisp function LISP-NAME which acts as an interface to the -C function C-NAME. ARG-LIST is a list of (NAME TYPE) pairs. All types -are supposed to be symbols mappable by FFI-MAP-TYPE above." + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of (NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." (flet ((arg-spec (arg-list) (mapcar #'(lambda (name-and-type) (destructuring-bind (name type) name-and-type @@ -150,9 +151,9 @@ (defmacro ffi-define-callable ((c-name result-type) arg-list &body body) - "Defines a Lisp which can be called from C as the C function -C-NAME. ARG-LIST is a list of (NAME TYPE) pairs. All types are -supposed to be symbols mappable by FFI-MAP-TYPE above." + "Defines a Lisp which can be called from C. ARG-LIST is a list +of (NAME TYPE) pairs. All types are supposed to be symbols +mappable by FFI-MAP-TYPE above." (declare (ignore result-type)) `(progn (ff:defun-foreign-callable ,c-name @@ -274,5 +275,5 @@ sys:*exit-cleanup-forms*))

(defun full-gc () - "Invoke a full garbage collection." + "Invokes a full garbage collection." (excl:gc t)) --- /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp 2006/02/01 01:00:56 1.3 @@ -1,282 +1,283 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; Corman-specific definitions - -(in-package :rdnzl) - -(defvar *dll-path* nil - "The name of RDNZL.dll.") - -(defmacro ffi-register-module (dll-path &optional module-name) - "Store the DLL name provided by the argument DLL-PATH." - (declare (ignore module-name)) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *dll-path* ,dll-path))) - -(defun ffi-pointer-p (object) - "Tests whether OBJECT is an FFI pointer." - (ct:cpointerp object)) - -(defun ffi-null-pointer-p (pointer) - "Returns whether the FFI pointer POINTER is a null pointer." - (ct:cpointer-null pointer)) - -(defun ffi-pointer-address (pointer) - "Returns the address of the FFI pointer POINTER." - (ct:cpointer-value pointer)) - -(defun ffi-make-pointer (name) - "Returns an FFI pointer to the address specified by the name NAME." - (ct:get-callback-procinst name)) - -(defun ffi-map-type (type-name) - "Maps type names like FFI-INTEGER to their corresponding names in -the LispWorks FLI." - (ecase type-name - (ffi-void :void) - (ffi-void-pointer '(:void *)) - (ffi-const-string '(:void *)) - (ffi-integer :long) - (ffi-boolean :long-bool) - (ffi-wide-char :unsigned-short) - (ffi-float :single-float) - (ffi-double :double-float))) - -(defmacro ffi-define-function* ((lisp-name c-name) - arg-list - result-type) - "Defines a Lisp function LISP-NAME which acts as an interface to the -C function C-NAME. ARG-LIST is a list of (NAME TYPE) pairs. All types -are supposed to be symbols mappable by FFI-MAP-TYPE above." - (cond ((or (eq result-type 'ffi-wide-char) - (find 'ffi-wide-char arg-list :key #'second :test #'eq)) - ;; define a wrapper if one of the args and/or the return type - ;; is a __wchar_t because Corman Lisp doesn't handle this - ;; type automatically - (with-unique-names (internal-name result) - `(progn - (ct:defun-dll ,internal-name - ,(mapcar (lambda (name-and-type) - (destructuring-bind (name type) name-and-type - (list name (ffi-map-type type)))) - arg-list) - :return-type ,(ffi-map-type result-type) - :linkage-type :c - :library-name ,*dll-path* - :entry-name ,c-name) - (defun ,lisp-name ,(mapcar #'first arg-list) - (let ((,result (,internal-name ,@(loop for (name type) in arg-list - when (eq type 'ffi-wide-char) - collect `(char-code ,name) - else - collect name)))) - ,(if (eq result-type 'ffi-wide-char) - ;; only use lower octet... - `(code-char (logand ,result 255)) - result)))))) - (t - `(ct:defun-dll ,lisp-name - ,(mapcar (lambda (name-and-type) - (destructuring-bind (name type) name-and-type - (list name (ffi-map-type type)))) - arg-list) - :return-type ,(ffi-map-type result-type) - :linkage-type :c - :library-name ,*dll-path* - :entry-name ,c-name)))) - -(defmacro ffi-define-callable ((c-name result-type) - arg-list - &body body) - "Defines a Lisp which can be called from C as the C function C-NAME. -ARG-LIST is a list of (NAME TYPE) pairs. All types are supposed to -be symbols mappable by FFI-MAP-TYPE above." - (declare (ignore result-type)) - `(ct:defun-direct-c-callback ,c-name - ,(mapcar (lambda (name-and-type) - (destructuring-bind (name type) name-and-type - (list name (ffi-map-type type)))) - arg-list) - ,@body)) - -(defmacro ffi-get-call-by-ref-string (function object length-function) - "Calls the foreign function FUNCTION. FUNCTION is supposed to call -a C function f with the signature void f(..., __wchar_t *s) where s -is a result string which is returned by this macro. OBJECT is the -first argument given to f. Prior to calling f the length of the -result string s is obtained by evaluating (LENGTH-FUNCTION OBJECT)." - (with-rebinding (object) - (with-unique-names (length temp) - `(let ((,length (,length-function ,object)) - ,temp) - (unwind-protect - (progn - (setq ,temp (ct:malloc (* 2 (1+ ,length)))) - (,function ,object ,temp) - (copy-seq (ct:unicode-to-lisp-string ,temp))) - (when ,temp - (ct:free ,temp))))))) - -(defmacro ffi-call-with-foreign-string* (function string &optional other-args) - "Applies the foreign function FUNCTION to the string STRING and -OTHER-ARGS. OTHER-ARGS (a list of CONTAINER structures or `native' -Lisp objects) is converted to a foreign array prior to calling -FUNCTION. STRING may be NIL which means that this argument is skipped -(i.e. the macro actually needs a better name)." - (with-rebinding (other-args) - (with-unique-names (length arg-pointers ffi-arg-pointers arg i - arg-pointer foreign-string) - ` (let* ((,length (length ,other-args)) - (,arg-pointers (make-array ,length :initial-element nil)) - ,foreign-string) - (unwind-protect - (let ((,ffi-arg-pointers - (loop for ,arg in ,other-args - for ,i from 0 - for ,arg-pointer = (cond - ((container-p ,arg) (pointer ,arg)) - (t (setf (aref ,arg-pointers ,i) - (box* ,arg)))) - collect ,arg-pointer))) - ,(cond (string - `(progn - (setq ,foreign-string (ct:lisp-string-to-unicode ,string)) - (apply #',function ,foreign-string ,ffi-arg-pointers))) - (t - `(apply #',function ,ffi-arg-pointers)))) - (when ,foreign-string - (ct:free ,foreign-string)) - ;; all .NET elements that were solely created (by BOX*) - ;; for this FFI call are immediately freed - (dotimes (,i ,length) - (named-when (,arg-pointer (aref ,arg-pointers ,i)) - (%free-dot-net-container ,arg-pointer)))))))) - -(defmacro ffi-call-with-args* (function object name args) - "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS (a -list of CONTAINER structures or `native' Lisp objects) is converted to -a foreign array prior to calling FUNCTION. If NAME is not NIL, then -it should be a string and the first argument to FUNCTION will be the -corresponding foreign string." - (with-rebinding (args) - (with-unique-names (length arg-pointers ffi-arg-pointers arg i - arg-pointer foreign-name) - ` (let* ((,length (length ,args)) - (,arg-pointers (make-array ,length :initial-element nil)) - ,ffi-arg-pointers - ,foreign-name) - (unwind-protect - (progn - (setq ,ffi-arg-pointers (ct:malloc (* ,length (ct:sizeof '(:void *))))) - (loop for ,arg in ,args - for ,i from 0 - for ,arg-pointer = (cond - ((container-p ,arg) (pointer ,arg)) - (t (setf (aref ,arg-pointers ,i) - (box* ,arg)))) - do (setf (ct:cref ((:void *) *) ,ffi-arg-pointers ,i) - ,arg-pointer)) - ,(cond (name - `(progn - (setq ,foreign-name (ct:lisp-string-to-unicode ,name)) - (,function ,foreign-name - ,object - ,length - ,ffi-arg-pointers))) - (t - `(,function ,object - ,length - ,ffi-arg-pointers)))) - (when ,ffi-arg-pointers - (ct:free ,ffi-arg-pointers)) - (when ,foreign-name - (ct:free ,foreign-name)) - ;; all .NET elements that were solely created (by BOX*) - ;; for this FFI call are immediately freed - (dotimes (,i ,length) - (named-when (,arg-pointer (aref ,arg-pointers ,i)) - (%free-dot-net-container ,arg-pointer)))))))) - -(defun flag-for-finalization (object &optional function) - "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT -is removed by GC." - (ccl:register-finalization object function)) - -(defun register-exit-function (function &optional name) - "Makes sure the function FUNCTION (with no arguments) is called -before the Lisp images exits." - ;; don't know how to do that in Corman Lisp - (declare (ignore function name))) - -(defun full-gc () - "Invoke a full garbage collection." - (ccl:gc 3)) - -(export 'lf-to-crlf :rdnzl) -(defun lf-to-crlf (string) - "Add #\Return before each #\Newline in STRING." - (loop with new-string = (make-array (length string) - :element-type 'character - :fill-pointer 0) - for c across string - when (char= c #\Newline) - do (vector-push-extend #\Return new-string) - do (vector-push-extend c new-string) - finally (return new-string))) - -;; Corman's WITH-STANDARD-IO-SYNTAX doesn't work correctly so we fix -;; it here for our purposes - -(defvar *standard-readtable* (copy-readtable nil)) -(defvar *standard-pprint-dispatch* (copy-pprint-dispatch nil)) - -(defmacro with-standard-io-syntax (&body body) - `(let ((*package* (find-package :user)) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-lines* nil) - (*print-miser-width* nil) - (*print-pprint-dispatch* *standard-pprint-dispatch*) - (*print-pretty* nil) - (*print-radix* nil) - (*print-readably* nil) - (*print-right-margin* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-eval* t) - (*read-suppress* nil) - (*readtable* *standard-readtable*)) - ,@body)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-ccl.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Corman-specific definitions + +(in-package :rdnzl) + +(defvar *dll-path* nil + "The name of RDNZL.dll.") + +(defmacro ffi-register-module (dll-path &optional module-name) + "Store the DLL name provided by the argument DLL-PATH." + (declare (ignore module-name)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *dll-path* ,dll-path))) + +(defun ffi-pointer-p (object) + "Tests whether OBJECT is an FFI pointer." + (ct:cpointerp object)) + +(defun ffi-null-pointer-p (pointer) + "Returns whether the FFI pointer POINTER is a null pointer." + (ct:cpointer-null pointer)) + +(defun ffi-pointer-address (pointer) + "Returns the address of the FFI pointer POINTER." + (ct:cpointer-value pointer)) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the address specified by the name NAME." + (ct:get-callback-procinst name)) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the LispWorks FLI." + (ecase type-name + (ffi-void :void) + (ffi-void-pointer '(:void *)) + (ffi-const-string '(:void *)) + (ffi-integer :long) + (ffi-boolean :long-bool) + (ffi-wide-char :unsigned-short) + (ffi-float :single-float) + (ffi-double :double-float))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of (NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + (cond ((or (eq result-type 'ffi-wide-char) + (find 'ffi-wide-char arg-list :key #'second :test #'eq)) + ;; define a wrapper if one of the args and/or the return type + ;; is a __wchar_t because Corman Lisp doesn't handle this + ;; type automatically + (with-unique-names (internal-name result) + `(progn + (ct:defun-dll ,internal-name + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + :return-type ,(ffi-map-type result-type) + :linkage-type :c + :library-name ,*dll-path* + :entry-name ,c-name) + (defun ,lisp-name ,(mapcar #'first arg-list) + (let ((,result (,internal-name ,@(loop for (name type) in arg-list + when (eq type 'ffi-wide-char) + collect `(char-code ,name) + else + collect name)))) + ,(if (eq result-type 'ffi-wide-char) + ;; only use lower octet... + `(code-char (logand ,result 255)) + result)))))) + (t + `(ct:defun-dll ,lisp-name + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + :return-type ,(ffi-map-type result-type) + :linkage-type :c + :library-name ,*dll-path* + :entry-name ,c-name)))) +

[168 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp 2006/02/01 01:00:56 1.3 @@ -1,254 +1,254 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Vasilis Margioulas, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; CLISP-specific definitions - -(in-package :rdnzl) - -(defvar *dll-path* nil - "The name of RDNZL.dll.") - -(defmacro ffi-register-module (dll-path &optional module-name) - "Store the DLL name provided by the argument DLL-PATH." - (declare (ignore module-name)) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *dll-path* ,dll-path))) - -(defun ffi-pointer-p (object) - "Tests whether OBJECT is an FFI pointer." - (eql (type-of object) 'ffi:foreign-address)) - -(defun ffi-null-pointer-p (pointer) - "Returns whether the FFI pointer POINTER is a null pointer." - (null pointer)) - -(defun ffi-pointer-address (pointer) - "Returns the address of the FFI pointer POINTER." - (ffi:foreign-address-unsigned pointer)) - -(defun ffi-make-pointer (name) - "Returns an FFI pointer to the address specified by the name NAME." - (get-function-pointer name)) - -(defun ffi-map-type (type-name) - "Maps type names like FFI-INTEGER to their corresponding names in -the CLISP FFI." - (ecase type-name - (ffi-void nil) - (ffi-void-pointer 'ffi:c-pointer) - (ffi-const-string 'ffi:c-pointer) - (ffi-integer 'ffi:int) - (ffi-boolean 'ffi:boolean) - (ffi-wide-char 'ffi:uint16) - (ffi-float 'ffi:single-float) - (ffi-double 'ffi:double-float))) - -(defmacro ffi-define-function* ((lisp-name c-name) - arg-list - result-type) - "Defines a Lisp function LISP-NAME which acts as an interface to the -C function C-NAME. ARG-LIST is a list of (NAME TYPE) pairs. All types -are supposed to be symbols mappable by FFI-MAP-TYPE above." - (cond ((or (eq result-type 'ffi-wide-char) - (find 'ffi-wide-char arg-list :key #'second :test #'eq)) - ;; define a wrapper if one of the args and/or the return type - ;; is a __wchar_t because CLISP doesn't handle this - ;; type automatically - (with-unique-names (internal-name result) - `(progn - (ffi:def-call-out ,internal-name - (:name ,c-name) - (:arguments ,@(mapcar (lambda (name-and-type) - (destructuring-bind (name type) name-and-type - (list name (ffi-map-type type)))) - arg-list)) - ,@(when (ffi-map-type result-type) - `((:return-type ,(ffi-map-type result-type)))) - (:language :stdc) - (:library ,*dll-path*)) - (defun ,lisp-name ,(mapcar #'first arg-list) - (let ((,result (,internal-name ,@(loop for (name type) in arg-list - when (eq type 'ffi-wide-char) - collect `(char-code ,name) - else - collect name)))) - ,(if (eq result-type 'ffi-wide-char) - `(code-char ,result) - result)))))) - (t - `(ffi:def-call-out ,lisp-name - (:name ,c-name) - (:arguments ,@(mapcar (lambda (name-and-type) - (destructuring-bind (name type) name-and-type - (list name (ffi-map-type type)))) - arg-list)) - ,@(when (ffi-map-type result-type) - `((:return-type ,(ffi-map-type result-type)))) - (:language :stdc) - (:library ,*dll-path*))))) - -(defgeneric get-function-pointer (name)) - -(defmacro ffi-define-callable ((c-name result-type) - arg-list - &body body) - "Defines a Lisp which can be called from C as the C function -C-NAME. ARG-LIST is a list of (NAME TYPE) pairs. All types are -supposed to be symbols mappable by FFI-MAP-TYPE above." - (with-unique-names (foreign-function) - `(progn - (defun ,c-name ,(mapcar #'first arg-list) - ,@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 () - "Invoke a full garbage collection." - (ext:gc)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-clisp.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Vasilis Margioulas, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; CLISP-specific definitions + +(in-package :rdnzl) + +(defvar *dll-path* nil + "The name of RDNZL.dll.") + +(defmacro ffi-register-module (dll-path &optional module-name) + "Store the DLL name provided by the argument DLL-PATH." + (declare (ignore module-name)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *dll-path* ,dll-path))) + +(defun ffi-pointer-p (object) + "Tests whether OBJECT is an FFI pointer." + (eql (type-of object) 'ffi:foreign-address)) + +(defun ffi-null-pointer-p (pointer) + "Returns whether the FFI pointer POINTER is a null pointer." + (null pointer)) + +(defun ffi-pointer-address (pointer) + "Returns the address of the FFI pointer POINTER." + (ffi:foreign-address-unsigned pointer)) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the address specified by the name NAME." + (get-function-pointer name)) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the CLISP FFI." + (ecase type-name + (ffi-void nil) + (ffi-void-pointer 'ffi:c-pointer) + (ffi-const-string 'ffi:c-pointer) + (ffi-integer 'ffi:int) + (ffi-boolean 'ffi:boolean) + (ffi-wide-char 'ffi:uint16) + (ffi-float 'ffi:single-float) + (ffi-double 'ffi:double-float))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of (NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + (cond ((or (eq result-type 'ffi-wide-char) + (find 'ffi-wide-char arg-list :key #'second :test #'eq)) + ;; define a wrapper if one of the args and/or the return type + ;; is a __wchar_t because CLISP doesn't handle this + ;; type automatically + (with-unique-names (internal-name result) + `(progn + (ffi:def-call-out ,internal-name + (:name ,c-name) + (:arguments ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list)) + ,@(when (ffi-map-type result-type) + `((:return-type ,(ffi-map-type result-type)))) + (:language :stdc) + (:library ,*dll-path*)) + (defun ,lisp-name ,(mapcar #'first arg-list) + (let ((,result (,internal-name ,@(loop for (name type) in arg-list + when (eq type 'ffi-wide-char) + collect `(char-code ,name) + else + collect name)))) + ,(if (eq result-type 'ffi-wide-char) + `(code-char ,result) + result)))))) + (t + `(ffi:def-call-out ,lisp-name + (:name ,c-name) + (:arguments ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list)) + ,@(when (ffi-map-type result-type) + `((:return-type ,(ffi-map-type result-type)))) + (:language :stdc) + (:library ,*dll-path*))))) + +(defgeneric get-function-pointer (name)) + +(defmacro ffi-define-callable ((c-name result-type) + arg-list + &body body) + "Defines a Lisp function which can be called from C. +ARG-LIST is a list of (NAME TYPE) pairs. All types are supposed +to be symbols mappable by FFI-MAP-TYPE above." + (with-unique-names (foreign-function) + `(progn + (defun ,c-name ,(mapcar #'first arg-list) + ,@body) + + (let ((,foreign-function (ffi:allocate-deep + '(ffi:c-function + (:language :stdc-stdcall) + (:arguments ,@(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list)) + (:return-type ,(ffi-map-type result-type))) + nil))) + + (defmethod get-function-pointer ((name (eql ',c-name))) + (ffi:with-c-place (f-function ,foreign-function) + (unless f-function + (setf f-function #',c-name))

[111 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/port-lw.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/port-lw.lisp 2006/02/01 01:00:56 1.3 @@ -1,213 +1,214 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-lw.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; LispWorks-specific definitions - -(in-package :rdnzl) - -(defvar *module-name* nil - "Holds the last module name defined by FFI-REGISTER-MODULE. This is -only needed for LispWorks.") - -(defmacro ffi-register-module (path &optional (module-name path)) - "Loads a C library designated by PATH. Optionally (for LispWorks) -registers this library under the name MODULE-NAME." - `(eval-when (:compile-toplevel :load-toplevel :execute) - (fli:register-module ,module-name - :real-name ,path) - (setq *module-name* ,module-name))) - -(defun ffi-pointer-p (object) - "Tests whether OBJECT is an FFI pointer." - (fli:pointerp object)) - -(defun ffi-null-pointer-p (pointer) - "Returns whether the FFI pointer POINTER is a null pointer." - (fli:null-pointer-p pointer)) - -(defun ffi-pointer-address (pointer) - "Returns the address of the FFI pointer POINTER." - (fli:pointer-address pointer)) - -(defun ffi-make-pointer (name) - "Returns an FFI pointer to the address specified by the name NAME." - (fli:make-pointer :symbol-name (symbol-name name))) - -(defun ffi-map-type (type-name) - "Maps type names like FFI-INTEGER to their corresponding names in -the LispWorks FLI." - (ecase type-name - (ffi-void :void) - (ffi-void-pointer :pointer) - (ffi-const-string '(:reference-pass (:ef-wc-string - :external-format :unicode))) - (ffi-integer :int) - (ffi-boolean :boolean) - (ffi-wide-char :wchar-t) - (ffi-float :float) - (ffi-double :double))) - -(defmacro ffi-define-function* ((lisp-name c-name) - arg-list - result-type) - "Defines a Lisp function LISP-NAME which acts as an interface to the -C function C-NAME. ARG-LIST is a list of (NAME TYPE) pairs. All types -are supposed to be symbols mappable by FFI-MAP-TYPE above." - `(fli:define-foreign-function - (,lisp-name ,c-name) - ,(mapcar (lambda (name-and-type) - (destructuring-bind (name type) name-and-type - (list name (ffi-map-type type)))) - arg-list) - :result-type ,(ffi-map-type result-type) - :calling-convention :cdecl - ;; use the last module that was registered - ,@(when *module-name* - (list :module *module-name*)))) - -(defmacro ffi-define-callable ((c-name result-type) - arg-list - &body body) - "Defines a Lisp which can be called from C as the C function -C-NAME. ARG-LIST is a list of (NAME TYPE) pairs. All types are -supposed to be symbols mappable by FFI-MAP-TYPE above." -`(fli:define-foreign-callable - (,(symbol-name c-name) :result-type ,(ffi-map-type result-type) - :calling-convention :cdecl) - ,(mapcar (lambda (name-and-type) - (destructuring-bind (name type) name-and-type - (list name (ffi-map-type type)))) - arg-list) - ,@body)) - -(defmacro ffi-get-call-by-ref-string (function object length-function) - "Calls the foreign function FUNCTION. FUNCTION is supposed to call -a C function f with the signature void f(..., __wchar_t *s) where s -is a result string which is returned by this macro. OBJECT is the -first argument given to f. Prior to calling f the length of the -result string s is obtained by evaluating (LENGTH-FUNCTION OBJECT)." - (with-rebinding (object) - (with-unique-names (length temp) - `(let ((,length (,length-function ,object))) - (fli:with-dynamic-foreign-objects () - (let ((,temp (fli:allocate-dynamic-foreign-object :type :wchar-t - :nelems (1+ ,length)))) - (,function ,object ,temp) - (fli:convert-from-foreign-string ,temp :external-format :unicode))))))) - -(defmacro ffi-call-with-foreign-string* (function string &optional other-args) - "Applies the foreign function FUNCTION to the string STRING and -OTHER-ARGS. OTHER-ARGS (a list of CONTAINER structures or `native' -Lisp objects) is converted to a foreign array prior to calling -FUNCTION. STRING may be NIL which means that this argument is skipped -(i.e. the macro actually needs a better name)." - (with-rebinding (other-args) - (with-unique-names (length arg-pointers ffi-arg-pointers arg i arg-pointer) - `(let* ((,length (length ,other-args)) - (,arg-pointers (make-array ,length :initial-element nil))) - (unwind-protect - (let ((,ffi-arg-pointers - (loop for ,arg in ,other-args - for ,i from 0 - for ,arg-pointer = (cond - ((container-p ,arg) (pointer ,arg)) - (t (setf (aref ,arg-pointers ,i) - (box* ,arg)))) - collect ,arg-pointer))) - ,(cond (string - `(apply #',function ,string ,ffi-arg-pointers)) - (t - `(apply #',function ,ffi-arg-pointers)))) - ;; all .NET elements that were solely created (by BOX*) - ;; for this FFI call are immediately freed - (dotimes (,i ,length) - (named-when (,arg-pointer (aref ,arg-pointers ,i)) - (%free-dot-net-container ,arg-pointer)))))))) - -(defmacro ffi-call-with-args* (function object name args) - "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS (a -list of CONTAINER structures or `native' Lisp objects) is converted to -a foreign array prior to calling FUNCTION. If NAME is not NIL, then -it should be a string and the first argument to FUNCTION will be the -corresponding foreign string." - (with-rebinding (args) - (with-unique-names (length arg-pointers ffi-arg-pointers arg i arg-pointer) - (declare (ignorable foreign-name element-count byte-count)) - ` (let* ((,length (length ,args)) - (,arg-pointers (make-array ,length :initial-element nil))) - (unwind-protect - (fli:with-dynamic-foreign-objects () - (let ((,ffi-arg-pointers (fli:allocate-dynamic-foreign-object :type :pointer - :nelems ,length))) - (loop for ,arg in ,args - for ,i from 0 - for ,arg-pointer = (cond - ((container-p ,arg) (pointer ,arg)) - (t (setf (aref ,arg-pointers ,i) - (box* ,arg)))) - do (setf (fli:dereference ,ffi-arg-pointers :index ,i) - ,arg-pointer)) - (,function ,@(if name (list name) nil) - ,object - ,length - ,ffi-arg-pointers))) - ;; all .NET elements that were solely created (by BOX*) - ;; for this FFI call are immediately freed - (dotimes (,i ,length) - (named-when (,arg-pointer (aref ,arg-pointers ,i)) - (%free-dot-net-container ,arg-pointer)))))))) - -;; register MAYBE-FREE-CONTAINER-POINTER as a finalization -;; function - needed for LispWorks -(hcl:add-special-free-action 'maybe-free-container-pointer) - -(defun flag-for-finalization (object &optional function) - "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT -is removed by GC." - ;; LispWorks can ignore FUNCTION because it was registered globally - ;; above - (declare (ignore function)) - (hcl:flag-special-free-action object)) - -(defvar *exit-function-registered* nil - "Whether LW:DEFINE-ACTION was already called for DllForceTerm.") - -(defun register-exit-function (function &optional name) - "Makes sure the function FUNCTION (with no arguments) is called -before the Lisp images exits." - (unless *exit-function-registered* - (lw:define-action "When quitting image" - name - function - :once) - (setq *exit-function-registered* t))) - -(defun full-gc () - "Invoke a full garbage collection." - (hcl:mark-and-sweep 3)) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-lw.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; LispWorks-specific definitions + +(in-package :rdnzl) + +(defvar *module-name* nil + "Holds the last module name defined by FFI-REGISTER-MODULE. +This is only needed for LispWorks.") + +(defmacro ffi-register-module (path &optional (module-name path)) + "Loads a C library designated by PATH. Optionally (for +LispWorks) registers this library under the name MODULE-NAME." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (fli:register-module ,module-name + :real-name ,path) + (setq *module-name* ,module-name))) + +(defun ffi-pointer-p (object) + "Tests whether OBJECT is an FFI pointer." + (fli:pointerp object)) + +(defun ffi-null-pointer-p (pointer) + "Returns whether the FFI pointer POINTER is a null pointer." + (fli:null-pointer-p pointer)) + +(defun ffi-pointer-address (pointer) + "Returns the address of the FFI pointer POINTER." + (fli:pointer-address pointer)) + +(defun ffi-make-pointer (name) + "Returns an FFI pointer to the address specified by the name NAME." + (fli:make-pointer :symbol-name (symbol-name name))) + +(defun ffi-map-type (type-name) + "Maps type names like FFI-INTEGER to their corresponding names in +the LispWorks FLI." + (ecase type-name + (ffi-void :void) + (ffi-void-pointer :pointer) + (ffi-const-string '(:reference-pass (:ef-wc-string + :external-format :unicode))) + (ffi-integer :int) + (ffi-boolean :boolean) + (ffi-wide-char :wchar-t) + (ffi-float :float) + (ffi-double :double))) + +(defmacro ffi-define-function* ((lisp-name c-name) + arg-list + result-type) + "Defines a Lisp function LISP-NAME which acts as an interface +to the C function C-NAME. ARG-LIST is a list of (NAME TYPE) +pairs. All types are supposed to be symbols mappable by +FFI-MAP-TYPE above." + `(fli:define-foreign-function + (,lisp-name ,c-name) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + :result-type ,(ffi-map-type result-type) + :calling-convention :cdecl + ;; use the last module that was registered + ,@(when *module-name* + (list :module *module-name*)))) + +(defmacro ffi-define-callable ((c-name result-type) + arg-list + &body body) + "Defines a Lisp function which can be called from C. ARG-LIST +is a list of (NAME TYPE) pairs. All types are supposed to be +symbols mappable by FFI-MAP-TYPE above." +`(fli:define-foreign-callable + (,(symbol-name c-name) :result-type ,(ffi-map-type result-type) + :calling-convention :cdecl) + ,(mapcar (lambda (name-and-type) + (destructuring-bind (name type) name-and-type + (list name (ffi-map-type type)))) + arg-list) + ,@body)) + +(defmacro ffi-get-call-by-ref-string (function object length-function) + "Calls the foreign function FUNCTION. FUNCTION is supposed to call +a C function f with the signature void f(..., __wchar_t *s) where s +is a result string which is returned by this macro. OBJECT is the +first argument given to f. Prior to calling f the length of the +result string s is obtained by evaluating (LENGTH-FUNCTION OBJECT)." + (with-rebinding (object) + (with-unique-names (length temp) + `(let ((,length (,length-function ,object))) + (fli:with-dynamic-foreign-objects () + (let ((,temp (fli:allocate-dynamic-foreign-object :type :wchar-t + :nelems (1+ ,length)))) + (,function ,object ,temp) + (fli:convert-from-foreign-string ,temp :external-format :unicode))))))) + +(defmacro ffi-call-with-foreign-string* (function string &optional other-args) + "Applies the foreign function FUNCTION to the string STRING and +OTHER-ARGS. OTHER-ARGS (a list of CONTAINER structures or `native' +Lisp objects) is converted to a foreign array prior to calling +FUNCTION. STRING may be NIL which means that this argument is skipped +(i.e. the macro actually needs a better name)." + (with-rebinding (other-args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i arg-pointer) + `(let* ((,length (length ,other-args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (let ((,ffi-arg-pointers + (loop for ,arg in ,other-args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + collect ,arg-pointer))) + ,(cond (string + `(apply #',function ,string ,ffi-arg-pointers)) + (t + `(apply #',function ,ffi-arg-pointers)))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i)) + (%free-dot-net-container ,arg-pointer)))))))) + +(defmacro ffi-call-with-args* (function object name args) + "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS (a +list of CONTAINER structures or `native' Lisp objects) is converted to +a foreign array prior to calling FUNCTION. If NAME is not NIL, then +it should be a string and the first argument to FUNCTION will be the +corresponding foreign string." + (with-rebinding (args) + (with-unique-names (length arg-pointers ffi-arg-pointers arg i arg-pointer) + (declare (ignorable foreign-name element-count byte-count)) + ` (let* ((,length (length ,args)) + (,arg-pointers (make-array ,length :initial-element nil))) + (unwind-protect + (fli:with-dynamic-foreign-objects () + (let ((,ffi-arg-pointers (fli:allocate-dynamic-foreign-object :type :pointer + :nelems ,length))) + (loop for ,arg in ,args + for ,i from 0 + for ,arg-pointer = (cond + ((container-p ,arg) (pointer ,arg)) + (t (setf (aref ,arg-pointers ,i) + (box* ,arg)))) + do (setf (fli:dereference ,ffi-arg-pointers :index ,i) + ,arg-pointer)) + (,function ,@(if name (list name) nil) + ,object + ,length + ,ffi-arg-pointers))) + ;; all .NET elements that were solely created (by BOX*) + ;; for this FFI call are immediately freed + (dotimes (,i ,length) + (named-when (,arg-pointer (aref ,arg-pointers ,i))

[30 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/rdnzl.asd 2006/01/13 07:06:28 1.3 +++ /project/rdnzl/cvsroot/RDNZL/rdnzl.asd 2006/02/01 01:00:56 1.4 @@ -1,56 +1,57 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.3 2006/01/13 07:06:28 eweitz Exp $ - -;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; System definition for ASDF - see http://www.cliki.net/asdf - -(in-package :cl-user) - -(defpackage #:rdnzl.system - (:use #:cl - #:asdf)) - -(in-package #:rdnzl.system) - -(defsystem #:rdnzl - :serial t - :version "0.8.0" - :components ((:file "packages") - (:file "specials") - (:file "util") - #+:allegro (:file "port-acl") ; AllegroCL-specific stuff here - #+:cormanlisp (:file "port-ccl") ; Corman-specific stuff here - #+:clisp (:file "port-clisp") ; CLISP-specific stuff here - #+:lispworks (:file "port-lw") ; LispWorks-specific stuff here - (:file "ffi") - (:file "container") - (:file "reader") - (:file "arrays") - (:file "adapter") - (:file "import") - (:file "direct"))) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/rdnzl.asd,v 1.4 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; System definition for ASDF - see http://www.cliki.net/asdf + +(in-package :cl-user) + +(defpackage #:rdnzl.system + (:use #:cl + #:asdf)) + +(in-package #:rdnzl.system) + +(defsystem #:rdnzl + :serial t + :version "0.9.0" + :components ((:file "packages") + (:file "specials") + (:file "util") + #+:allegro (:file "port-acl") ; AllegroCL-specific stuff here + #+:cormanlisp (:file "port-ccl") ; Corman-specific stuff here + #+:clisp (:file "port-clisp") ; CLISP-specific stuff here + #+:lispworks (:file "port-lw") ; LispWorks-specific stuff here + #+:sbcl (:file "port-sbcl") ; SBCL-specific stuff here + (:file "ffi") + (:file "container") + (:file "reader") + (:file "arrays") + (:file "adapter") + (:file "import") + (:file "direct"))) --- /project/rdnzl/cvsroot/RDNZL/reader.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/reader.lisp 2006/02/01 01:00:56 1.3 @@ -1,260 +1,260 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/reader.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; This file defines the special reader syntax for .NET calls. - -(in-package :rdnzl) - -(define-condition rdnzl-reader-error (simple-condition reader-error) - () - (:report (lambda (condition stream) - (format stream "RDNZL reader error: ~?" - (simple-condition-format-control condition) - (simple-condition-format-arguments condition)))) - (:documentation "A reader error which can be signalled by ERROR.")) - -(defmacro signal-reader-error (stream format-control &rest format-arguments) - "Like ERROR but signals a SIMPLE-READER-ERROR for the stream -STREAM." - `(error 'rdnzl-reader-error - :stream ,stream - :format-control ,format-control - :format-arguments (list ,@format-arguments))) - -(defun read-rdnzl-token (stream) - "Tries to emulate how the Lisp reader reads a token with standard -syntax but is case-sensitive. Returns a string." - (let ((collector (make-array 0 - :element-type 'character - :fill-pointer t - :adjustable t)) - in-multiple-escape-p - in-single-escape-p - char-seen-p) - (loop - (let ((char (peek-char nil stream nil nil t))) - (cond (in-multiple-escape-p - ;; in multiple escape mode, read everything as is but - ;; don't accept EOF - (unless char - (signal-reader-error stream - "End of file while in multiple~ -escape mode (i.e. after pipe character).")) - (read-char stream nil nil t) - (cond ((char= char #|) - ;; end of multiple escape mode - (setq in-multiple-escape-p nil)) - (t - (vector-push-extend char collector)))) - (in-single-escape-p - ;; single escape mode, i.e. last char was backslash - - ;; read next char as is but don't accept EOF - (unless char - (signal-reader-error stream - "End of file while in single~ -escape mode (i.e. after backslash character).")) - (setq in-single-escape-p nil) - (read-char stream nil nil t) - (vector-push-extend char collector)) - ((null char) - ;; EOF - return what has been read so far - (return-from read-rdnzl-token collector)) - ((and (not char-seen-p) - (whitespacep char)) - ;; skip whitespace after #[ - (read-char stream nil nil t)) - ((char= char #|) - ;; switch to multiple escape mode - (setq in-multiple-escape-p t - char-seen-p t) - (read-char stream nil nil t)) - ((char= char #\) - ;; switch to single escape mode - (setq in-single-escape-p t - char-seen-p t) - (read-char stream nil nil t)) - ((or (whitespacep char) - (member char '(#" #' #( #) #[ #] #, #; #`) - :test #'char=)) - ;; whitespace or terminating macro character, stop - ;; parsing this token - (return-from read-rdnzl-token collector)) - (t - ;; otherwise just consume the character - (setq char-seen-p t) - (read-char stream nil nil t) - (vector-push-extend char collector))))))) - -(defun read-and-parse-rdnzl-token (stream) - "Reads a token like "%Environment.UserName" with READ-RDNZL-TOKEN -and dissects it into its parts (type name and member name) if -necessary. Also returns the corresponding function (INVOKE, -PROPERTY, or FIELD) from container.lisp." - (let ((token (read-rdnzl-token stream)) - (function-name 'invoke)) - (when (string= token "") - (signal-reader-error stream - "Empty token after #[ character.")) - (when (and (= (length token) 1) - (member (char token 0) '(#% #$ #+ #-) - :test #'char=)) - (signal-reader-error stream - "Illegal token "~C" after #[ character." - token)) - (let ((first-char (char token 0))) - (case first-char - ((#%) - ;; first char #% means property - (setf function-name 'property - token (subseq token 1))) - ((#$) - ;; first char #$ means field - (setf function-name 'field - token (subseq token 1))) - ((#+) - ;; first char #+ adds "add_" - (setf token (concatenate 'string "add_" - (subseq token 1)))) - ((#-) - ;; first char #- adds "remove_" - (setf token (concatenate 'string "remove_" - (subseq token 1)))))) - ;; find last dot (if any) in token - (let ((dot-pos (position #. token :test #'char= :from-end t))) - (cond (dot-pos - ;; if there is a dot we have a static invocation and the - ;; part before the dot is the type name - (when (= dot-pos (1- (length token))) - (signal-reader-error stream - "Dot at end of token.")) - (let ((type-name (subseq token 0 dot-pos)) - (member-name (subseq token (1+ dot-pos)))) - (values member-name function-name type-name))) - (t - ;; otherwise it's an instance invocation - (values token function-name)))))) - - -(defun rdnzl-list-reader (stream char) - (declare (ignore char)) - "The reader function for the RDNZL [] notation." - ;; read the first token after the opening bracket with - ;; READ-RDNZL-TOKEN - (multiple-value-bind (member-name function-name type-name) - (read-and-parse-rdnzl-token stream) - ;; now read rest until #] - (let ((args (read-delimited-list #] stream t))) - (cond (type-name - ;; static invocation - (list* function-name type-name member-name args)) - (t - ;; instance invocation - (unless args - ;; we always need at least one argument - the object - ;; instance itself - (signal-reader-error stream - "Missing arguments after token "~A~A"." - (case function-name - ((invoke) "") - ((property) "%") - ((field) "$")) - member-name)) - (list* function-name (first args) member-name (rest args))))))) - -(defun rdnzl-function-reader (stream char arg) - "The reader function for the RDNZL #` notation. Always returns a -function object." - (declare (ignore char arg)) - (cond ((char= #( (peek-char nil stream t nil t)) - ;; starts with a left parenthesis, so we expect #`(SETF ...) - (read-char stream t nil t) - (let ((symbol (read stream t nil t))) - (unless (eq symbol 'setf) - (signal-reader-error stream - "Expected CL:SETF after "#`("")) - (multiple-value-bind (member-name function-name type-name) - (read-and-parse-rdnzl-token stream) - (unless (char= #) (peek-char t stream t nil t)) - (signal-reader-error stream - "Expected #) after "#`(CL:SETF ~A"." - (if type-name - (concatenate 'string type-name "." member-name) - member-name))) - (read-char stream t nil t) - (cond (type-name - `(lambda (new-value &rest args) - (apply #'(setf ,function-name) - new-value ,type-name ,member-name args))) - (t - `(lambda (new-value object &rest args) - (apply #'(setf ,function-name) - new-value object ,member-name args))))))) - (t - (multiple-value-bind (member-name function-name type-name) - (read-and-parse-rdnzl-token stream) - (cond (type-name - `(lambda (&rest args) - (apply #',function-name - ,type-name ,member-name args))) - (t - `(lambda (object &rest args) - (apply #',function-name - object ,member-name args)))))))) - -(defun %enable-rdnzl-syntax () - "Internal function used to enable reader syntax and store current -readtable on stack." - (push *readtable* - *previous-readtables*) - (setq *readtable* (copy-readtable)) - (set-syntax-from-char #] #) *readtable*) - ;; make #[ non-terminating - (set-macro-character #[ - #'rdnzl-list-reader) - (set-dispatch-macro-character ## #` #'rdnzl-function-reader) - (values)) - -(defun %disable-rdnzl-syntax () - "Internal function used to restore previous readtable." - (if *previous-readtables* - (setq *readtable* (pop *previous-readtables*)) - (setq *readtable* (copy-readtable nil))) - (values)) - -(defmacro enable-rdnzl-syntax () - "Enables RDNZL reader syntax." - `(eval-when (:compile-toplevel :load-toplevel :execute) - (%enable-rdnzl-syntax))) - -(defmacro disable-rdnzl-syntax () - "Restores the readtable which was active before the last call to -ENABLE-RDNZL-SYNTAX. If there was no such call, the standard readtable -is used." - `(eval-when (:compile-toplevel :load-toplevel :execute) - (%disable-rdnzl-syntax))) +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/reader.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; This file defines the special reader syntax for .NET calls. + +(in-package :rdnzl) + +(define-condition rdnzl-reader-error (simple-condition reader-error) + () + (:report (lambda (condition stream) + (format stream "RDNZL reader error: ~?" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))) + (:documentation "A reader error which can be signalled by ERROR.")) + +(defmacro signal-reader-error (stream format-control &rest format-arguments) + "Like ERROR but signals a SIMPLE-READER-ERROR for the stream +STREAM." + `(error 'rdnzl-reader-error + :stream ,stream + :format-control ,format-control + :format-arguments (list ,@format-arguments))) + +(defun read-rdnzl-token (stream) + "Tries to emulate how the Lisp reader reads a token with standard +syntax but is case-sensitive. Returns a string." + (let ((collector (make-array 0 + :element-type 'character + :fill-pointer t + :adjustable t)) + in-multiple-escape-p + in-single-escape-p + char-seen-p) + (loop + (let ((char (peek-char nil stream nil nil t))) + (cond (in-multiple-escape-p + ;; in multiple escape mode, read everything as is but + ;; don't accept EOF + (unless char + (signal-reader-error stream + "End of file while in multiple~ +escape mode (i.e. after pipe character).")) + (read-char stream nil nil t) + (cond ((char= char #|) + ;; end of multiple escape mode + (setq in-multiple-escape-p nil)) + (t + (vector-push-extend char collector)))) + (in-single-escape-p + ;; single escape mode, i.e. last char was backslash - + ;; read next char as is but don't accept EOF + (unless char + (signal-reader-error stream + "End of file while in single~ +escape mode (i.e. after backslash character).")) + (setq in-single-escape-p nil) + (read-char stream nil nil t) + (vector-push-extend char collector)) + ((null char) + ;; EOF - return what has been read so far + (return-from read-rdnzl-token collector)) + ((and (not char-seen-p) + (whitespacep char)) + ;; skip whitespace after #[ + (read-char stream nil nil t)) + ((char= char #|) + ;; switch to multiple escape mode + (setq in-multiple-escape-p t + char-seen-p t) + (read-char stream nil nil t)) + ((char= char #\) + ;; switch to single escape mode + (setq in-single-escape-p t + char-seen-p t) + (read-char stream nil nil t)) + ((or (whitespacep char) + (member char '(#" #' #( #) #[ #] #, #; #`) + :test #'char=)) + ;; whitespace or terminating macro character, stop + ;; parsing this token + (return-from read-rdnzl-token collector)) + (t + ;; otherwise just consume the character + (setq char-seen-p t) + (read-char stream nil nil t) + (vector-push-extend char collector))))))) + +(defun read-and-parse-rdnzl-token (stream) + "Reads a token like "%Environment.UserName" with READ-RDNZL-TOKEN +and dissects it into its parts (type name and member name) if +necessary. Also returns the corresponding function (INVOKE, +PROPERTY, or FIELD) from container.lisp." + (let ((token (read-rdnzl-token stream)) + (function-name 'invoke)) + (when (string= token "") + (signal-reader-error stream + "Empty token after #[ character.")) + (when (and (= (length token) 1) + (member (char token 0) '(#% #$ #+ #-) + :test #'char=)) + (signal-reader-error stream + "Illegal token "~C" after #[ character." + token)) + (let ((first-char (char token 0))) + (case first-char + ((#%) + ;; first char #% means property + (setf function-name 'property + token (subseq token 1))) + ((#$) + ;; first char #$ means field

[123 lines skipped] --- /project/rdnzl/cvsroot/RDNZL/specials.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/specials.lisp 2006/02/01 01:00:56 1.3 @@ -1,99 +1,106 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/specials.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ - -;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. - -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: - -;;; * Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. - -;;; * Redistributions in binary form must reproduce the above -;;; copyright notice, this list of conditions and the following -;;; disclaimer in the documentation and/or other materials -;;; provided with the distribution. - -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED -;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY -;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;;; Global special variables (and constants) used by RDNZL. - -(in-package :rdnzl) - -(defvar *used-namespaces* nil - "A list of namespaces which are `used.' See USE-NAMESPACE and -related functions.") - -(defvar *dll-initialized* nil - "Whether RDNZL.dll was initialized with DllEnsureInit.") - -(defconstant +private-assembly-name+ "RDNZLPrivateAssembly" - "The name of the assembly which is generated at run time to create -subtypes of DelegateAdapter.") - -(defvar *callback-counter* 0 - "The index of the last closure from which a delegate was created - -or 0 if no delegate has been created yet. Used as a key in the -*CALLBACK-HASH* hash table.") - -(defvar *callback-hash* (make-hash-table) - "A hash table which maps integers to closures used as delegates - -see the instance variable indexIntoLisp in DelegateAdapter.cpp.") - -(defvar *delegate-counter* 0 - "Counter used to make sure each subtype of DelegateAdapter has a -unique name.") - -(defvar *signature-hash* (make-hash-table :test #'equal) - "A hash table which maps delegate signatures to subtypes of -DelegateAdapter so that we only create one such subtype for each -signature.") - -(defvar *type-hash* (make-hash-table :test #'equal) - "A hash table which maps short type names of `imported' types to -fully qualified type names (or to T if the type can be retrieved by -Type::GetType without a fully qualified name).") - -(defvar *direct-definitions* (make-hash-table :test #'equal) - "Maps function names (for direct calls) to data structures which -can be used to re-construct the function.") - -(defconstant +whitespace-char-list+ - '(#\Space #\Tab #\Linefeed #\Newline #\Return #\Page) - "A list of all characters which are considered to be whitespace.") - -(defvar *previous-readtables* nil - "A stack which holds the previous readtables that have been pushed -here by ENABLE-RDNZL-SYNTAX.") - -(pushnew :rdnzl *features*) - -;; stuff for Nikodemus Siivola's HYPERDOC -;; see http://common-lisp.net/project/hyperdoc/ -;; and http://www.cliki.net/hyperdoc - -(defvar *hyperdoc-base-uri* "http://weitz.de/rdnzl/") - -(let ((exported-symbols-alist - (loop for symbol being the external-symbols of :rdnzl - collect (cons symbol - (concatenate 'string - "#" - (string-downcase symbol)))))) - (defun hyperdoc-lookup (symbol type) - (declare (ignore type)) - (cdr (assoc symbol - exported-symbols-alist - :test #'eq)))) - \ No newline at end of file +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- +;;; $Header: /project/rdnzl/cvsroot/RDNZL/specials.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $ + +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Global special variables (and constants) used by RDNZL. + +(in-package :rdnzl) + +#+:sbcl +(defmacro defconstant (name form &optional documentation) + ;; see http://www.sbcl.org/manual/Defining-Constants.html + `(cl:defconstant ,name + (cond ((boundp ',name) (symbol-value ',name)) + (t ,form)) + ,@(and documentation (list documentation)))) + +(defvar *used-namespaces* nil + "A list of namespaces which are `used.' See USE-NAMESPACE and +related functions.") + +(defvar *dll-initialized* nil + "Whether RDNZL.dll was initialized with DllEnsureInit.") + +(defconstant +private-assembly-name+ "RDNZLPrivateAssembly" + "The name of the assembly which is generated at run time to create +subtypes of DelegateAdapter.") + +(defvar *callback-counter* 0 + "The index of the last closure from which a delegate was created - +or 0 if no delegate has been created yet. Used as a key in the +*CALLBACK-HASH* hash table.") + +(defvar *callback-hash* (make-hash-table) + "A hash table which maps integers to closures used as delegates - +see the instance variable indexIntoLisp in DelegateAdapter.cpp.") + +(defvar *delegate-counter* 0 + "Counter used to make sure each subtype of DelegateAdapter has a +unique name.") + +(defvar *signature-hash* (make-hash-table :test #'equal) + "A hash table which maps delegate signatures to subtypes of +DelegateAdapter so that we only create one such subtype for each +signature.") + +(defvar *type-hash* (make-hash-table :test #'equal) + "A hash table which maps short type names of `imported' types to +fully qualified type names (or to T if the type can be retrieved by +Type::GetType without a fully qualified name).") + +(defvar *direct-definitions* (make-hash-table :test #'equal) + "Maps function names (for direct calls) to data structures which +can be used to re-construct the function.") + +(defconstant +whitespace-char-list+ + '(#\Space #\Tab #\Linefeed #\Newline #\Return #\Page) + "A list of all characters which are considered to be whitespace.") + +(defvar *previous-readtables* nil + "A stack which holds the previous readtables that have been pushed +here by ENABLE-RDNZL-SYNTAX.") + +(pushnew :rdnzl *features*) + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see http://common-lisp.net/project/hyperdoc/ +;; and http://www.cliki.net/hyperdoc + +(defvar *hyperdoc-base-uri* "http://weitz.de/rdnzl/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :rdnzl + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) --- /project/rdnzl/cvsroot/RDNZL/util.lisp 2005/07/08 18:45:34 1.2 +++ /project/rdnzl/cvsroot/RDNZL/util.lisp 2006/02/01 01:00:56 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- -;;; $Header: /project/rdnzl/cvsroot/RDNZL/util.lisp,v 1.2 2005/07/08 18:45:34 eweitz Exp $ +;;; $Header: /project/rdnzl/cvsroot/RDNZL/util.lisp,v 1.3 2006/02/01 01:00:56 eweitz Exp $

-;;; Copyright (c) 2004-2005, Dr. Edmund Weitz. All rights reserved. +;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions

--- /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp 2006/02/01 01:00:57 NONE +++ /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp 2006/02/01 01:00:57 1.1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*- ;;; $Header: /project/rdnzl/cvsroot/RDNZL/port-sbcl.lisp,v 1.1 2006/02/01 01:00:56 eweitz Exp $

;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met:

;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer.

;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; SBCL-specific definitions

(in-package :rdnzl)

(defconstant +ffi-pointer-size+ #.(/ (sb-alien:alien-size sb-alien:system-area-pointer) 8) "The size of a pointer in octets.")

(defmacro ffi-register-module (path &optional (module-name path)) "Loads a C library designated by PATH." (declare (ignore module-name)) `(eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:load-shared-object ,path)))

(defun ffi-pointer-p (object) "Tests whether OBJECT is an FFI pointer." (sb-sys:system-area-pointer-p object))

(defun ffi-null-pointer-p (pointer) "Returns whether the FFI pointer POINTER is a null pointer." (zerop (sb-sys:sap-int pointer)))

(defun ffi-pointer-address (pointer) "Returns the address of the FFI pointer POINTER." (sb-sys:sap-int pointer))

(defun ffi-map-type (type-name) "Maps type names like FFI-INTEGER to their corresponding names in the LispWorks FLI." (ecase type-name (ffi-void 'sb-alien:void) (ffi-void-pointer 'sb-alien:system-area-pointer) (ffi-const-string 'sb-alien:system-area-pointer) (ffi-integer 'sb-alien:int) (ffi-wide-char 'sb-alien:unsigned-short) (ffi-float 'sb-alien:single-float) (ffi-double 'sb-alien:double-float)))

(defmacro ffi-define-function* ((lisp-name c-name) arg-list result-type) "Defines a Lisp function LISP-NAME which acts as an interface to the C function C-NAME. ARG-LIST is a list of (NAME TYPE) pairs. All types are supposed to be symbols mappable by FFI-MAP-TYPE above." (cond ((eq result-type 'ffi-boolean) (with-unique-names (inner-fn) `(progn (ffi-define-function* (,inner-fn ,c-name) ,arg-list ffi-integer) (defun ,lisp-name ,(mapcar #'first arg-list) (not (zerop (,inner-fn ,@(mapcar #'first arg-list)))))))) ((find 'ffi-boolean arg-list :key #'second) (with-unique-names (inner-fn) `(progn (ffi-define-function* (,inner-fn ,c-name) ,(mapcar (lambda (name-and-type) (destructuring-bind (name type) name-and-type (if (eq type 'ffi-boolean) (list name 'ffi-integer) name-and-type))) arg-list) ,result-type) (defun ,lisp-name ,(mapcar #'first arg-list) (,inner-fn ,@(mapcar (lambda (name-and-type) (destructuring-bind (name type) name-and-type (if (eq type 'ffi-boolean) `(if ,name 1 0) name))) arg-list)))))) (t `(sb-alien:define-alien-routine (,c-name ,lisp-name) ,(ffi-map-type result-type) ,@(mapcar (lambda (name-and-type) (destructuring-bind (name type) name-and-type (list name (ffi-map-type type)))) arg-list)))))

(defvar *callbacks* (make-hash-table) "A hash table which maps symbols (function names) to callbacks.")

(defmacro ffi-define-callable ((c-name result-type) arg-list &body body) "Defines a Lisp function which can be called from C. ARG-LIST is a list of (NAME TYPE) pairs. All types are supposed to be symbols mappable by FFI-MAP-TYPE above." `(setf (gethash ',c-name *callbacks*) (sb-alien:alien-sap (sb-alien::alien-lambda ,(ffi-map-type result-type) ,(mapcar (lambda (name-and-type) (destructuring-bind (name type) name-and-type (list name (ffi-map-type type)))) arg-list) ,@body))))

(defun ffi-make-pointer (name) "Returns an FFI pointer to the (callback) address specified by the name NAME." (gethash name *callbacks*))

(defun ffi-alloc (size) "Allocates an `alien' of size SIZE octets and returns a pointer to it. Must be freed with FFI-FREE afterwards." (sb-alien:alien-sap (sb-alien:make-alien (sb-alien:unsigned 8) size)))

(defun ffi-free (pointer) "Frees space that was allocated with FFI-ALLOC." (sb-alien:free-alien (sb-alien:sap-alien pointer (* (sb-alien:unsigned 8)))))

(defun ffi-convert-from-foreign-ucs-2-string (pointer size) "Converts the foreign UCS-2 string pointed to by POINTER of size SIZE octets to a Lisp string." (with-output-to-string (out) (loop for i from 0 below size by 2 do (write-char (code-char (+ (sb-sys:sap-ref-8 pointer i) (ash (sb-sys:sap-ref-8 pointer (1+ i)) 8))) out))))

(defmacro ffi-get-call-by-ref-string (function object length-function) "Calls the foreign function FUNCTION. FUNCTION is supposed to call a C function f with the signature void f(..., __wchar_t *s) where s is a result string which is returned by this macro. OBJECT is the first argument given to f. Prior to calling f the length of the result string s is obtained by evaluating (LENGTH-FUNCTION OBJECT)." (with-rebinding (object) (with-unique-names (length temp) `(let ((,length (* 2 (,length-function ,object))) ,temp) (unwind-protect (progn (setq ,temp (ffi-alloc (+ 2 ,length))) (,function ,object ,temp) (ffi-convert-from-foreign-ucs-2-string ,temp ,length)) (when ,temp (ffi-free ,temp)))))))

(defmacro with-ucs-2-string ((var lisp-string) &body body) "Converts the Lisp string LISP-STRING to a foreign string using UCS-2 encoding and evaluates BODY with VAR bound to this foreign string." (with-unique-names (size char char-code i) `(let (,var) (unwind-protect (let ((,size (* 2 (length ,lisp-string)))) (setq ,var (ffi-alloc (+ 2 ,size))) (loop for ,i from 0 by 2 for ,char across ,lisp-string for ,char-code = (char-code ,char) do (setf (sb-sys:sap-ref-8 ,var ,i) (ldb (byte 8 0) ,char-code) (sb-sys:sap-ref-8 ,var (1+ ,i)) (ldb (byte 8 8) ,char-code))) (setf (sb-sys:sap-ref-8 ,var ,size) 0 (sb-sys:sap-ref-8 ,var (1+ ,size)) 0) ,@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))