fixed PR 10684 and fixed up some old, broken tests and fiddled with the test suite infrastructure
svn: r17536
This commit is contained in:
Robby Findler
parent
dc9f3227c5
commit
52eee4547b
|
|
@ -1,171 +1,161 @@
|
||||||
(module bitmap-test-util mzscheme
|
#lang scheme/gui
|
||||||
(require (lib "mred.ss" "mred")
|
(require framework
|
||||||
(lib "mrpict.ss" "texpict")
|
slideshow
|
||||||
(lib "framework.ss" "framework")
|
"../pict.ss"
|
||||||
(lib "class.ss")
|
"../reduction-semantics.ss"
|
||||||
"../pict.ss"
|
"config.ss")
|
||||||
"../reduction-semantics.ss")
|
|
||||||
|
|
||||||
(provide test done)
|
(provide test done)
|
||||||
|
|
||||||
(define-struct failed-test (panel))
|
(define tests 0)
|
||||||
|
(define failed '())
|
||||||
|
(define (done)
|
||||||
|
(printf "~a tests" tests)
|
||||||
|
(if (null? failed)
|
||||||
|
(printf ", all passed\n")
|
||||||
|
(printf ", ~a failed\n" (length failed))))
|
||||||
|
|
||||||
(define show-diffs?-env "PLT_REDEX_TEST_NOSHOW_DIFFS")
|
(define-syntax (test stx)
|
||||||
(define show-diffs? (not (getenv show-diffs?-env)))
|
(syntax-case stx ()
|
||||||
|
[(_ test-exp bitmap-filename)
|
||||||
|
#`(test/proc
|
||||||
|
#,(syntax-line stx)
|
||||||
|
test-exp
|
||||||
|
bitmap-filename)]))
|
||||||
|
|
||||||
(define tests 0)
|
(define (test/proc line-number pict raw-bitmap-filename)
|
||||||
(define failed '())
|
(set! tests (+ tests 1))
|
||||||
(define (done)
|
(let* ([bitmap-filename
|
||||||
(printf "~a tests" tests)
|
(build-path (format "bmps-~a" (system-type))
|
||||||
(if (null? failed)
|
(case (system-type)
|
||||||
(printf ", all passed\n")
|
[(unix) (string-append "unix-" raw-bitmap-filename)]
|
||||||
(printf ", ~a failed\n" (length failed))))
|
[else raw-bitmap-filename]))]
|
||||||
|
[old-bitmap (if (file-exists? bitmap-filename)
|
||||||
|
(make-object bitmap% bitmap-filename)
|
||||||
|
(let* ([bm (make-object bitmap% 100 20)]
|
||||||
|
[bdc (make-object bitmap-dc% bm)])
|
||||||
|
(send bdc clear)
|
||||||
|
(send bdc draw-text "does not exist" 0 0)
|
||||||
|
(send bdc set-bitmap #f)
|
||||||
|
bm))]
|
||||||
|
[new-bitmap (make-object bitmap%
|
||||||
|
(inexact->exact (pict-width pict))
|
||||||
|
(inexact->exact (pict-height pict)))]
|
||||||
|
[bdc (make-object bitmap-dc% new-bitmap)])
|
||||||
|
(send bdc clear)
|
||||||
|
(draw-pict pict bdc 0 0)
|
||||||
|
(send bdc set-bitmap #f)
|
||||||
|
(let ([diff-bitmap (compute-diffs old-bitmap new-bitmap)])
|
||||||
|
(when diff-bitmap
|
||||||
|
(let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)])
|
||||||
|
(set! failed (append failed (list failed-panel))))))))
|
||||||
|
|
||||||
(define-syntax (test stx)
|
(define (compute-diffs old-bitmap new-bitmap)
|
||||||
(syntax-case stx ()
|
(let* ([w (max (send old-bitmap get-width)
|
||||||
[(_ test-exp bitmap-filename)
|
(send new-bitmap get-width))]
|
||||||
#`(test/proc
|
[h (max (send old-bitmap get-height)
|
||||||
#,(syntax-line stx)
|
(send new-bitmap get-height))]
|
||||||
test-exp
|
[diff-bitmap (make-object bitmap% w h)]
|
||||||
bitmap-filename)]))
|
[new (make-object bitmap-dc% new-bitmap)]
|
||||||
|
[old (make-object bitmap-dc% old-bitmap)]
|
||||||
|
[diff (make-object bitmap-dc% diff-bitmap)]
|
||||||
|
[new-c (make-object color%)]
|
||||||
|
[old-c (make-object color%)]
|
||||||
|
[any-different? #f])
|
||||||
|
(let loop ([x 0])
|
||||||
|
(unless (= x w)
|
||||||
|
(let loop ([y 0])
|
||||||
|
(unless (= y h)
|
||||||
|
(cond
|
||||||
|
[(and (<= x (send new-bitmap get-width))
|
||||||
|
(<= y (send new-bitmap get-height))
|
||||||
|
(<= x (send old-bitmap get-width))
|
||||||
|
(<= y (send old-bitmap get-height)))
|
||||||
|
(send new get-pixel x y new-c)
|
||||||
|
(send old get-pixel x y old-c)
|
||||||
|
(cond
|
||||||
|
[(and (= (send new-c red) (send old-c red))
|
||||||
|
(= (send new-c green) (send old-c green))
|
||||||
|
(= (send new-c blue) (send old-c blue)))
|
||||||
|
(send diff set-pixel x y new-c)]
|
||||||
|
[else
|
||||||
|
(set! any-different? #t)
|
||||||
|
(send new-c set 255 0 0)
|
||||||
|
(send diff set-pixel x y new-c)])]
|
||||||
|
[else
|
||||||
|
(set! any-different? #t)
|
||||||
|
(send new-c set 255 0 0)
|
||||||
|
(send diff set-pixel x y new-c)])
|
||||||
|
(loop (+ y 1))))
|
||||||
|
(loop (+ x 1))))
|
||||||
|
(send diff set-bitmap #f)
|
||||||
|
(send old set-bitmap #f)
|
||||||
|
(send new set-bitmap #f)
|
||||||
|
(and any-different? diff-bitmap)))
|
||||||
|
|
||||||
(define (test/proc line-number pict raw-bitmap-filename)
|
(define test-result-single-panel #f)
|
||||||
(set! tests (+ tests 1))
|
(define (get-test-result-single-panel)
|
||||||
(let* ([bitmap-filename
|
(cond
|
||||||
(build-path "bmps"
|
[test-result-single-panel
|
||||||
(case (system-type)
|
test-result-single-panel]
|
||||||
[(unix) (string-append "unix-" raw-bitmap-filename)]
|
[else
|
||||||
[else raw-bitmap-filename]))]
|
(let ()
|
||||||
[old-bitmap (if (file-exists? bitmap-filename)
|
(define f (new frame% [label "bitmap-test.ss failures"]))
|
||||||
(make-object bitmap% bitmap-filename)
|
(define lined (new vertical-panel% [parent f] [style '(border)]))
|
||||||
(let* ([bm (make-object bitmap% 100 20)]
|
(define sp (new panel:single% [parent lined]))
|
||||||
[bdc (make-object bitmap-dc% bm)])
|
(define current-index 0)
|
||||||
(send bdc clear)
|
(define hp (new horizontal-panel% [parent f]))
|
||||||
(send bdc draw-text "does not exist" 0 0)
|
(define prev
|
||||||
(send bdc set-bitmap #f)
|
(new button%
|
||||||
bm))]
|
[label "Prev"]
|
||||||
[new-bitmap (make-object bitmap%
|
[parent hp]
|
||||||
(inexact->exact (pict-width pict))
|
[callback
|
||||||
(inexact->exact (pict-height pict)))]
|
(λ (x y)
|
||||||
[bdc (make-object bitmap-dc% new-bitmap)])
|
(set! current-index (modulo (- current-index 1) (length failed)))
|
||||||
(send bdc clear)
|
(update-gui))]))
|
||||||
(draw-pict pict bdc 0 0)
|
(define next (new button%
|
||||||
(send bdc set-bitmap #f)
|
[label "Next"]
|
||||||
(let ([diff-bitmap (compute-diffs old-bitmap new-bitmap)])
|
[parent hp]
|
||||||
(when diff-bitmap
|
[callback
|
||||||
(if show-diffs?
|
(λ (x y)
|
||||||
(let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)])
|
(set! current-index (modulo (+ current-index 1) (length failed)))
|
||||||
(set! failed (append failed (list (make-failed-test failed-panel)))))
|
(update-gui))]))
|
||||||
(set! failed (append failed (list #f))))))))
|
(define (update-gui)
|
||||||
|
(send sp active-child (list-ref failed current-index)))
|
||||||
|
(set! test-result-single-panel sp)
|
||||||
|
(when (get-show-bitmaps?) (send f show #t))
|
||||||
|
sp)]))
|
||||||
|
|
||||||
(define (compute-diffs old-bitmap new-bitmap)
|
(define (make-failed-panel line-number filename old-bitmap new-bitmap diff-bitmap)
|
||||||
(let* ([w (max (send old-bitmap get-width)
|
(define f (new vertical-panel% [parent (get-test-result-single-panel)]))
|
||||||
(send new-bitmap get-width))]
|
(define msg (new message% [label (format "line ~a" line-number)] [parent f]))
|
||||||
[h (max (send old-bitmap get-height)
|
(define hp (new horizontal-panel% [parent f]))
|
||||||
(send new-bitmap get-height))]
|
(define vp1 (new vertical-panel% [parent hp]))
|
||||||
[diff-bitmap (make-object bitmap% w h)]
|
(define vp2 (new vertical-panel% [parent hp]))
|
||||||
[new (make-object bitmap-dc% new-bitmap)]
|
(define chk (new check-box%
|
||||||
[old (make-object bitmap-dc% old-bitmap)]
|
[label "Show diff"]
|
||||||
[diff (make-object bitmap-dc% diff-bitmap)]
|
[parent f]
|
||||||
[new-c (make-object color%)]
|
[callback
|
||||||
[old-c (make-object color%)]
|
(λ (_1 _2)
|
||||||
[any-different? #f])
|
(cond
|
||||||
(let loop ([x 0])
|
[(send chk get-value)
|
||||||
(unless (= x w)
|
(send right-hand set-label diff-bitmap)]
|
||||||
(let loop ([y 0])
|
[else
|
||||||
(unless (= y h)
|
(send right-hand set-label new-bitmap)]))]))
|
||||||
(cond
|
(define btn (new button%
|
||||||
[(and (<= x (send new-bitmap get-width))
|
[parent f]
|
||||||
(<= y (send new-bitmap get-height))
|
[label "Save"]
|
||||||
(<= x (send old-bitmap get-width))
|
[callback
|
||||||
(<= y (send old-bitmap get-height)))
|
(λ (x y)
|
||||||
(send new get-pixel x y new-c)
|
(send new-bitmap save-file filename 'png))]))
|
||||||
(send old get-pixel x y old-c)
|
(define left-label (new message% [parent vp1] [label "Old"]))
|
||||||
(cond
|
(define left-hand (new message%
|
||||||
[(and (= (send new-c red) (send old-c red))
|
[parent vp1]
|
||||||
(= (send new-c green) (send old-c green))
|
[label diff-bitmap]))
|
||||||
(= (send new-c blue) (send old-c blue)))
|
(define right-label (new message% [parent vp2] [label "New"]))
|
||||||
(send diff set-pixel x y new-c)]
|
(define right-hand (new message%
|
||||||
[else
|
[parent vp2]
|
||||||
(set! any-different? #t)
|
[label diff-bitmap]))
|
||||||
(send new-c set 255 0 0)
|
(send left-hand set-label old-bitmap)
|
||||||
(send diff set-pixel x y new-c)])]
|
(send right-hand set-label new-bitmap)
|
||||||
[else
|
f)
|
||||||
(set! any-different? #t)
|
|
||||||
(send new-c set 255 0 0)
|
|
||||||
(send diff set-pixel x y new-c)])
|
|
||||||
(loop (+ y 1))))
|
|
||||||
(loop (+ x 1))))
|
|
||||||
(send diff set-bitmap #f)
|
|
||||||
(send old set-bitmap #f)
|
|
||||||
(send new set-bitmap #f)
|
|
||||||
(and any-different? diff-bitmap)))
|
|
||||||
|
|
||||||
(define test-result-single-panel #f)
|
|
||||||
(define (get-test-result-single-panel)
|
|
||||||
(cond
|
|
||||||
[test-result-single-panel
|
|
||||||
test-result-single-panel]
|
|
||||||
[else
|
|
||||||
(let ()
|
|
||||||
(define f (new frame% [label "bitmap-test.ss failures"]))
|
|
||||||
(define lined (new vertical-panel% [parent f] [style '(border)]))
|
|
||||||
(define sp (new panel:single% [parent lined]))
|
|
||||||
(define current-index 0)
|
|
||||||
(define hp (new horizontal-panel% [parent f]))
|
|
||||||
(define prev
|
|
||||||
(new button%
|
|
||||||
[label "Prev"]
|
|
||||||
[parent hp]
|
|
||||||
[callback
|
|
||||||
(λ (x y)
|
|
||||||
(set! current-index (modulo (- current-index 1) (length failed)))
|
|
||||||
(update-gui))]))
|
|
||||||
(define next (new button%
|
|
||||||
[label "Next"]
|
|
||||||
[parent hp]
|
|
||||||
[callback
|
|
||||||
(λ (x y)
|
|
||||||
(set! current-index (modulo (+ current-index 1) (length failed)))
|
|
||||||
(update-gui))]))
|
|
||||||
(define (update-gui)
|
|
||||||
(send sp active-child (failed-test-panel (list-ref failed current-index))))
|
|
||||||
(set! test-result-single-panel sp)
|
|
||||||
(send f show #t)
|
|
||||||
sp)]))
|
|
||||||
|
|
||||||
(define (make-failed-panel line-number filename old-bitmap new-bitmap diff-bitmap)
|
|
||||||
(define f (new vertical-panel% [parent (get-test-result-single-panel)]))
|
|
||||||
(define msg (new message% [label (format "line ~a" line-number)] [parent f]))
|
|
||||||
(define hp (new horizontal-panel% [parent f]))
|
|
||||||
(define vp1 (new vertical-panel% [parent hp]))
|
|
||||||
(define vp2 (new vertical-panel% [parent hp]))
|
|
||||||
(define chk (new check-box%
|
|
||||||
[label "Show diff"]
|
|
||||||
[parent f]
|
|
||||||
[callback
|
|
||||||
(λ (_1 _2)
|
|
||||||
(cond
|
|
||||||
[(send chk get-value)
|
|
||||||
(send chk set-label "Hide diff")
|
|
||||||
(send right-hand set-label diff-bitmap)]
|
|
||||||
[else
|
|
||||||
(send chk set-label "Show diff")
|
|
||||||
(send right-hand set-label new-bitmap)]))]))
|
|
||||||
(define btn (new button%
|
|
||||||
[parent f]
|
|
||||||
[label "Save"]
|
|
||||||
[callback
|
|
||||||
(λ (x y)
|
|
||||||
(send new-bitmap save-file filename 'png))]))
|
|
||||||
(define left-label (new message% [parent vp1] [label "Old"]))
|
|
||||||
(define left-hand (new message%
|
|
||||||
[parent vp1]
|
|
||||||
[label diff-bitmap]))
|
|
||||||
(define right-label (new message% [parent vp2] [label "New"]))
|
|
||||||
(define right-hand (new message%
|
|
||||||
[parent vp2]
|
|
||||||
[label diff-bitmap]))
|
|
||||||
(send left-hand set-label old-bitmap)
|
|
||||||
(send right-hand set-label new-bitmap)
|
|
||||||
f))
|
|
||||||
|
|
|
||||||
BIN
collects/redex/private/bmps-macosx/extended-language.png
Normal file
BIN
collects/redex/private/bmps-macosx/extended-language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.9 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 394 B |
BIN
collects/redex/private/bmps-macosx/language-nox.png
Normal file
BIN
collects/redex/private/bmps-macosx/language-nox.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.9 KiB |
BIN
collects/redex/private/bmps-macosx/language.png
Normal file
BIN
collects/redex/private/bmps-macosx/language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.9 KiB |
BIN
collects/redex/private/bmps-macosx/lw.png
Normal file
BIN
collects/redex/private/bmps-macosx/lw.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.2 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 4.7 KiB |
BIN
collects/redex/private/bmps-macosx/metafunction-Name.png
Normal file
BIN
collects/redex/private/bmps-macosx/metafunction-Name.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.3 KiB |
BIN
collects/redex/private/bmps-macosx/metafunction-T.png
Normal file
BIN
collects/redex/private/bmps-macosx/metafunction-T.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.6 KiB |
BIN
collects/redex/private/bmps-macosx/metafunction-TL.png
Normal file
BIN
collects/redex/private/bmps-macosx/metafunction-TL.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.6 KiB |
BIN
collects/redex/private/bmps-macosx/metafunction-multi-arg.png
Normal file
BIN
collects/redex/private/bmps-macosx/metafunction-multi-arg.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 8.3 KiB |
BIN
collects/redex/private/bmps-macosx/metafunction-subst.png
Normal file
BIN
collects/redex/private/bmps-macosx/metafunction-subst.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.3 KiB |
BIN
collects/redex/private/bmps-macosx/metafunction.png
Normal file
BIN
collects/redex/private/bmps-macosx/metafunction.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.1 KiB |
BIN
collects/redex/private/bmps-macosx/metafunctions-multiple.png
Normal file
BIN
collects/redex/private/bmps-macosx/metafunctions-multiple.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 9.1 KiB |
BIN
collects/redex/private/bmps-macosx/red2.png
Normal file
BIN
collects/redex/private/bmps-macosx/red2.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.1 KiB |
BIN
collects/redex/private/bmps-macosx/reduction-relation.png
Normal file
BIN
collects/redex/private/bmps-macosx/reduction-relation.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.8 KiB |
|
Before Width: | Height: | Size: 2.1 KiB After Width: | Height: | Size: 2.1 KiB |
|
Before Width: | Height: | Size: 507 B After Width: | Height: | Size: 507 B |
|
Before Width: | Height: | Size: 3.1 KiB After Width: | Height: | Size: 3.1 KiB |
|
Before Width: | Height: | Size: 5.5 KiB After Width: | Height: | Size: 5.5 KiB |
|
Before Width: | Height: | Size: 1.2 KiB After Width: | Height: | Size: 1.2 KiB |
|
Before Width: | Height: | Size: 4.4 KiB After Width: | Height: | Size: 4.4 KiB |
|
Before Width: | Height: | Size: 3.7 KiB After Width: | Height: | Size: 3.7 KiB |
|
Before Width: | Height: | Size: 3.9 KiB After Width: | Height: | Size: 3.9 KiB |
|
Before Width: | Height: | Size: 4.4 KiB After Width: | Height: | Size: 4.4 KiB |
|
Before Width: | Height: | Size: 7.0 KiB After Width: | Height: | Size: 7.0 KiB |
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 1.1 KiB After Width: | Height: | Size: 1.1 KiB |
|
Before Width: | Height: | Size: 10 KiB After Width: | Height: | Size: 10 KiB |
|
Before Width: | Height: | Size: 1.9 KiB After Width: | Height: | Size: 1.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 398 B |
Binary file not shown.
|
Before Width: | Height: | Size: 2.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.2 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.5 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 8.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 9.2 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.7 KiB |
5
collects/redex/private/config.ss
Normal file
5
collects/redex/private/config.ss
Normal file
|
|
@ -0,0 +1,5 @@
|
||||||
|
#lang scheme
|
||||||
|
(provide set-show-bitmaps? get-show-bitmaps?)
|
||||||
|
(define show-bitmaps? #t)
|
||||||
|
(define (set-show-bitmaps? sb?) (set! show-bitmaps? sb?))
|
||||||
|
(define (get-show-bitmaps?) show-bitmaps?)
|
||||||
|
|
@ -220,76 +220,73 @@
|
||||||
|
|
||||||
;; the withs, freshs, and side-conditions come in backwards order
|
;; the withs, freshs, and side-conditions come in backwards order
|
||||||
(define-for-syntax (bind-withs orig-name main lang lang-nts stx where-mode body)
|
(define-for-syntax (bind-withs orig-name main lang lang-nts stx where-mode body)
|
||||||
(let loop ([stx stx]
|
(let* ([bindings '()]
|
||||||
[body body]
|
[body
|
||||||
[bindings '()])
|
(let loop ([stx stx]
|
||||||
(syntax-case stx (side-condition where fresh)
|
[to-not-be-in main])
|
||||||
[() (values body bindings)]
|
(syntax-case stx (side-condition where fresh)
|
||||||
[((where x e) y ...)
|
[() body]
|
||||||
(let-values ([(names names/ellipses) (extract-names lang-nts 'reduction-relation #t #'x)])
|
[((where x e) y ...)
|
||||||
(with-syntax ([(cpat) (generate-temporaries '(compiled-pattern))]
|
(let-values ([(names names/ellipses) (extract-names lang-nts 'reduction-relation #t #'x)])
|
||||||
[side-conditions-rewritten (rewrite-side-conditions/check-errs
|
(with-syntax ([(cpat) (generate-temporaries '(compiled-pattern))]
|
||||||
lang-nts
|
[side-conditions-rewritten (rewrite-side-conditions/check-errs
|
||||||
'reduction-relation
|
lang-nts
|
||||||
#f
|
'reduction-relation
|
||||||
#'x)]
|
#f
|
||||||
[(names ...) names]
|
#'x)]
|
||||||
[(names/ellipses ...) names/ellipses])
|
[(names ...) names]
|
||||||
(loop #'(y ...)
|
[(names/ellipses ...) names/ellipses])
|
||||||
#`(let ([mtchs (match-pattern cpat (term e))])
|
(with-syntax ([(x ...) (generate-temporaries #'(names ...))])
|
||||||
(if mtchs
|
(set! bindings (cons #`[cpat (compile-pattern #,lang `side-conditions-rewritten #t)] bindings))
|
||||||
#,
|
(let ([rest-body (loop #'(y ...) #`(list x ... #,to-not-be-in))])
|
||||||
(case where-mode
|
#`(let ([mtchs (match-pattern cpat (term e))])
|
||||||
[(flatten)
|
(if mtchs
|
||||||
#`(apply
|
#,
|
||||||
append
|
(case where-mode
|
||||||
(map (λ (mtch)
|
[(flatten)
|
||||||
(let ([bindings (mtch-bindings mtch)])
|
#`(apply
|
||||||
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
|
append
|
||||||
#,body)))
|
(map (λ (mtch)
|
||||||
mtchs))]
|
(let ([bindings (mtch-bindings mtch)])
|
||||||
[(predicate)
|
(let ([x (lookup-binding bindings 'names)] ...)
|
||||||
#`(andmap (λ (mtch)
|
(term-let ([names/ellipses x] ...)
|
||||||
(let ([bindings (mtch-bindings mtch)])
|
#,rest-body))))
|
||||||
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
|
mtchs))]
|
||||||
#,body)))
|
[(predicate)
|
||||||
mtchs)]
|
#`(andmap (λ (mtch)
|
||||||
[else (error 'unknown-where-mode "~s" where-mode)])
|
(let ([bindings (mtch-bindings mtch)])
|
||||||
#f))
|
(let ([x (lookup-binding bindings 'names)] ...)
|
||||||
(cons #`[cpat (compile-pattern #,lang `side-conditions-rewritten #t)]
|
(term-let ([names/ellipses x] ...)
|
||||||
bindings))))]
|
#,rest-body))))
|
||||||
[((side-condition s ...) y ...)
|
mtchs)]
|
||||||
(loop #'(y ...) #`(and s ... #,body) bindings)]
|
[else (error 'unknown-where-mode "~s" where-mode)])
|
||||||
[((fresh x) y ...)
|
#f))))))]
|
||||||
(identifier? #'x)
|
[((side-condition s ...) y ...)
|
||||||
(loop #'(y ...)
|
#`(and s ... #,(loop #'(y ...) to-not-be-in))]
|
||||||
#`(term-let ([x (variable-not-in #,main 'x)]) #,body)
|
[((fresh x) y ...)
|
||||||
bindings)]
|
(identifier? #'x)
|
||||||
[((fresh x name) y ...)
|
#`(term-let ([x (variable-not-in #,to-not-be-in 'x)])
|
||||||
(identifier? #'x)
|
#,(loop #'(y ...) #`(list (term x) #,to-not-be-in)))]
|
||||||
(loop #'(y ...)
|
[((fresh x name) y ...)
|
||||||
#`(term-let ([x (let ([the-name (term name)])
|
(identifier? #'x)
|
||||||
(verify-name-ok '#,orig-name the-name)
|
#`(term-let ([x (let ([the-name (term name)])
|
||||||
(variable-not-in #,main the-name))])
|
(verify-name-ok '#,orig-name the-name)
|
||||||
#,body)
|
(variable-not-in #,to-not-be-in the-name))])
|
||||||
bindings)]
|
#,(loop #'(y ...) #`(list (term x) #,to-not-be-in)))]
|
||||||
[((fresh (y) (x ...)) z ...)
|
[((fresh (y) (x ...)) z ...)
|
||||||
(loop #'(z ...)
|
#`(term-let ([(y #,'...)
|
||||||
#`(term-let ([(y #,'...)
|
(variables-not-in #,to-not-be-in
|
||||||
(variables-not-in #,main
|
(map (λ (_ignore_) 'y)
|
||||||
(map (λ (_ignore_) 'y)
|
(term (x ...))))])
|
||||||
(term (x ...))))])
|
#,(loop #'(z ...) #`(list (term (y #,'...)) #,to-not-be-in)))]
|
||||||
#,body)
|
[((fresh (y) (x ...) names) z ...)
|
||||||
bindings)]
|
#`(term-let ([(y #,'...)
|
||||||
[((fresh (y) (x ...) names) z ...)
|
(let ([the-names (term names)]
|
||||||
(loop #'(z ...)
|
[len-counter (term (x ...))])
|
||||||
#`(term-let ([(y #,'...)
|
(verify-names-ok '#,orig-name the-names len-counter)
|
||||||
(let ([the-names (term names)]
|
(variables-not-in #,to-not-be-in the-names))])
|
||||||
[len-counter (term (x ...))])
|
#,(loop #'(z ...) #`(list (term (y #,'...)) #,to-not-be-in)))]))])
|
||||||
(verify-names-ok '#,orig-name the-names len-counter)
|
(values body bindings)))
|
||||||
(variables-not-in #,main the-names))])
|
|
||||||
#,body)
|
|
||||||
bindings)])))
|
|
||||||
|
|
||||||
(define-syntax-set (do-reduction-relation)
|
(define-syntax-set (do-reduction-relation)
|
||||||
(define (do-reduction-relation/proc stx)
|
(define (do-reduction-relation/proc stx)
|
||||||
|
|
@ -746,84 +743,76 @@
|
||||||
case-id)))))))
|
case-id)))))))
|
||||||
|
|
||||||
(define (process-extras stx orig-name name-table extras)
|
(define (process-extras stx orig-name name-table extras)
|
||||||
(let ([the-name #f]
|
(let* ([the-name #f]
|
||||||
[the-name-stx #f]
|
[the-name-stx #f]
|
||||||
[sides/withs/freshs '()])
|
[sides/withs/freshs
|
||||||
(let loop ([extras extras])
|
(let loop ([extras extras])
|
||||||
(cond
|
(cond
|
||||||
[(null? extras) (values the-name sides/withs/freshs)]
|
[(null? extras) '()]
|
||||||
[else
|
[else
|
||||||
(syntax-case (car extras) (side-condition fresh where)
|
(syntax-case (car extras) (side-condition fresh where)
|
||||||
[name
|
[name
|
||||||
(or (identifier? (car extras))
|
(or (identifier? (car extras))
|
||||||
(string? (syntax-e (car extras))))
|
(string? (syntax-e (car extras))))
|
||||||
(begin
|
(begin
|
||||||
(let* ([raw-name (syntax-e (car extras))]
|
(let* ([raw-name (syntax-e (car extras))]
|
||||||
[name-sym
|
[name-sym
|
||||||
(if (symbol? raw-name)
|
(if (symbol? raw-name)
|
||||||
raw-name
|
raw-name
|
||||||
(string->symbol raw-name))])
|
(string->symbol raw-name))])
|
||||||
(when (hash-ref name-table name-sym #f)
|
(when (hash-ref name-table name-sym #f)
|
||||||
(raise-syntax-errors orig-name
|
(raise-syntax-errors orig-name
|
||||||
"same name on multiple rules"
|
"same name on multiple rules"
|
||||||
stx
|
stx
|
||||||
(list (car (hash-ref name-table name-sym))
|
(list (car (hash-ref name-table name-sym))
|
||||||
(syntax name))))
|
(syntax name))))
|
||||||
(let ([num (hash-ref name-table #f)])
|
(let ([num (hash-ref name-table #f)])
|
||||||
(hash-set! name-table #f (+ num 1))
|
(hash-set! name-table #f (+ num 1))
|
||||||
(hash-set! name-table name-sym (list (syntax name) num)))
|
(hash-set! name-table name-sym (list (syntax name) num)))
|
||||||
|
|
||||||
(when the-name
|
(when the-name
|
||||||
(raise-syntax-errors orig-name
|
(raise-syntax-errors orig-name
|
||||||
"expected only a single name"
|
"expected only a single name"
|
||||||
stx
|
stx
|
||||||
(list the-name-stx (car extras))))
|
(list the-name-stx (car extras))))
|
||||||
(set! the-name (if (symbol? raw-name)
|
(set! the-name (if (symbol? raw-name)
|
||||||
(symbol->string raw-name)
|
(symbol->string raw-name)
|
||||||
raw-name))
|
raw-name))
|
||||||
(set! the-name-stx (car extras))
|
(set! the-name-stx (car extras))
|
||||||
(loop (cdr extras))))]
|
(loop (cdr extras))))]
|
||||||
[(fresh var ...)
|
[(fresh var ...)
|
||||||
(begin
|
(append (map (λ (x)
|
||||||
(set! sides/withs/freshs
|
(syntax-case x ()
|
||||||
(append
|
[x
|
||||||
(reverse
|
(identifier? #'x)
|
||||||
(map (λ (x)
|
#'(fresh x)]
|
||||||
(syntax-case x ()
|
[(x name)
|
||||||
[x
|
(identifier? #'x)
|
||||||
(identifier? #'x)
|
#'(fresh x name)]
|
||||||
#'(fresh x)]
|
[((ys dots2) (xs dots1))
|
||||||
[(x name)
|
(and (eq? (syntax-e #'dots1) (string->symbol "..."))
|
||||||
(identifier? #'x)
|
(eq? (syntax-e #'dots2) (string->symbol "...")))
|
||||||
#'(fresh x name)]
|
#'(fresh (ys) (xs dots1))]
|
||||||
[((ys dots2) (xs dots1))
|
[((ys dots2) (xs dots1) names)
|
||||||
(and (eq? (syntax-e #'dots1) (string->symbol "..."))
|
(and (eq? (syntax-e #'dots1) (string->symbol "..."))
|
||||||
(eq? (syntax-e #'dots2) (string->symbol "...")))
|
(eq? (syntax-e #'dots2) (string->symbol "...")))
|
||||||
#'(fresh (ys) (xs dots1))]
|
#'(fresh (ys) (xs dots1) names)]
|
||||||
[((ys dots2) (xs dots1) names)
|
[x
|
||||||
(and (eq? (syntax-e #'dots1) (string->symbol "..."))
|
(raise-syntax-error orig-name
|
||||||
(eq? (syntax-e #'dots2) (string->symbol "...")))
|
"malformed fresh variable clause"
|
||||||
#'(fresh (ys) (xs dots1) names)]
|
stx
|
||||||
[x
|
#'x)]))
|
||||||
(raise-syntax-error orig-name
|
(syntax->list #'(var ...)))
|
||||||
"malformed fresh variable clause"
|
(loop (cdr extras)))]
|
||||||
stx
|
[(side-condition exp ...)
|
||||||
#'x)]))
|
(cons (car extras) (loop (cdr extras)))]
|
||||||
(syntax->list #'(var ...))))
|
[(where x e)
|
||||||
sides/withs/freshs))
|
(cons (car extras) (loop (cdr extras)))]
|
||||||
(loop (cdr extras)))]
|
[(where . x)
|
||||||
[(side-condition exp ...)
|
(raise-syntax-error orig-name "malformed where clause" stx (car extras))]
|
||||||
(begin
|
[_
|
||||||
(set! sides/withs/freshs (cons (car extras) sides/withs/freshs))
|
(raise-syntax-error orig-name "unknown extra" stx (car extras))])]))])
|
||||||
(loop (cdr extras)))]
|
(values the-name sides/withs/freshs)))
|
||||||
[(where x e)
|
|
||||||
(begin
|
|
||||||
(set! sides/withs/freshs (cons (car extras) sides/withs/freshs))
|
|
||||||
(loop (cdr extras)))]
|
|
||||||
[(where . x)
|
|
||||||
(raise-syntax-error orig-name "malformed where clause" stx (car extras))]
|
|
||||||
[_
|
|
||||||
(raise-syntax-error orig-name "unknown extra" stx (car extras))])]))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1125,182 +1114,178 @@
|
||||||
(list name
|
(list name
|
||||||
(car names)))))
|
(car names)))))
|
||||||
(loop name (cdr names))]))])
|
(loop name (cdr names))]))])
|
||||||
|
(parse-extras #'((stuff ...) ...))
|
||||||
|
(with-syntax ([(((cp-let-bindings ...) rhs/wheres) ...)
|
||||||
|
(map (λ (sc/b rhs)
|
||||||
|
(let-values ([(body-code cp-let-bindings)
|
||||||
|
(bind-withs
|
||||||
|
syn-error-name '()
|
||||||
|
#'lang lang-nts
|
||||||
|
sc/b 'flatten
|
||||||
|
#`(list (term #,rhs)))])
|
||||||
|
(list cp-let-bindings body-code)))
|
||||||
|
(syntax->list #'((stuff ...) ...))
|
||||||
|
(syntax->list #'(rhs ...)))]
|
||||||
|
[(((rg-cp-let-bindings ...) rg-rhs/wheres) ...)
|
||||||
|
(map (λ (sc/b rhs)
|
||||||
|
(let-values ([(body-code cp-let-bindings)
|
||||||
|
(bind-withs
|
||||||
|
syn-error-name '()
|
||||||
|
#'lang lang-nts
|
||||||
|
sc/b 'predicate
|
||||||
|
#`#t)])
|
||||||
|
(list cp-let-bindings body-code)))
|
||||||
|
(syntax->list #'((stuff ...) ...))
|
||||||
|
(syntax->list #'(rhs ...)))])
|
||||||
|
(with-syntax ([(side-conditions-rewritten ...)
|
||||||
|
(map (λ (x) (rewrite-side-conditions/check-errs
|
||||||
|
lang-nts
|
||||||
|
syn-error-name
|
||||||
|
#t
|
||||||
|
x))
|
||||||
|
(syntax->list (syntax (lhs ...))))]
|
||||||
|
[(rg-side-conditions-rewritten ...)
|
||||||
|
(map (λ (x) (rewrite-side-conditions/check-errs
|
||||||
|
lang-nts
|
||||||
|
syn-error-name
|
||||||
|
#t
|
||||||
|
x))
|
||||||
|
(syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))]
|
||||||
|
[(clause-src ...)
|
||||||
|
(map (λ (lhs)
|
||||||
|
(format "~a:~a:~a"
|
||||||
|
(syntax-source lhs)
|
||||||
|
(syntax-line lhs)
|
||||||
|
(syntax-column lhs)))
|
||||||
|
pats)]
|
||||||
|
[dom-side-conditions-rewritten
|
||||||
|
(and dom-ctcs
|
||||||
|
(rewrite-side-conditions/check-errs
|
||||||
|
lang-nts
|
||||||
|
syn-error-name
|
||||||
|
#f
|
||||||
|
dom-ctcs))]
|
||||||
|
[codom-side-conditions-rewritten
|
||||||
|
(rewrite-side-conditions/check-errs
|
||||||
|
lang-nts
|
||||||
|
syn-error-name
|
||||||
|
#f
|
||||||
|
codom-contract)]
|
||||||
|
[(rhs-fns ...)
|
||||||
|
(map (λ (lhs rhs/where)
|
||||||
|
(let-values ([(names names/ellipses)
|
||||||
|
(extract-names lang-nts syn-error-name #t lhs)])
|
||||||
|
(with-syntax ([(names ...) names]
|
||||||
|
[(names/ellipses ...) names/ellipses]
|
||||||
|
[rhs/where rhs/where])
|
||||||
|
(syntax
|
||||||
|
(λ (name bindings)
|
||||||
|
(term-let-fn ((name name))
|
||||||
|
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
|
||||||
|
rhs/where)))))))
|
||||||
|
(syntax->list (syntax (lhs ...)))
|
||||||
|
(syntax->list (syntax (rhs/wheres ...))))]
|
||||||
|
[(name2 name-predicate) (generate-temporaries (syntax (name name)))]
|
||||||
|
|
||||||
(with-syntax ([(((tl-side-conds ...) ...)
|
;; See "!!" below for information on the `seq-' bindings:
|
||||||
(tl-bindings ...)
|
[seq-of-rhs #'(rhs ...)]
|
||||||
(tl-side-cond/binds ...))
|
[seq-of-lhs #'(lhs ...)]
|
||||||
(parse-extras #'((stuff ...) ...))])
|
[seq-of-tl-side-cond/binds #'((stuff ...) ...)]
|
||||||
(with-syntax ([(((cp-let-bindings ...) rhs/wheres) ...)
|
[seq-of-lhs-for-lw #'(lhs-for-lw ...)])
|
||||||
(map (λ (sc/b rhs)
|
(with-syntax ([defs #`(begin
|
||||||
(let-values ([(body-code cp-let-bindings)
|
(define-values (name2 name-predicate)
|
||||||
(bind-withs
|
(let ([sc `(side-conditions-rewritten ...)]
|
||||||
syn-error-name '()
|
[dsc `dom-side-conditions-rewritten]
|
||||||
#'lang lang-nts
|
cp-let-bindings ... ...
|
||||||
sc/b 'flatten
|
rg-cp-let-bindings ... ...)
|
||||||
#`(list (term #,rhs)))])
|
(let ([cases (map (λ (pat rhs-fn rg-lhs src)
|
||||||
(list cp-let-bindings body-code)))
|
(make-metafunc-case
|
||||||
(syntax->list #'(tl-side-cond/binds ...))
|
(compile-pattern lang pat #t) rhs-fn rg-lhs src (gensym)))
|
||||||
(syntax->list #'(rhs ...)))]
|
sc
|
||||||
[(((rg-cp-let-bindings ...) rg-rhs/wheres) ...)
|
(list rhs-fns ...)
|
||||||
(map (λ (sc/b rhs)
|
`(rg-side-conditions-rewritten ...)
|
||||||
(let-values ([(body-code cp-let-bindings)
|
`(clause-src ...))]
|
||||||
(bind-withs
|
[parent-cases
|
||||||
syn-error-name '()
|
#,(if prev-metafunction
|
||||||
#'lang lang-nts
|
#`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction)))
|
||||||
sc/b 'predicate
|
#'null)])
|
||||||
#`#t)])
|
(build-metafunction
|
||||||
(list cp-let-bindings body-code)))
|
lang
|
||||||
(syntax->list #'(tl-side-cond/binds ...))
|
cases
|
||||||
(syntax->list #'(rhs ...)))])
|
parent-cases
|
||||||
(with-syntax ([(side-conditions-rewritten ...)
|
(λ (f/dom)
|
||||||
(map (λ (x) (rewrite-side-conditions/check-errs
|
(make-metafunc-proc
|
||||||
lang-nts
|
(let ([name (lambda (x) (f/dom x))]) name)
|
||||||
syn-error-name
|
;; !! This code goes back to phase 1 to call `to-lw', but it's delayed
|
||||||
#t
|
;; through `let-syntax' instead of `unsyntax' so that `to-lw' isn't called
|
||||||
x))
|
;; until all metafunction definitions have been processed.
|
||||||
(syntax->list (syntax (lhs ...))))]
|
;; It gets a little complicated because we want to use sequences from the
|
||||||
[(rg-side-conditions-rewritten ...)
|
;; original `define-metafunction' (step 1) and sequences that are generated within
|
||||||
(map (λ (x) (rewrite-side-conditions/check-errs
|
;; `let-syntax' (step 2). So we quote all the `...' in the `let-syntax' form ---
|
||||||
lang-nts
|
;; and also have to quote all uses step-1 pattern variables in case they produce
|
||||||
syn-error-name
|
;; `...', which should be treated as literals at step 2. Hece the `seq-' bindings
|
||||||
#t
|
;; above and a quoting `...' on each use of a `seq-' binding.
|
||||||
x))
|
(...
|
||||||
(syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))]
|
(let-syntax
|
||||||
[(clause-src ...)
|
([generate-lws
|
||||||
(map (λ (lhs)
|
(lambda (stx)
|
||||||
(format "~a:~a:~a"
|
(with-syntax
|
||||||
(syntax-source lhs)
|
([(rhs/lw ...) (map to-lw/proc (syntax->list #'(... seq-of-rhs)))]
|
||||||
(syntax-line lhs)
|
[(((bind-id/lw . bind-pat/lw) ...) ...)
|
||||||
(syntax-column lhs)))
|
;; Also for pict, extract pattern bindings
|
||||||
pats)]
|
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
|
||||||
[dom-side-conditions-rewritten
|
(extract-pattern-binds x)))
|
||||||
(and dom-ctcs
|
(syntax->list #'(... seq-of-lhs)))]
|
||||||
(rewrite-side-conditions/check-errs
|
|
||||||
lang-nts
|
|
||||||
syn-error-name
|
|
||||||
#f
|
|
||||||
dom-ctcs))]
|
|
||||||
[codom-side-conditions-rewritten
|
|
||||||
(rewrite-side-conditions/check-errs
|
|
||||||
lang-nts
|
|
||||||
syn-error-name
|
|
||||||
#f
|
|
||||||
codom-contract)]
|
|
||||||
[(rhs-fns ...)
|
|
||||||
(map (λ (lhs rhs/where)
|
|
||||||
(let-values ([(names names/ellipses)
|
|
||||||
(extract-names lang-nts syn-error-name #t lhs)])
|
|
||||||
(with-syntax ([(names ...) names]
|
|
||||||
[(names/ellipses ...) names/ellipses]
|
|
||||||
[rhs/where rhs/where])
|
|
||||||
(syntax
|
|
||||||
(λ (name bindings)
|
|
||||||
(term-let-fn ((name name))
|
|
||||||
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
|
|
||||||
rhs/where)))))))
|
|
||||||
(syntax->list (syntax (lhs ...)))
|
|
||||||
(syntax->list (syntax (rhs/wheres ...))))]
|
|
||||||
[(name2 name-predicate) (generate-temporaries (syntax (name name)))]
|
|
||||||
|
|
||||||
;; See "!!" below for information on the `seq-' bindings:
|
[((where/sc/lw ...) ...)
|
||||||
[seq-of-rhs #'(rhs ...)]
|
;; Also for pict, extract where bindings
|
||||||
[seq-of-lhs #'(lhs ...)]
|
(map (λ (hm)
|
||||||
[seq-of-tl-side-cond/binds #'(tl-side-cond/binds ...)]
|
(map
|
||||||
[seq-of-lhs-for-lw #'(lhs-for-lw ...)])
|
(λ (lst)
|
||||||
(with-syntax ([defs #`(begin
|
(syntax-case lst (side-condition where)
|
||||||
(define-values (name2 name-predicate)
|
[(where pat exp)
|
||||||
(let ([sc `(side-conditions-rewritten ...)]
|
#`(cons #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))]
|
||||||
[dsc `dom-side-conditions-rewritten]
|
[(side-condition x)
|
||||||
cp-let-bindings ... ...
|
(to-lw/uq/proc #'x)]))
|
||||||
rg-cp-let-bindings ... ...)
|
(reverse (syntax->list hm))))
|
||||||
(let ([cases (map (λ (pat rhs-fn rg-lhs src)
|
(syntax->list #'(... seq-of-tl-side-cond/binds)))]
|
||||||
(make-metafunc-case
|
|
||||||
(compile-pattern lang pat #t) rhs-fn rg-lhs src (gensym)))
|
|
||||||
sc
|
|
||||||
(list rhs-fns ...)
|
|
||||||
`(rg-side-conditions-rewritten ...)
|
|
||||||
`(clause-src ...))]
|
|
||||||
[parent-cases
|
|
||||||
#,(if prev-metafunction
|
|
||||||
#`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction)))
|
|
||||||
#'null)])
|
|
||||||
(build-metafunction
|
|
||||||
lang
|
|
||||||
cases
|
|
||||||
parent-cases
|
|
||||||
(λ (f/dom)
|
|
||||||
(make-metafunc-proc
|
|
||||||
(let ([name (lambda (x) (f/dom x))]) name)
|
|
||||||
;; !! This code goes back to phase 1 to call `to-lw', but it's delayed
|
|
||||||
;; through `let-syntax' instead of `unsyntax' so that `to-lw' isn't called
|
|
||||||
;; until all metafunction definitions have been processed.
|
|
||||||
;; It gets a little complicated because we want to use sequences from the
|
|
||||||
;; original `define-metafunction' (step 1) and sequences that are generated within
|
|
||||||
;; `let-syntax' (step 2). So we quote all the `...' in the `let-syntax' form ---
|
|
||||||
;; and also have to quote all uses step-1 pattern variables in case they produce
|
|
||||||
;; `...', which should be treated as literals at step 2. Hece the `seq-' bindings
|
|
||||||
;; above and a quoting `...' on each use of a `seq-' binding.
|
|
||||||
(...
|
|
||||||
(let-syntax
|
|
||||||
([generate-lws
|
|
||||||
(lambda (stx)
|
|
||||||
(with-syntax
|
|
||||||
([(rhs/lw ...) (map to-lw/proc (syntax->list #'(... seq-of-rhs)))]
|
|
||||||
[(((bind-id/lw . bind-pat/lw) ...) ...)
|
|
||||||
;; Also for pict, extract pattern bindings
|
|
||||||
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
|
|
||||||
(extract-pattern-binds x)))
|
|
||||||
(syntax->list #'(... seq-of-lhs)))]
|
|
||||||
|
|
||||||
[((where/sc/lw ...) ...)
|
[(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...)
|
||||||
;; Also for pict, extract where bindings
|
;; Also for pict, extract pattern bindings
|
||||||
(map (λ (hm)
|
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x))))
|
||||||
(map
|
(extract-term-let-binds x)))
|
||||||
(λ (lst)
|
(syntax->list #'(... seq-of-rhs)))]
|
||||||
(syntax-case lst (side-condition where)
|
|
||||||
[(where pat exp)
|
|
||||||
#`(cons #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))]
|
|
||||||
[(side-condition x)
|
|
||||||
(to-lw/uq/proc #'x)]))
|
|
||||||
(reverse (syntax->list hm))))
|
|
||||||
(syntax->list #'(... seq-of-tl-side-cond/binds)))]
|
|
||||||
|
|
||||||
[(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...)
|
[(x-lhs-for-lw ...) #'(... seq-of-lhs-for-lw)])
|
||||||
;; Also for pict, extract pattern bindings
|
#'(list (list x-lhs-for-lw
|
||||||
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x))))
|
(list (cons bind-id/lw bind-pat/lw) ...
|
||||||
(extract-term-let-binds x)))
|
(cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ...
|
||||||
(syntax->list #'(... seq-of-rhs)))]
|
where/sc/lw ...)
|
||||||
|
rhs/lw)
|
||||||
[(x-lhs-for-lw ...) #'(... seq-of-lhs-for-lw)])
|
...)))])
|
||||||
#'(list (list x-lhs-for-lw
|
(generate-lws)))
|
||||||
(list (cons bind-id/lw bind-pat/lw) ...
|
lang
|
||||||
(cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ...
|
#t ;; multi-args?
|
||||||
where/sc/lw ...)
|
'name
|
||||||
rhs/lw)
|
(let ([name (lambda (x) (name-predicate x))]) name)
|
||||||
...)))])
|
dsc
|
||||||
(generate-lws)))
|
(append cases parent-cases)))
|
||||||
lang
|
dsc
|
||||||
#t ;; multi-args?
|
`codom-side-conditions-rewritten
|
||||||
'name
|
'name
|
||||||
(let ([name (lambda (x) (name-predicate x))]) name)
|
#,relation?))))
|
||||||
dsc
|
(term-define-fn name name2))])
|
||||||
(append cases parent-cases)))
|
(syntax-property
|
||||||
dsc
|
(if (eq? 'top-level (syntax-local-context))
|
||||||
`codom-side-conditions-rewritten
|
; Introduce the names before using them, to allow
|
||||||
'name
|
; metafunction definition at the top-level.
|
||||||
#,relation?))))
|
(syntax
|
||||||
(term-define-fn name name2))])
|
(begin
|
||||||
(syntax-property
|
(define-syntaxes (name2 name-predicate) (values))
|
||||||
(if (eq? 'top-level (syntax-local-context))
|
defs))
|
||||||
; Introduce the names before using them, to allow
|
(syntax defs))
|
||||||
; metafunction definition at the top-level.
|
'disappeared-use
|
||||||
(syntax
|
(map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))))))]
|
||||||
(begin
|
|
||||||
(define-syntaxes (name2 name-predicate) (values))
|
|
||||||
defs))
|
|
||||||
(syntax defs))
|
|
||||||
'disappeared-use
|
|
||||||
(map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))))))]
|
|
||||||
[(_ prev-metafunction name lang clauses ...)
|
[(_ prev-metafunction name lang clauses ...)
|
||||||
(begin
|
(begin
|
||||||
(unless (identifier? #'name)
|
(unless (identifier? #'name)
|
||||||
|
|
@ -1383,41 +1368,25 @@
|
||||||
(raise-syntax-error syn-error-name "error checking failed.2" stx))]))
|
(raise-syntax-error syn-error-name "error checking failed.2" stx))]))
|
||||||
|
|
||||||
(define (parse-extras extras)
|
(define (parse-extras extras)
|
||||||
(let loop ([stuffs (syntax->list extras)]
|
(for-each
|
||||||
[side-conditionss '()]
|
(λ (stuffs)
|
||||||
[bindingss '()]
|
(for-each
|
||||||
[bothss '()])
|
(λ (stuff)
|
||||||
(cond
|
(syntax-case stuff (where side-condition)
|
||||||
[(null? stuffs) (list (reverse side-conditionss)
|
[(side-condition tl-side-conds ...)
|
||||||
(reverse bindingss)
|
(void)]
|
||||||
(reverse bothss))]
|
[(where x e)
|
||||||
[else
|
(void)]
|
||||||
(let s-loop ([stuff (syntax->list (car stuffs))]
|
[(where . args)
|
||||||
[side-conditions '()]
|
(raise-syntax-error 'define-metafunction
|
||||||
[bindings '()]
|
"malformed where clause"
|
||||||
[boths '()])
|
stuff)]
|
||||||
(cond
|
[_
|
||||||
[(null? stuff) (loop (cdr stuffs)
|
(raise-syntax-error 'define-metafunction
|
||||||
(cons (reverse side-conditions) side-conditionss)
|
"expected a side-condition or where clause"
|
||||||
(cons (reverse bindings) bindingss)
|
stuff)]))
|
||||||
; Want these in reverse order.
|
(syntax->list stuffs)))
|
||||||
(cons boths bothss))]
|
(syntax->list extras))))
|
||||||
[else
|
|
||||||
(syntax-case (car stuff) (where side-condition)
|
|
||||||
[(side-condition tl-side-conds ...)
|
|
||||||
(s-loop (cdr stuff)
|
|
||||||
(append (syntax->list #'(tl-side-conds ...)) side-conditions)
|
|
||||||
bindings
|
|
||||||
(cons (car stuff) boths))]
|
|
||||||
[(where x e)
|
|
||||||
(s-loop (cdr stuff)
|
|
||||||
side-conditions
|
|
||||||
(cons #'(x e) bindings)
|
|
||||||
(cons (car stuff) boths))]
|
|
||||||
[_
|
|
||||||
(raise-syntax-error 'define-metafunction
|
|
||||||
"expected a side-condition or where clause"
|
|
||||||
(car stuff))])]))]))))
|
|
||||||
|
|
||||||
(define (build-metafunction lang cases parent-cases wrap dom-contract-pat codom-contract-pat name relation?)
|
(define (build-metafunction lang cases parent-cases wrap dom-contract-pat codom-contract-pat name relation?)
|
||||||
(let ([dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
|
(let ([dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,11 @@
|
||||||
;; require this file to run all of the test suites for redex.
|
;; require this file to run all of the test suites for redex.
|
||||||
|
|
||||||
#lang scheme/base
|
#lang scheme/base
|
||||||
(require scheme/runtime-path)
|
(require scheme/runtime-path
|
||||||
|
"config.ss"
|
||||||
|
"test-util.ss")
|
||||||
|
|
||||||
|
(set-show-bitmaps? #t)
|
||||||
|
|
||||||
(define test-files
|
(define test-files
|
||||||
'("lw-test.ss"
|
'("lw-test.ss"
|
||||||
|
|
@ -17,8 +21,6 @@
|
||||||
|
|
||||||
(define-runtime-path here ".")
|
(define-runtime-path here ".")
|
||||||
|
|
||||||
(putenv "PLT_REDEX_TEST_NOSHOW_DIFFS" "yes")
|
|
||||||
|
|
||||||
(define (flush)
|
(define (flush)
|
||||||
;; these flushes are here for running under cygwin,
|
;; these flushes are here for running under cygwin,
|
||||||
;; which somehow makes mzscheme think it isn't using
|
;; which somehow makes mzscheme think it isn't using
|
||||||
|
|
|
||||||
|
|
@ -35,7 +35,9 @@
|
||||||
|
|
||||||
(define tests 0)
|
(define tests 0)
|
||||||
(define failures 0)
|
(define failures 0)
|
||||||
(define (reset-count) (set! tests 0))
|
(define (reset-count)
|
||||||
|
(set! tests 0)
|
||||||
|
(set! failures 0))
|
||||||
|
|
||||||
(define (print-tests-passed filename)
|
(define (print-tests-passed filename)
|
||||||
(cond
|
(cond
|
||||||
|
|
|
||||||
|
|
@ -1212,6 +1212,35 @@
|
||||||
'(x y z))
|
'(x y z))
|
||||||
(list '(x1 y1 z1 x y z)))
|
(list '(x1 y1 z1 x y z)))
|
||||||
|
|
||||||
|
(test (apply-reduction-relation
|
||||||
|
(reduction-relation
|
||||||
|
empty-language
|
||||||
|
(--> any (any_y x)
|
||||||
|
(where any_y x)
|
||||||
|
(fresh x)))
|
||||||
|
(term junk))
|
||||||
|
(list '(x x1)))
|
||||||
|
|
||||||
|
(test (apply-reduction-relation
|
||||||
|
(reduction-relation
|
||||||
|
empty-language
|
||||||
|
(--> any (any_y x)
|
||||||
|
(fresh x)
|
||||||
|
(where any_y x)
|
||||||
|
(fresh x)))
|
||||||
|
(term junk))
|
||||||
|
(list '(x x1)))
|
||||||
|
|
||||||
|
(test (apply-reduction-relation
|
||||||
|
(reduction-relation
|
||||||
|
empty-language
|
||||||
|
(--> (variable ...) (variable_0 ... variable_1 ...)
|
||||||
|
(fresh ((variable_0 ...) (variable ...)))
|
||||||
|
(fresh ((variable_1 ...) (variable ...)))))
|
||||||
|
(term (x y)))
|
||||||
|
(list '(variable_0 variable_1 variable_2 variable_3)))
|
||||||
|
|
||||||
|
|
||||||
;; test that redex match can be used in a side-condition
|
;; test that redex match can be used in a side-condition
|
||||||
;; with the same language that is used to define the
|
;; with the same language that is used to define the
|
||||||
;; reduction relation.
|
;; reduction relation.
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user