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

added exn:fail:redex

Browse Source 
svn: r11221
This commit is contained in:
Robby Findler 2008-08-13 15:10:46 +00:00
parent a58e5ab74c
commit 7c6d9bfb58
6 changed files with 119 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/redex/private/error.ss Normal file
View File

@ -0,0 +1,7 @@
#lang scheme/base
(define-struct (exn:fail:redex exn:fail) ())
(define (redex-error name fmt . args)
(let ([str (format "~a: ~a" name (apply format fmt args))])
(raise (make-exn:fail:redex str (current-continuation-marks)))))
(provide redex-error
exn:fail:redex?)

4
collects/redex/private/matcher.ss
View File

@ -1307,9 +1307,7 @@ before the pattern compiler is invoked.
(cond
[(eq? none s1) s2]
[(eq? none s2) s1]
;; MF: error message simplified because it is too close to
;; implementation matters.
[(error 'matcher.ss "found two holes" #;s1 #;s2)]))
[(error 'matcher.ss "found two holes")]))
;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists])
;; reverses the rhs of each rib in the bindings and reverses the context.

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

@ -4,6 +4,7 @@
"struct.ss"
"term.ss"
"loc-wrapper.ss"
"error.ss"
(lib "list.ss")
(lib "etc.ss"))
@ -38,13 +39,15 @@
(let ([match (match-pattern cp-x exp)])
(when match
(unless (null? (cdr match))
(error 'term-match "pattern ~s matched term ~e multiple ways"
'pattern
exp))
(redex-error
'term-match/single
"pattern ~s matched term ~e multiple ways"
'pattern
exp))
(k (term-let ([names/ellipses (lookup-binding (mtch-bindings (car match)) 'names)] ...)
rhs))))
...
(error 'term-match/single "no patterns matched ~e" exp))))))))]))
(redex-error 'term-match/single "no patterns matched ~e" exp))))))))]))
(define-syntax (term-match stx)
(syntax-case stx ()
@ -946,7 +949,7 @@
(when (null? (cdr more))
(raise-syntax-error syn-error-name "expected a range contract to follow the arrow" stx (car more)))
(let ([doms (reverse dom-pats)]
[codomain (car more)]
[codomain (cadr more)]
[clauses (check-clauses stx syn-error-name (cddr more))])
(values doms codomain clauses))]
[else
@ -1010,26 +1013,26 @@
"expected a side-condition or where clause"
(car stuff))])]))]))))
(define (build-metafunction lang patterns rhss old-cps old-rhss wrap dom-contract-pat rng-contract-pat name)
(define (build-metafunction lang patterns rhss old-cps old-rhss wrap dom-contract-pat codom-contract-pat name)
(let ([compiled-patterns (append old-cps
(map (λ (pat) (compile-pattern lang pat #t)) patterns))]
[dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
[rng-compiled-pattern (compile-pattern lang rng-contract-pat #t)])
[codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)])
(values
(wrap
(letrec ([metafunc
(λ (exp)
(when dom-compiled-pattern
(unless (match-pattern dom-compiled-pattern exp)
(error name
"~s is not in my domain"
`(,name ,@exp))))
(redex-error name
"~s is not in my domain"
`(,name ,@exp))))
(let loop ([patterns compiled-patterns]
[rhss (append old-rhss rhss)]
[num (- (length old-cps))])
(cond
[(null? patterns)
(error name "no clauses matched for ~s" `(,name . ,exp))]
(redex-error name "no clauses matched for ~s" `(,name . ,exp))]
[else
(let ([pattern (car patterns)]
[rhs (car rhss)])
@ -1039,14 +1042,17 @@
(cdr rhss)
(+ num 1))]
[(not (null? (cdr mtchs)))
(error name "~a matched ~s ~a different ways"
(if (< num 0)
"a clause from an extended metafunction"
(format "clause ~a" num))
`(,name ,@exp)
(length mtchs))]
(redex-error name "~a matched ~s ~a different ways"
(if (< num 0)
"a clause from an extended metafunction"
(format "clause ~a" num))
`(,name ,@exp)
(length mtchs))]
[else
(rhs metafunc (mtch-bindings (car mtchs)))])))])))])
(let ([ans (rhs metafunc (mtch-bindings (car mtchs)))])
(unless (match-pattern codom-compiled-pattern ans)
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
ans)])))])))])
metafunc)
compiled-patterns
rhss)

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

