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

accidentally committed some changes on the branch, now moving back to trunk (w/ some conflicts, argh!): fixed a bug in the way redex expanded metafunctions (it had old code left in there) and improved error messages for domain failures in reduction relations

Browse Source 
svn: r15317
This commit is contained in:
Robby Findler 2009-06-27 13:47:02 +00:00
parent 440ab66ae7
commit ea6c99c69f
6 changed files with 258 additions and 217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/redex/private/bitmap-test.ss
View File

@ -36,6 +36,20 @@
(extend-reduction-relation red lang (--> 1 2))) (extend-reduction-relation red lang (--> 1 2)))
"extended-reduction-relation.png") "extended-reduction-relation.png")
;; this test should fail because it gets the order wrong
;; for the where/side-conditions
(define red2
(reduction-relation
lang
(--> (number_a number_b number_c)
any_z
(where (any_x any_y) (number_a number_b))
(side-condition (= (term number_c) 5))
(where any_z any_x))))
(test (render-reduction-relation red2)
"red2.png")
(define-metafunction lang (define-metafunction lang
[(S x v e) e]) [(S x v e) e])
@ -92,7 +106,6 @@
(render-metafunction Name)) (render-metafunction Name))
"metafunction-Name-vertical.png") "metafunction-Name-vertical.png")
;; makes sure that there is no overlap inside or across metafunction calls ;; makes sure that there is no overlap inside or across metafunction calls
;; or when there are unquotes involved ;; or when there are unquotes involved
(define-metafunction lang (define-metafunction lang

BIN
collects/redex/private/bmps/metafunction-Name-vertical.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.7 KiB

After

Width:  |  Height:  |  Size: 4.7 KiB

28
collects/redex/private/pict.ss
View File

@ -251,7 +251,10 @@
ltl-superimpose ltl-superimpose ltl-superimpose ltl-superimpose
(list* 2 (+ 2 (current-label-extra-space))) 2))) (list* 2 (+ 2 (current-label-extra-space))) 2)))
(define (side-condition-pict fresh-vars side-conditions pattern-binds max-w) ;; side-condition-pict : (listof pict) (listof (or/c (cons/c pict pict) pict)) number -> pict
;; the elements of pattern-binds/sc that are pairs are bindings (ie "x = <something>")
;; and the elements of pattern-binds/sc that are just picts are just plain side-conditions
(define (side-condition-pict fresh-vars pattern-binds/sc max-w)
(let* ([frsh (let* ([frsh
(if (null? fresh-vars) (if (null? fresh-vars)
null null
@ -264,16 +267,17 @@
fresh-vars)) fresh-vars))
(basic-text " fresh" (default-style)))))] (basic-text " fresh" (default-style)))))]
[binds (map (lambda (b) [binds (map (lambda (b)
(if (pair? b)
(htl-append (htl-append
(car b) (car b)
(make-=) (make-=)
(cdr b))) (cdr b))
pattern-binds)] b))
pattern-binds/sc)]
[lst (add-between [lst (add-between
'comma 'comma
(append (append
binds binds
side-conditions
frsh))]) frsh))])
(if (null? lst) (if (null? lst)
(blank) (blank)
@ -293,8 +297,8 @@
(define (rp->side-condition-pict rp max-w) (define (rp->side-condition-pict rp max-w)
(side-condition-pict (rule-pict-fresh-vars rp) (side-condition-pict (rule-pict-fresh-vars rp)
(rule-pict-side-conditions rp) (append (rule-pict-side-conditions rp)
(rule-pict-pattern-binds rp) (rule-pict-pattern-binds rp))
max-w)) max-w))
(define (rp->pict-label rp) (define (rp->pict-label rp)
@ -737,21 +741,21 @@
[eqns (select-cases all-eqns)] [eqns (select-cases all-eqns)]
[lhss (select-cases all-lhss)] [lhss (select-cases all-lhss)]
[scs (map (lambda (eqn) [scs (map (lambda (eqn)
(if (and (null? (list-ref eqn 1)) (if (null? (list-ref eqn 1))
(null? (list-ref eqn 2)))
#f #f
(side-condition-pict null (side-condition-pict null
(map wrapper->pict (list-ref eqn 1))
(map (lambda (p) (map (lambda (p)
(if (pair? p)
(cons (wrapper->pict (car p)) (cons (wrapper->pict (car p))
(wrapper->pict (cdr p)))) (wrapper->pict (cdr p)))
(list-ref eqn 2)) (wrapper->pict p)))
(list-ref eqn 1))
(if (memq style '(up-down/vertical-side-conditions (if (memq style '(up-down/vertical-side-conditions
left-right/vertical-side-conditions)) left-right/vertical-side-conditions))
0 0
+inf.0)))) +inf.0))))
eqns)] eqns)]
[rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 3))) eqns)] [rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 2))) eqns)]
[linebreak-list (or current-linebreaks [linebreak-list (or current-linebreaks
(map (lambda (x) #f) eqns))] (map (lambda (x) #f) eqns))]
[=-pict (make-=)] [=-pict (make-=)]

41
collects/redex/private/reduction-semantics.ss
View File

@ -1165,41 +1165,45 @@
#f #f
codom-contract)] codom-contract)]
[(rhs-fns ...) [(rhs-fns ...)
(map (λ (lhs rhs/where bindings) (map (λ (lhs rhs/where)
(let-values ([(names names/ellipses) (let-values ([(names names/ellipses)
(extract-names lang-nts syn-error-name #t lhs)]) (extract-names lang-nts syn-error-name #t lhs)])
(with-syntax ([(names ...) names] (with-syntax ([(names ...) names]
[(names/ellipses ...) names/ellipses] [(names/ellipses ...) names/ellipses]
[rhs/where rhs/where] [rhs/where rhs/where])
[((tl-var tl-exp) ...) bindings])
(syntax (syntax
(λ (name bindings) (λ (name bindings)
(term-let-fn ((name name)) (term-let-fn ((name name))
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...) (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
(term-let ([tl-var (term tl-exp)] ...) rhs/where)))))))
rhs/where))))))))
(syntax->list (syntax (lhs ...))) (syntax->list (syntax (lhs ...)))
(syntax->list (syntax (rhs/wheres ...))) (syntax->list (syntax (rhs/wheres ...))))]
(syntax->list (syntax (tl-bindings ...))))]
[(name2 name-predicate) (generate-temporaries (syntax (name name)))] [(name2 name-predicate) (generate-temporaries (syntax (name name)))]
[((side-cond/lw/uq ...) ...)
(map (lambda (scs) (map to-lw/uq/proc (syntax->list scs)))
(syntax->list #'((tl-side-conds ...) ...)))]
[(((bind-id/lw . bind-pat/lw) ...) ...) [(((bind-id/lw . bind-pat/lw) ...) ...)
;; Also for pict, extract pattern bindings ;; Also for pict, extract pattern bindings
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x)))) (map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
(extract-pattern-binds x))) (extract-pattern-binds x)))
(syntax->list #'(lhs ...)))] (syntax->list #'(lhs ...)))]
[((where/sc/lw ...) ...)
;; Also for pict, extract where bindings
(map (λ (hm)
(map
(λ (lst)
(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)]))
(syntax->list hm)))
(syntax->list #'(tl-side-cond/binds ...)))]
[(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...) [(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...)
;; Also for pict, extract pattern bindings ;; Also for pict, extract pattern bindings
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x)))) (map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x))))
(extract-term-let-binds x))) (extract-term-let-binds x)))
(syntax->list #'(rhs ...)))] (syntax->list #'(rhs ...)))])
[(((where-id/lw where-pat/lw) ...) ...)
;; Also for pict, extract where bindings
(map (λ (lst) (map (λ (ab) (map to-lw/proc (syntax->list ab)))
(syntax->list lst)))
(syntax->list #'(tl-bindings ...)))])
(syntax-property (syntax-property
#`(begin #`(begin
(define-values (name2 name-predicate) (define-values (name2 name-predicate)
@ -1224,10 +1228,9 @@
(make-metafunc-proc (make-metafunc-proc
(let ([name (lambda (x) (f/dom x))]) name) (let ([name (lambda (x) (f/dom x))]) name)
(list (list lhs-for-lw (list (list lhs-for-lw
(list side-cond/lw/uq ...)
(list (cons bind-id/lw bind-pat/lw) ... (list (cons bind-id/lw bind-pat/lw) ...
(cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ... (cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ...
(cons where-id/lw where-pat/lw) ...) where/sc/lw ...)
rhs/lw) rhs/lw)
...) ...)
lang lang
@ -1430,7 +1433,7 @@
(redex-error name "~a matched ~s ~a different ways and returned different results" (redex-error name "~a matched ~s ~a different ways and returned different results"
(if (< num 0) (if (< num 0)
"a clause from an extended metafunction" "a clause from an extended metafunction"
(format "clause ~a" num)) (format "clause #~a (counting from 0)" num))
`(,name ,@exp) `(,name ,@exp)
(length mtchs))] (length mtchs))]
[else [else

22
collects/redex/private/struct.ss
View File

@ -50,8 +50,13 @@
;; I started to add it, but didn't finish. -robby ;; I started to add it, but didn't finish. -robby
(define (build-reduction-relation orig-reduction-relation lang make-procs rule-names lws domain-pattern) (define (build-reduction-relation orig-reduction-relation lang make-procs rule-names lws domain-pattern)
(let* ([make-procs/check-domain (let* ([make-procs/check-domain
(map (λ (make-proc) (let loop ([make-procs make-procs]
(make-rewrite-proc [i 0])
(cond
[(null? make-procs) null]
[else
(let ([make-proc (car make-procs)])
(cons (make-rewrite-proc
(λ (lang) (λ (lang)
(let ([compiled-domain-pat (compile-pattern lang domain-pattern #f)] (let ([compiled-domain-pat (compile-pattern lang domain-pattern #f)]
[proc (make-proc lang)]) [proc (make-proc lang)])
@ -63,14 +68,19 @@
(λ (res) (λ (res)
(let ([term (cadr res)]) (let ([term (cadr res)])
(unless (match-pattern compiled-domain-pat term) (unless (match-pattern compiled-domain-pat term)
(error 'reduction-relation "relation reduced to ~s, which is outside its domain" (error 'reduction-relation "relation reduced to ~s via ~a, which is outside its domain"
term)))) term
(let ([name (rewrite-proc-name make-proc)])
(if name
(format "the rule named ~a" name)
(format "rule #~a (counting from 0)" i)))))))
ress) ress)
ress)))) ress))))
(rewrite-proc-name make-proc) (rewrite-proc-name make-proc)
(rewrite-proc-lhs make-proc) (rewrite-proc-lhs make-proc)
(rewrite-proc-id make-proc))) (rewrite-proc-id make-proc))
make-procs)]) (loop (cdr make-procs)
(+ i 1))))]))])
(cond (cond
[orig-reduction-relation [orig-reduction-relation
(let* ([new-names (map rewrite-proc-name make-procs)] (let* ([new-names (map rewrite-proc-name make-procs)]

13
collects/redex/private/tl-test.ss
View File

@ -647,6 +647,17 @@
(test (term (ex quote)) (term quote))) (test (term (ex quote)) (term quote)))
(let ()
(define-metafunction empty-language
[(f any ...)
(any ...)
(where variable_1 x)
(side-condition #f)
(where (number ...) y)]
[(f any ...)
12345])
(test (term (f 8)) 12345))
; ;
@ -924,7 +935,7 @@
(with-handlers ((exn? exn-message)) (with-handlers ((exn? exn-message))
(apply-reduction-relation red 1) (apply-reduction-relation red 1)
'no-exception-raised)) 'no-exception-raised))
"reduction-relation: relation reduced to x, which is outside its domain") "reduction-relation: relation reduced to x via rule #0 (counting from 0), which is outside its domain")
(let* ([red1 (let* ([red1
(reduction-relation (reduction-relation