ADDED   iup/iup-base.scm
Index: iup/iup-base.scm
==================================================================
--- /dev/null
+++ iup/iup-base.scm
@@ -0,0 +1,705 @@
+(require-library
+	lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex posix)
+
+(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 <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")
+(define ihandle? (cut tagged-pointer? <> *ihandle-tag*))
+
+(define (ihandle->pointer nonnull?)
+	(if nonnull?
+		(lambda (handle)
+			(ensure ihandle? handle)
+			handle)
+		(lambda (handle)
+			(ensure (disjoin not ihandle?) handle)
+			handle)))
+
+(define (pointer->ihandle nonnull?)
+	(if nonnull?
+		(lambda (handle)
+			(ensure pointer? handle)
+			(tag-pointer handle *ihandle-tag*))
+		(lambda (handle)
+			(and handle (tag-pointer handle *ihandle-tag*)))))
+
+(define (ihandle-list->pointer-vector lst)
+	(let ([ptrs (make-pointer-vector (add1 (length lst)) #f)])
+		(do-ec (:list handle (index i) lst)
+			(begin
+				(ensure ihandle? handle)
+				(pointer-vector-set! ptrs i handle)))
+		ptrs))
+
+(define (istatus->integer status)
+	(case status
+		[(error)                 +1]
+		[(opened invalid ignore) -1]
+		[(default)               -2]
+		[(close #f)              -3]
+		[(continue)              -4]
+		[else                    (if (integer? status) status 0)]))
+
+(define (integer->istatus status)
+	(case status
+		[(+1) 'error]
+		[( 0) #t]
+		[(-1) 'ignore]
+		[(-2) 'default]
+		[(-3) #f]
+		[(-4) 'continue]
+		[else status]))
+
+(define (iname->string default-case)
+	(let ([change-case
+	       (case default-case
+	       	 [(upcase)   string-upcase]
+	       	 [(downcase) string-downcase]
+	       	 [else       (error 'iname->string "unsupported default case" default-case)])])
+		(lambda (name)
+			(cond
+				[(or (not name) (string? name))
+				 name]
+				[(symbol? name)
+				 (change-case (string-translate (symbol->string name) #\- #\_))]
+				[else
+				 (error 'iname->string "bad name" name)]))))
+
+(define (string->iname default-case)
+	(let ([specials
+	       (irregex
+	       	 (case default-case
+	       	 	 [(upcase)   "[-a-z]"]
+	       	 	 [(downcase) "[-A-Z]"]
+	       	 	 [else       (error 'string->iname "unsupported default case" default-case)]))])
+		(lambda (name)
+			(cond
+				[(or (not name) (irregex-search specials name))
+				 name]
+				[else
+				 (string->symbol (string-downcase (string-translate name #\_ #\-)))]))))
+
+(include "iup-types.scm")
+
+;; }}}
+
+;; {{{ Support macros and functions
+
+(define-syntax :children
+	(syntax-rules ()
+		[(:children cc child handle)
+		 (:do cc ([child (child-ref handle 0)]) child ((sibling child)))]))
+
+(define-syntax optional-args
+	(syntax-rules ()
+		[(optional-args [name default] ...)
+		 (lambda (args) (let-optionals args ([name default] ...) (list name ...)))]))
+
+(define ((make-constructor-procedure proc #!key [apply-args values]) . args)
+	(let more ([keys '()] [key-args '()] [pos-args '()] [rest args])
+		(cond
+			[(null? rest)
+			 (let ([handle (apply proc (apply-args (reverse! pos-args)))])
+			 	 (do-ec (:parallel (:list key keys) (:list arg key-args))
+			 	 	 ((if (procedure? arg) callback-set! attribute-set!) handle key arg))
+			 	 handle)]
+			[(keyword? (car rest))
+			 (more
+			 	 (cons (car rest) keys) (cons (cadr rest) key-args) pos-args
+			 	 (cddr rest))]
+			[else
+			 (more
+			 	 keys key-args (cons (car rest) pos-args)
+			 	 (cdr rest))])))
+
+;; }}}
+
+;; {{{ System functions
+
+(define iup-version
+	(foreign-lambda c-string "IupVersion"))
+
+(define load/led
+	(letrec ([load/raw (foreign-lambda c-string "IupLoad" c-string)])
+		(lambda (file)
+			(and-let* ([status (load/raw file)])
+				(error 'load/led status))
+			(void))))
+
+;; }}}
+
+;; {{{ Attribute functions
+
+(define attribute-set!
+  (letrec ([set/string! (foreign-safe-lambda void "IupStoreAttribute" ihandle iname/upcase c-string)]
+           [set/handle! (foreign-safe-lambda void "IupSetAttributeHandle" ihandle iname/upcase ihandle)])
+    (lambda (handle name value)
+    	(cond
+    		[(or (not value) (string? value))
+         (set/string! handle name value)]
+        [(ihandle? value)
+         (set/handle! handle name value)]
+        [(boolean? value)
+         (set/string! handle name (if value "YES" "NO"))]
+        [else
+         (set/string! handle name (->string value))]))))
+
+(define attribute-reset!
+	(foreign-safe-lambda void "IupResetAttribute" ihandle iname/upcase))
+
+(define attribute
+  (getter-with-setter
+  	(foreign-safe-lambda c-string "IupGetAttribute" ihandle iname/upcase)
+  	attribute-set!))
+
+(define handle-name-set!
+	(letrec ([handle-set! (foreign-lambda ihandle "IupSetHandle" iname/downcase ihandle)])
+		(lambda (handle name)
+			(handle-set! (or name (handle-name handle)) (and name handle)))))
+
+(define handle-name
+  (getter-with-setter
+  	(foreign-lambda iname/downcase "IupGetName" nonnull-ihandle)
+  	handle-name-set!))
+
+(define handle-ref
+	(foreign-lambda ihandle "IupGetHandle" iname/downcase))
+
+;; }}}
+
+;; {{{ Event functions
+
+(define main-loop
+	(letrec ([loop (foreign-safe-lambda istatus "IupMainLoop")])
+		(lambda ()
+			(let ([status (loop)])
+				(case status
+					[(#t) (void)]
+					[else (error 'main-loop (format "error in IUP main loop (~s)" status))])))))
+
+(define main-loop-step
+  (letrec ([loop-step (foreign-safe-lambda istatus "IupLoopStep")]
+           [loop-step/wait (foreign-safe-lambda istatus "IupLoopStepWait")])
+    (lambda (poll?)
+      (let ([status ((if poll? loop-step loop-step/wait))])
+        (case status
+          [(error) (error 'main-loop-step "error in IUP main loop")]
+          [else    status])))))
+
+(define main-loop-level
+	(foreign-lambda int "IupMainLoopLevel"))
+
+(define main-loop-exit
+	(foreign-lambda void "IupExitLoop"))
+
+(define main-loop-flush
+	(foreign-safe-lambda void "IupFlush"))
+
+(define-values (registry-set! registry registry-destroy!)
+  (letrec ([registry-cell-set!
+  					(foreign-lambda* void ([nonnull-ihandle handle] [c-pointer cell])
+  						"IupSetAttribute(handle, \"CHICKEN_REGISTRY\", cell);")]
+  				 [registry-cell
+  				  (foreign-lambda* c-pointer ([nonnull-ihandle handle])
+  				  	"C_return(IupGetAttribute(handle, \"CHICKEN_REGISTRY\"));")]
+  				 [make-immobile-cell
+  				  (foreign-lambda* nonnull-c-pointer ([scheme-object v])
+  				  	"void *cell = CHICKEN_new_gc_root();\n"
+  				  	"CHICKEN_gc_root_set(cell, v);\n"
+  				  	"C_return(cell);\n")]
+  				 [cell-destroy!
+  				  (foreign-lambda void "CHICKEN_delete_gc_root" nonnull-c-pointer)]
+  				 [cell-set!
+  				  (foreign-lambda void "CHICKEN_gc_root_set" nonnull-c-pointer scheme-object)]
+  				 [cell-ref
+  				  (foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer)])
+    (values
+     (lambda (handle value)
+       (cond
+         [(registry-cell handle) => (cut cell-set! <> value)]
+         [else (registry-cell-set! handle (make-immobile-cell value))]))
+     (lambda (handle)
+       (cond
+         [(registry-cell handle) => cell-ref]
+         [else '()]))
+     (lambda (handle)
+       (cond
+         [(registry-cell handle)
+          => (lambda (cell)
+               (registry-cell-set! handle #f)
+               (cell-destroy! cell))])))))
+
+(define-external (callback_entry [c-pointer cell] [c-pointer frame]) void
+	(define cell-ref
+		(foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer))
+	
+	(define frame-start/ubyte!
+		(foreign-lambda* void ([c-pointer frame]) "va_start_uchar((va_alist)frame);"))
+	(define frame-start/int!
+		(foreign-lambda* void ([c-pointer frame]) "va_start_int((va_alist)frame);"))
+	(define frame-start/float!
+		(foreign-lambda* void ([c-pointer frame]) "va_start_float((va_alist)frame);"))
+	(define frame-start/double!
+		(foreign-lambda* void ([c-pointer frame]) "va_start_double((va_alist)frame);"))
+	(define frame-start/pointer!
+		(foreign-lambda* void ([c-pointer frame]) "va_start_ptr((va_alist)frame, void *);"))
+	
+	(define frame-arg/ubyte!
+		(foreign-lambda* unsigned-byte ([c-pointer frame]) "C_return(va_arg_uchar((va_alist)frame));"))
+	(define frame-arg/int!
+		(foreign-lambda* int ([c-pointer frame]) "C_return(va_arg_int((va_alist)frame));"))
+	(define frame-arg/float!
+		(foreign-lambda* float ([c-pointer frame]) "C_return(va_arg_float((va_alist)frame));"))
+	(define frame-arg/double!
+		(foreign-lambda* double ([c-pointer frame]) "C_return(va_arg_double((va_alist)frame));"))
+	(define frame-arg/string!
+		(foreign-lambda* c-string ([c-pointer frame]) "C_return(va_arg_ptr((va_alist)frame, char *));"))
+	(define frame-arg/pointer!
+		(foreign-lambda* c-pointer ([c-pointer frame]) "C_return(va_arg_ptr((va_alist)frame, void *));"))
+	(define frame-arg/handle!
+		(foreign-lambda* ihandle ([c-pointer frame]) "C_return(va_arg_ptr((va_alist)frame, Ihandle *));"))
+	
+	(define frame-return/ubyte!
+		(foreign-lambda* void ([c-pointer frame] [unsigned-byte ret]) "va_return_uchar((va_alist)frame, ret);"))
+	;(define frame-return/int!
+	;	(foreign-lambda* void ([c-pointer frame] [int ret]) "va_return_int((va_alist)frame, ret);"))
+	(define frame-return/status!
+		(foreign-lambda* void ([c-pointer frame] [istatus ret]) "va_return_int((va_alist)frame, ret);"))
+	(define frame-return/float!
+		(foreign-lambda* void ([c-pointer frame] [float ret]) "va_return_float((va_alist)frame, ret);"))
+	(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 (cell-ref cell)]
+				 [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));")]
+					 [make-wrapper
+					  (foreign-lambda* c-pointer ([scheme-object v])
+					  	"void *cell = CHICKEN_new_gc_root();\n"
+					  	"CHICKEN_gc_root_set(cell, v);\n"
+					  	"C_return(alloc_callback(&callback_entry, cell));\n")]
+					 [wrapper-data
+	          (foreign-lambda* scheme-object ([c-pointer proc])
+	          	"C_return((proc && is_callback(proc) ? CHICKEN_gc_root_ref(callback_data(proc)) : C_SCHEME_FALSE));")]
+	         [wrapper-destroy!
+	          (foreign-lambda* void ([c-pointer proc])
+	          	"if (proc && is_callback(proc)) {\n"
+	          	"  CHICKEN_delete_gc_root(callback_data(proc));\n"
+	          	"  free_callback(proc);\n"
+	          	"}\n")]
+	         [wrapper->proc
+	          (lambda (signature proc)
+	          	(cond
+	          		[(wrapper-data proc) => cdr]
+	          		[else proc]))]
+					 [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
+																(or (irregex-match-substring groups 2) "i")
+																(irregex-match-substring groups 1)))]
+												[else
+												 (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))))))]
+					 [callback
+					  (lambda (handle name)
+					  	(let ([proc (get/pointer handle name)])
+					  		(cond
+					  			[(wrapper-data proc) => cdr]
+					  			[else proc])))])
+		(values
+			callback-set!
+			(getter-with-setter callback callback-set!))))
+
+;; }}}
+
+;; {{{ Layout functions
+
+(define create
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupCreate" iname/downcase)))
+
+(define destroy!
+  (letrec ([registry-destroy/recursive!
+            (lambda (handle)
+              (registry-destroy! handle)
+              (do-ec (:children child handle)
+                (registry-destroy/recursive! child)))]
+           [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)])
+		(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))
+
+(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)])
+    (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))
+
+(define child-move!
+	(letrec ([move! (foreign-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
+  (letrec ([ref/position (foreign-lambda ihandle "IupGetChild" nonnull-ihandle int)]
+           [ref/name (foreign-lambda ihandle "IupGetDialogChild" nonnull-ihandle iname/upcase)])
+    (lambda (container id)
+      ((if (integer? id) ref/position ref/name) container id))))
+
+(define child-pos
+	(letrec ([pos/raw (foreign-lambda int "IupGetChildPos" nonnull-ihandle nonnull-ihandle)])
+		(lambda (parent child)
+			(let ([pos (pos/raw parent child)])
+				(and (not (negative? pos)) pos)))))
+
+(define child-count
+	(foreign-lambda int "IupGetChildCount" nonnull-ihandle))
+
+(define (children handle)
+	(list-ec (:children child handle) child))
+
+(define refresh
+	(foreign-safe-lambda void "IupRefresh" nonnull-ihandle))
+
+(define redraw
+	(letrec ([update
+	          (foreign-safe-lambda* void ([nonnull-ihandle handle] [bool children])
+	          	"IupUpdate(handle); if (children) IupUpdateChildren(handle);")]
+	         [update/sync
+	          (foreign-safe-lambda void "IupRedraw" nonnull-ihandle bool)])
+	  (lambda (handle #!key [children? #f] [sync? #f])
+	  	((if sync? update/sync update) handle children?))))
+
+(define child-x/y->pos
+	(letrec ([x/y->pos/raw (foreign-lambda int "IupConvertXYToPos" nonnull-ihandle int int)])
+		(lambda (parent x y)
+			(let ([pos (x/y->pos/raw parent x y)])
+				(and (not (negative? pos)) pos)))))
+
+;; }}}
+
+;; {{{ Dialog functions
+
+(define show
+  (letrec ([position
+            (lambda (v)
+              (case v
+                [(center)           #xffff]
+                [(start top left)   #xfffe]
+                [(end bottom right) #xfffd]
+                [(mouse)            #xfffc]
+                [(parent-center)    #xfffa]
+                [(current)          #xfffb]
+                [else               v]))]
+           [popup (foreign-safe-lambda istatus "IupPopup" nonnull-ihandle int int)]
+           [show/x/y (foreign-safe-lambda istatus "IupShowXY" nonnull-ihandle int int)])
+    (lambda (handle #!key [x 'current] [y 'current] [modal? #f])
+      (let ([status ((if modal? popup show/x/y) handle (position x) (position y))])
+        (case status
+          [(error) (error 'show "failed to show" handle)]
+          [else    status])))))
+
+(define hide
+	(letrec ([hide/raw (foreign-safe-lambda istatus "IupHide" nonnull-ihandle)])
+		(lambda (handle)
+			(let ([status (hide/raw handle)])
+				(case status
+					[(#t) (void)]
+					[else (error 'hide (format "failed to hide (~s)" status) handle)])))))
+
+;; }}}
+
+;; {{{ Composition functions
+
+(define dialog
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupDialog" ihandle)))
+
+(define fill
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupFill")))
+
+(define hbox
+  (make-constructor-procedure
+  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupHboxv((Ihandle **)handles));")
+  	#:apply-args list))
+
+(define vbox
+  (make-constructor-procedure
+  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupVboxv((Ihandle **)handles));")
+  	#:apply-args list))
+
+(define zbox
+  (make-constructor-procedure
+  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupZboxv((Ihandle **)handles));")
+  	#:apply-args list))
+
+(define cbox
+  (make-constructor-procedure
+  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupCboxv((Ihandle **)handles));")
+  	#:apply-args list))
+
+(define sbox
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupSbox" ihandle)))
+
+(define radio
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupRadio" ihandle)))
+
+(define normalizer
+  (make-constructor-procedure
+  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupNormalizerv((Ihandle **)handles));")
+  	#:apply-args list))
+
+(define split
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupSplit" ihandle ihandle)))
+
+;; }}}
+
+;; {{{ Image resource functions
+
+(define image/palette
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupImage" int int blob)))
+
+(define image/rgb
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupImageRGB" int int blob)))
+
+(define image/rgba
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupImageRGBA" int int blob)))
+
+(define image/file
+	(letrec ([load-image (foreign-lambda ihandle "IupLoadImage" c-string)])
+		(make-constructor-procedure
+			(lambda (file)
+				(or (load-image file) (error 'image/file (attribute #f 'iupim-lasterror)))))))
+
+(define image-save
+	(letrec ([save-image (foreign-lambda bool "IupSaveImage" nonnull-ihandle c-string iname/upcase)])
+		(lambda (handle file format)
+			(unless (save-image handle file format)
+				(error 'image-save (attribute #f 'iupim-lasterror))))))
+
+;; }}}
+
+;; {{{ Focus functions
+
+(define current-focus
+  (letrec ([focus (foreign-safe-lambda ihandle "IupGetFocus")]
+           [focus-set! (foreign-safe-lambda ihandle "IupSetFocus" ihandle)]
+           [current-focus
+            (case-lambda
+              [()       (focus)]
+              [(handle) (focus-set! handle)])])
+    (getter-with-setter current-focus current-focus)))
+
+(define focus-next
+	(letrec ([focus-next/raw (foreign-safe-lambda ihandle "IupNextField" ihandle)])
+		(lambda (#!optional [handle (current-focus)])
+			(focus-next/raw handle))))
+
+(define focus-previous
+	(letrec ([focus-previous/raw (foreign-safe-lambda ihandle "IupPreviousField" ihandle)])
+		(lambda (#!optional [handle (current-focus)])
+			(focus-previous/raw handle))))
+
+;; }}}
+
+;; {{{ Menu functions
+
+(define menu
+  (make-constructor-procedure
+  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupMenuv((Ihandle **)handles));")
+  	#:apply-args list))
+
+(define menu-item
+  (letrec ([action-item (foreign-lambda nonnull-ihandle "IupItem" c-string iname/upcase)]
+           [submenu-item (foreign-lambda nonnull-ihandle "IupSubmenu" c-string ihandle)])
+    (make-constructor-procedure
+     (lambda (#!optional [title #f] [action/menu #f])
+       ((if (ihandle? action/menu) submenu-item action-item) title action/menu)))))
+
+(define menu-separator
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupSeparator")))
+
+;; }}}
+
+;; {{{ Miscellaneous resource functions
+
+(define clipboard
+	(make-constructor-procedure
+		(foreign-lambda nonnull-ihandle "IupClipboard")))
+
+(define timer
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupTimer")))
+
+(define send-url
+	(letrec ([send-url/raw (foreign-lambda int "IupHelp" c-string)])
+		(lambda (url)
+			(and-let* ([status (send-url/raw url)]
+			           [(not (= status 1))])
+			  (error 'send-url (format "failed to open URL (~s)" status) url))
+			(void))))
+
+;; }}}
+
+;; {{{ The library watchdog
+
+(define thread-watchdog
+  (letrec ([open (foreign-lambda* istatus () "C_return(IupOpen(NULL, NULL));")]
+           [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))])
+    			        (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)))
+
+;; }}}
+
+)

ADDED   iup/iup-controls.scm
Index: iup/iup-controls.scm
==================================================================
--- /dev/null
+++ iup/iup-controls.scm
@@ -0,0 +1,128 @@
+(require-library iup-base)
+
+(module iup-controls
+	(canvas
+	 frame tabs
+	 label button toggle
+	 spin spinbox valuator
+	 textbox listbox treebox
+	 progress-bar
+	 matrix cells
+	 color-bar color-browser
+	 dial)
+	(import
+		scheme chicken foreign
+		iup-base)
+
+;; {{{ Data types
+
+(foreign-declare
+	"#include <iup.h>\n"
+	"#include <iupcontrols.h>\n")
+	
+(include "iup-types.scm")
+
+;; }}}
+
+;; {{{ Standard controls
+
+(define canvas
+	(make-constructor-procedure
+		(foreign-lambda nonnull-ihandle "IupCanvas" iname/upcase)
+		#:apply-args (optional-args [action #f])))
+
+(define frame
+	(make-constructor-procedure
+		(foreign-lambda nonnull-ihandle "IupFrame" ihandle)
+		#:apply-args (optional-args [action #f])))
+
+(define tabs
+  (make-constructor-procedure
+  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles])
+  		"C_return(IupTabsv((Ihandle **)handles));")
+  	#:apply-args list))
+
+(define label
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupLabel" c-string)
+  	#:apply-args (optional-args [action #f])))
+
+(define button
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupButton" c-string iname/upcase)
+  	#:apply-args (optional-args [title #f] [action #f])))
+
+(define toggle
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupToggle" c-string iname/upcase)
+  	#:apply-args (optional-args [title #f] [action #f])))
+
+(define spin
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupSpin")))
+
+(define spinbox
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupSpinbox" ihandle)))
+
+(define valuator
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupVal" c-string)
+  	#:apply-args (optional-args [type "HORIZONTAL"])))
+
+(define textbox
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupText" iname/upcase)
+  	#:apply-args (optional-args [action #f])))
+
+(define listbox
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupList" iname/upcase)
+  	#:apply-args (optional-args [action #f])))
+
+(define treebox
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupTree")))
+
+(define progress-bar
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupProgressBar")))
+
+;; }}}
+
+;; {{{ Extended controls
+
+(define matrix
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupMatrix" iname/upcase)
+  	#:apply-args (optional-args [action #f])))
+
+(define cells
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupCells")))
+
+(define color-bar
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupColorbar")))
+
+(define color-browser
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupColorBrowser")))
+
+(define dial
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupDial" c-string)
+  	#:apply-args (optional-args [type "HORIZONTAL"])))
+
+;; }}}
+
+;; {{{ Library setup
+
+(let ([status (foreign-value "IupControlsOpen()" istatus)])
+	(case status
+		[(#t ignore) (void)]
+		[else        (error 'iup "failed to initialize library (~s)" status)]))
+
+;; }}}
+
+)

ADDED   iup/iup-dialogs.scm
Index: iup/iup-dialogs.scm
==================================================================
--- /dev/null
+++ iup/iup-dialogs.scm
@@ -0,0 +1,38 @@
+(require-library iup-base)
+
+(module iup-dialogs
+	(file-dialog message-dialog color-dialog font-dialog)
+	(import
+		scheme chicken foreign
+		iup-base)
+
+;; {{{ Data types
+
+(foreign-declare
+	"#include <iup.h>\n")
+	
+(include "iup-types.scm")
+
+;; }}}
+
+;; {{{ Standard dialogs
+
+(define file-dialog
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupFileDlg")))
+
+(define message-dialog
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupMessageDlg")))
+
+(define color-dialog
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupColorDlg")))
+
+(define font-dialog
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupFontDlg")))
+
+;; }}}
+
+)

ADDED   iup/iup-dynamic.scm
Index: iup/iup-dynamic.scm
==================================================================
--- /dev/null
+++ iup/iup-dynamic.scm
@@ -0,0 +1,12 @@
+(module iup-dynamic
+	(iup-available? iup-dynamic-require)
+	(import scheme chicken)
+
+(define (iup-dynamic-require sym)
+	(eval `(begin (require-extension iup) ,sym)))
+
+(define (iup-available?)
+	(condition-case ((iup-dynamic-require 'iup-version))
+		[(exn) #f]))
+
+)

ADDED   iup/iup-glcanvas.scm
Index: iup/iup-glcanvas.scm
==================================================================
--- /dev/null
+++ iup/iup-glcanvas.scm
@@ -0,0 +1,64 @@
+(require-library iup-base)
+
+(module iup-glcanvas
+	(glcanvas
+	 call-with-glcanvas glcanvas-is-current?
+	 glcanvas-palette-set! glcanvas-font-set!)
+	(import
+		scheme chicken foreign
+		iup-base)
+
+;; {{{ Data types
+
+(foreign-declare
+	"#include <iup.h>\n"
+	"#include <iupgl.h>\n")
+	
+(include "iup-types.scm")
+
+;; }}}
+
+;; {{{ GLCanvas control
+
+(define glcanvas
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupGLCanvas" iname/upcase)
+  	#:apply-args (optional-args [action #f])))
+
+;; }}}
+
+;; {{{ OpenGL context functions
+
+(define call-with-glcanvas
+  (letrec ([glcanvas-make-current (foreign-lambda void "IupGLMakeCurrent" nonnull-ihandle)]
+           [glcanvas-swap-buffers (foreign-lambda void "IupGLSwapBuffers" nonnull-ihandle)]
+           [glcanvas-wait (foreign-lambda void "IupGLWait" bool)])
+    (lambda (handle proc #!key [swap? #f] [sync? #f])
+      (dynamic-wind
+       (lambda ()
+         (glcanvas-make-current handle)
+         (when sync? (glcanvas-wait #f)))
+       (lambda ()
+         (proc handle))
+       (lambda ()
+         (when swap? (glcanvas-swap-buffers handle))
+         (when sync? (glcanvas-wait #t)))))))
+
+(define glcanvas-is-current?
+	(foreign-lambda bool "IupGLIsCurrent" nonnull-ihandle))
+
+(define glcanvas-palette-set!
+	(foreign-lambda void "IupGLPalette" nonnull-ihandle int float float float))
+
+(define glcanvas-font-set!
+	(foreign-lambda void "IupGLUseFont" nonnull-ihandle int int int))
+
+;; }}}
+
+;; {{{ Library setup
+
+(foreign-code "IupGLCanvasOpen();")
+
+;; }}}
+
+)

ADDED   iup/iup-pplot.scm
Index: iup/iup-pplot.scm
==================================================================
--- /dev/null
+++ iup/iup-pplot.scm
@@ -0,0 +1,77 @@
+(require-library iup-base)
+
+(module iup-pplot
+	(pplot
+	 call-with-pplot pplot-add!
+	 pplot-x/y->pixel-x/y
+	 pplot-paint-to)
+	(import
+		scheme chicken foreign
+		iup-base)
+
+;; {{{ Data types
+
+(foreign-declare
+	"#include <iup.h>\n"
+	"#include <iup_pplot.h>\n")
+	
+(include "iup-types.scm")
+
+;; }}}
+
+;; {{{ PPlot control
+
+(define pplot
+  (make-constructor-procedure
+  	(foreign-lambda nonnull-ihandle "IupPPlot")))
+
+;; }}}
+
+;; {{{ Plotting functions
+
+(define call-with-pplot
+  (letrec ([pplot-begin (foreign-lambda void "IupPPlotBegin" nonnull-ihandle bool)]
+           [pplot-end (foreign-lambda void "IupPPlotEnd" nonnull-ihandle)])
+    (lambda (handle proc #!key [x-string? #f])
+      (dynamic-wind
+       (lambda ()
+         (pplot-begin handle x-string?))
+       (lambda ()
+         (proc handle))
+       (lambda ()
+         (pplot-end handle))))))
+
+(define pplot-add!
+  (letrec ([append/real (foreign-lambda void "IupPPlotAdd" nonnull-ihandle float float)]
+           [append/string (foreign-lambda void "IupPPlotAddStr" nonnull-ihandle c-string float)]
+           [insert/real (foreign-lambda void "IupPPlotInsert" nonnull-ihandle int int float float)]
+           [insert/string (foreign-lambda void "IupPPlotInsertStr" nonnull-ihandle int int c-string float)]
+           [current-index (lambda (handle) (string->number (attribute handle 'current)))])
+    (lambda (handle x y #!optional [sample-index #f] [index #f])
+      (if (string? x)
+          (if index
+              (insert/string handle (or index (current-index handle)) sample-index x y)
+              (append/string handle x y))
+          (if index
+              (insert/real handle (or index (current-index handle)) sample-index x y)
+              (append/real handle x y))))))
+
+(define pplot-x/y->pixel-x/y
+	(letrec ([transform (foreign-lambda void "IupPPlotTransform" nonnull-ihandle float float (c-pointer int) (c-pointer int))])
+		(lambda (handle pplot-x pplot-y)
+			(let-location ([pixel-x int 0] [pixel-y int 0])
+				(transform handle pplot-x pplot-y (location pixel-x) (location pixel-y))
+				(values pixel-x pixel-y)))))
+
+(define pplot-paint-to
+	(foreign-lambda void "IupPPlotPaintTo" nonnull-ihandle nonnull-c-pointer))
+
+;; }}}
+
+;; {{{ Library setup
+
+(foreign-code "IupPPlotOpen();")
+
+;; }}}
+
+)

ADDED   iup/iup-types.scm
Index: iup/iup-types.scm
==================================================================
--- /dev/null
+++ iup/iup-types.scm
@@ -0,0 +1,22 @@
+(define-foreign-type ihandle (c-pointer "Ihandle")
+	(ihandle->pointer #f)
+	(pointer->ihandle #f))
+
+(define-foreign-type ihandle-list nonnull-pointer-vector
+	ihandle-list->pointer-vector)
+
+(define-foreign-type nonnull-ihandle (nonnull-c-pointer "Ihandle")
+	(ihandle->pointer #t)
+	(pointer->ihandle #t))
+
+(define-foreign-type istatus int
+	istatus->integer
+	integer->istatus)
+
+(define-foreign-type iname/upcase c-string
+	(iname->string 'upcase)
+	(string->iname 'upcase))
+
+(define-foreign-type iname/downcase c-string
+	(iname->string 'downcase)
+	(iname->string 'downcase))

ADDED   iup/iup.meta
Index: iup/iup.meta
==================================================================
--- /dev/null
+++ iup/iup.meta
@@ -0,0 +1,6 @@
+((category ui)
+ (license "BSD")
+ (author "Thomas Chust")
+ (synopsis "Bindings to the IUP GUI library")
+ (doc-from-wiki)
+ (needs srfi-42))

ADDED   iup/iup.scm
Index: iup/iup.scm
==================================================================
--- /dev/null
+++ iup/iup.scm
@@ -0,0 +1,13 @@
+(require-library iup-base iup-controls iup-dialogs)
+
+(module iup
+	()
+	(import scheme chicken)
+	(reexport
+		(except iup-base
+			ihandle->pointer pointer->ihandle ihandle-list->blob
+			istatus->integer integer->istatus
+			iname->string string->iname
+			make-constructor-procedure optional-args)
+		iup-controls
+		iup-dialogs))

ADDED   iup/iup.setup
Index: iup/iup.setup
==================================================================
--- /dev/null
+++ iup/iup.setup
@@ -0,0 +1,100 @@
+;; -*- mode: Scheme; tab-width: 2; -*- ;;
+(cond-expand
+ [no-library-checks
+	(define-syntax check-libraries
+		(syntax-rules ()
+			[(check-libraries [lib fun] ...)
+			 #t]))]
+ [else
+	(define-syntax check-libraries
+		(syntax-rules ()
+			[(check-libraries [lib fun] ...)
+			 (and (find-library lib fun) ...)]))])
+
+(if (check-libraries
+		  ["callback" "alloc_trampoline_r"]
+			["iup" "IupOpen"]
+			["iupim" "IupLoadImage"]
+			["iupimglib" "IupImageLibOpen"])
+	(begin
+		(compile -s -O2 -d1 "iup-base.scm" -j iup-base "-lcallback -liup -liupim -liupimglib")
+		(compile -c -O2 -d1 "iup-base.scm" -j iup-base -unit iup-base)
+		(compile -s -O2 -d0 "iup-base.import.scm")
+		
+		(install-extension
+		 'iup-base
+		 '("iup-base.so" "iup-base.o" "iup-base.import.so" "iup-types.scm")
+		 '((version 1.0.2)
+			 (static "iup-base.o")
+			 (static-options "-lcallback -liup -liupim -liupimglib")))
+		
+		(compile -s -O2 -d1 "iup-controls.scm" -j iup-controls "-liup -liupcontrols")
+		(compile -c -O2 -d1 "iup-controls.scm" -j iup-controls -unit iup-controls)
+		(compile -s -O2 -d0 "iup-controls.import.scm")
+		
+		(install-extension
+		 'iup-controls
+		 '("iup-controls.so" "iup-controls.o" "iup-controls.import.so")
+		 '((version 1.0.2)
+			 (static "iup-controls.o")
+			 (static-options "-liup -liupcontrols")))
+		
+		(compile -s -O2 -d1 "iup-dialogs.scm" -j iup-dialogs "-liup")
+		(compile -c -O2 -d1 "iup-dialogs.scm" -j iup-dialogs -unit iup-dialogs)
+		(compile -s -O2 -d0 "iup-dialogs.import.scm")
+		
+		(install-extension
+		 'iup-dialogs
+		 '("iup-dialogs.so" "iup-dialogs.o" "iup-dialogs.import.so")
+		 '((version 1.0.2)
+			 (static "iup-dialogs.o")
+			 (static-options "-liup")))
+		
+		(if (check-libraries ["iupgl" "IupGLCanvasOpen"])
+			(begin
+				(compile -s -O2 -d1 "iup-glcanvas.scm" -j iup-glcanvas "-liup -liupgl")
+				(compile -c -O2 -d1 "iup-glcanvas.scm" -j iup-glcanvas -unit iup-glcanvas)
+				(compile -s -O2 -d0 "iup-glcanvas.import.scm")
+				
+				(install-extension
+				 'iup-glcanvas
+				 '("iup-glcanvas.so" "iup-glcanvas.o" "iup-glcanvas.import.so")
+				 '((version 1.0.2)
+					 (static "iup-glcanvas.o")
+					 (static-options "-liup -liupgl"))))
+			(warning "IUP GLCanvas not found, some bindings cannot be compiled"))
+		
+		(if (check-libraries ["iup_pplot" "IupPPlotOpen"])
+			(begin
+				(compile -s -O2 -d1 "iup-pplot.scm" -j iup-pplot "-liup -liup_pplot")
+				(compile -c -O2 -d1 "iup-pplot.scm" -j iup-pplot -unit iup-pplot)
+				(compile -s -O2 -d0 "iup-pplot.import.scm")
+				
+				(install-extension
+				 'iup-pplot
+				 '("iup-pplot.so" "iup-pplot.o" "iup-pplot.import.so")
+				 '((version 1.0.2)
+					 (static "iup-pplot.o")
+					 (static-options "-liup -liup_pplot"))))
+			(warning "IUP PPlot not found, some bindings cannot be compiled"))
+		
+		(compile -s -O2 -d1 "iup.scm" -j iup)
+		(compile -c -O2 -d1 "iup.scm" -j iup -unit iup)
+		(compile -s -O2 -d0 "iup.import.scm")
+		
+		(install-extension
+		 'iup
+		 '("iup.so" "iup.o" "iup.import.so")
+		 '((version 1.0.2)
+			 (static "iup.o"))))
+	(warning "IUP or ffcall not found, none of the bindings can be compiled"))
+
+(compile -s -O2 -d1 "iup-dynamic.scm" -j iup-dynamic)
+(compile -c -O2 -d1 "iup-dynamic.scm" -j iup-dynamic -unit iup-dynamic)
+(compile -s -O2 -d0 "iup-dynamic.import.scm")
+
+(install-extension
+ 'iup-dynamic
+ '("iup-dynamic.so" "iup-dynamic.o" "iup-dynamic.import.so")
+ '((version 1.0.2)
+   (static "iup-dynamic.o")))

ADDED   iup/test.scm
Index: iup/test.scm
==================================================================
--- /dev/null
+++ iup/test.scm
@@ -0,0 +1,2 @@
+(let ([dlg (dialog #:title "Test" (button "Push me!" #:action print))]) 
+  (show dlg #:modal? #t))