/[cells]/Celtk/tk-interp.lisp
ViewVC logotype

Contents of /Celtk/tk-interp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (show annotations)
Fri Apr 11 09:23:51 2008 UTC (6 years ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.20: +6 -0 lines
*** empty log message ***
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 #+test
218 (load-foreign-library 'Togl)
219
220 #+test
221 (load "togl17.dll" :verbose t)
222
223 ;; Send a script to a given Tcl/Tk interpreter
224
225 (defun eval-script (interp script)
226 (assert interp)
227 (assert script)
228 (tcl-eval interp script))
229

  ViewVC Help
Powered by ViewVC 1.1.5