/[rdnzl]/RDNZL/import.lisp
ViewVC logotype

Contents of /RDNZL/import.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Thu Aug 10 15:36:47 2006 UTC (7 years, 8 months ago) by eweitz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.5: +0 -0 lines
Sync with 10.1.2
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
2 ;;; $Header: /tiger/var/lib/cvsroots/rdnzl/RDNZL/import.lisp,v 1.6 2006/08/10 15:36:47 eweitz Exp $
3
4 ;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 ;;; Importing types and assemblies, initialization.
31
32 (in-package :rdnzl)
33
34 (enable-rdnzl-syntax)
35
36 (defun import-type (type &optional assembly)
37 "Imports the .NET type TYPE, i.e. registers its name as one that can
38 be abbreviated \(see USE-NAMESPACE) and maybe creates a mapping from
39 its short name to its assembly-qualified name. If TYPE is a string
40 and ASSEMBLY is NIL then the function will try to create the type from
41 the string with the static method System.Type::GetType. If TYPE is a
42 string and ASSEMBLY is an assembly \(a CONTAINER) then instead the
43 instance method System.Reflection.Assembly::GetType will be used. If
44 TYPE is already a .NET object \(i.e. a CONTAINER) then the function
45 will just register its name. If ASSEMBLY is a true value then the
46 name will also be mapped to its assembly-qualified name. In all cases
47 the type itself \(as a CONTAINER) will be returned."
48 (cond ((container-p type)
49 (setf (gethash [%FullName type] *type-hash*)
50 (cond (assembly [%AssemblyQualifiedName type])
51 (t t)))
52 type)
53 ((stringp type)
54 (import-type (cond (assembly
55 (or [GetType assembly type]
56 (error "Type with name ~S not found in assembly ~S."
57 type [%FullName assembly])))
58 (t
59 (let ((imported-type (make-type-from-name type)))
60 (when (%dot-net-container-is-null (pointer imported-type))
61 (error "Type with name ~S not found."
62 type))
63 imported-type)))
64 assembly))
65 (t (error "Don't know how to import type ~S." type))))
66
67 (defun new (type &rest other-args)
68 "Creates a new .NET object \(a CONTAINER) of the type TYPE. Calls
69 the constructor determined by OTHER-ARGS \(a list of Lisp object
70 and/or CONTAINERs), i.e. by the corresponding signature. TYPE can be
71 a string \(naming the type) or a CONTAINER \(representing the type).
72 If TYPE is a delegate then the second argument to NEW must be a Lisp
73 closure with a correspoding signature."
74 (cond ((stringp type)
75 (apply #'new
76 (make-type-from-name (resolve-type-name type))
77 other-args))
78 ((container-p type)
79 (cond ([IsAssignableFrom (make-type-from-name "System.Delegate") type]
80 ;; it's a delegate
81 (let* ((method-info [GetMethod type "Invoke"])
82 (adapter (make-adapter (first other-args)
83 [%ReturnType method-info]
84 (mapcar #`%ParameterType
85 (rdnzl-array-to-list [GetParameters method-info])))))
86 (invoke-constructor type
87 adapter
88 [GetFunctionPointer [%MethodHandle [GetMethod [GetType adapter]
89 "InvokeClosure"]]])))
90 (t (apply #'invoke-constructor
91 type
92 other-args))))
93 (t (error "Don't know how to make a new ~S." type))))
94
95 (defun load-assembly (name)
96 "Loads and returns the assembly with the name NAME \(a string), uses
97 LoadWithPartialName."
98 [System.Reflection.Assembly.LoadWithPartialName name])
99
100 (defun import-assembly (assembly)
101 "Imports all public types of the assembly ASSEMBLY \(a string or a
102 CONTAINER). If ASSEMBLY is a string then the assembly is first loaded
103 with LOAD-ASSEMBLY. Returns ASSEMBLY as a CONTAINER."
104 (cond ((container-p assembly)
105 (do-rdnzl-array (type [GetTypes assembly])
106 (when [%IsPublic type]
107 (import-type type)))
108 assembly)
109 ((stringp assembly)
110 (import-assembly (load-assembly assembly)))
111 (t (error "Don't know how to import assembly ~S." assembly))))
112
113 (defun import-types (assembly-name &rest type-names)
114 "Loads the assembly named ASSEMBLY-NAME and imports \(see function
115 IMPORT-TYPE) all types listed from this assembly. The assembly name
116 is prepended to the type names before importing them. All arguments
117 should be strings."
118 (let ((assembly (or (load-assembly assembly-name)
119 (error "Assembly ~S not found" assembly-name))))
120 (dolist (type-name type-names)
121 (import-type (concatenate 'string
122 assembly-name
123 "."
124 type-name)
125 assembly))))
126
127 (defun reset-cached-data ()
128 "Resets all relevant global special variables to their initial value,
129 thereby releasing pointers to DotNetContainer objects if necessary.
130 Also removes all direct call definitions."
131 (setq *callback-counter* 0
132 *delegate-counter* 0)
133 (clrhash *callback-hash*)
134 (clrhash *signature-hash*)
135 (loop for function-name being the hash-keys in *direct-definitions*
136 do (fmakunbound function-name)))
137
138 (defun init-rdnzl ()
139 "Initializes RDNZL. This function must be called once before RDNZL
140 is used."
141 ;; see <http://msdn.microsoft.com/library/en-us/vcmex/html/vcconconvertingmanagedextensionsforcprojectsfrompureintermediatelanguagetomixedmode.asp?frame=true>
142 (dll-ensure-init)
143 ;; inform the DelegateAdapter class about where the Lisp callbacks
144 ;; are located
145 (%set-function-pointers (ffi-make-pointer 'LispCallback)
146 (ffi-make-pointer 'ReleaseDelegateAdapter))
147 ;; reset to a sane state
148 (reset-cached-data)
149 (reimport-types)
150 (redefine-direct-calls)
151 ;; see comment for DLL-ENSURE-INIT above
152 (register-exit-function #'dll-force-term "Close DLL")
153 (values))
154
155 (defun shutdown-rdnzl (&optional no-gc)
156 "Prepares RDNZL for delivery or image saving. After calling this
157 function RDNZL can't be used anymore unless INIT-RDNZL is called
158 again. If NO-GC is NIL \(the default) a full garbage collection is
159 also performed."
160 (reset-cached-data)
161 (dll-force-term)
162 (unless no-gc
163 (full-gc))
164 (values))
165
166 (defun reimport-types ()
167 "Loops through all imported types and tries to associate them with
168 the correct assembly. Only relevant for delivery and saved images."
169 (let ((assembly-hash (make-hash-table :test #'equal)))
170 (loop for type-name being the hash-keys in *type-hash*
171 using (hash-value assembly-qualified-name)
172 ;; only do this for types which need the assembly-qualified
173 ;; name
174 when (stringp assembly-qualified-name)
175 do (let ((assembly-name (find-partial-assembly-name assembly-qualified-name)))
176 (import-type type-name
177 (or (gethash assembly-name assembly-hash)
178 (setf (gethash assembly-name assembly-hash)
179 (load-assembly assembly-name))))))))
180
181 (defun redefine-direct-calls ()
182 "Loops through all direct call definition which have been stored in
183 *DIRECT-DEFINITIONS* and re-animates them. Only relevant for delivery
184 and saved images."
185 (loop for function-name being the hash-keys in *direct-definitions*
186 using (hash-value function-data)
187 do (create-direct-call function-name function-data)))
188
189 ;; when loading this file initialize RDNZL
190 (eval-when (:load-toplevel :execute)
191 (init-rdnzl))
192
193 (disable-rdnzl-syntax)

  ViewVC Help
Powered by ViewVC 1.1.5