@ -409,6 +409,52 @@
(test (term (f p q)) (term p))
(test (in-domain? (f p q)) #t))
(let ()
(define-metafunction empty-language
[(err number_1 ... number_2 ...) 1])
(test (term (err)) 1)
(test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
((λ (x) #t) (λ (x) 'wrong-exn)))
(term (err 1 2))
'no-exn)
'right-exn))
(let ()
(define-metafunction empty-language
err : number ... -> number
[(err number ...) 1])
(test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
((λ (x) #t) (λ (x) 'wrong-exn)))
(term (err #f #t))
'no-exn)
'right-exn))
(let ()
(define-metafunction empty-language
err : number ... -> number
[(err number ...) #f])
(test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
((λ (x) #t) (λ (x) 'wrong-exn)))
(term (err 1 2))
'no-exn)
'right-exn))
(let ()
(define-metafunction empty-language
err : number ... -> (number number)
[(err number ...) (number ...)])
(test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
((λ (x) #t) (λ (x) 'wrong-exn)))
(term (err 1 2))
'no-exn)
'no-exn)
(test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
((λ (x) #t) (λ (x) 'wrong-exn)))
(term (err 1 1))
'no-exn)
'no-exn))
;
;
@ -426,6 +472,7 @@
;
(test (apply-reduction-relation
(reduction-relation
grammar
@ -869,7 +916,7 @@
(require (lib "list.ss"))
(let ()
(define-metafunction lc-lang
free-vars : e -> (listof x)
free-vars : e -> (x ...)
[(free-vars (e_1 e_2 ...))
(∪ (free-vars e_1) (free-vars e_2) ...)]
[(free-vars x) (x)]
@ -938,6 +985,28 @@
'(x y))
'(x . y))
(test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
((λ (x) #t) (λ (x) 'wrong-exn)))
((term-match/single empty-language
[(number_1 ... number_2 ...) 1])
'(1 2 3))
'no-exn)
'right-exn)
(test (with-handlers ((exn:fail:redex? (λ (x) 'right-exn))
((λ (x) #t) (λ (x) 'wrong-exn)))
((term-match/single empty-language
[(number_1 ... number_2 ...) 1])
'x)
'no-exn)
'right-exn)
(test ((term-match empty-language
[(number_1 ... number_2 ...) 1])
'x)
'())
(define-language x-is-1-language
[x 1])

14
collects/redex/redex.scrbl
View File

@ -467,6 +467,9 @@ expressions and checks them against each pattern. The
function returns the expression behind the first sucessful
match. If that pattern produces multiple matches, an error
is signaled. If no patterns match, an error is signaled.
Raises an exception recognized by @scheme[exn:fail:redex?] if
no clauses match or if one of the clauses matches multiple ways.
}
@defproc[(plug [context any?] [expression any?]) any]{
@ -496,6 +499,11 @@ Does not expect the input symbols to be distinct, but does
produce variables that are always distinct.
}
@defproc[(exn:fail:redex? [v any/c]) boolean?]{
Returns @scheme[#t] if its argument is a Redex exception record, and
@scheme[#f] otherwise.
}
@section{Languages}
All of the exports in this section are provided both by
@ -820,12 +828,16 @@ argument to each side-condition should be a Scheme
expression, and the pattern variables in the <pattern> are
bound in that expression.
Raises an exception recognized by @scheme[exn:fail:redex?] if
no clauses match, if one of the clauses matches multiple ways, or
if the contract is violated.
As an example, these metafunctions finds the free variables in
an expression in the lc-lang above:
@schemeblock[
(define-metafunction lc-lang
free-vars : e -> (listof x)
free-vars : e -> (x ...)
[(free-vars (e_1 e_2 ...))
(∪ (free-vars e_1) (free-vars e_2) ...)]
[(free-vars x) (x)]

5
collects/redex/reduction-semantics.ss
View File

@ -4,10 +4,13 @@
(require "private/reduction-semantics.ss"
"private/matcher.ss"
"private/term.ss"
"private/rg.ss")
"private/rg.ss"
"private/error.ss")
#;(provide (all-from-out "private/rg.ss"))
(provide exn:fail:redex?) ;; from error.ss
(provide reduction-relation
--> fresh with ;; keywords for reduction-relation
extend-reduction-relation