suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Carl Eastlund 2013-07-10 16:07:33 -04:00
parent 30a1c3565d
commit 704857bbfe
4 changed files with 106 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt
View File

@ -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)))

26
pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt
View File

@ -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))))

9
pkgs/racket-pkgs/racket-test/tests/generic/top-level.rkt
View File

@ -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

31
racket/lib/collects/racket/private/generic.rkt
View File

@ -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 ...)
(generate-temporaries #'(default-pred ...)))
(define/with-syntax (default-impl-name ...)
(generate-temporaries #'(default-pred ...)))
(define/with-syntax ([default-pred-name default-impl-name] ...)
(for/list ([pred-stx (in-list (syntax->list #'(default-pred ...)))]
[i (in-naturals 0)])
(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 ()