IUP

Check-in [8f6bdb17f4]
Login
Home Timeline Branches Tags Tickets Wiki

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
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 8f6bdb17f4ce3b828c416aac7a660a47b00bfde7
User & Date: murphy 2015-07-26 23:57:12.573
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
Unified Diff 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

;; -*- 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!




|








1
2
3
4
5
6
7
8
9
10
11

;; -*- 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!
︙︙
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41

	 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








|








27
28
29
30
31
32
33
34
35
36
37
38
39
40
41

	 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. 
1
2
3
4
5
6
7
8




9
10
11
12
13
14
15

#lang racket
(require
 srfi/2
 srfi/17
 srfi/26
 ffi/unsafe)

;; Data types





(define-cpointer-type _ihandle)

(define _istatus
  (make-ctype
   _int
   (λ (status)









>
>
>
>








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

#lang racket
(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)
︙︙
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

                     #: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]))])








<
<
<
<
<
|
<
<
<
<

<
<
<
<
<
<
|
<
<
<
|
<
|
<








250
251
252
253
254
255
256





257




258






259



260

261

262
263
264
265
266
267
268

                     #: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]))])
︙︙
This page was generated in about 0.008s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32