new test case based on bug

original commit: 0d5d3617188a016105d8b7039eaeb86b5f2ba779

collects/embedded-gui/private/tests/only-one-child.ss

@@ -0,0 +1,54 @@
+(require
+ (lib "mred.ss" "mred")
+ (lib "class.ss")
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "match.ss")
+ (prefix a: "../alignment.ss")
+ "../alignment-helpers.ss"
+ "../dllist.ss"
+ (lib "click-forwarding-editor.ss" "mrlib")
+ "../on-show-pasteboard.ss"
+ "../really-resized-pasteboard.ss"
+ "../interface.ss"
+ "../locked-pasteboard.ss"
+ "../suppress-modify-editor.ss")
+
+;;;;;;;;;;
+;; alignment
+
+(define (vert/horiz-alignment type)
+  (class* dllist% ()
+    
+    (init-field [parent #f])
+    
+    (field
+     [head (new head%)]
+     [tail (new tail%)])
+    
+    (send head next tail)
+    (send tail prev head)
+    
+    #;(((is-a?/c alignment<%>)) ((union (is-a?/c alignment<%>) false?)) . opt-> . void?)
+    ;; Add the given alignment as a child before the existing child
+    (define/public add-child
+      (opt-lambda (child (after #f))
+        (define (link p item n)
+          (send p next child)
+          (send child prev p)
+          (send n prev child)
+          (send child next n))
+        (if after
+            (link after child (send after next))
+            (link (send tail prev) child tail))))
+    
+    (super-new)
+    (when parent (send parent add-child this))))
+
+(define vertical-alignment% (vert/horiz-alignment 'vertical))
+(define horizontal-alignment% (vert/horiz-alignment 'horizontal))
+
+(let* ([interactions (new vertical-alignment% (parent (new vertical-alignment%)))])
+  (new horizontal-alignment% (parent interactions))
+  (new horizontal-alignment% (parent interactions))
+  `(equal? ,(length (send interactions map-to-list (lambda (x) x))) 2))