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 Side-by-Side Diffs Ignore Whitespace Patch

Changes to racket/base.rkt.

   279    279   (define callback-set!
   280    280     (letrec ([set/pointer!
   281    281               (get-ffi-obj
   282    282                "IupSetCallback" libiup
   283    283                (_fun [handle : _ihandle] [name : _iname/upcase] [callback : _fpointer]
   284    284                      -> [callback : _fpointer]))])
   285    285       (λ (handle name callback)
   286         -      (let ([callback (function-ptr callback (callback-type 'callback-set! handle name))])
          286  +      (let* ([callback1 (function-ptr callback (callback-type 'callback-set! handle name))]
          287  +             [callback0 (set/pointer! handle name callback1)])
   287    288           (registry-set! handle
   288    289             (cons
   289         -           callback
   290         -           (remove
   291         -            (set/pointer! handle name callback)
   292         -            (registry handle)
   293         -            ptr-equal?)))))))
          290  +           (cons callback1 callback)
          291  +           ((if callback0
          292  +                (cute filter (λ (it) (not (ptr-equal? (car it) callback0))) <>)
          293  +                identity)
          294  +            (registry handle))))))))
   294    295   
   295    296   (define callback
   296    297     (getter-with-setter
   297    298      (get-ffi-obj
   298    299       "IupGetCallback" libiup
   299    300       (_fun [handle : _ihandle] [name : _iname/upcase]
   300    301             -> [callback : _fpointer]
   301         -          -> (cast callback _fpointer (callback-type 'callback handle name))))
          302  +          -> (cond
          303  +               [(assoc callback (registry handle) ptr-equal?)
          304  +                => cdr]
          305  +               [else
          306  +                (cast callback _fpointer (callback-type 'callback handle name))])))
   302    307      callback-set!))
   303    308   
   304    309   ;; Layout functions
   305    310   
   306    311   (define (make-constructor-procedure proc)
   307    312     (make-keyword-procedure
   308    313      (λ (keys key-args . pos-args)