IUP

Check-in [8f6bdb17f4]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Use external callback registry - prevents attribute lookup chaining problems - creates fewer garbage collection roots
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 8f6bdb17f4ce3b828c416aac7a660a47b00bfde7
User & Date: murphy 2015-07-26 23:57:12
Context
2015-07-27
00:01
Bumped version to 1.7.0 check-in: d10d3a9ff4 user: murphy tags: trunk, v1.7.0
2015-07-26
23:57
Use external callback registry - prevents attribute lookup chaining problems - creates fewer garbage collection roots check-in: 8f6bdb17f4 user: murphy tags: trunk
2015-07-25
14:29
Bindings for GridBox constructor check-in: ef300926a4 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to chicken/iup-base.scm.

200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228

229
230
231
232

233
234
235
236
237
238

239
240
241
242
243
244
245
(define main-loop-exit
	(foreign-lambda void "IupExitLoop"))

(define main-loop-flush
	(foreign-safe-lambda void "IupFlush"))

(define-values (registry-set! registry registry-destroy!)
  (letrec ([registry-cell-set!
  					(foreign-lambda* void ([nonnull-ihandle handle] [c-pointer cell])
  						"IupSetAttribute(handle, \"CHICKEN_REGISTRY\", cell);")]
  				 [registry-cell
  				  (foreign-lambda* c-pointer ([nonnull-ihandle handle])
  				  	"C_return(IupGetAttribute(handle, \"CHICKEN_REGISTRY\"));")]
  				 [make-immobile-cell
  				  (foreign-lambda* nonnull-c-pointer ([scheme-object v])
  				  	"void *cell = CHICKEN_new_gc_root();\n"
  				  	"CHICKEN_gc_root_set(cell, v);\n"
  				  	"C_return(cell);\n")]
  				 [cell-destroy!
  				  (foreign-lambda void "CHICKEN_delete_gc_root" nonnull-c-pointer)]
  				 [cell-set!
  				  (foreign-lambda void "CHICKEN_gc_root_set" nonnull-c-pointer scheme-object)]
  				 [cell-ref
  				  (foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer)])
    (values
     (lambda (handle value)
       (cond
         [(registry-cell handle) => (cut cell-set! <> value)]
         [else (registry-cell-set! handle (make-immobile-cell value))]))

     (lambda (handle)
       (cond
         [(registry-cell handle) => cell-ref]
         [else '()]))

     (lambda (handle)
       (cond
         [(registry-cell handle)
          => (lambda (cell)
               (registry-cell-set! handle #f)
               (cell-destroy! cell))])))))


(define-external (callback_entry [c-pointer cell] [c-pointer frame]) void
	(define cell-ref
		(foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer))
	
	(define frame-start/ubyte!
		(foreign-lambda* void ([c-pointer frame]) "va_start_uchar((va_alist)frame);"))







|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
>
|
<
<
<
>
|
<
<
<
<
<
>







200
201
202
203
204
205
206
207
















208
209



210
211



212
213





214
215
216
217
218
219
220
221
(define main-loop-exit
	(foreign-lambda void "IupExitLoop"))

(define main-loop-flush
	(foreign-safe-lambda void "IupFlush"))

(define-values (registry-set! registry registry-destroy!)
	(let ([registry (make-hash-table = number-hash)])
















		(values
		 (lambda (handle refs)



			 (hash-table-set! registry (pointer->address handle) refs))
		 (lambda (handle)



			 (hash-table-ref/default registry (pointer->address handle) '()))
		 (lambda (handle)





			 (hash-table-delete! registry (pointer->address handle))))))

(define-external (callback_entry [c-pointer cell] [c-pointer frame]) void
	(define cell-ref
		(foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer))
	
	(define frame-start/ubyte!
		(foreign-lambda* void ([c-pointer frame]) "va_start_uchar((va_alist)frame);"))

Changes to chicken/iup.scm.

1
2
3
4
5
6
7
8
9
10
11
..
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
;; -*- mode: Scheme; tab-width: 2; -*- ;;

(require-library
  lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex posix)

(module iup-base
	(ihandle->pointer pointer->ihandle ihandle-list->pointer-vector ihandle?
	 istatus->integer integer->istatus
	 iname->string string->iname
	 thread-watchdog iup-version load/led
	 attribute attribute-set! attribute-reset!
................................................................................
	 radio normalizer split
	 image/palette image/rgb image/rgba image/file image-save
	 current-focus focus-next focus-previous
	 menu menu-item menu-separator
	 clipboard timer send-url)
	(import
		scheme chicken foreign
		lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex
		(only posix setenv))
	(include "iup-base.scm"))

(module iup-controls
	(canvas
	 frame tabs
	 label link button toggle



|







 







|







1
2
3
4
5
6
7
8
9
10
11
..
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
;; -*- mode: Scheme; tab-width: 2; -*- ;;

(require-library
  lolevel data-structures extras srfi-1 srfi-13 srfi-42 srfi-69 irregex posix)

(module iup-base
	(ihandle->pointer pointer->ihandle ihandle-list->pointer-vector ihandle?
	 istatus->integer integer->istatus
	 iname->string string->iname
	 thread-watchdog iup-version load/led
	 attribute attribute-set! attribute-reset!
................................................................................
	 radio normalizer split
	 image/palette image/rgb image/rgba image/file image-save
	 current-focus focus-next focus-previous
	 menu menu-item menu-separator
	 clipboard timer send-url)
	(import
		scheme chicken foreign
		lolevel data-structures extras srfi-1 srfi-13 srfi-42 srfi-69 irregex
		(only posix setenv))
	(include "iup-base.scm"))

(module iup-controls
	(canvas
	 frame tabs
	 label link button toggle

Changes to racket/base.rkt.

2
3
4
5
6
7
8




9
10
11
12
13
14
15
...
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277



278
279
280
281
282
283
284
(require
 srfi/2
 srfi/17
 srfi/26
 ffi/unsafe)

;; Data types





(define-cpointer-type _ihandle)

(define _istatus
  (make-ctype
   _int
   (λ (status)
................................................................................
                     #:keep #f)])
              (hash-set! type-cache signature type)
              type)]
           [_
            (error location "bad callback signature ~e" signature)]))))))

(define-values (registry-set! registry registry-destroy!)
  (letrec ([registry-cell-set!
            (get-ffi-obj
             "IupSetAttribute" libiup
             (_fun [handle : _ihandle] [name : _string/utf-8 = "RACKET_REGISTRY"] [cell : _pointer]
                   -> _void))]
           [registry-cell
            (get-ffi-obj
             "IupGetAttribute" libiup
             (_fun [handle : _ihandle] [name : _string/utf-8 = "RACKET_REGISTRY"]
                   -> [cell : _pointer]))])
    (values
     (λ (handle value)
       (cond
         [(registry-cell handle) => (cut ptr-set! <> _racket value)]
         [else (registry-cell-set! handle (malloc-immobile-cell value))]))
     (λ (handle)
       (cond
         [(registry-cell handle) => (cut ptr-ref <> _racket)]
         [else null]))
     (λ (handle)
       (cond
         [(registry-cell handle)
          => (λ (cell)
               (registry-cell-set! handle #f)
               (free-immobile-cell cell))])))))




(define callback-set!
  (letrec ([set/pointer!
            (get-ffi-obj
             "IupSetCallback" libiup
             (_fun [handle : _ihandle] [name : _iname/upcase] [callback : _fpointer]
                   -> [callback : _fpointer]))])







>
>
>
>







 







|
<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
>







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
250
251
252
253
254
255
256
257









258














259
260
261
262
263
264
265
266
267
268
(require
 srfi/2
 srfi/17
 srfi/26
 ffi/unsafe)

;; Data types

(define-custom-hash-types ptr-hash
  #:key? cpointer?
  ptr-equal?)

(define-cpointer-type _ihandle)

(define _istatus
  (make-ctype
   _int
   (λ (status)
................................................................................
                     #:keep #f)])
              (hash-set! type-cache signature type)
              type)]
           [_
            (error location "bad callback signature ~e" signature)]))))))

(define-values (registry-set! registry registry-destroy!)
  (let ([registry (make-weak-ptr-hash)])









    (values














     (cut dict-set! registry <> <>)
     (cut dict-ref registry <> null)
     (cut dict-remove! registry <>))))

(define callback-set!
  (letrec ([set/pointer!
            (get-ffi-obj
             "IupSetCallback" libiup
             (_fun [handle : _ihandle] [name : _iname/upcase] [callback : _fpointer]
                   -> [callback : _fpointer]))])