I am trying to get rdnzl 0.13.3 to work on clozure cl 1.6 on a windows 7 32 bit machine.
I am running it from the lisp in a box system. I've tried both with slime and w/o slime and I get the same problem.
I modified port-sbcl.lisp and added the appropriate #+:ccl in load.lisp. I included the content of the port-sbcl.lisp file below (I know this makes it a long post but I hope its ok). I then tried to run the first example:
CL-USER> (load "C:/Users/idan.mandelbaum/Desktop/lispbox-0.7/rdnzl-0.13.3/load.lisp")
#P"C:/Users/idan.mandelbaum/Desktop/lispbox-0.7/rdnzl-0.13.3/load.lisp"
CL-USER> (in-package rdnzl-user)
#<Package "RDNZL-USER">
RDNZL-USER> (enable-rdnzl-syntax)
; No value
RDNZL-USER> (import-types "System.Windows.Forms" "MessageBox" "MessageBoxButtons" "DialogResult")
I get the following:
Trying to call function RDNZL::%INVOKE-STATIC-MEMBER with NULL object #<CONTAINER NULL #x28C1B10>.
[Condition of type SIMPLE-ERROR]
Restarts:
0: [RETRY] Retry SLIME REPL evaluation request.
1: [*ABORT] Return to SLIME's top level.
2: [ABORT-BREAK] Reset this thread
3: [ABORT] Kill this thread
Backtrace:
0: (INVOKE "System.Reflection.Assembly" "LoadWithPartialName" "System.Windows.Forms")
Locals:
RDNZL::OBJECT = "System.Reflection.Assembly"
RDNZL::METHOD-NAME = "LoadWithPartialName"
RDNZL::ARGS = ("System.Windows.Forms")
#:OBJECT1390 = #<CONTAINER NULL #x28C1B10>
#:POINTER1391 = #<A Foreign Pointer #x28C1B10>
1: (LOAD-ASSEMBLY "System.Windows.Forms")
Locals:
RDNZL::NAME = "System.Windows.Forms"
2: (IMPORT-TYPES "System.Windows.Forms" "MessageBox" "MessageBoxButtons" "DialogResult")
3: (CCL::CALL-CHECK-REGS IMPORT-TYPES "System.Windows.Forms" "MessageBox" "MessageBoxButtons" "DialogResult")
4: (CCL::CHEAP-EVAL (IMPORT-TYPES "System.Windows.Forms" "MessageBox" "MessageBoxButtons" "DialogResult"))
5: (SWANK::EVAL-REGION "(import-types \"System.Windows.Forms\" \"MessageBox\" \"MessageBoxButtons\" \"DialogResult\")\n")
6: ((:INTERNAL SWANK::REPL-EVAL))
7: (SWANK::TRACK-PACKAGE #<CCL:COMPILED-LEXICAL-CLOSURE (:INTERNAL SWANK::REPL-EVAL) #x1891A766>)
8: (SWANK::CALL-WITH-RETRY-RESTART "Retry SLIME REPL evaluation request." #<CCL:COMPILED-LEXICAL-CLOSURE (:INTERNAL SWANK::REPL-EVAL) #x1891A7B6>)
9: (SWANK::CALL-WITH-BUFFER-SYNTAX NIL #<CCL:COMPILED-LEXICAL-CLOSURE (:INTERNAL SWANK::REPL-EVAL) #x1891A7DE>)
10: (SWANK::REPL-EVAL "(import-types \"System.Windows.Forms\" \"MessageBox\" \"MessageBoxButtons\" \"DialogResult\")\n")
11: (CCL::CALL-CHECK-REGS SWANK:LISTENER-EVAL "(import-types \"System.Windows.Forms\" \"MessageBox\" \"MessageBoxButtons\" \"DialogResult\")\n")
12: (CCL::CHEAP-EVAL (SWANK:LISTENER-EVAL "(import-types \"System.Windows.Forms\" \"MessageBox\" \"MessageBoxButtons\" \"DialogResult\")\n"))
13: (SWANK:EVAL-FOR-EMACS (SWANK:LISTENER-EVAL "(import-types \"System.Windows.Forms\" \"MessageBox\" \"MessageBoxButtons\" \"DialogResult\")\n") "RDNZL-USER" 11)
14: (SWANK::PROCESS-REQUESTS NIL)
15: ((:INTERNAL SWANK::HANDLE-REQUESTS))
16: ((:INTERNAL SWANK::HANDLE-REQUESTS))
17: (SWANK-BACKEND:CALL-WITH-DEBUGGER-HOOK #<Compiled-function SWANK:SWANK-DEBUGGER-HOOK #x1844386E> #<CCL:COMPILED-LEXICAL-CLOSURE (:INTERNAL SWANK::HANDLE-REQUESTS) #x187AC8C6>)
18: (SWANK::CALL-WITH-BINDINGS ((*STANDARD-OUTPUT* . #<SWANK-BACKEND::SLIME-OUTPUT-STREAM #x1879F07E>) (*STANDARD-INPUT* . #<SWANK-BACKEND::SLIME-INPUT-STREAM #x1879F2B6>) ..))) #<CCL:COMPILED-LEXICAL-CLO..
19: (SWANK::HANDLE-REQUESTS #<CONNECTION #x186C734E> NIL)
20: (CCL::RUN-PROCESS-INITIAL-FORM #<PROCESS repl-thread(10) [Active] #x1879F786> (#<CCL:COMPILED-LEXICAL-CLOSURE (:INTERNAL CCL::%PROCESS-RUN-FUNCTION) #x1879F646>))
21: ((:INTERNAL (CCL::%PROCESS-PRESET-INTERNAL (CCL:PROCESS))) #<PROCESS repl-thread(10) [Active] #x1879F786> (#<CCL:COMPILED-LEXICAL-CLOSURE (:INTERNAL CCL::%PROCESS-RUN-FUNCTION) #x1879F646>))
22: ((:INTERNAL CCL::THREAD-MAKE-STARTUP-FUNCTION))
I traced this to a failure in [System.Reflection.Assembly.LoadWithPartialName name] called within load-addembly in the import.lisp file. Upon further tracing it seems like the error ocures becasue make-type-from-name may have a problem when called with "System.Reflection.Assembly". I think they might be something wrong with the way I am working with strings in the ffi-call-with-foreign-string* function below. Any thoughts/ideas?
My modified port-sbcl.lisp file (called port-clozurecl.lisp)
;;; Clozure-specific definitions
(in-package :rdnzl)
(defconstant +ffi-pointer-size+ 4 "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)
(ccl:open-shared-library ,path)))
(defun ffi-pointer-p (object)
"Tests whether OBJECT is an FFI pointer."
(typep object 'ccl:macptr))
(defun ffi-null-pointer-p (pointer)
"Returns whether the FFI pointer POINTER is a null pointer."
(ccl:%null-ptr-p pointer))
(defun ffi-pointer-address (pointer)
"Returns the address of the FFI pointer POINTER."
(ccl:%ptr-to-int pointer))
;Defines void pointer to use in this package
(ccl:def-foreign-type :voidpointer (:* T))
(defun ffi-map-type (type-name)
"Maps type names like FFI-INTEGER to their corresponding names in
the SBCL FFI."
(ecase type-name
(ffi-void ':void)
(ffi-void-pointer '(:* T))
(ffi-const-string ':address)
(ffi-integer ':signed-halfword)
(ffi-boolean ':unsigned-byte)
(ffi-wide-char ':unsigned-halfword)
(ffi-unsigned-short ':unsigned-halfword)
(ffi-float ':single-float)
(ffi-double ':double-float)))
(defun flatten (structure)
"Flatten only the first level of a list of arguments
for use in ccl:ffi macros below"
(cond ((null structure) nil)
(t (append (first structure) (flatten (rest structure))))))
(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."
`(defun ,lisp-name
,(mapcar #'first arg-list)
(ccl:external-call ,c-name ,@(flatten (mapcar (lambda (name-and-type)
(destructuring-bind (name type) name-and-type
(list (ffi-map-type type) name)))
arg-list))
,(when (ffi-map-type result-type) (ffi-map-type result-type)))))
(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."
`(ccl:defcallback ,c-name
( ,@(flatten (mapcar (lambda (name-and-type)
(destructuring-bind (name type) name-and-type
(list (ffi-map-type type) name)))
arg-list))
,(when (ffi-map-type result-type) (ffi-map-type result-type)) ) ,@body))
(defun ffi-make-pointer (name)
"Returns an FFI pointer to the \(callback) address specified by
the name NAME."
(if (symbolp name) (symbol-value name) name))
(defun ffi-make-null-pointer ()
"Returns an FFI NULL pointer."
(ccl:%null-ptr))
(defun ffi-alloc (size)
"Allocates an `alien' of size SIZE octets and returns a pointer
to it. Must be freed with FFI-FREE afterwards."
(#_malloc size))
(defun ffi-free (pointer)
"Frees space that was allocated with FFI-ALLOC."
(#_free pointer))
(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
(+ (ccl:%get-unsigned-byte pointer i)
(ash (ccl:%get-unsigned-byte 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."
`(ccl:with-encoded-cstrs :ucs-2 ((,var ,lisp-string)) ,@body))
(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 (ccl:%setf-macptr (ccl:%get-ptr ,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))))))))
(defmacro make-fun-for-finalization (object function)
"Make function to call function for flag-for finalization since
clozure cl only allows function ccl:terminate to be called"
`(defmethod ccl:terminate ((x ,(type-of object))) (funcall ,function)))
(defun flag-for-finalization (object &optional function)
"Mark OBJECT such that FUNCTION is applied to OBJECT before OBJECT
is removed by GC."
(ccl:terminate-when-unreachable object)
(unless (null function)
(make-fun-for-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 SBCL
(declare (ignore function name)))
(defun full-gc ()
"Invokes a full garbage collection."
(ccl:gc))
