[rdnzl-devel] rdnzl for clozure cl - rdnzl-devel@common-lisp.net - mailman3.common-lisp.net

10 Nov 2011

      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))