...

original commit: c6ffde3a099aa20db55015de41e9ec206da5fc60

collects/framework/exit.ss

@@ -3,36 +3,44 @@
 	  [gui-utils : framework:gui-utils^])
   (rename (-exit exit))
   
-  (define callbacks '())
+  (define can?-callbacks '())
+  (define on-callbacks '())
   
-  (define insert-callback
+  (define insert-can?-callback
     (lambda (cb)
-      (set! callbacks (cons cb callbacks))
+      (set! can?-callbacks (cons cb can?-callbacks))
       (lambda ()
-	(set! callbacks
-	      (let loop ([cb-list callbacks])
+	(set! can?-callbacks
+	      (let loop ([cb-list can?-callbacks])
 		(cond
 		  [(null? cb-list) ()]
 		  [(eq? cb (car cb-list)) (cdr cb-list)]
 		  [else (cons (car cb-list) (loop (cdr cb-list)))]))))))
+
+  (define insert-on-callback
+    (lambda (cb)
+      (set! on-callbacks (cons cb on-callbacks))
+      (lambda ()
+	(set! on-callbacks
+	      (let loop ([cb-list on-callbacks])
+		(cond
+		 [(null? cb-list) ()]
+		 [(eq? cb (car cb-list)) (cdr cb-list)]
+		 [else (cons (car cb-list) (loop (cdr cb-list)))]))))))
   
   (define exiting? #f)
 
-  (define run-callbacks
-    (lambda ()
-      (let loop ([cb-list callbacks])
-	    (cond
-	      [(null? cb-list) #t]
-	      [(not ((car cb-list))) #f]
-	      [else (loop (cdr cb-list))]))))
-  
+  (define (can-exit?) (andmap (lambda (cb) (cb)) can?-callbacks))
+  (define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks))
+
   (define -exit
     (opt-lambda ([just-ran-callbacks? #f])
       (unless exiting?
 	(dynamic-wind
 	 (lambda () (set! exiting? #t))
 	 (lambda ()
-	   (if (and (let*-values ([(w capw)
+	   (if (and (can-exit?)
+		    (let*-values ([(w capw)
 				   (if (eq? (system-type) 'windows)
 				       (values "exit" "Exit")
 				       (values "quit" "Quit"))]
@@ -40,13 +48,14 @@
 				   (string-append "Are you sure you want to "
 						  w
 						  "?")])
+		      (printf "showing dialog~n")
 		      (if (preferences:get 'framework:verify-exit)
 			  (if (gui-utils:get-choice message capw "Cancel")
-			      #t
-			      #f)
-			  #t))
-		    (or just-ran-callbacks?
-			(run-callbacks)))
-	       (exit)
+			      #f
+			      #t)
+			  #t)))
+	       (begin
+		 (on-exit)
+		 (printf "~a~n" '(exit)))
 	       #f))
 	 (lambda () (set! exiting? #f)))))))

collects/framework/finder.ss

@@ -247,7 +247,7 @@
 							   " already exists. "
 							   "Replace it?")
 							  #f
-							  'yes-no)
+							  '(yes-no))
 					     'yes))
 				    (let ([normal-path
 					   (with-handlers 

collects/framework/frameworks.ss

@@ -56,8 +56,9 @@
   (register))
 
 (define-signature framework:exit^
-  (insert-callback
-   run-callbacks
+  (insert-on-callback
+   insert-can?-callback
+   can-exit?
    exit))
 
 (define-signature framework:gui-utils^

collects/framework/group.ss

@@ -184,8 +184,9 @@
 	   (let/ec escape
 	     (for-each (lambda (f)
 			 (let ([frame (frame-frame f)])
-			   (if (send frame on-close)
-			       (send frame show #f)
+			   (if (send frame can-close?)
+			       (begin (send frame on-close)
+				      (send frame show #f))
 			       (escape #f))))
 		       frames)
 	     #t))]

collects/framework/main.ss

@@ -159,62 +159,67 @@
 	 (preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v)))
 	 main-panel))))
   
-  (preferences:read)
-  
   ;; groups
   
-  (define at-most-one-maker
-    (lambda ()
-      (let ([s (make-semaphore 1)]
-	    [test #f])
-	(lambda (return thunk)
-	  (semaphore-wait s)
-	  (if test
-	      (begin (semaphore-post s)
-		     return)
-	      (begin
-		(set! test #t)
-		(semaphore-post s)
-		(begin0 (thunk)
-			(semaphore-wait s)
-			(set! test #f)
-			(semaphore-post s))))))))
-  
   (preferences:set-default 'framework:exit-when-no-frames #t boolean?)
 
-  (let ([at-most-one (at-most-one-maker)])
+  (let ([at-most-one
+	 (let ([skip? #f])
+	   (lambda (answer thunk)
+	     (printf "at most one: skip? ~a~n" skip?)
+	     (if skip?
+		 answer
+		 (begin
+		   (set! skip? #t)
+		   (begin0 (thunk)
+			   (set! skip? #f))))))])
+
     (send (group:get-the-frame-group) set-empty-callbacks
+
+	  ;; empty test
+	  (lambda ()
+	    (printf "empty test~n")
+	    (begin0
+	     (if (preferences:get 'framework:exit-when-no-frames)
+		 (at-most-one #t
+			      (lambda ()
+				(printf "empty test.1~n")
+				(exit:can-exit?)))
+		 #t)
+	     (printf "empty test done~n")))
+
+	  ;; empty close down
 	  (lambda () 
+	    (printf "empty close down~n")
 	    (if (preferences:get 'framework:exit-when-no-frames)
 		(at-most-one (void) 
-			     (lambda () (exit:exit #t)))
-		(void)))
-	  (lambda ()
-	    (if (preferences:get 'framework:exit-when-no-frames)
-		(at-most-one #t
 			     (lambda ()
-			       (exit:run-callbacks)))
-		#t)))
+			       (printf "empty close down.1~n")
+			       (exit:exit)))
+		(void))))
     
-    (exit:insert-callback
+    (exit:insert-can?-callback
      (lambda ()
+       (printf "exit callback~n")
        (at-most-one
 	#t
 	(lambda ()
 	  (send (group:get-the-frame-group) close-all))))))
   
-  ;; misc other stuff
-  
-  (exit:insert-callback 
+  (exit:insert-on-callback 
    (lambda ()
-     (with-handlers ([(lambda (x) #t)
+     (with-handlers ([(lambda (x) (void))
 		      (lambda (exn)
 			(message-box
 			 "Saving Prefs"
 			 (format "Error saving preferences: ~a"
 				 (exn-message exn))))])
+       (printf "saving preferences~n")
        (preferences:save))))
   
   ;(wx:application-file-handler edit-file) ;; how to handle drag and drop?
 
+  (preferences:read)
+  (preferences:set 'framework:exit-when-no-frames #t)
+  
   (void))

collects/framework/panel.ss

@@ -17,7 +17,9 @@
 	       (set! current-active-child c)))]
        [container-size
 	(lambda (l)
-	  (values (apply max (map car l)) (apply max (map cadr l))))]
+	  (if (null? l)
+	      (values 0 0)
+	      (values (apply max (map car l)) (apply max (map cadr l)))))]
        [place-children
 	(lambda (l width height)
 	  (let-values ([(h-align-spec v-align-spec) (get-alignment)])