/[rdnzl]/RDNZL/port-ecl.lisp
ViewVC logotype

Contents of /RDNZL/port-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (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.1: +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/port-ecl.lisp,v 1.2 2006/08/10 15:36:47 eweitz Exp $
3
4 ;;; Copyright (c) 2004-2006, Vasilis Margioulas, Michael Goffioul, 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 ;;; ECL-specific definitions
31
32 (in-package :rdnzl)
33
34 (defvar *dll-path* nil
35 "The name of RDNZL.dll.")
36
37 (defmacro ffi-register-module (dll-path &optional module-name)
38 "Store the DLL name provided by the argument DLL-PATH."
39 (declare (ignore module-name))
40 `(eval-when (:compile-toplevel :load-toplevel :execute)
41 (setq *dll-path* ,dll-path)))
42
43 (defun ffi-pointer-p (object)
44 "Tests whether OBJECT is an FFI pointer."
45 (eql (type-of object) 'si::foreign-data))
46
47 (defun ffi-null-pointer-p (pointer)
48 "Returns whether the FFI pointer POINTER is a null pointer."
49 (ffi:null-pointer-p pointer))
50
51 (defun ffi-pointer-address (pointer)
52 "Returns the address of the FFI pointer POINTER."
53 (ffi:pointer-address pointer))
54
55 (defun ffi-make-pointer (name)
56 "Returns an FFI pointer to the address specified by the name NAME."
57 (ffi:callback name))
58
59 (defun ffi-map-type (type-name)
60 "Maps type names like FFI-INTEGER to their corresponding names in
61 the ECL FFI."
62 (ecase type-name
63 (ffi-void :void)
64 (ffi-void-pointer :pointer-void)
65 (ffi-const-string '(* :unsigned-short))
66 (ffi-integer :int)
67 (ffi-boolean :byte)
68 (ffi-wide-char :unsigned-short)
69 (ffi-float :float)
70 (ffi-double :double)))
71
72 (defmacro ffi-define-function* ((lisp-name c-name)
73 arg-list
74 result-type)
75 "Defines a Lisp function LISP-NAME which acts as an interface
76 to the C function C-NAME. ARG-LIST is a list of \(NAME TYPE)
77 pairs. All types are supposed to be symbols mappable by
78 FFI-MAP-TYPE above."
79 (cond ((or (member result-type '(ffi-wide-char ffi-boolean))
80 (find 'ffi-wide-char arg-list :key #'second :test #'eq)
81 (find 'ffi-boolean arg-list :key #'second :test #'eq))
82 ;; define a wrapper if one of the args and/or the return type
83 ;; is a __wchar_t because ECL doesn't handle this
84 ;; type automatically
85 (with-unique-names (internal-name result)
86 `(progn
87 (ffi:def-function (,c-name ,internal-name)
88 ,(mapcar (lambda (name-and-type)
89 (destructuring-bind (name type) name-and-type
90 (list name (ffi-map-type type))))
91 arg-list)
92 ,@(when (ffi-map-type result-type)
93 `(:returning ,(ffi-map-type result-type)))
94 :module ,*dll-path*)
95 (defun ,lisp-name ,(mapcar #'first arg-list)
96 (let ((,result (,internal-name ,@(loop for (name type) in arg-list
97 if (eq type 'ffi-wide-char)
98 collect `(char-code ,name)
99 else if (eq type 'ffi-boolean)
100 collect `(if ,name 1 0)
101 else
102 collect name))))
103 ,(cond ((eq result-type 'ffi-wide-char)
104 `(code-char ,result))
105 ((eq result-type 'ffi-boolean)
106 `(if (= ,result 0) nil t))
107 (t result)))))))
108 (t
109 `(ffi:def-function (,c-name ,lisp-name)
110 ,(mapcar (lambda (name-and-type)
111 (destructuring-bind (name type) name-and-type
112 (list name (ffi-map-type type))))
113 arg-list)
114 ,@(when (ffi-map-type result-type)
115 `(:returning ,(ffi-map-type result-type)))
116 :module ,*dll-path*))))
117
118 (defmacro ffi-define-callable ((c-name result-type)
119 arg-list
120 &body body)
121 "Defines a Lisp function which can be called from C.
122 ARG-LIST is a list of \(NAME TYPE) pairs. All types are supposed
123 to be symbols mappable by FFI-MAP-TYPE above."
124 `(ffi:defcallback ,c-name ,(ffi-map-type result-type)
125 ,(mapcar (lambda (name-and-type)
126 (destructuring-bind (name type) name-and-type
127 (list name (ffi-map-type type))))
128 arg-list)
129 ,@body))
130
131 (eval-when (:compile-toplevel :load-toplevel :execute)
132 (defmacro with-unicode-string ((var lisp-string) &body body)
133 (with-unique-names (str-len k)
134 `(let* ((,str-len (length ,lisp-string)))
135 (ffi:with-foreign-object (,var `(:array :unsigned-short ,(1+ ,str-len)))
136 (loop for ,k below ,str-len
137 do (si::foreign-data-set-elt ,var (* 2 ,k) :unsigned-short (char-code (char ,lisp-string ,k))))
138 (si::foreign-data-set-elt ,var (* 2 ,str-len) :unsigned-short 0)
139 ,@body)))))
140
141 (defun unicode-string-to-lisp (ubyte16-array)
142 (let ((char-list (loop for k from 0
143 for uc = (si::foreign-data-ref-elt ubyte16-array (* 2 k) :unsigned-short)
144 while (/= uc 0) collect (code-char uc))))
145 (coerce char-list 'string)))
146
147 (defmacro ffi-get-call-by-ref-string (function object length-function)
148 "Calls the foreign function FUNCTION. FUNCTION is supposed to call
149 a C function f with the signature void f\(..., __wchar_t *s) where s
150 is a result string which is returned by this macro. OBJECT is the
151 first argument given to f. Prior to calling f the length of the
152 result string s is obtained by evaluating \(LENGTH-FUNCTION OBJECT)."
153 (with-rebinding (object)
154 (with-unique-names (length temp)
155 `(let* ((,length (,length-function ,object)))
156 (ffi:with-foreign-object (,temp `(:array :unsigned-short ,(1+ ,length)))
157 (,function ,object ,temp)
158 (unicode-string-to-lisp ,temp))))))
159
160 (defmacro ffi-call-with-foreign-string* (function string &optional other-args)
161 "Applies the foreign function FUNCTION to the string STRING and
162 OTHER-ARGS. OTHER-ARGS \(a list of CONTAINER structures or `native'
163 Lisp objects) is converted to a foreign array prior to calling
164 FUNCTION. STRING may be NIL which means that this argument is skipped
165 \(i.e. the macro actually needs a better name)."
166 (with-rebinding (other-args)
167 (with-unique-names (length arg-pointers ffi-arg-pointers arg i
168 arg-pointer foreign-string)
169 (declare (ignorable foreign-string))
170 `(let* ((,length (length ,other-args))
171 (,arg-pointers (make-array ,length :initial-element nil)))
172 (unwind-protect
173 (let ((,ffi-arg-pointers
174 (loop for ,arg in ,other-args
175 for ,i from 0
176 for ,arg-pointer = (cond
177 ((container-p ,arg) (pointer ,arg))
178 (t (setf (aref ,arg-pointers ,i)
179 (box* ,arg))))
180 collect ,arg-pointer)))
181 ,(cond (string
182 `(with-unicode-string (,foreign-string ,string)
183 (apply #',function ,foreign-string ,ffi-arg-pointers)))
184 (t
185 `(apply #',function ,ffi-arg-pointers))))
186 ;; all .NET elements that were solely created (by BOX*)
187 ;; for this FFI call are immediately freed
188 (dotimes (,i ,length)
189 (named-when (,arg-pointer (aref ,arg-pointers ,i))
190 (%free-dot-net-container ,arg-pointer))))))))
191
192 (defmacro ffi-call-with-args* (function object name args)
193 "Applies the foreign function FUNCTION to OBJECT and ARGS. ARGS \(a
194 list of CONTAINER structures or `native' Lisp objects) is converted to
195 a foreign array prior to calling FUNCTION. If NAME is not NIL, then
196 it should be a string and the first argument to FUNCTION will be the
197 corresponding foreign string."
198 (with-rebinding (args)
199 (with-unique-names (length arg-pointers ffi-arg-pointers arg i
200 arg-pointer foreign-name)
201 `(let* ((,length (length ,args))
202 (,arg-pointers (make-array ,length :initial-element nil)))
203 (unwind-protect
204 (progn
205 (ffi:with-foreign-object (,ffi-arg-pointers `(:array :pointer-void ,,length))
206 (loop for ,arg in ,args
207 for ,i from 0
208 for ,arg-pointer = (cond
209 ((container-p ,arg) (pointer ,arg))
210 (t (setf (aref ,arg-pointers ,i)
211 (box* ,arg))))
212 do (si::foreign-data-set-elt ,ffi-arg-pointers (* 4 ,i) :pointer-void ,arg-pointer))
213 ,(cond (name
214 `(with-unicode-string (,foreign-name ,name)
215 (,function ,foreign-name
216 ,object
217 ,length
218 ,ffi-arg-pointers)))
219 (t `(,function ,object
220 ,length
221 ,ffi-arg-pointers)))))
222 ;; all .NET elements that were solely created (by BOX*)
223 ;; for this FFI call are immediately freed
224 (dotimes (,i ,length)
225 (named-when (,arg-pointer (aref ,arg-pointers ,i))
226 (%free-dot-net-container ,arg-pointer))))))))
227
228 (defun flag-for-finalization (object &optional function)
229 "Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT
230 is removed by GC."
231 ;; don't know how to do that in ECL
232 (declare (ignore object function)))
233
234 (defun register-exit-function (function &optional name)
235 "Makes sure the function FUNCTION \(with no arguments) is called
236 before the Lisp images exits."
237 ;; don't know how to do that in ECL
238 (declare (ignore function name)))
239
240 (defun full-gc ()
241 "Invokes a full garbage collection."
242 (si::gc t))
243
244 (export 'lf-to-crlf :rdnzl)
245 (defun lf-to-crlf (string)
246 "Add #\Return before each #\Newline in STRING."
247 (loop with new-string = (make-array (+ (length string) (count #\Newline string))
248 :element-type 'character
249 :fill-pointer 0)
250 for c across string
251 when (char= c #\Newline)
252 do (vector-push-extend #\Return new-string)
253 do (vector-push-extend c new-string)
254 finally (return new-string)))

  ViewVC Help
Powered by ViewVC 1.1.5