IUP

Check-in [4b6ca5be46]
Login

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

Overview
Comment:Allow callbacks to be retrieved without wrapper accumulation in the Racket binding
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 4b6ca5be46d9b3c89b45f45d14ce0f8e3eb33680
User & Date: murphy 2015-05-03 22:14:43
Context
2015-05-03
22:28
Corrected native menu constructor call in Racket binding check-in: b9de6e58fe user: murphy tags: trunk
22:14
Allow callbacks to be retrieved without wrapper accumulation in the Racket binding check-in: 4b6ca5be46 user: murphy tags: trunk
21:30
Corrected Ihandle_ field alignment problem in Racket binding check-in: 215c766d56 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to racket/base.rkt.

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
(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 ([callback (function-ptr callback (callback-type 'callback-set! handle name))])

        (registry-set! handle
          (cons
           callback
           (remove
            (set/pointer! handle name callback)


            (registry handle)
            ptr-equal?)))))))

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




          -> (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)







|
>


|
<
|
>
>
|
<







>
>
>
>
|







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
312
313
(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)