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

[Frank Goenninger]

Hi you all, the gurus of CFFI ;-)




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

  ))

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

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


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





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

Frank

--
  Frank Goenninger
  [EMAIL PROTECTED]

I do have a major problem when running the following code on LW Personal Edition on Mac OS X 10.4.10 Intel: #-net.goenninger.app.debug (asdf:operate 'asdf:load-op 'net.goenninger.app.debug) ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- (format *debug-io* "~&~%--- ~a --------------------------------------------------" ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; Helper function: translate int return code to :tcl-ok or :tcl- error and checks for ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- ;;; ------------------------------------------------------------------------ ----------------- 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.

PGP.sig
Description: PGP signature

_______________________________________________
cffi-devel mailing list
cffi-devel@common-lisp.net
http://common-lisp.net/cgi-bin/mailman/listinfo/cffi-devel