IUP

Check-in [59297e2f3f]
Login
Home Timeline Branches Tags Tickets Wiki

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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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);")

This page was generated in about 0.007s by Fossil 2.8 [f8d7f76bfd] 2019-02-20 15:01:32