Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Canvas pointer marshalling for callbacks |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: | fb90ae1afa4d3b0c41b84cc6f75c5ced3e8f1adb |
| User & Date: | murphy 2015-10-15 05:58:29 |
Context
|
2016-01-01
| ||
| 15:27 | Image loading from blobs / strings for CHICKEN check-in: f9c7269e5a user: murphy tags: trunk | |
|
2015-10-15
| ||
| 05:58 | Canvas pointer marshalling for callbacks check-in: fb90ae1afa user: murphy tags: trunk | |
|
2015-08-07
| ||
| 16:01 | Flush the main loop after widget destruction before clearing the registry check-in: d42d57606e user: murphy tags: trunk | |
Changes
Changes to chicken/iup-base.scm.
322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 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 |
(dynamic-wind void (lambda () (let* ([data (registry-ref (pointer->address cid))] [proc (cdr data)]) (set! sig (car 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 #\h) (frame-start/pointer! frame)]) (let ([args (list-ec (:string chr "h" (string-drop sig 1)) (case chr [(#\b) (frame-arg/ubyte! frame)] [(#\i) (frame-arg/int! frame)] [(#\f) (frame-arg/float! frame)] [(#\d) (frame-arg/double! frame)] [(#\s) (frame-arg/string! frame)] [(#\v) (frame-arg/pointer! frame)] [(#\h) (frame-arg/handle! frame)]))]) (handle-exceptions exn (print-error-message exn (current-error-port) "Error: in callback") (let ([ret (apply proc args)]) (case (string-ref sig 0) [(#\b) (frame-return/ubyte! frame ret)] [(#\i) (frame-return/status! frame ret)] [(#\f) (frame-return/float! frame ret)] [(#\d) (frame-return/double! frame ret)] [(#\v) (frame-return/pointer! frame ret)] [(#\h) (frame-return/handle! frame ret)]) (set! ret? #t)))))) (lambda () (unless ret? (case (string-ref sig 0) [(#\b) (frame-return/ubyte! frame 0)] [(#\i) (frame-return/status! frame 'continue)] [(#\f) (frame-return/float! frame 0.0)] [(#\d) (frame-return/double! frame 0.0)] [(#\v #\h) (frame-return/pointer! frame #f)])) (return (void)))))))) (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! (lambda (handle name proc) (let* ([sig (cond [(irregex-match sigils (or (signature/raw handle name) "")) => (lambda (groups) (string-append |
| | | | | | | | | | | | | | | | | | | | | | | | |
322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 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 |
(dynamic-wind void (lambda () (let* ([data (registry-ref (pointer->address cid))] [proc (cdr data)]) (set! sig (car 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 #\C #\h) (frame-start/pointer! frame)]) (let ([args (list-ec (:string chr "h" (string-drop sig 1)) (case chr [(#\b) (frame-arg/ubyte! frame)] [(#\i) (frame-arg/int! frame)] [(#\f) (frame-arg/float! frame)] [(#\d) (frame-arg/double! frame)] [(#\s) (frame-arg/string! frame)] [(#\v #\C) (frame-arg/pointer! frame)] [(#\h) (frame-arg/handle! frame)]))]) (handle-exceptions exn (print-error-message exn (current-error-port) "Error: in callback") (let ([ret (apply proc args)]) (case (string-ref sig 0) [(#\b) (frame-return/ubyte! frame ret)] [(#\i) (frame-return/status! frame ret)] [(#\f) (frame-return/float! frame ret)] [(#\d) (frame-return/double! frame ret)] [(#\v #\C) (frame-return/pointer! frame ret)] [(#\h) (frame-return/handle! frame ret)]) (set! ret? #t)))))) (lambda () (unless ret? (case (string-ref sig 0) [(#\b) (frame-return/ubyte! frame 0)] [(#\i) (frame-return/status! frame 'continue)] [(#\f) (frame-return/float! frame 0.0)] [(#\d) (frame-return/double! frame 0.0)] [(#\v #\C #\h) (frame-return/pointer! frame #f)])) (return (void)))))))) (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 "([bifdsvCh]*)(?:=([bifdvCh]))?")] [callback-set! (lambda (handle name proc) (let* ([sig (cond [(irregex-match sigils (or (signature/raw handle name) "")) => (lambda (groups) (string-append |