tk-interp.lisp

   1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
   2 #|
   3
   4     Celtk -- Cells, Tcl, and Tk
   5
   6 Copyright (C) 2006 by Kenneth Tilton
   7
   8 This library is free software; you can redistribute it and/or
   9 modify it under the terms of the Lisp Lesser GNU Public License
  10  (http://opensource.franz.com/preamble.html), known as the LLGPL.
  11
  12 This library is distributed  WITHOUT ANY WARRANTY; without even
  13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15 See the Lisp Lesser GNU Public License for more details.
  16
  17 |#
  18
  19
  20 (in-package :celtk)
  21
  22 ;; Tcl/Tk
  23
  24 (define-foreign-library Tcl
  25     (:darwin (:framework "Tcl"))
  26   (:windows (:or "Tcl85.dll"))
  27   (:unix "libtcl.so")
  28   (t (:default "libtcl")))
  29
  30 (define-foreign-library Tk
  31     (:darwin (:framework "Tk"))
  32   (:windows (:or "Tk85.dll"))
  33   (:unix "libtk.so")
  34   (t (:default "libtk")))
  35
  36 (define-foreign-library Tile
  37     ;(:darwin (:framework "Tk"))
  38     (:windows (:or "tile078.dll"))
  39   ;(:unix "libtk.so")
  40   (t (:default "libtk")))
  41
  42 (defctype tcl-retcode :int)
  43
  44 (defcenum tcl-retcode-values
  45   (:tcl-ok    0)
  46   (:tcl-error 1))
  47
  48 (defmethod translate-from-foreign (value (type (eql 'tcl-retcode)))
  49   (unless (eq value (foreign-enum-value 'tcl-retcode-values :tcl-ok))
  50     (error "Tcl error: ~a" (tcl-get-string-result *tki*)))
  51   value)
  52
  53 ;; --- initialization ----------------------------------------
  54
  55 (defcfun ("Tcl_FindExecutable" tcl-find-executable) :void
  56   (argv0 :string))
  57
  58 (defcfun ("Tcl_Init" Tcl_Init) tcl-retcode
  59   (interp :pointer))
  60
  61 (defcfun ("Tk_Init" Tk_Init) tcl-retcode
  62   (interp :pointer))
  63
  64 (defcallback Tk_AppInit tcl-retcode
  65   ((interp :pointer))
  66   (unwind-protect
  67     (tk-app-init interp)))
  68
  69 (defun tk-app-init (interp)
  70   (assert interp)
  71   (Tcl_Init interp)
  72   (Tk_Init interp)
  73   ;; Return OK
  74   (foreign-enum-value 'tcl-retcode-values :tcl-ok))
  75
  76   ;; Tk_Main
  77
  78 (defcfun ("Tk_MainEx" %Tk_MainEx) :void
  79   (argc :int)
  80   (argv :string)
  81   (Tk_AppInitProc :pointer)
  82   (interp :pointer))
  83
  84 (defun Tk_Main ()
  85   (with-foreign-string (argv (argv0))
  86     (%Tk_MainEx 1 argv
  87       (get-callback 'Tk_AppInit)
  88       (Tcl_CreateInterp))))
  89
  90 ;; Tcl_CreateInterp
  91
  92 (defcfun ("Tcl_CreateInterp" Tcl_CreateInterp) :pointer)
  93
  94 (defcfun ("Tcl_DeleteInterp" tcl-delete-interp) :void
  95   (interp :pointer))
  96
  97 ;;; --- windows ----------------------------------
  98
  99 (defcfun ("Tk_GetNumMainWindows" tk-get-num-main-windows) :int)
 100 (defcfun ("Tk_MainWindow" tk-main-window) :pointer (interp :pointer))
 101
 102 (defcfun ("Tk_NameToWindow" tk-name-to-window) :pointer
 103   (interp :pointer)
 104   (pathName :string)
 105   (related-tkwin :pointer))
 106
 107 ;;; --- eval -----------------------------------------------
 108
 109 (defcfun ("Tcl_EvalFile" %Tcl_EvalFile) tcl-retcode
 110   (interp        :pointer)
 111   (filename-cstr :string))
 112
 113 (defun Tcl_EvalFile (interp filename)
 114   (with-foreign-string (filename-cstr filename)
 115     (%Tcl_EvalFile interp filename-cstr)))
 116
 117 (defcfun ("Tcl_Eval" %Tcl_Eval) tcl-retcode
 118   (interp      :pointer)
 119   (script-cstr :string))
 120
 121 (defun tcl-eval (i s)
 122   (%Tcl_Eval i s))
 123
 124 (defcfun ("Tcl_EvalEx" %Tcl_EvalEx) tcl-retcode
 125   (interp      :pointer)
 126   (script-cstr :string)
 127   (num-bytes   :int)
 128   (flags       :int))
 129
 130 (defun tcl-eval-ex (i s)
 131   (%Tcl_EvalEx i s -1 0))
 132
 133 (defcfun ("Tcl_GetVar" tcl-get-var) :string
 134   (interp  :pointer)
 135   (varName :string)
 136   (flags   :int))
 137
 138 (defcfun ("Tcl_SetVar" tcl-set-var) :string
 139   (interp    :pointer)
 140   (var-name  :string)
 141   (new-value :string)
 142   (flags     :int))
 143
 144 (defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string
 145   (interp :pointer))
 146
 147 ;; ----------------------------------------------------------------------------
 148 ;; Tcl_CreateCommand - used to implement direct callbacks
 149 ;; ----------------------------------------------------------------------------
 150
 151 (defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer
 152   (interp :pointer)
 153   (cmdName :string)
 154   (proc :pointer)
 155   (client-data :pointer)
 156   (delete-proc :pointer))
 157
 158 ;; ----------------------------------------------------------------------------
 159 ;; Tcl/Tk channel related stuff
 160 ;; ----------------------------------------------------------------------------
 161
 162 (defcfun ("Tcl_RegisterChannel" Tcl_RegisterChannel) :void
 163   (interp :pointer)
 164   (channel :pointer))
 165
 166 (defcfun ("Tcl_UnregisterChannel" Tcl_UnregisterChannel) :void
 167   (interp :pointer)
 168   (channel :pointer))
 169
 170 (defcfun ("Tcl_MakeFileChannel" Tcl_MakeFileChannel) :pointer
 171   (handle :int)
 172   (readOrWrite :int))
 173
 174 (defcfun ("Tcl_GetChannelName" Tcl_GetChannelName) :string
 175   (channel :pointer))
 176
 177 (defcfun ("Tcl_GetChannelType" Tcl_GetChannelType) :pointer
 178   (channel :pointer))
 179
 180
 181 (defcfun ("Tcl_GetChannel" Tcl_GetChannel) :pointer
 182   (interp :pointer)
 183   (channelName :string)
 184   (modePtr :pointer))
 185
 186 ;; Initialization mgmt - required to avoid multiple library loads
 187
 188 (defvar *initialized* nil)
 189
 190 (defun set-initialized ()
 191   (setq *initialized* t))
 192
 193 (defun reset-initialized ()
 194   (setq *initialized* nil))
 195
 196 #+doit
 197 (reset-initialized)
 198
 199 (defun argv0 ()
 200   #+allegro (sys:command-line-argument 0)
 201   #+lispworks (nth 0 system:*line-arguments-list*) ;; portable to OS X
 202   #+sbcl (nth 0 sb-ext:*posix-argv*)
 203   #+openmcl (car ccl:*command-line-argument-list*)
 204   #-(or allegro lispworks sbcl openmcl)
 205   (error "argv0 function not implemented for this lisp"))
 206
 207 (defun tk-interp-init-ensure ()
 208   (unless *initialized*
 209     (use-foreign-library Tcl)
 210     (use-foreign-library Tk)
 211     #-macosx (use-foreign-library Tile)
 212     #-macosx (pushnew :tile cl-user::*features*)
 213     (use-foreign-library Togl)
 214     (tcl-find-executable (argv0))
 215     (set-initialized)))
 216
 217 ;; Send a script to a given Tcl/Tk interpreter
 218
 219 (defun eval-script (interp script)
 220   (assert interp)
 221   (assert script)
 222   (tcl-eval interp script))
 223