File iup/iup-glcanvas.scm artifact eea8264eee part of check-in b1dcd0ebc6

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

;; }}}

)