first implementation of the record-type for widgets
This commit is contained in:
parent
1cd80a8dcf
commit
0418c393dd
|
@ -0,0 +1,55 @@
|
||||||
|
;--- the widget-datatype ---
|
||||||
|
|
||||||
|
;; the free-field in the record-type indicates whether the widget is alive or
|
||||||
|
;; not. It's set by a XtNdestroyCallback (see callback.c)
|
||||||
|
;; Is's neccessary to know if the XtWidged is still there or not.
|
||||||
|
|
||||||
|
(define-record-type widget :widget
|
||||||
|
(really-make-widget free Xwidget)
|
||||||
|
widget?
|
||||||
|
(free get-free set-free!)
|
||||||
|
(Xwidget real-widget-Xwidget widget-set-Xwidget!))
|
||||||
|
|
||||||
|
(define (widget-Xwidget widget)
|
||||||
|
(if (none-resource? widget)
|
||||||
|
0
|
||||||
|
(real-widget-Xwidget widget)))
|
||||||
|
|
||||||
|
(define (make-widget XWidget)
|
||||||
|
(if (= 0 XWidget)
|
||||||
|
none-resource
|
||||||
|
(let ((maybe-widget (widget-list-find Xwidget)))
|
||||||
|
(if maybe-widget
|
||||||
|
maybe-widget
|
||||||
|
(let ((widget (really-make-widget #f Xwidget)))
|
||||||
|
(add-finalizer! widget finalize-widget)
|
||||||
|
(atom-list-set! Xwidget widget)
|
||||||
|
widget)))))
|
||||||
|
|
||||||
|
|
||||||
|
;; finalize-widget is called, when the garbage collector removes the last
|
||||||
|
;; reference to the widget from the heap. Then we can savely close the
|
||||||
|
;; widget and remove the weak-pointer from our list.
|
||||||
|
|
||||||
|
(define (finalize-widget widget)
|
||||||
|
(let ((Xwidget (widget-Xwidget widget)))
|
||||||
|
(widget-list-delete! Xwidget)))
|
||||||
|
|
||||||
|
|
||||||
|
;; All widget records need to be saved in a weak-list, to have only one record
|
||||||
|
;; for the same XLib widget
|
||||||
|
|
||||||
|
(define *weak-widget-list* (make-integer-table))
|
||||||
|
|
||||||
|
(define (atom-list-find Xwidget)
|
||||||
|
(let ((r (table-ref *weak-widget-list* Xwidget)))
|
||||||
|
(if r
|
||||||
|
(weak-pointer-ref r)
|
||||||
|
r)))
|
||||||
|
|
||||||
|
(define (widget-list-set! Xwidget widget)
|
||||||
|
(let ((p (make-weak-pointer widget)))
|
||||||
|
(table-set! *weak-widget-list* Xwidget p)))
|
||||||
|
|
||||||
|
(define (widget-list-delete! Xwidget)
|
||||||
|
(table-set! *weak-widget-list* Xwidget #f))
|
Loading…
Reference in New Issue