.

original commit: df9db3ecf97c5f81e94992cd838c6c10c291b9a2

collects/mred/mred.ss

@@ -3946,7 +3946,7 @@
 		     label parent #f))))))
 
 (define check-box%
-  (class100 basic-control% (label parent callback [style null])
+  (class100 basic-control% (label parent callback [style null] [value #f])
     (sequence
       (let ([cwho '(constructor check-box)])
 	(check-label-string-or-bitmap cwho label)
@@ -3967,10 +3967,11 @@
 					     (mred->wx-container parent) (wrap-callback callback)
 					     label -1 -1 -1 -1 style))
 		       wx)
-		     label parent #f))))))
+		     label parent #f)))
+      (when value (set-value #t)))))
 
 (define radio-box%
-  (class100 basic-control% (label choices parent callback [style '(vertical)])
+  (class100 basic-control% (label choices parent callback [style '(vertical)] [selection 0])
     (private-field [chcs choices])
     (sequence 
       (let ([cwho '(constructor radio-box)])
@@ -3982,7 +3983,13 @@
 	(check-container-parent cwho parent)
 	(check-callback cwho callback)
 	(check-orientation cwho style)
-	(check-container-ready cwho parent)))
+	(check-non-negative-integer cwho selection)
+	(check-container-ready cwho parent)
+	(unless (< selection (length choices))
+	  (raise-mismatch-error (who->name cwho)
+				(format "initial selection is too large, given only ~a choices: "
+					(length choices))
+				selection))))
     (private-field
       [wx #f])
     (private
@@ -4026,7 +4033,9 @@
 					     (mred->wx-container parent) (wrap-callback callback)
 					     label -1 -1 -1 -1 chcs 0 style))
 		       wx)
-		     label parent #f))))))
+		     label parent #f)))
+      (when (positive? selection)
+	(set-selection selection)))))
 
 (define slider%
   (class100 basic-control% (label min-value max-value parent callback [init-value min-value] [style '(horizontal)])
@@ -4114,7 +4123,7 @@
 (define (-1=>false v) (if (negative? v) #f v))
 
 (define basic-list-control%
-  (class100* basic-control% (list-control<%>) (mk-wx label parent)
+  (class100* basic-control% (list-control<%>) (mk-wx label parent selection)
     (public
       [append (entry-point (lambda (i) (send wx append i)))]
       [clear (entry-point (lambda () (send wx clear)))]
@@ -4145,7 +4154,9 @@
     (sequence
       (as-entry
        (lambda ()
-	 (super-init (lambda () (set! wx (mk-wx)) wx) label parent #f))))))
+	 (super-init (lambda () (set! wx (mk-wx)) wx) label parent #f)))
+      (when selection
+	(set-selection selection)))))
 
 (define (check-list-control-args cwho label choices parent callback)
   (check-label-string/false cwho label)
@@ -4154,25 +4165,39 @@
   (check-container-parent cwho parent)
   (check-callback cwho callback))
 
+(define (check-list-control-selection cwho choices selection)
+  (unless (< selection (length choices))
+    (raise-mismatch-error (who->name cwho)
+			  (format "initial selection is too large, given only ~a choices: "
+				  (length choices))
+			  selection)))
+
 (define choice%
-  (class100 basic-list-control% (label choices parent callback [style null])
+  (class100 basic-list-control% (label choices parent callback [style null] [selection 0])
     (sequence
       (let ([cwho '(constructor choice)])
 	(check-list-control-args cwho label choices parent callback)
 	(check-style cwho #f null style)
-	(check-container-ready cwho parent))
+	(check-non-negative-integer cwho selection)
+	(check-container-ready cwho parent)
+	(unless (= 0 selection)
+	  (check-list-control-selection cwho choices selection)))
       (super-init (lambda () (make-object wx-choice% this this
 					  (mred->wx-container parent) (wrap-callback callback)
 					  label -1 -1 -1 -1 choices style))
-		  label parent))))
+		  label parent 
+		  (and (positive? selection) selection)))))
 
 (define list-box%
-  (class100 basic-list-control% (label choices parent callback [style '(single)])
+  (class100 basic-list-control% (label choices parent callback [style '(single)] [selection 0])
     (sequence 
       (let ([cwho '(constructor list-box)])
 	(check-list-control-args cwho label choices parent callback)
 	(check-style cwho '(single multiple extended) null style)
-	(check-container-ready cwho parent)))
+	(check-non-negative-integer/false cwho selection)
+	(check-container-ready cwho parent)
+	(when selection
+	  (check-list-control-selection cwho choices selection))))
     (rename [super-append append])
     (override
       [append (entry-point
@@ -4232,7 +4257,7 @@
 					    label kind
 					    -1 -1 -1 -1 choices style)))
 		    wx)
-		  label parent))))
+		  label parent (and (pair? choices) selection)))))
 
 (define text-field%
   (class100* basic-control% () (label parent callback [init-value ""] [style '(single)])
@@ -5067,7 +5092,7 @@
       (super-init label #f parent callback shortcut help-string (lambda (x) x) demand-callback))))
 
 (define checkable-menu-item%
-  (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void])
+  (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void] [checked #f])
     (sequence
       (check-shortcut-args 'checkable-menu-item label parent callback shortcut help-string demand-callback))
     (private-field
@@ -5077,7 +5102,8 @@
       [check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))]
       [is-checked? (entry-point (lambda () (send (send (mred->wx mnu) get-container) checked? (send wx id))))])
     (sequence
-      (super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback))))
+      (super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback)
+      (when checked (check #t)))))
 
 (define menu-item-container<%> (interface () get-items on-demand))
 (define internal-menu<%> (interface ()))
@@ -6563,9 +6589,20 @@
 		      "real number in [0.0, 1.0]"
 		      x)))
 
+(define (-check-non-negative-integer who i false-ok?)
+  (when (or i (not false-ok?))
+    (unless (and (integer? i) (exact? i) (not (negative? i)))
+      (raise-type-error (who->name who) 
+			(if false-ok?
+			    "non-negative exact integeror #f" 
+			    "non-negative exact integer" )
+			i))))
+
 (define (check-non-negative-integer who i)
-  (unless (and (integer? i) (exact? i) (not (negative? i)))
+  (-check-non-negative-integer who i #f))
-    (raise-type-error (who->name who) "non-negative exact integer" i)))
+
+(define (check-non-negative-integer/false who i)
+  (-check-non-negative-integer who i #t))
 
 (define check-dimension (check-bounded-integer 0 10000 #t))
 (define check-non#f-dimension (check-bounded-integer 0 10000 #f))

collects/tests/mred/frame-steps.txt

@@ -52,10 +52,13 @@ Medium Frame should contain:
  V Gauge (a vertical slider)
  Text (a multi-line text field)
    initial & starting
+ A tab panel with two tabs
    
-The names on labels must match the above exactly (except that <>
+
-indicates an image). Watch out for letters that are dropped or
+The names on labels must match the above exactly, except that most
-&s that are dropped.
+labels have an "e" or "i" that gets an accent mark to test Latin-1
+labels. Also, <> above indicates an image. Watch out for letters that
+are dropped or &s that are dropped.
 
 Make sure all the controls with moving parts work.
 
@@ -273,5 +276,8 @@ Go back to the default configuration and try the 3 other combinations
 of label and button fonts. The big label font should apply to external
 control labels, and to message items. The button font should apply to
 the content of controls (names within a button, checkbox, listbox,
-choice, or text control).
+choice, or text control). The "Initially" radio box controls whether
-
+the control-containing panel is initially enabled (before the controls
+it contains are created). The "Selection" radio box controls the
+initial-value setting for check boxes, radio buttons, list boxes, and
+choices.

collects/tests/mred/item.ss

@@ -321,7 +321,7 @@
     (sequence
       (apply super-init name args))))
 
-(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy?)
+(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits?)
   
   (define return-bmp 
     (make-object bitmap% (icons-path "return.xbm") 'xbm))
@@ -367,11 +367,13 @@
   (define lb (make-object (trace-mixin list-box%)
 			  (if null-label? #f "L\355&st") ; 355 is i with '
 			  '("Appl\351" "Banana" "Coconut & Donuts" "Eclair" "French Fries" "Gatorade" "Huevos Rancheros") ; 351 is e with '
-			  ip void))
+			  ip void
+			  '(single)
+			  (if alt-inits? 2 #f)))
   
-  (define cb (make-object (trace-mixin check-box%) "C&h\351ck" ip void)) ; 351 is e with '
+  (define cb (make-object (trace-mixin check-box%) "C&h\351ck" ip void null alt-inits?)) ; 351 is e with '
   
-  (define icb (make-object (trace-mixin check-box%) mred-bmp ip void))
+  (define icb (make-object (trace-mixin check-box%) mred-bmp ip void null alt-inits?))
   
   (define rb (make-object (trace-mixin radio-box%)
 			  (if null-label? #f "R&ad\355o") ; 355 is i with '
@@ -379,7 +381,8 @@
 			  ip void 
 			  (if radio-h?
 			      '(horizontal)
-			      '(vertical))))
+			      '(vertical))
+			  (if alt-inits? 2 0)))
   
   (define irb (make-object (trace-mixin radio-box%)
 			   (if null-label? #f "Image Ra&dio")
@@ -387,12 +390,15 @@
 			    ip void 
 			    (if radio-h?
 				'(horizontal)
-				'(vertical))))
+				'(vertical))
+			  (if alt-inits? 1 0)))
   
   (define ch (make-object (trace-mixin choice%)
 			  (if null-label? #f "Ch&o\355ce") ; 355 is i with '
 			  '("Alpha" "Beta" "Gamma" "Delta & R\351st") ; 351 is e with '
-			  ip void))
+			  ip void
+			  null
+			  (if alt-inits? 3 0)))
   
   (define txt (make-object (trace-mixin text-field%)
 			   (if null-label? #f "T\351&xt") ; 351 is e with '
@@ -464,7 +470,7 @@
 	  items)))
 
 (define (big-frame h-radio? v-label? null-label? stretchy? special-label-font? special-button-font? 
-		   initially-disabled?)
+		   initially-disabled? alternate-init?)
   (define f (make-frame active-frame% "T\351ster")) ; 351 is e with '
   
   (define hp (make-object horizontal-panel% f))
@@ -505,7 +511,7 @@
   (when special-button-font?
     (send tp set-control-font special-font))
 
-  (let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy?)])
+  (let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init?)])
     (add-focus-note f ep)
     (send f set-info ep)
     
@@ -516,7 +522,7 @@
   f)
 
 (define (med-frame plain-slider? label-h? null-label? stretchy? special-label-font? special-button-font?
-		   initially-disabled?)
+		   initially-disabled? alternate-init?)
   (define f2 (make-frame active-frame% "Tester2"))
 
   (define hp2 (make-object horizontal-panel% f2))
@@ -1953,10 +1959,13 @@
     (define enabled-radio
       (make-object radio-box% "Initially" '("Enabled" "Disabled")
 		   p1 void))
+    (define selection-radio
+      (make-object radio-box% "Selection" '("Default" "Alternate")
+		   p1 void))
     (define next-button
       (make-next-button p2 (list radio-h-radio label-h-radio label-null-radio 
 				 stretchy-radio label-font-radio button-font-radio
-				 enabled-radio)))
+				 enabled-radio selection-radio)))
     (define go-button
       (make-object button% (format "Make ~a Frame" size) p2
 		   (lambda (b e)
@@ -1967,7 +1976,8 @@
 		      (positive? (send stretchy-radio get-selection))
 		      (positive? (send label-font-radio get-selection))
 		      (positive? (send button-font-radio get-selection))
-		      (positive? (send enabled-radio get-selection))))))
+		      (positive? (send enabled-radio get-selection))
+		      (positive? (send selection-radio get-selection))))))
     #t))
 
 (make-selector-and-runner bp1 bp2 #t "Big" big-frame)