Home
Reading
Searching
Subscribe
Sponsors
Statistics
Posting
Contact
Spam
Lists
Links
About
Hosting
Filtering
Features Download
Marketing
Archives
FAQ
Blog
 
Gmane
From: idan mandelbaum <idanman2002 <at> yahoo.com>
Subject: rdnzl for clozure cl
Newsgroups: gmane.lisp.lib.rdnzl.general
Date: Thursday 10th November 2011 17:22:18 UTC (over 4 years ago)
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)
#
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
#.
   [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 = #
        #:POINTER1391 = #
  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 #)
  8: (SWANK::CALL-WITH-RETRY-RESTART "Retry SLIME REPL evaluation
request." #)
  9: (SWANK::CALL-WITH-BUFFER-SYNTAX NIL #)
 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 # #)
 18: (SWANK::CALL-WITH-BINDINGS ((*STANDARD-OUTPUT* .
#) (*STANDARD-INPUT* .
#) ..)))
# NIL)
 20: (CCL::RUN-PROCESS-INITIAL-FORM # (#))
 21: ((:INTERNAL (CCL::%PROCESS-PRESET-INTERNAL (CCL:PROCESS))) # (#))
 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))  
 
CD: 4ms