Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 237 lines (173 sloc) 5.86 KB
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|
Celtk -- Cells, Tcl, and Tk
Copyright (C) 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :celtk)
;; Tcl/Tk
(define-foreign-library Tcl
(:darwin (:framework "Tcl"))
(:windows (:or "Tcl85.dll"))
(:unix "/opt/ActiveTcl-8.5/lib/libtcl8.5.so")
(t (:default "libtcl")))
#+test
(use-foreign-library Tk)
(define-foreign-library Tk
(:darwin (:framework "Tk"))
(:windows (:or "Tk85.dll"))
(:unix "/opt/ActiveTcl-8.5/lib/libtk8.5.so") ;; also "libtk.so"
(t (:default "libtk")))
#+nowbuiltin?
(define-foreign-library Tile
;(:darwin (:framework "Tk"))
(:windows (:or "tile083.dll"))
;(:unix "libtk.so")
(t (:default "libtk")))
(defctype tcl-retcode :int)
(defcenum tcl-retcode-values
(:tcl-ok 0)
(:tcl-error 1))
(defmethod translate-from-foreign (value (type (eql 'tcl-retcode)))
(unless (eq value (foreign-enum-value 'tcl-retcode-values :tcl-ok))
(error "Tcl error: ~a" (tcl-get-string-result *tki*)))
value)
;; --- initialization ----------------------------------------
(defcfun ("Tcl_FindExecutable" tcl-find-executable) :void
(argv0 :string))
(defcfun ("Tcl_Init" Tcl_Init) tcl-retcode
(interp :pointer))
(defcfun ("Tk_Init" Tk_Init) tcl-retcode
(interp :pointer))
(defcallback Tk_AppInit tcl-retcode
((interp :pointer))
(unwind-protect
(tk-app-init interp)))
(defun tk-app-init (interp)
(assert interp)
(trace Tcl_Init Tk_Init)
(Tcl_Init interp)
(Tk_Init interp)
;; Return OK
(foreign-enum-value 'tcl-retcode-values :tcl-ok))
;; Tk_Main
(defcfun ("Tk_MainEx" %Tk_MainEx) :void
(argc :int)
(argv :string)
(Tk_AppInitProc :pointer)
(interp :pointer))
(defun Tk_Main ()
(with-foreign-string (argv (argv0))
(%Tk_MainEx 1 argv
(get-callback 'Tk_AppInit)
(Tcl_CreateInterp))))
;; Tcl_CreateInterp
(defcfun ("Tcl_CreateInterp" Tcl_CreateInterp) :pointer)
(defcfun ("Tcl_DeleteInterp" tcl-delete-interp) :void
(interp :pointer))
;;; --- windows ----------------------------------
(defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int)
(defcfun ("Tk_MainWindow" tk-main-window) :pointer (interp :pointer))
(defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer
(interp :pointer)
(pathname :string)
(related-tkwin :pointer))
;;; --- eval -----------------------------------------------
(defcfun ("Tcl_EvalFile" %Tcl_EvalFile) tcl-retcode
(interp :pointer)
(filename-cstr :string))
(defun Tcl_EvalFile (interp filename)
(with-foreign-string (filename-cstr filename)
(%Tcl_EvalFile interp filename-cstr)))
(defcfun ("Tcl_Eval" %Tcl_Eval) tcl-retcode
(interp :pointer)
(script-cstr :string))
(defun tcl-eval (i s)
(%Tcl_Eval i s))
(defcfun ("Tcl_EvalEx" %Tcl_EvalEx) tcl-retcode
(interp :pointer)
(script-cstr :string)
(num-bytes :int)
(flags :int))
(defun tcl-eval-ex (i s)
(%Tcl_EvalEx i s -1 0))
(defcfun ("Tcl_GetVar" tcl-get-var) :string
(interp :pointer)
(varName :string)
(flags :int))
(defcfun ("Tcl_SetVar" tcl-set-var) :string
(interp :pointer)
(var-name :string)
(new-value :string)
(flags :int))
(defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string
(interp :pointer))
;; ----------------------------------------------------------------------------
;; Tcl_CreateCommand - used to implement direct callbacks
;; ----------------------------------------------------------------------------
(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer
(interp :pointer)
(cmdName :string)
(proc :pointer)
(client-data :pointer)
(delete-proc :pointer))
;; ----------------------------------------------------------------------------
;; Tcl/Tk channel related stuff
;; ----------------------------------------------------------------------------
(defcfun ("Tcl_RegisterChannel" Tcl_RegisterChannel) :void
(interp :pointer)
(channel :pointer))
(defcfun ("Tcl_UnregisterChannel" Tcl_UnregisterChannel) :void
(interp :pointer)
(channel :pointer))
(defcfun ("Tcl_MakeFileChannel" Tcl_MakeFileChannel) :pointer
(handle :int)
(readOrWrite :int))
(defcfun ("Tcl_GetChannelName" Tcl_GetChannelName) :string
(channel :pointer))
(defcfun ("Tcl_GetChannelType" Tcl_GetChannelType) :pointer
(channel :pointer))
(defcfun ("Tcl_GetChannel" Tcl_GetChannel) :pointer
(interp :pointer)
(channelName :string)
(modePtr :pointer))
;; Initialization mgmt - required to avoid multiple library loads
(defvar *initialized* nil)
(defun set-initialized ()
(setq *initialized* t))
(defun reset-initialized ()
(setq *initialized* nil))
#+doit
(reset-initialized)
(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"))
(defun tk-interp-init-ensure ()
(unless *initialized*
(use-foreign-library Tcl)
(use-foreign-library Tk)
;;#-macosx (use-foreign-library Tile)
;;#-macosx (pushnew :tile cl-user::*features*)
(print :try-using-togl)
#+togl (use-foreign-library Togl)
#+togl (print :try-using-togl-ok)
(tcl-find-executable (argv0))
(set-initialized)))
#+test
(load-foreign-library 'Togl)
#+test
(load "togl17.dll" :verbose t)
;; Send a script to a given Tcl/Tk interpreter
(defun eval-script (interp script)
(assert interp)
(assert script)
(tcl-eval interp script))
Something went wrong with that request. Please try again.