IUP

Check-in [fb90ae1afa]
Login

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

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