IUP

Check-in [371a59c42d]
Login

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

Overview
Comment:Improved callback handling and destructor safety
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 371a59c42d908fc3eee5c85696e7893fa3f3b9d8
User & Date: murphy 2015-08-03 12:41:02
Context
2015-08-04
16:59
Additional constructors: background-box detach-box expander scroll-box check-in: 4596413016 user: murphy tags: trunk
2015-08-03
12:41
Improved callback handling and destructor safety check-in: 371a59c42d user: murphy tags: trunk
2015-07-30
17:22
Added an accessor for user-defined attribute names check-in: c7c1c37d26 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to chicken/iup-base.scm.

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
...
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
...
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
...
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354


355
356
357
358
359
360
361
...
362
363
364
365
366
367
368
369
370

371
372
373

374
375
376
377

378

379
380
381
382
383
384
385

(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);"))
	(define frame-start/int!
		(foreign-lambda* void ([c-pointer frame]) "va_start_int((va_alist)frame);"))
	(define frame-start/float!
		(foreign-lambda* void ([c-pointer frame]) "va_start_float((va_alist)frame);"))
	(define frame-start/double!
................................................................................
	(define frame-return/double!
		(foreign-lambda* void ([c-pointer frame] [double ret]) "va_return_double((va_alist)frame, ret);"))
	(define frame-return/pointer!
		(foreign-lambda* void ([c-pointer frame] [c-pointer ret]) "va_return_ptr((va_alist)frame, void *, ret);"))
	(define frame-return/handle!
		(foreign-lambda* void ([c-pointer frame] [ihandle ret]) "va_return_ptr((va_alist)frame, Ihandle *, ret);"))
	
	(let* ([data (cell-ref cell)]
				 [sig (car data)]
				 [proc (cdr data)])
		(case (string-ref sig 0)
			[(#\b)     (frame-start/ubyte! frame)]
			[(#\i)     (frame-start/int! frame)]
			[(#\f)     (frame-start/float! frame)]
			[(#\d)     (frame-start/double! frame)]
................................................................................
				[(#\v) (frame-return/pointer! frame ret)]
				[(#\h) (frame-return/handle! frame ret)]))))

(define-values (callback-set! callback)
	(letrec ([signature/raw
						(foreign-lambda* c-string ([nonnull-ihandle handle] [iname/upcase name])
							"C_return(iupClassCallbackGetFormat(handle->iclass, name));")]
					 [make-wrapper
					  (foreign-lambda* c-pointer ([scheme-object v])
					  	"void *cell = CHICKEN_new_gc_root();\n"
					  	"CHICKEN_gc_root_set(cell, v);\n"
					  	"C_return(alloc_callback(&callback_entry, cell));\n")]
					 [wrapper-data
	          (foreign-lambda* scheme-object ([c-pointer proc])
	          	"C_return((proc && is_callback(proc) ? CHICKEN_gc_root_ref(callback_data(proc)) : C_SCHEME_FALSE));")]
	         [wrapper-destroy!
	          (foreign-lambda* void ([c-pointer proc])
	          	"if (proc && is_callback(proc)) {\n"
	          	"  CHICKEN_delete_gc_root(callback_data(proc));\n"
	          	"  free_callback(proc);\n"
	          	"}\n")]
	         [wrapper->proc
	          (lambda (signature proc)
	          	(cond
	          		[(wrapper-data proc) => cdr]
	          		[else proc]))]
					 [set/pointer!
					  (foreign-lambda c-pointer "IupSetCallback" nonnull-ihandle iname/upcase c-pointer)]
					 [get/pointer
					  (foreign-lambda c-pointer "IupGetCallback" nonnull-ihandle iname/upcase)]
					 [sigils
					  (irregex "([bifdsvh]*)(?:=([bifdvh]))?")]
					 [callback-set!
................................................................................
																(or (irregex-match-substring groups 2) "i")
																(irregex-match-substring groups 1)))]
												[else
												 (error 'callback-set! "callback has bad signature" handle name)])]
					  			   [new
					  	        (cond
					  	        	[(or (not proc) (pointer? proc)) proc]
					  	        	[else (set-finalizer! (make-wrapper (cons sig proc)) wrapper-destroy!)])]
					  	       [old
					  	        (set/pointer! handle name new)])
								(registry-set! handle (cons new ((if old (cut remove! (cut pointer=? <> old) <>) identity) (registry handle))))))]
					 [callback
					  (lambda (handle name)
					  	(let ([proc (get/pointer handle name)])
					  		(cond
					  			[(wrapper-data proc) => cdr]


					  			[else proc])))])
		(values
			callback-set!
			(getter-with-setter callback callback-set!))))

;; }}}

................................................................................
;; {{{ Layout functions

(define create
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupCreate" iname/downcase)))

(define destroy!
  (letrec ([registry-destroy/recursive!
            (lambda (handle)

              (registry-destroy! handle)
              (do-ec (:children child handle)
                (registry-destroy/recursive! child)))]

           [handle-destroy!
            (foreign-lambda void "IupDestroy" nonnull-ihandle)])
    (lambda (handle)
      (registry-destroy/recursive! handle)

      (handle-destroy! handle))))


(define map-peer!
	(letrec ([map-peer/raw! (foreign-safe-lambda istatus "IupMap" nonnull-ihandle)])
		(lambda (handle)
			(let ([status (map-peer/raw! handle)])
				(case status
					[(#t) (void)]







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>

>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
|
>
>
>
>
|
>
>
>

>
>
>
>
>
|
>

|
<
<
<







 







|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|
|
|
|




|
>
>







 







|
|
>
|
|
<
>

|

<
>
|
>







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
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
...
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
...
343
344
345
346
347
348
349



















350
351
352
353
354
355
356
...
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
...
388
389
390
391
392
393
394
395
396
397
398
399

400
401
402
403

404
405
406
407
408
409
410
411
412
413

(define main-loop-exit
	(foreign-lambda void "IupExitLoop"))

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

(define make-wrapper
	(let ([make-wrapper/data
				 (foreign-lambda* c-pointer ([c-pointer data])
					 "C_return(alloc_callback(&callback_entry, data));")])
		(lambda (id)
			(make-wrapper/data (address->pointer id)))))

(define wrapper-id
	(let ([wrapper-data
				 (foreign-lambda* c-pointer ([c-pointer proc])
					 "C_return((proc && is_callback(proc) ? callback_data(proc) : NULL));")])
		(lambda (proc)
			(cond
			 [(wrapper-data proc) => pointer->address]
			 [else #f]))))

(define wrapper-destroy!
	(foreign-lambda void "free_callback" c-pointer))

(define-values (registry-ref registry-add! registry-remove! registry-clear!)
	(let ([registry (make-hash-table = number-hash)]
				[id-range (fxshr most-positive-fixnum 1)])
		(values
		 (lambda (id)
			 (cdr (hash-table-ref registry id)))
		 (lambda (handle data)
			 (let retry ()
				 (let ([id (fxior (fxshl (random id-range) 1) 1)])
					 (if (hash-table-exists? registry id)
							 (retry)
							 (let ([proc (make-wrapper id)])
								 (hash-table-set!
									registry id
									(cons proc data))
								 (hash-table-update!/default
									registry (pointer->address handle)
									(cut cons id <>) '())
								 proc)))))
		 (lambda (handle proc)
			 (cond
				[(wrapper-id proc)
				 => (lambda (id)
							(hash-table-update!/default
							 registry (pointer->address handle)
							 (cut delete id <> =) '())
							(hash-table-delete! registry id)
							(wrapper-destroy! proc))]))
		 (lambda (handle)
			 (let* ([key (pointer->address handle)]
							[ids (hash-table-ref/default registry key '())])
				 (hash-table-delete! registry key)
				 (do-ec (:list id ids)
					 (let ([proc (car (hash-table-ref registry id))])
						 (hash-table-delete! registry id)
						 (wrapper-destroy! proc))))))))

(define-external (callback_entry [c-pointer cid] [c-pointer frame]) void



	(define frame-start/ubyte!
		(foreign-lambda* void ([c-pointer frame]) "va_start_uchar((va_alist)frame);"))
	(define frame-start/int!
		(foreign-lambda* void ([c-pointer frame]) "va_start_int((va_alist)frame);"))
	(define frame-start/float!
		(foreign-lambda* void ([c-pointer frame]) "va_start_float((va_alist)frame);"))
	(define frame-start/double!
................................................................................
	(define frame-return/double!
		(foreign-lambda* void ([c-pointer frame] [double ret]) "va_return_double((va_alist)frame, ret);"))
	(define frame-return/pointer!
		(foreign-lambda* void ([c-pointer frame] [c-pointer ret]) "va_return_ptr((va_alist)frame, void *, ret);"))
	(define frame-return/handle!
		(foreign-lambda* void ([c-pointer frame] [ihandle ret]) "va_return_ptr((va_alist)frame, Ihandle *, ret);"))
	
	(let* ([data (registry-ref (pointer->address cid))]
				 [sig (car data)]
				 [proc (cdr data)])
		(case (string-ref sig 0)
			[(#\b)     (frame-start/ubyte! frame)]
			[(#\i)     (frame-start/int! frame)]
			[(#\f)     (frame-start/float! frame)]
			[(#\d)     (frame-start/double! frame)]
................................................................................
				[(#\v) (frame-return/pointer! frame ret)]
				[(#\h) (frame-return/handle! frame ret)]))))

(define-values (callback-set! callback)
	(letrec ([signature/raw
						(foreign-lambda* c-string ([nonnull-ihandle handle] [iname/upcase name])
							"C_return(iupClassCallbackGetFormat(handle->iclass, name));")]



















					 [set/pointer!
					  (foreign-lambda c-pointer "IupSetCallback" nonnull-ihandle iname/upcase c-pointer)]
					 [get/pointer
					  (foreign-lambda c-pointer "IupGetCallback" nonnull-ihandle iname/upcase)]
					 [sigils
					  (irregex "([bifdsvh]*)(?:=([bifdvh]))?")]
					 [callback-set!
................................................................................
																(or (irregex-match-substring groups 2) "i")
																(irregex-match-substring groups 1)))]
												[else
												 (error 'callback-set! "callback has bad signature" handle name)])]
					  			   [new
					  	        (cond
					  	        	[(or (not proc) (pointer? proc)) proc]
					  	        	[else (registry-add! handle (cons sig proc))])])
								(cond
								 [(set/pointer! handle name new) =>
									(cut registry-remove! handle <>)])))]
					 [callback
					  (lambda (handle name)
					  	(let ([proc (get/pointer handle name)])
					  		(cond
					  			[(wrapper-id proc)
									 => (lambda (id)
												(cdr (registry-ref id)))]
					  			[else proc])))])
		(values
			callback-set!
			(getter-with-setter callback callback-set!))))

;; }}}

................................................................................
;; {{{ Layout functions

(define create
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupCreate" iname/downcase)))

(define destroy!
  (letrec ([collect-handles
            (lambda (handle acc)
							(cons
							 handle
							 (fold-ec acc (:children child handle)

								 child collect-handles)))]
           [handle-destroy!
            (foreign-safe-lambda void "IupDestroy" nonnull-ihandle)])
    (lambda (handle)

			(let ([handles (collect-handles handle '())])
				(handle-destroy! handle)
				(for-each registry-clear! handles)))))

(define map-peer!
	(letrec ([map-peer/raw! (foreign-safe-lambda istatus "IupMap" nonnull-ihandle)])
		(lambda (handle)
			(let ([status (map-peer/raw! handle)])
				(case status
					[(#t) (void)]

Changes to racket/base.rkt.

1
2

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
263
264
265
266
267
268
269
270
271

272
273
274
275











276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
...
318
319
320
321
322
323
324
325
326

327
328
329

330
331
332
333
334
335
336

337
338
339
340
341
342
343
#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)
     (case status
................................................................................
                     (char->type location return #f)
                     #: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]))])
    (λ (handle name callback)
      (let* ([callback1 (function-ptr callback (callback-type 'callback-set! handle name))]
             [callback0 (set/pointer! handle name callback1)])
        (registry-set! handle
          (cons
           (cons callback1 callback)
           ((if callback0
                (cute filter (λ (it) (not (ptr-equal? (car it) callback0))) <>)
                identity)
            (registry handle))))))))

(define callback
  (getter-with-setter
   (get-ffi-obj
    "IupGetCallback" libiup
    (_fun [handle : _ihandle] [name : _iname/upcase]
          -> [callback : _fpointer]
          -> (cond
               [(assoc callback (registry handle) ptr-equal?)
                => cdr]
               [else
                (cast callback _fpointer (callback-type 'callback handle name))])))
   callback-set!))

;; Layout functions

(define (make-constructor-procedure proc)
  (make-keyword-procedure
   (λ (keys key-args . pos-args)
................................................................................
  (make-constructor-procedure
   (get-ffi-obj
    "IupCreate" libiup
    (_fun [class : _iname/downcase] -> [handle : _ihandle/null]
          -> (or handle (error 'create "failed to create instance of ~e" class))))))

(define destroy!
  (letrec ([registry-destroy/recursive!
            (λ (handle)

              (registry-destroy! handle)
              (for ([child (in-children handle)])
                (registry-destroy/recursive! child)))]

           [handle-destroy!
            (get-ffi-obj
             "IupDestroy" libiup
             (_fun [handle : _ihandle] -> _void))])
    (λ (handle)
      (registry-destroy/recursive! handle)
      (handle-destroy! handle))))


(define map-peer!
  (get-ffi-obj
   "IupMap" libiup
   (_fun [handle : _ihandle] -> [status : _istatus]
         -> (case status
              [(#t) (void)]


>







<
<
<
<







 







|
|
>

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










<
<
|
<
<
<
<







|
<
<
<
|







 







|
|
>
|
|
<
>





|
|
>







1
2
3
4
5
6
7
8
9
10




11
12
13
14
15
16
17
...
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
285
286
287
288
289
290
291
292
293


294




295
296
297
298
299
300
301
302



303
304
305
306
307
308
309
310
...
317
318
319
320
321
322
323
324
325
326
327
328

329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
#lang racket
(require
 (only-in srfi/1 alist-cons alist-delete)
 srfi/2
 srfi/17
 srfi/26
 ffi/unsafe)

;; Data types





(define-cpointer-type _ihandle)

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

(define-values (registry-ref registry-update! registry-clear!)
  (let ([registry (make-hasheqv)]
        [ptr->address (cut cast <> _pointer _intptr)])
    (values

     (λ (handle callback0)
       (and-let* ([callbacks (hash-ref registry (ptr->address handle) #f)]
                  [callback (assoc callback0 callbacks ptr-equal?)])
         (cdr callback)))
     (λ (handle callback0 callback1 callback)
       (hash-update!
        registry (ptr->address handle)
        (λ (callbacks)
          (alist-cons callback1 callback (alist-delete callback0 callbacks ptr-equal?)))
        null))
     (λ (handle)
       (hash-remove!
        registry (ptr->address handle))))))

(define callback-set!
  (letrec ([set/pointer!
            (get-ffi-obj
             "IupSetCallback" libiup
             (_fun [handle : _ihandle] [name : _iname/upcase] [callback : _fpointer]
                   -> [callback : _fpointer]))])
    (λ (handle name callback)
      (let* ([callback1 (function-ptr callback (callback-type 'callback-set! handle name))]
             [callback0 (set/pointer! handle name callback1)])


        (registry-update! handle callback0 callback1 callback)))))





(define callback
  (getter-with-setter
   (get-ffi-obj
    "IupGetCallback" libiup
    (_fun [handle : _ihandle] [name : _iname/upcase]
          -> [callback : _fpointer]
          -> (or (registry-ref handle callback)



                 (cast callback _fpointer (callback-type 'callback handle name)))))
   callback-set!))

;; Layout functions

(define (make-constructor-procedure proc)
  (make-keyword-procedure
   (λ (keys key-args . pos-args)
................................................................................
  (make-constructor-procedure
   (get-ffi-obj
    "IupCreate" libiup
    (_fun [class : _iname/downcase] -> [handle : _ihandle/null]
          -> (or handle (error 'create "failed to create instance of ~e" class))))))

(define destroy!
  (letrec ([collect-handles
            (λ (handle acc)
              (cons
               handle
               (for/fold ([acc acc]) ([child (in-children handle)])

                 (collect-handles child acc))))]
           [handle-destroy!
            (get-ffi-obj
             "IupDestroy" libiup
             (_fun [handle : _ihandle] -> _void))])
    (λ (handle)
      (let ([handles (collect-handles handle null)])
        (handle-destroy! handle)
        (for-each registry-clear! handles)))))

(define map-peer!
  (get-ffi-obj
   "IupMap" libiup
   (_fun [handle : _ihandle] -> [status : _istatus]
         -> (case status
              [(#t) (void)]