Fixed bugs related to define/generic and to define-generics at top-level.

Added tests using define/generic in both #:defaults and #:fallbacks, both inside
modules and at the top level.  Changed the implementation of define-generics so
that defaults and fallbacks come after method definitions so that define/generic
works properly.  Changed internal names to be created with format-id and
syntax-local-introduce rather than generate-temporaries so that they work at the
top level.

pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt

@@ -62,3 +62,56 @@
 
   (check-true (to-bool my-a))
   (check-false (to-bool my-b)))
+
+(define-generics nested-stream
+  (nested-stream-first  nested-stream)
+  (nested-stream-rest   nested-stream)
+  (nested-stream-empty? nested-stream)
+  #:defaults
+  ;; list of streams, yield elements of substreams
+  ([(lambda (los) (and (list? los) (andmap nested-stream? los)))
+    (define/generic super-first  nested-stream-first)
+    (define/generic super-rest   nested-stream-rest)
+    (define/generic super-empty? nested-stream-empty?)
+    (define (nested-stream-first los)
+      (when (stream-empty? los)
+        (error 'empty!))
+      (if (super-empty? (first los))
+          (super-first (rest los))
+          (super-first (first los))))
+    (define (nested-stream-rest los)
+      (when (stream-empty? los)
+        (error 'empty!))
+      (if (super-empty? (first los))
+          (super-rest (rest los))
+          (cons (super-rest (first los)) (rest los))))
+    (define (nested-stream-empty? los)
+      (or (empty? los)
+          (and (super-empty? (first los))
+               (super-empty? (rest los)))))]
+   ;; base case, flat list
+   [list?
+    (define nested-stream-first  first)
+    (define nested-stream-rest   rest)
+    (define nested-stream-empty? empty?)]))
+
+(module+ test
+  (define (nested-stream->list ns)
+    (if (nested-stream-empty? ns)
+        '()
+        (cons (nested-stream-first ns)
+              (nested-stream->list (nested-stream-rest ns)))))
+
+  (define ns1 '())
+  (define ns2 '(() ()))
+  (define ns3 '((1 2 3) (4 5 6)))
+  (define ns4 '((1 2 3) (4 5 6) ()))
+  (define ns5 '((1 (2 (3)) (4 (5 (6))))))
+  (define ns6 '(() (4 (5 (6)))))
+
+  (check-equal? (nested-stream->list ns1) '())
+  (check-equal? (nested-stream->list ns2) '())
+  (check-equal? (nested-stream->list ns3) '(1 2 3 4 5 6))
+  (check-equal? (nested-stream->list ns4) '(1 2 3 4 5 6))
+  (check-equal? (nested-stream->list ns5) '(1 2 3 4 5 6))
+  (check-equal? (nested-stream->list ns6) '(4 5 6)))

pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt

@@ -84,6 +84,29 @@
 (define (make-wrapped n)
   (wrapped n))
 
+(struct generic-wrapped [numeric]
+  #:transparent
+  #:methods gen:numeric
+  [(define/generic numeric-decrement decrement)
+   (define/generic numeric-zero? is-zero?)
+   (define/generic numeric-even? is-even?)
+   (define/generic numeric-odd? is-odd?)
+   (define (decrement n)
+     (generic-wrapped
+       (numeric-decrement
+         (generic-wrapped-numeric n))))
+   (define (is-zero? n)
+     (numeric-zero?
+       (generic-wrapped-numeric n)))
+   (define (is-even? n)
+     (numeric-even?
+       (generic-wrapped-numeric n)))
+   (define (is-odd? n)
+     (numeric-odd?
+       (generic-wrapped-numeric n)))])
+(define (make-generic-wrapped n)
+  (generic-wrapped (make-peano n)))
+
 (module+ test
   (require rackunit rackunit/text-ui)
 
@@ -106,4 +129,5 @@
       (tests "peano" make-peano)
       (tests "binary" make-binary)
       (tests "parity" make-parity)
-      (tests "wrapped" make-wrapped))))
+      (tests "wrapped" make-wrapped)
+      (tests "generic-wrapped" make-generic-wrapped))))

pkgs/racket-pkgs/racket-test/tests/generic/top-level.rkt

@@ -10,7 +10,14 @@
 (check-not-exn
  (λ ()
   (eval '(require racket/generic) ns)
-  (eval '(define-generics foobar [foo foobar a1]) ns)
+  (eval '(define-generics foobar [foo foobar a1] [bar foobar a1]
+           #:defaults ([keyword?
+                        (define/generic gbar bar)
+                        (define (bar foobar a1) (gbar a1 '#:dummy))])
+           #:fallbacks [(define/generic gfoo foo)
+                        (define (foo foobar a1) 'foo)
+                        (define (bar foobar a1) (gfoo a1 foobar))])
+        ns)
   (eval '(struct inst ()
                  ;; make sure `gen:foobar` doesn't cause an
                  ;; error here

racket/lib/collects/racket/private/generic.rkt

@@ -53,12 +53,21 @@
        (define/with-syntax [method-index ...] method-indices)
        (define/with-syntax contract-str
          (format "~s" (syntax-e #'predicate-name)))
-       (define/with-syntax (default-pred-name ...)
+       (define/with-syntax ([default-pred-name default-impl-name] ...)
-         (generate-temporaries #'(default-pred ...)))
+         (for/list ([pred-stx (in-list (syntax->list #'(default-pred ...)))]
-       (define/with-syntax (default-impl-name ...)
+                    [i (in-naturals 0)])
-         (generate-temporaries #'(default-pred ...)))
+           (list (format-id (syntax-local-introduce #'self-name)
+                            "~a-default-pred~a"
+                            #'self-name
+                            i)
+                 (format-id (syntax-local-introduce #'self-name)
+                            "~a-default-impl~a"
+                            #'self-name
+                            i))))
        (define/with-syntax fallback-name
-         (generate-temporary #'self-name))
+         (format-id (syntax-local-introduce #'self-name)
+                    "~a-fallback"
+                    #'self-name))
        #'(begin
            (define-syntax generic-name
              (make-generic-info (quote-syntax property-name)
@@ -88,11 +97,6 @@
                [else (raise-argument-error who 'contract-str self-name)]))
            (define-values (default-pred-name ...)
              (values default-pred ...))
-           (define default-impl-name
-             (generic-method-table generic-name default-defn ...))
-           ...
-           (define fallback-name
-             (generic-method-table generic-name fallback-defn ...))
            (define-generic-support supported-name
                                    self-name
                                    [method-name ...]
@@ -105,7 +109,12 @@
              (or (vector-ref (table-name self-name 'method-name) 'method-index)
                  (vector-ref fallback-name 'method-index))
              original)
-           ...))]))
+           ...
+           (define default-impl-name
+             (generic-method-table generic-name default-defn ...))
+           ...
+           (define fallback-name
+             (generic-method-table generic-name fallback-defn ...))))]))
 
 (define-syntax (define-primitive-generics stx)
   (syntax-case stx ()