gl-glxgears: Fix missing MAP event bug.

The MAP event was sometimes arriving before its handler was assigned,
leaving the animation thread to wait forever for the widget to be
mapped.  Fix this by moving the handler assignments to the
initialize-instance method.

The more common way to initialize a widget is in its fix-widget-
realize-callback.  Rename the "mapped?" slot "realized?".  Add an
unrealize-callback method to clear the "realized?" slot, just for
completeness.

Use (fresh-line) and "; glxgears: " consistently before the
asynchronous, running notes.

Also add some missing `free's to the primitive version: glxgears.scm.

diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm
index 4dad46c1b43166a8b6d9f8b562f79be69401ba55..4855a9122337b90d84bb3524a68aba425ef260a0 100644 (file)
--- a/src/gl/gl-glxgears.scm
+++ b/src/gl/gl-glxgears.scm
@@ -37,22 +37,7 @@ USA.
                          (/ flo:/ (null-value 1. single) (group left))))
 
 (define (make-glxgears-demo)
-  (let ((dev (make-glxgears-demo-device 400 400 "glxgears.scm")))
-    (set-gtk-widget-unrealize-callback! dev unrealize-callback)
-    (set-gtk-widget-draw-callback! dev draw-callback)
-    (set-fix-widget-map-handler! dev map-handler)
-    (set-fix-widget-unmap-handler! dev unmap-handler)
-    (set-fix-widget-enter-notify-handler! dev enter-notify-handler)
-    (set-fix-widget-leave-notify-handler! dev leave-notify-handler)
-    (set-fix-widget-focus-change-handler! dev focus-change-handler)
-    (set-fix-widget-visibility-notify-handler! dev visibility-notify-handler)
-    (set-fix-widget-key-press-handler! dev key-press-handler)
-    (set-fix-widget-motion-handler! dev motion-handler)
-    (set-fix-widget-button-handler! dev 'press button-handler)
-    (set-fix-widget-button-handler! dev 'release button-handler)
-    (set-fix-widget-button-handler! dev 'double-press button-handler)
-    (set-fix-widget-button-handler! dev 'triple-press button-handler)
-    dev))
+  (make-glxgears-demo-device 400 400 "gl-glxgears.scm"))
 
 (define (make-glxgears-demo-device width height title)
   (let ((window (gtk-window-new 'toplevel)))
@@ -75,7 +60,7 @@ USA.
   (gears define standard initial-value #f)
 
   (shape define standard initial-value '(0 . 0))
-  (mapped? define standard initial-value #f)
+  (realized? define standard initial-value #f)
   ;; This "visibility" slot was intended to reflect when my screen is
   ;; blanked, because the animation loop spins up to more than 300fps.
   ;; (Please help stop the spinning!)  Why so few visibility-notify
@@ -94,14 +79,34 @@ USA.
 
 (define-method initialize-instance ((widget <glxgears-demo>) width height)
   (call-next-method widget width height)
+  (set-gtk-widget-draw-callback! widget draw-callback)
+  (set-fix-widget-visibility-notify-handler! widget visibility-notify-handler)
+  (set-fix-widget-key-press-handler! widget key-press-handler)
+  (set-fix-widget-motion-handler! widget motion-handler)
+  (set-fix-widget-button-handler! widget 'press button-handler)
+  (set-fix-widget-button-handler! widget 'release button-handler)
+  (set-fix-widget-button-handler! widget 'double-press button-handler)
+  (set-fix-widget-button-handler! widget 'triple-press button-handler)
+
+  (set-fix-widget-enter-notify-handler! widget enter-notify-handler)
+  (set-fix-widget-leave-notify-handler! widget leave-notify-handler)
+  (set-fix-widget-focus-change-handler! widget focus-change-handler)
+
   (make-animation-thread widget))
 
 (define-method fix-widget-new-geometry-callback ((widget <glxgears-demo>))
-  (%trace "fix-widget-new-geometry-callback <glxgears-demo>")
+  (%trace "fix-widget-new-geometry-callback <glxgears-demo> "widget))
+
+(define-method fix-widget-realize-callback ((widget <glxgears-demo>))
+  (call-next-method widget)
+  (%trace "fix-widget-realize-callback <glxgears-demo> "widget)
+  (set-glxgears-demo-realized?! widget #t)
   (wake-animation-thread widget))
 
-(define (unrealize-callback widget)
-  (%trace "unrealize-callback "widget" "(gtk-widget-destroyed? widget))
+(define-method fix-widget-unrealize-callback ((widget <glxgears-demo>))
+  (call-next-method widget)
+  (%trace "fix-widget-unrealize-callback <glxgears-demo> "widget
+         " "(gtk-widget-destroyed? widget))
   ;; Is this necessary when the context is about to be (already?) destroyed?
   #;(let ((gears (glxgears-demo-gears widget)))
     (with-glx-widget widget
@@ -109,21 +114,12 @@ USA.
        (gl:delete-lists (car gears) 1)
        (gl:delete-lists (cadr gears) 1)
        (gl:delete-lists (caddr gears) 1))))
+  (set-glxgears-demo-realized?! widget #f)
   (halt-animation-thread widget))
 
 (define (draw-callback widget area)
-  (%trace "draw-callback "widget" "area))
-
-(define (map-handler widget)
-  (%trace "map-handler "widget)
-  (set-glxgears-demo-mapped?! widget #t)
-  (wake-animation-thread widget)
-  #f)
-
-(define (unmap-handler widget)
-  (%trace "unmap-handler "widget)
-  (set-glxgears-demo-mapped?! widget #f)
-  #f)
+  (%trace "draw-callback "widget" "area)
+  (wake-animation-thread widget))
 
 (define (enter-notify-handler widget)
   (%trace "enter-notify-handler "widget)
@@ -153,20 +149,20 @@ USA.
     ((#\a #\A)
      (if (glxgears-demo-animate? widget)
         (begin
-          (display "; glxgears: animation OFF\n")
+          (fresh-line) (display "; glxgears: animation OFF\n")
           (set-glxgears-demo-animate?! widget #f))
         (begin
-          (display "; glxgears: animation ON\n")
+          (fresh-line) (display "; glxgears: animation ON\n")
           (set-glxgears-demo-frame-count-start! widget #f)
           (set-glxgears-demo-animate?! widget #t)
           (wake-animation-thread widget))))
     ((#\i #\I)
      (if (glxgears-demo-report-fps? widget)
         (begin
-          (display "; glxgears: fps reporting OFF\n")
+          (fresh-line) (display "; glxgears: fps reporting OFF\n")
           (set-glxgears-demo-report-fps?! widget #f))
         (begin
-          (display "; glxgears: fps reporting ON\n")
+          (fresh-line) (display "; glxgears: fps reporting ON\n")
           (set-glxgears-demo-frame-count-start! widget #f)
           (set-glxgears-demo-report-fps?! widget #t))))           
     ((|Up|) (rotx! widget 5.) (wake-animation-thread widget))
@@ -202,11 +198,11 @@ USA.
                (%trace "animation thread started")
                (let loop ()
 
-                 ;; Sleep when not mapped?, not animate?, or obscured.
+                 ;; Sleep when not realized?, not animate?, or obscured.
                  (without-interrupts
                   (lambda ()
                     (let ((visibility (glxgears-demo-visibility widget)))
-                      (if (or (not (glxgears-demo-mapped? widget))
+                      (if (or (not (glxgears-demo-realized? widget))
                               (not (glxgears-demo-animate? widget))
                               (eq? 'OBSCURED visibility))
                           (begin
@@ -216,8 +212,8 @@ USA.
                             (suspend-current-thread)
                             (%trace "...awake!"))))))
 
-                 (if (not (glxgears-demo-mapped? widget))
-                     (%trace "not mapped!")
+                 (if (not (glxgears-demo-realized? widget))
+                     (%trace "not realized!")
                      (begin
                        ;; Init, if necessary.
                        (if (not (glxgears-demo-gears widget))
@@ -226,7 +222,7 @@ USA.
                        ;; Draw.
                        (draw-frame widget)))
                  (loop))))
-            (display "; glxgears: done\n")))))
+            (fresh-line) (display "; glxgears: done\n")))))
     (set-glxgears-demo-animation-thread! widget thread)
     thread))
 
@@ -278,6 +274,7 @@ USA.
                      (number->string (/ (round (* 10. n)) 10.)))
                    (define-integrable (%.3f n)
                      (number->string (/ (round (* 1000. n)) 1000.)))
+                   (fresh-line)
                    (for-each display (list "; glxgears: "count" frames"
                                            " in "(%.1f seconds)" seconds"
                                            " = "(%.3f fps)" FPS\n"))
@@ -533,7 +530,7 @@ USA.
 
 (define-integrable color flo:4d)
 
-(define %trace? #t)
+(define %trace? #f)
 
 (define-syntax %trace
   (syntax-rules ()

diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg
index 1e793719f2d37d84ac207877b7bee5f98c83c140..5d502622f544da6f85ac541481603cf0247457d6 100644 (file)
--- a/src/gl/gl.pkg
+++ b/src/gl/gl.pkg
@@ -91,8 +91,7 @@ USA.
          gtk-widget-destroy-callback)
   (import (gtk fix-layout)
          fix-rect-x fix-rect-y fix-rect-width fix-rect-height
-         fix-widget-geometry fix-widget-window
-         set-fix-widget-map-handler! set-fix-widget-unmap-handler!)
+         fix-widget-geometry fix-widget-window)
   (import (gtk)
          error-if-null
          gtk-window-new
@@ -130,24 +129,20 @@ USA.
   (import (gtk)
          gtk-widget-destroyed? gtk-widget-destroy
          gtk-widget-parent gtk-widget-show-all
+         set-gtk-widget-draw-callback!
          gtk-container-add gtk-container-set-border-width
          gtk-window-new gtk-window-set-opacity gtk-window-set-title
          set-gtk-window-delete-event-callback!
+         fix-widget-new-geometry-callback
+         fix-widget-realize-callback
+         fix-widget-unrealize-callback
          set-fix-widget-key-press-handler!
-         fix-widget-new-geometry-callback)
-
-  (import (gtk)
-         set-gtk-widget-draw-callback!
-         set-gtk-widget-unrealize-callback!
          set-fix-widget-button-handler!
          set-fix-widget-enter-notify-handler!
          set-fix-widget-focus-change-handler!
          set-fix-widget-leave-notify-handler!
-         set-fix-widget-map-handler!
          set-fix-widget-motion-handler!
-         set-fix-widget-unmap-handler!
          set-fix-widget-visibility-notify-handler!)
-
   (import (gtk fix-layout)
          fix-rect-width fix-rect-height
          fix-widget-geometry)

diff --git a/src/gl/glxgears.scm b/src/gl/glxgears.scm
index dac8a825c423181dd253e33d1cbe7ffe1dc48454..b63344109f87ca980a5f70eb7c8b76e2696ffa4b 100644 (file)
--- a/src/gl/glxgears.scm
+++ b/src/gl/glxgears.scm
@@ -445,6 +445,7 @@ USA.
                          mask          ;valuemask
                          attr)))
        (%trace ";XCreateWindow => "win"\n")
+       (free attr)
        (if fullscreen
            (no-border dpy win))
 
@@ -586,6 +587,7 @@ USA.
                    (let ((buffer (malloc 10 'char)))
                      (C-call "XLookupString" event buffer 10 0 0)
                      (let ((buffer0 (C-> buffer "char")))
+                       (free buffer)
                        (cond ((= buffer0 27)
                               ;; escape
                               'EXIT)