Differences From Artifact [a5eab89f2a]:

To Artifact [f43d2a041d]:


1
2
3

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45



1






























2
3
4
5
6
7
8
9
10
11
12
13
14
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-





+







(require-library
	lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex posix)

;; -*- mode: Scheme; tab-width: 2; -*- ;;
(module iup-base
	(ihandle->pointer pointer->ihandle ihandle-list->pointer-vector ihandle?
	 istatus->integer integer->istatus
	 iname->string string->iname
	 thread-watchdog iup-version load/led
	 attribute attribute-set! attribute-reset!
	 handle-name handle-name-set! handle-ref
	 main-loop main-loop-step main-loop-level main-loop-exit main-loop-flush
	 callback callback-set!
	 make-constructor-procedure optional-args
	 create destroy! map-peer! unmap-peer!
	 class-name class-type save-attributes!
	 parent parent-dialog sibling
	 child-add! child-remove! child-move!
	 child-ref child-pos child-count
	 :children children
	 refresh redraw
	 child-x/y->pos
	 show hide
	 dialog
	 fill hbox vbox zbox cbox sbox
	 radio normalizer split
	 image/palette image/rgb image/rgba image/file image-save
	 current-focus focus-next focus-previous
	 menu menu-item menu-separator
	 clipboard timer send-url)
	(import
		scheme chicken foreign
		lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex
		(only posix setenv))

;; {{{ Data types

(foreign-declare
	"#include <callback.h>\n"
	"#include <locale.h>\n"
	"#include <iup.h>\n"
	"#include <iupim.h>\n"
	"typedef struct Iclass_ Iclass;\n"
	"struct Ihandle_ { char sig[4]; Iclass *iclass; /* ... */ } ;\n"
	"extern char *iupClassCallbackGetFormat(Iclass *iclass, const char *name);\n")

(define *ihandle-tag* "Ihandle")
382
383
384
385
386
387
388
389

390
391
392
393
394
395
396
351
352
353
354
355
356
357

358
359
360
361
362
363
364
365







-
+







												 (error 'callback-set! "callback has bad signature" handle name)])]
					  			   [new
					  	        (cond
					  	        	[(or (not proc) (pointer? proc)) proc]
					  	        	[else (set-finalizer! (make-wrapper (cons sig proc)) wrapper-destroy!)])]
					  	       [old
					  	        (set/pointer! handle name new)])
								(registry-set! handle (cons new (remove! (cut pointer=? <> old) (registry handle))))))]
								(registry-set! handle (cons new ((if old (cut remove! (cut pointer=? <> old) <>) identity) (registry handle))))))]
					 [callback
					  (lambda (handle name)
					  	(let ([proc (get/pointer handle name)])
					  		(cond
					  			[(wrapper-data proc) => cdr]
					  			[else proc])))])
		(values
414
415
416
417
418
419
420
421

422
423
424
425
426
427
428
429

430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451


452
453
454
455
456
457
458
459

460
461
462

463
464
465
466
467
468
469
383
384
385
386
387
388
389

390
391
392
393
394
395
396
397

398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418


419
420
421
422
423
424
425
426
427

428
429
430

431
432
433
434
435
436
437
438







-
+







-
+




















-
-
+
+







-
+


-
+







           [handle-destroy!
            (foreign-lambda void "IupDestroy" nonnull-ihandle)])
    (lambda (handle)
      (registry-destroy/recursive! handle)
      (handle-destroy! handle))))

(define map-peer!
	(letrec ([map-peer/raw! (foreign-lambda istatus "IupMap" nonnull-ihandle)])
	(letrec ([map-peer/raw! (foreign-safe-lambda istatus "IupMap" nonnull-ihandle)])
		(lambda (handle)
			(let ([status (map-peer/raw! handle)])
				(case status
					[(#t) (void)]
					[else (error 'map-peer! (format "failed to map peer (~s)" status) handle)])))))

(define unmap-peer!
	(foreign-lambda void "IupUnmap" nonnull-ihandle))
	(foreign-safe-lambda void "IupUnmap" nonnull-ihandle))

(define class-name
	(foreign-lambda iname/downcase "IupGetClassName" nonnull-ihandle))

(define class-type
	(foreign-lambda iname/downcase "IupGetClassType" nonnull-ihandle))

(define save-attributes!
	(foreign-lambda void "IupSaveClassAttributes" nonnull-ihandle))

(define parent
	(foreign-lambda ihandle "IupGetParent" nonnull-ihandle))

(define parent-dialog
	(foreign-lambda ihandle "IupGetDialog" nonnull-ihandle))

(define sibling
	(foreign-lambda ihandle "IupGetBrother" nonnull-ihandle))

(define child-add!
  (letrec ([append! (foreign-lambda ihandle "IupAppend" nonnull-ihandle nonnull-ihandle)]
           [insert! (foreign-lambda ihandle "IupInsert" nonnull-ihandle nonnull-ihandle nonnull-ihandle)])
  (letrec ([append! (foreign-safe-lambda ihandle "IupAppend" nonnull-ihandle nonnull-ihandle)]
           [insert! (foreign-safe-lambda ihandle "IupInsert" nonnull-ihandle nonnull-ihandle nonnull-ihandle)])
    (lambda (child container #!optional [anchor #f])
      (or (if anchor
              (insert! container anchor child)
              (append! container child))
					(error 'child-add! "failed to add child" child container anchor)))))

(define child-remove!
	(foreign-lambda void "IupDetach" nonnull-ihandle))
	(foreign-safe-lambda void "IupDetach" nonnull-ihandle))

(define child-move!
	(letrec ([move! (foreign-lambda istatus "IupReparent" nonnull-ihandle nonnull-ihandle ihandle)])
	(letrec ([move! (foreign-safe-lambda istatus "IupReparent" nonnull-ihandle nonnull-ihandle ihandle)])
		(lambda (child parent #!optional ref-child)
			(let ([status (move! child parent ref-child)])
				(case status
					[(#t) (void)]
					[else (error 'child-move! (format "failed to move child (~s)" status) child parent)])))))

(define child-ref
675
676
677
678
679
680
681

682
683
684
685
686

687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
644
645
646
647
648
649
650
651
652
653
654


655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672









+



-
-
+

















-
-

;; }}}

;; {{{ The library watchdog

(define thread-watchdog
  (letrec ([open (foreign-lambda* istatus () "C_return(IupOpen(NULL, NULL));")]
					 [setlocale (foreign-lambda* void () "setlocale(LC_NUMERIC, \"C\");")]
           [open-imglib (foreign-lambda void "IupImageLibOpen")]
           [close (foreign-lambda void "IupClose")]
           [chicken-yield (foreign-value "&CHICKEN_yield" c-pointer)])
		(and-let* ([lang (or (getenv "LANG") "")]
               [(let ([status (dynamic-wind (cut setenv "LANG" "C") open (cut setenv "LANG" lang))])
		(and-let* ([(let ([status (dynamic-wind void open setlocale)])
    			        (case status
										[(#t)     #t]
										[(ignore) #f]
										[else     (error 'iup (format "failed to initialize library (~s)" status))]))]
      	       [(open-imglib)]
               [watchdog (timer)])
      (set-finalizer!
       watchdog
       (lambda (watchdog)
         (destroy! watchdog)
         (close)))
      (callback-set! watchdog 'action-cb chicken-yield)
      (attribute-set! watchdog 'time 500)
      (attribute-set! watchdog 'run #t)
      watchdog)))

;; }}}

)