From c9445d4215756c279881217b43d0479c38deb8d6 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 19 Oct 2014 21:22:42 -0400 Subject: gl: Properly undo state change caused by with-gl-bind-texture. * sly/wrappers/gl.scm (gl-current-texture): New procedure. (with-gl-bind-texture): Don't bind texture if already bound. Restore the previously bound texture after evaluating the body. --- sly/wrappers/gl.scm | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/sly/wrappers/gl.scm b/sly/wrappers/gl.scm index 4d5afcc..66b08cf 100644 --- a/sly/wrappers/gl.scm +++ b/sly/wrappers/gl.scm @@ -23,7 +23,11 @@ ;;; Code: (define-module (sly wrappers gl) + #:use-module (ice-9 match) + #:use-module (srfi srfi-4) + #:use-module ((system foreign) #:select (bytevector->pointer)) #:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%)) + #:use-module (gl enums) #:use-module (gl runtime) #:use-module (gl types)) @@ -68,13 +72,29 @@ (re-export (%glTexParameteri . gl-texture-parameter)) +(define gl-current-texture + (let ((binding-map (list (cons (texture-target texture-1d) + (get-p-name texture-binding-1d)) + (cons (texture-target texture-2d) + (get-p-name texture-binding-2d)) + (cons (texture-target texture-3d-ext) + (get-p-name texture-binding-3d))))) + (lambda (target) + "Return the id of the currently bound texture." + (let ((bv (make-s32vector 1))) + (%glGetIntegerv (assoc-ref binding-map target) + (bytevector->pointer bv)) + (s32vector-ref bv 0))))) + ;; emacs: (put 'with-gl-bind-texture 'scheme-indent-function 2) (define-syntax-rule (with-gl-bind-texture target id body ...) - (begin - (%glBindTexture target id) - body - ... - (%glBindTexture target 0))) + (let ((old-id (gl-current-texture target))) + (if (= id old-id) + (begin body ...) + (begin + (%glBindTexture target id) + body ... + (%glBindTexture target old-id))))) (export with-gl-bind-texture) -- cgit v1.2.3