[cffi-devel] For the CFFI gurus: Tcl/Tk: Tk_Init crashes (Lispworks)

[Frank Goenninger]

Hi you all, the gurus of CFFI ;-)

I do have a major problem when running the following code on LW  
Personal Edition on Mac OS X 10.4.10 Intel:

;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-

(eval-when (:load-toplevel :compile-toplevel :execute)
   (ignore-errors
      #-asdf (load "~/lw-start.lisp")
      #-cffi (asdf:operate 'asdf:load-op 'cffi)
      #-net.goenninger.app.debug (asdf:operate 'asdf:load-op  
'net.goenninger.app.debug)
   ))

(defpackage #:lw-tk-test
   (:use
    #:common-lisp
    #:clos
    #:cffi
    #+net.goenninger.app.debug #:net.goenninger.app.debug
    )
   (:export
    #:main
    ))

(in-package #:lw-tk-test)
(in-module :lw-tk-test) ;; needed for debugging

;;;  
------------------------------------------------------------------------ 
-----------------
;;;   SPECIAL VARS
;;;  
------------------------------------------------------------------------ 
-----------------

(defparameter *tki* nil) ;; Pointer to Tcl/Tk Interp structure.

;;;  
------------------------------------------------------------------------ 
-----------------
;;;   DEBUG...
;;;  
------------------------------------------------------------------------ 
-----------------

#-net.goenninger.app.debug
(defun logmsg (msg-class method method-desc msg &rest msg-args)
     (format *debug-io* "~&~%--- ~a  
--------------------------------------------------"
             (get-universal-time) t)
     (format *debug-io* "~&*** ~A [ FN ~S ( ~A ) ]~&"
	          msg-class method method-desc)
     (format *debug-io* "*** ")
     (apply 'format *debug-io* msg msg-args)
     (format *debug-io* "~%")
     (force-output *debug-io*))

;;;  
------------------------------------------------------------------------ 
-----------------
;;;   FOREIGN LIB DEFINITIONS
;;;  
------------------------------------------------------------------------ 
-----------------

(define-foreign-library Tcl
   (:darwin (:framework "Tcl"))
   (:windows (:or "/tcl/bin/Tcl85.dll"))
   (:unix "libtcl.so")
   (t (:default "libtcl")))

(define-foreign-library Tk
   (:darwin (:framework "Tk"))
   (:windows (:or "/tcl/bin/tk85.dll"))
   (:unix "libtk.so")
   (t (:default "libtk")))

;;;  
------------------------------------------------------------------------ 
-----------------
;;;   FOREIGN TYPE DEFINITIONS
;;;  
------------------------------------------------------------------------ 
-----------------

(defctype tcl-retcode :int)

(defcenum tcl-retcode-values
   (:tcl-ok    0)
   (:tcl-error 1))

;;;  
------------------------------------------------------------------------ 
-----------------
;;;   FOREIGN FUNCTION DEFINITIONS
;;;  
------------------------------------------------------------------------ 
-----------------

;;; <tcl.h> void Tcl_FindExecutable(char *);
(defcfun ("Tcl_FindExecutable" tcl-find-executable) :void
   (argv0 :string))

;;; <tcl.h> int Tcl_Init( Tcl-Interp *interp );
(defcfun ("Tcl_Init" Tcl_Init) tcl-retcode
   (interp :pointer))

;;; <tk.h> int Tk_Init( Tcl-Interp *interp );
(defcfun ("Tk_Init" Tk_Init) tcl-retcode
   (interp :pointer))

;;; <tcl.h> Tcl_Interp* Tcl_CreateInterp(void);
(defcfun ("Tcl_CreateInterp" Tcl_CreateInterp) :pointer)

;;; <tcl.h> voíd Tcl_DeleteInterp(Tcl_Interp* interp);
(defcfun ("Tcl_DeleteInterp" Tcl_DeleteInterp) :void
   (interp :pointer))

;;; <tcl.> char *Tcl_GetStringResult( Tcl_Interp *interp);
(defcfun ("Tcl_GetStringResult" Tcl_GetStringResult) :string
   (interp :pointer))

;;; Helper function: translate int return code to :tcl-ok or :tcl- 
error and checks for
;;; :tcl-ok.
(defmethod translate-from-foreign (value (type (eql 'tcl-retcode)))
   (unless (eql value (foreign-enum-value 'tcl-retcode-values :tcl-ok))
     (error "Tcl error: ~a" (Tcl_GetStringResult *tki*)))
   value)

;;;  
------------------------------------------------------------------------ 
-----------------
;;;    TCL/TK LOADING ...
;;;  
------------------------------------------------------------------------ 
-----------------

(defun tk-app-init (interp)
   (assert (not (null-pointer-p interp)))
   (Tcl_Init interp)
   (Tk_Init interp)   ;; <<<--- CRASH HAPPENS HERE ...
   ;; Return OK
   (foreign-enum-value 'tcl-retcode-values :tcl-ok))

(defun argv0 ()
   #+allegro (sys:command-line-argument 0)
   #+lispworks (nth 0 system:*line-arguments-list*) ;; portable to OS X
   #+sbcl (nth 0 sb-ext:*posix-argv*)
   #+openmcl (car ccl:*command-line-argument-list*)
   #-(or allegro lispworks sbcl openmcl)
   (error "argv0 function not implemented for this lisp"))

;;;  
------------------------------------------------------------------------ 
-----------------
;;;   TEST ROUTINE
;;;  
------------------------------------------------------------------------ 
-----------------

#+net.goenninger.app.debug
(progn
   (enable-debugging :module :lw-tk-test)
   (enable-debugging :function 'main))

(defun main ()

   (use-foreign-library Tcl)
   (use-foreign-library Tk)

   (setq *tki* (Tcl_CreateInterp))
   (logmsg :DEBUG 'main "-" "*tki* = ~s" *tki*)

   (let ((argv0 (argv0)))
     (logmsg :DEBUG 'main "-" "argv0 = ~s" argv0)
     (tcl-find-executable argv0))

   (tk-app-init *tki*)
   (Tcl_DeleteInterp *tki*)
   (setf *tki* nil)
)

Sooo - the code crashes at the point marked "<<<--- CRASH HAPPENS  
HERE ...". This occurs on LW but not on ACL 8.1 Express Edition.

I have double, no triple, checked the defc... stuff - to no avail.  
The code had been working for half a year on ACL without problems. I  
recently switched to LW and can't get to the point of seeing where  
there's something going astray.

Any help really appreciated!!! Thanks so much in advance !

Frank

--
   Frank Goenninger
   frgo at goenninger.net





-------------- next part --------------
A non-text attachment was scrubbed...
Name: PGP.sig
Type: application/pgp-signature
Size: 833 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/cffi-devel/attachments/20070920/ab79121e/attachment.sig>