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

brought back syntax locations (for better error messages) in redex main forms and improved define-relation

Browse Source 
svn: r15214
This commit is contained in:
Robby Findler 2009-06-19 14:58:40 +00:00
parent ed4f066bb6
commit f9ba83cc1c
3 changed files with 72 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -26,15 +26,19 @@
(identifier-prune-lexical-context #'whatever '(#%app #%datum)) (identifier-prune-lexical-context #'whatever '(#%app #%datum))
(let loop ([stx stx]) (let loop ([stx stx])
(syntax-case stx (quote) (syntax-case stx (quote)
[(quote x) (list (quote-syntax/prune quote) [(quote x)
(list (quote-syntax/prune quote)
(syntax->datum #'x))] (syntax->datum #'x))]
[(a . b) (cons (loop #'a) (loop #'b))] [(a . b)
(datum->syntax (identifier-prune-lexical-context #'whatever '(#%app))
(cons (loop #'a) (loop #'b))
stx)]
[x [x
(identifier? #'x) (identifier? #'x)
(datum->syntax (identifier-prune-lexical-context #'x) (identifier-prune-lexical-context #'x)]
(syntax-e #'x))] [() (datum->syntax #f '() stx)]
[() '()] [_ (datum->syntax (identifier-prune-lexical-context #'whatever '(#%datum))
[_ (syntax->datum stx)])))) (syntax->datum stx) stx)]))))
(define-syntax (term-match/single stx) (define-syntax (term-match/single stx)
(syntax-case stx () (syntax-case stx ()
@ -1005,21 +1009,26 @@
(define (internal-define-metafunction orig-stx prev-metafunction stx relation?) (define (internal-define-metafunction orig-stx prev-metafunction stx relation?)
(syntax-case stx () (syntax-case stx ()
[(lang . rest) [(lang . rest)
(let ([syn-error-name (if prev-metafunction (let ([syn-error-name (if relation?
'define-relation
(if prev-metafunction
'define-metafunction/extension 'define-metafunction/extension
'define-metafunction)]) 'define-metafunction))])
(unless (identifier? #'lang) (unless (identifier? #'lang)
(raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang)) (raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang))
(when (null? (syntax-e #'rest)) (when (null? (syntax-e #'rest))
(raise-syntax-error syn-error-name "no clauses" orig-stx)) (raise-syntax-error syn-error-name "no clauses" orig-stx))
(prune-syntax (prune-syntax
(let-values ([(contract-name dom-ctcs codom-contract pats) (let-values ([(contract-name dom-ctcs codom-contract pats)
(split-out-contract orig-stx syn-error-name #'rest)]) (split-out-contract orig-stx syn-error-name #'rest relation?)])
(with-syntax ([(((original-names lhs-clauses ...) rhs stuff ...) ...) pats] (with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats]
[(lhs-for-lw ...) [(lhs-for-lw ...)
(with-syntax ([((lhs-for-lw _ _ ...) ...) pats]) (with-syntax ([((lhs-for-lw _ ...) ...) pats])
(map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x))) (map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x)))
(syntax->list #'(lhs-for-lw ...))))]) (syntax->list #'(lhs-for-lw ...))))])
(with-syntax ([((rhs stuff ...) ...) (if relation?
#'((,(and (term raw-rhses) ...)) ...)
#'((raw-rhses ...) ...))])
(parameterize ([is-term-fn? (parameterize ([is-term-fn?
(let ([names (syntax->list #'(original-names ...))]) (let ([names (syntax->list #'(original-names ...))])
(λ (x) (and (not (null? names)) (λ (x) (and (not (null? names))
@ -1057,7 +1066,7 @@
(with-syntax ([(side-conditions-rewritten ...) (with-syntax ([(side-conditions-rewritten ...)
(map (λ (x) (rewrite-side-conditions/check-errs (map (λ (x) (rewrite-side-conditions/check-errs
lang-nts lang-nts
'define-metafunction syn-error-name
#t #t
x)) x))
(syntax->list (syntax ((side-condition lhs tl-withs) ...))))] (syntax->list (syntax ((side-condition lhs tl-withs) ...))))]
@ -1065,18 +1074,19 @@
(and dom-ctcs (and dom-ctcs
(rewrite-side-conditions/check-errs (rewrite-side-conditions/check-errs
lang-nts lang-nts
'define-metafunction syn-error-name
#f #f
dom-ctcs))] dom-ctcs))]
[codom-side-conditions-rewritten [codom-side-conditions-rewritten
(rewrite-side-conditions/check-errs (rewrite-side-conditions/check-errs
lang-nts lang-nts
'define-metafunction syn-error-name
#f #f
codom-contract)] codom-contract)]
[(rhs-fns ...) [(rhs-fns ...)
(map (λ (lhs rhs bindings) (map (λ (lhs rhs bindings)
(let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)]) (let-values ([(names names/ellipses)
(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 rhs] [rhs rhs]
@ -1150,7 +1160,7 @@
#,relation?))) #,relation?)))
(term-define-fn name name2)) (term-define-fn name name2))
'disappeared-use 'disappeared-use
(map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))))] (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)
@ -1166,11 +1176,11 @@
(syntax->list (syntax (clauses ...)))) (syntax->list (syntax (clauses ...))))
(raise-syntax-error 'define-metafunction "missing error check for bad syntax" stx))])) (raise-syntax-error 'define-metafunction "missing error check for bad syntax" stx))]))
(define (split-out-contract stx syn-error-name rest) (define (split-out-contract stx syn-error-name rest relation?)
;; initial test determines if a contract is specified or not ;; initial test determines if a contract is specified or not
(cond (cond
[(pair? (syntax-e (car (syntax->list rest)))) [(pair? (syntax-e (car (syntax->list rest))))
(values #f #f #'any (check-clauses stx syn-error-name rest))] (values #f #f #'any (check-clauses stx syn-error-name rest relation?))]
[else [else
(syntax-case rest () (syntax-case rest ()
[(id colon more ...) [(id colon more ...)
@ -1187,7 +1197,7 @@
(raise-syntax-error syn-error-name "expected a range contract to follow the arrow" stx (car more))) (raise-syntax-error syn-error-name "expected a range contract to follow the arrow" stx (car more)))
(let ([doms (reverse dom-pats)] (let ([doms (reverse dom-pats)]
[codomain (cadr more)] [codomain (cadr more)]
[clauses (check-clauses stx syn-error-name (cddr more))]) [clauses (check-clauses stx syn-error-name (cddr more) relation?)])
(values #'id doms codomain clauses))] (values #'id doms codomain clauses))]
[else [else
(loop (cdr more) (cons (car more) dom-pats))])))] (loop (cdr more) (cons (car more) dom-pats))])))]
@ -1198,11 +1208,13 @@
stx stx
rest)])])) rest)])]))
(define (check-clauses stx syn-error-name rest) (define (check-clauses stx syn-error-name rest relation?)
(syntax-case rest () (syntax-case rest ()
[([(lhs ...) roc1 roc2 ...] ...) [([(lhs ...) roc1 roc2 ...] ...)
rest] rest]
[([(lhs ...) rhs ...] ...) [([(lhs ...) rhs ...] ...)
(if relation?
rest
(begin (begin
(for-each (for-each
(λ (clause) (λ (clause)
@ -1210,7 +1222,7 @@
[(a b) (void)] [(a b) (void)]
[x (raise-syntax-error syn-error-name "expected a pattern and a right-hand side" stx clause)])) [x (raise-syntax-error syn-error-name "expected a pattern and a right-hand side" stx clause)]))
(syntax->list #'([(lhs ...) rhs ...] ...))) (syntax->list #'([(lhs ...) rhs ...] ...)))
(raise-syntax-error syn-error-name "error checking failed.3" stx))] (raise-syntax-error syn-error-name "error checking failed.3" stx)))]
[([x roc ...] ...) [([x roc ...] ...)
(begin (begin
(for-each (for-each

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

@ -657,6 +657,23 @@
(test (term (<: 1 2 3 1 4)) #t) (test (term (<: 1 2 3 1 4)) #t)
(test (term (<: 1 2 3 4 1)) #t)) (test (term (<: 1 2 3 4 1)) #t))
(let ()
(define-relation empty-language
[(<: number_1 number_1)])
(test (term (<: 1 1)) #t)
(test (term (<: 1 2)) #f))
(let ()
(define-relation empty-language
[(<: number_1 number_2 number_3)
,(= (term number_1) (term number_2))
,(= (term number_2) (term number_3))])
(test (term (<: 1 2 3)) #f)
(test (term (<: 1 1 2)) #f)
(test (term (<: 1 2 2)) #f)
(test (term (<: 1 1 1)) #t))
; ;; ; ;; ; ; ;; ; ;; ;
; ; ; ; ; ; ; ; ; ;
; ;; ;; ;;; ;; ; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;;; ; ;;; ;;;;; ;;; ;;; ;; ;; ; ;; ;; ;;; ;; ; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;;; ; ;;; ;;;;; ;;; ;;; ;; ;;

28
collects/redex/redex.scrbl
View File

@ -982,11 +982,8 @@ and @scheme[#f] otherwise.
@defform/subs[#:literals () @defform/subs[#:literals ()
(define-relation language-exp (define-relation language-exp
[(name @#,ttpattern ...) @#,tttterm extras ...] [(name @#,ttpattern ...) @#,tttterm ...] ...)
...) ([tl-pat identifier (tl-pat-ele ...)]
([extras (side-condition scheme-expression)
(where tl-pat @#,tttterm)]
[tl-pat identifier (tl-pat-ele ...)]
[tl-pat-ele tl-pat (code:line tl-pat ... (code:comment "a literal ellipsis"))])]{ [tl-pat-ele tl-pat (code:line tl-pat ... (code:comment "a literal ellipsis"))])]{
The @scheme[define-relation] form builds a relation on The @scheme[define-relation] form builds a relation on
@ -995,21 +992,22 @@ expressions. The first argument indicates the language used
to resolve non-terminals in the pattern expressions. Each of to resolve non-terminals in the pattern expressions. Each of
the rhs-expressions is implicitly wrapped in @|tttterm|. the rhs-expressions is implicitly wrapped in @|tttterm|.
If specified, the side-conditions are collected with Relations are like metafunctions in that they are called with
@scheme[and] and used as guards on the case being matched. The arguments and return results (unlike in, say, prolog, where a relation
argument to each side-condition should be a Scheme definition would be able to synthesize some of the arguments based on
expression, and the pattern variables in the @|ttpattern| are the values of others).
bound in that expression.
Unlike metafunctions, relations check all possible ways to match each Unlike metafunctions, relations check all possible ways to match each
case, looking for a true result and if none of the clauses match, then case, looking for a true result and if none of the clauses match, then
the result is @scheme[#f]. the result is @scheme[#f]. If there are multiple expressions on
the right-hand side of a relation, then all of them must be satisfied
in order for that clause of the relation to be satisfied.
Note that relations are assumed to always return the same results Note that relations are assumed to always return the same results for
for the same inputs, and their results are cached, unless the same inputs, and their results are cached, unless
@scheme[caching-enable?] is set to @scheme[#f]. Accordingly, if a @scheme[caching-enable?] is set to @scheme[#f]. Accordingly, if a
metafunction is called with the same inputs twice, then its body is relation is called with the same inputs twice, then its right-hand
only evaluated a single time. sides are evaluated only once.
} }
@defparam[current-traced-metafunctions traced-metafunctions (or/c 'all (listof symbol?))]{ @defparam[current-traced-metafunctions traced-metafunctions (or/c 'all (listof symbol?))]{