Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Exception handlers and dynamic exit traps for CHICKEN callback trampolines |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: | 59297e2f3f400f7d0bb3520c1df2aceb93791723 |
| User & Date: | murphy 2015-08-05 16:05:08 |
Context
|
2015-08-06
| ||
| 15:17 | Improved return value marshalling in CHICKEN callback wrapper check-in: ab22068543 user: murphy tags: trunk | |
|
2015-08-05
| ||
| 16:05 | Exception handlers and dynamic exit traps for CHICKEN callback trampolines check-in: 59297e2f3f user: murphy tags: trunk | |
| 15:23 | Somewhat more consistent names: background-box -> backgroundbox, detach-box -> detachbox, expander -> expandbox, scroll-box -> scrollbox check-in: a04b3fd0a4 user: murphy tags: trunk | |
Changes
Changes to chicken/iup-base.scm.
312 313 314 315 316 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 345 346 347 348 349 350 351 |
(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 #\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)]))] [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)])))) (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)] |
> > > > > > | < | > | | | | | | | | | | | | | | | > > | > > > | | | | | | | > |
312 313 314 315 316 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 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 |
(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);")) (call-with-current-continuation (lambda (return) (let ([sig "i"] [ret 'continue]) (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") (set! ret (apply proc args)))))) (lambda () (handle-exceptions exn (void) (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)])) (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)] |
Changes to chicken/iup-config.scm.
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
(foreign-safe-lambda void "IupConfigDialogClosed" nonnull-ihandle nonnull-ihandle nonnull-c-string))
;; }}}
;; {{{ Configured Recent Files
(define-external (recent_action_entry [ihandle handle]) istatus
(let ([action (cond [(and handle (parent handle)) => (cut callback <> 'action)])])
(if action
(action handle)
'continue)))
(define config-recent-menu
(make-constructor-procedure
(lambda (handle max-recent)
(let ([menu (foreign-value "IupMenu(NULL)" nonnull-ihandle)])
((foreign-lambda* void ([nonnull-ihandle handle] [nonnull-ihandle menu] [int max_recent])
"IupConfigRecentInit(handle, menu, recent_action_entry, max_recent);")
|
| | > > > > > > > > | < > > |
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
(foreign-safe-lambda void "IupConfigDialogClosed" nonnull-ihandle nonnull-ihandle nonnull-c-string))
;; }}}
;; {{{ Configured Recent Files
(define-external (recent_action_entry [ihandle handle]) istatus
(call-with-current-continuation
(lambda (return)
(let ([r 'continue])
(dynamic-wind
void
(lambda ()
(and-let* ([group (and handle (parent handle))]
[action (callback group 'action)])
(handle-exceptions exn
(print-error-message exn (current-error-port) "Error: in recent action callback")
(set! r (action handle)))))
(lambda ()
(return r)))))))
(define config-recent-menu
(make-constructor-procedure
(lambda (handle max-recent)
(let ([menu (foreign-value "IupMenu(NULL)" nonnull-ihandle)])
((foreign-lambda* void ([nonnull-ihandle handle] [nonnull-ihandle menu] [int max_recent])
"IupConfigRecentInit(handle, menu, recent_action_entry, max_recent);")
|