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

20 Sep 2007


      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@goenninger.net