1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
; -*- Scheme -*-
;;;;; Tk interface code for a button
;;; $Id: widget-mit.scm,v 1.2 1996/11/14 22:14:06 adams Exp $
;;; Lowest-level makers for various kinds of TK widgets. These call C
;;; primitives in widget-c-mit.c, and are called by the higher-level
;;; widget object makers in widget.scm
(define-primitives
(%tkDeleteDisplay 1)
(%tkDestroyWidget 1)
(%tkMakeButton 2)
(%tkMakeCanvas 2)
(%tkMakeCheckbutton 2)
(%tkMakeEntry 2)
(%tkMakeLabel 2)
(%tkMakeListbox 2)
(%tkMakeMenu 2)
(%tkMakeMenubutton 2)
(%tkMakeMessage 2)
(%tkMakeRadiobutton 2)
(%tkMakeScale 2)
(%tkMakeScrollBar 2)
(%tkMakeText 2)
)
#| Widgets hold strong pointers to the display and the application.
Therefore, when we GC away the display or applcation, we can assume
that there are no pointers to the widgets still around. However, the
C end may need to be closed |#
;;; display->tk-widgets is a map that associates to each display a
;;; protection list of the tk-widgets for the display
(define display->tk-widgets 'INITIALIZED-LATER)
(define (add-widget-list-for-display-number! display-number)
(set! display->tk-widgets
(cons (cons display-number (make-protection-list))
display->tk-widgets)))
(define (find-tk-protection-list display)
(find-tk-protection-list-from-number (->xdisplay display)))
(define (find-tk-protection-list-from-number number)
(let ((list (assv number display->tk-widgets)))
(and (pair? list)
(cdr list))))
;;; The item on the protection list is a cell containing the widget
;;; pointer. This permits us to mark the cell when the C object is
;;; destroyed so we don't try to destroy it twice.
(define (Wrap-TK-widget surface name maker)
(let ((ToolKitParent (DrawingSurface.ToolKitWindow surface)))
;; Note that the DrawingSurface's UITKWindow may not yet exist.
(let ((parent-tk-window (ToolKitWindow.TK-window ToolKitParent))
(application (ToolKitWindow.Application ToolKitParent)))
(let ((display (Application->Display application)))
(let ((new-window-name
(string-append
(tkwin.pathname parent-tk-window) "." name)))
(let ((wrapped-object #F))
(define (kill-me)
;; Called when the object is destroyed
(SCXL-DESTROY! wrapped-object))
(set! wrapped-object
(SCXL-WRAP
(or (find-tk-protection-list display)
(error "No tk-protection-list for this display" display))
'tk-widget
(tk-op
(lambda ()
(maker parent-tk-window new-window-name)))
(list display surface kill-me) ;strong dependents
))
(tk-invoke-command
'BIND (Application->TKMainWindow application)
(list new-window-name "<Destroy>"
(string-append "SchemeCallBack "
(number->string
(hash kill-me *our-hash-table*)))))
wrapped-object))))))
(define (widget/widget widget)
(type-check-wrapped-object 'tk-widget widget)
(SCXL-UNWRAP widget (lambda (w) w)))
(define ->widget widget/widget)
(define (%tk-really-destroy-widget handle)
;; Given a lowest-level TK handle or #F
(if handle (tk-op (lambda() (%TkDestroyWidget handle))))
'destroyed)
(define tk-widget-destroy
;; This will actually close the TK widget only if the wrapper isn't
;; already marked destroyed. But that should be OK -- we shouldn't
;; be able to find a wrapper that's destroyed if the contents
;; haven't been closed.
(wrap-with-SCXL-DESTROY! 1 0
(lambda (scxl-wrapped-widget)
(tk-op (lambda ()
(%tkDestroyWidget (->widget scxl-wrapped-widget)))))))
(define (tk-delete-display disp)
(tk-op (lambda () (%tkDeleteDisplay (->Xdisplay disp)))))
(define (tk-make-button drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeButton parent-tk-window real-name))))
(define (tk-make-canvas drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeCanvas parent-tk-window real-name))))
(define (tk-make-checkbutton drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeCheckButton parent-tk-window real-name))))
(define (tk-make-entry drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeEntry parent-tk-window real-name))))
(define (tk-make-label drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeLabel parent-tk-window real-name))))
(define (tk-make-listbox drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeListbox parent-tk-window real-name))))
(define (tk-make-menu drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeMenu parent-tk-window real-name))))
(define (tk-make-menubutton drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeMenuButton parent-tk-window real-name))))
(define (tk-make-message drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeMessage parent-tk-window real-name))))
(define (tk-make-radiobutton drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeRadioButton parent-tk-window real-name))))
(define (tk-make-scale drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeScale parent-tk-window real-name))))
(define (tk-make-scrollbar drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeScrollBar parent-tk-window real-name))))
(define (tk-make-text drawing-surface name)
(Wrap-TK-widget drawing-surface name
(lambda (parent-tk-window real-name)
(%tkMakeText parent-tk-window real-name))))
(define (initialize-mit-widgets!)
(set! display->tk-widgets '()))
(initialize-mit-widgets!)
|
