IUP

Check-in [ab22068543]
Login

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

Overview
Comment:Improved return value marshalling in CHICKEN callback wrapper
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:ab22068543c55fa2fb3f13ea5836d025fde46485
User & Date: murphy 2015-08-06 15:17:38
Context
2015-08-07
16:01
Flush the main loop after widget destruction before clearing the registry check-in: d42d57606e user: murphy tags: trunk
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
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to chicken/iup-base.scm.

314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
...
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
	(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)
................................................................................
														 [(#\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!







|







 







|
<
<
<
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>







314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
...
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
	(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? #f])
			 (dynamic-wind
				 void
				 (lambda ()
					 (let* ([data (registry-ref (pointer->address cid))]
									[proc (cdr data)])
						 (set! sig (car data))
						 (case (string-ref sig 0)
................................................................................
														 [(#\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!