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

added define-union-language

Browse Source
This commit is contained in:
Robby Findler 2012-02-10 16:40:32 -06:00
parent 122625960d
commit e4e4d70b6b
9 changed files with 217 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/redex/private/matcher.rkt
View File

@ -257,6 +257,38 @@ See match-a-pattern.rkt for more details
(unless (memq pat nts)
(hash-set! ht pat #t)))))])))
;; prefix-nts : string pat -> pat
(define (prefix-nts prefix pat)
(let loop ([pat pat])
(match-a-pattern pat
[`any pat]
[`number pat]
[`string pat]
[`natural pat]
[`integer pat]
[`real pat]
[`variable pat]
[`(variable-except ,s ...) pat]
[`(variable-prefix ,s) pat]
[`variable-not-otherwise-mentioned pat]
[`hole pat]
[`(nt ,id) `(nt ,(string->symbol (string-append prefix (symbol->string id))))]
[`(name ,name ,pat) `(name , name ,(loop pat))]
[`(mismatch-name ,name ,pat) `(mismatch-name ,name ,(loop pat))]
[`(in-hole ,p1 ,p2) `(in-hole ,(loop p1) ,(loop p2))]
[`(hide-hole ,p) `(hide-hole ,(loop p))]
[`(side-condition ,p ,g ,e) `(side-condition ,(loop p) ,g ,e)]
[`(cross ,s) pat]
[`(list ,sub-pats ...)
`(list ,@(for/list ([sub-pat (in-list sub-pats)])
(match sub-pat
[`(repeat ,pat ,name ,mismatch)
`(repeat ,(loop pat) ,name ,mismatch)]
[else
(loop sub-pat)])))]
[(? (compose not pair?))
pat])))
; build-has-hole-or-hide-hole-ht : (listof nt) -> hash[symbol -o> boolean]
; produces a map of nonterminal -> whether that nonterminal could produce a hole
(define (build-has-hole-or-hide-hole-ht lang)
@ -1967,4 +1999,5 @@ See match-a-pattern.rkt for more details
rewrite-ellipses
build-compatible-context-language
caching-enabled?
check-redudancy)
check-redudancy
prefix-nts)

2
collects/redex/private/pict.rkt
View File

@ -483,6 +483,8 @@
(do-language->pict 'language->pict lang nts))
(define (do-language->pict what lang specd-non-terminals)
(unless (compiled-lang-pict-builder lang)
(error what "cannot render the result of define-union-language"))
(let ([all-non-terminals (hash-map (compiled-lang-ht lang) (λ (x y) x))])
(when specd-non-terminals
(check-non-terminals what specd-non-terminals lang))

85
collects/redex/private/reduction-semantics.rkt
View File

@ -2616,8 +2616,88 @@
(hash-map new-ht (λ (x y) y))
(compiled-lang-nt-map old-lang))))
(define (union-language lang1 lang2)
(void))
(define-syntax (define-union-language stx)
(syntax-case stx ()
[(_ name orig-langs ...)
(begin
(unless (identifier? (syntax name))
(raise-syntax-error 'define-extended-language "expected an identifier" stx #'name))
(when (null? (syntax->list #'(orig-langs ...)))
(raise-syntax-error 'define-union-language "expected at least one additional language" stx))
;; normalized-orig-langs : (listof (list string[prefix] id (listof symbol)[nts] stx[orig clause in union]))
(define normalized-orig-langs
(for/list ([orig-lang (in-list (syntax->list #'(orig-langs ...)))])
(syntax-case orig-lang ()
[x (identifier? #'x) (list "" #'x (language-id-nts #'x 'define-union-language) orig-lang)]
[(prefix lang)
(and (identifier? #'prefix)
(identifier? #'lang))
(list (symbol->string (syntax-e #'prefix)) #'lang (language-id-nts #'lang 'define-union-language) orig-lang)]
[else (raise-syntax-error 'define-union-language
"malformed additional language"
stx orig-lang)])))
;; ht : sym -o> stx
;; maps each non-terminal (with its prefix) to the
;; syntax object that it comes from in the original
;; define-union-language declaration
(define names-table (make-hash))
(for ([normalized-orig-lang (in-list normalized-orig-langs)])
(define prefix (list-ref normalized-orig-lang 0))
(for ([no-prefix-nt (in-list (list-ref normalized-orig-lang 2))])
(define nt (string->symbol (string-append prefix (symbol->string no-prefix-nt))))
(let ([prev (hash-ref names-table nt #f)])
(when prev
(raise-syntax-error 'define-union-language
(format "two sublanguages both contribute the non-terminal: ~a" nt)
#f
#f
(list prev
(list-ref normalized-orig-lang 3))))
(hash-set! names-table nt (list-ref normalized-orig-lang 3)))))
(with-syntax ([(all-names ...) (sort (hash-map names-table (λ (x y) x)) string<=? #:key symbol->string)]
[((prefix old-lang _1 _2) ...) normalized-orig-langs]
[(define-language-name) (generate-temporaries #'(name))])
#'(begin
(define define-language-name (union-language (list (list 'prefix old-lang) ...)))
(define-syntax name
(make-set!-transformer
(make-language-id
(λ (stx)
(syntax-case stx (set!)
[(set! x e) (raise-syntax-error 'define-extended-language "cannot set! identifier" stx #'e)]
[(x e (... ...)) #'(define-language-name e (... ...))]
[x
(identifier? #'x)
#'define-language-name]))
'(all-names ...)))))))]))
(define (union-language old-langs/prefixes)
(define new-nt-map
(for/list ([old-pr (in-list old-langs/prefixes)])
(define prefix (list-ref old-pr 0))
(define nt-map (compiled-lang-nt-map (list-ref old-pr 1)))
(for/list ([lst (in-list nt-map)])
(for/list ([sym (in-list lst)])
(string->symbol (string-append prefix (symbol->string sym)))))))
(define new-nts
(apply
append
(for/list ([old-lang/prefix (in-list old-langs/prefixes)])
(define prefix (list-ref old-lang/prefix 0))
(define lang (compiled-lang-lang (list-ref old-lang/prefix 1)))
(for/list ([nt (in-list lang)])
(make-nt (string->symbol (string-append prefix (symbol->string (nt-name nt))))
(for/list ([rhs (in-list (nt-rhs nt))])
(make-rhs (prefix-nts prefix (rhs-pattern rhs)))))))))
(compile-language #f
new-nts
new-nt-map))
;; find-primary-nt : symbol lang -> symbol or #f
;; returns the primary non-terminal for a given nt, or #f if `nt' isn't bound in the language.
@ -2937,6 +3017,7 @@
define-language
define-extended-language
define-union-language
define-metafunction
define-metafunction/extension

59
collects/redex/private/ref.scrbl
View File

@ -615,7 +615,7 @@ A @racket[non-terminal-def] comprises one or more non-terminal names
(considered aliases) followed by one or more productions.
For example, the following defines @deftech{@racket[lc-lang]} as the
grammar of the lambda calculus:
grammar of the λ-calculus:
@racketblock[
(define-language lc-lang
@ -624,7 +624,7 @@ grammar of the lambda calculus:
v)
(c (v ... c e ...)
hole)
(v (lambda (x ...) e))
(v (λ (x ...) e))
(x variable-not-otherwise-mentioned))
]
@ -652,7 +652,7 @@ extended non-terminals. For example, this language:
(v .... (code:comment "extend the previous `v' non-terminal")
+
number)
(x (variable-except lambda +)))
(x (variable-except λ +)))
]
extends lc-lang with two new alternatives for the @racket[v]
@ -676,6 +676,37 @@ defined together, extending any one of those non-terminals
extends all of them.
}
@defform/subs[(define-union-language L base/prefix-lang ...)
([base/prefix-lang lang-id
(prefix lang-id)])]{
Constructs a language that is the union of all of the
languages listed in the @racket[base/prefix-lang].
If a language has a prefix, then all of the non-terminals
from that language have the corresponding prefix in
the union language. The prefix helps avoid collisions
between the constituent language's non-terminals
(which is illegal).
For example, with two these two languages:
@racketblock[(define-language UT
(e (e e)
(λ (x) e)
x))
(define-language WT
(e (e e)
(λ (x t) e)
x)
(t (→ t t)
num))]
then this declaration:
@racketblock[(define-union-language B (ut. UT) (wt. WT))]
will create a language named @racket[B] containing the non-terminals
@racket[ut.e], @racket[wt.e], and @racket[wt.t] consisting
of the productions listed in the original languages.
}
@defproc[(language-nts [lang compiled-lang?]) (listof symbol?)]{
Returns the list of non-terminals (as symbols) that are
@ -737,7 +768,7 @@ For example, the expression
@racketblock[
(reduction-relation
lc-lang
(--> (in-hole c_1 ((lambda (variable_i ...) e_body) v_i ...))
(--> (in-hole c_1 ((λ (variable_i ...) e_body) v_i ...))
(in-hole c_1 ,(foldl lc-subst
(term e_body)
(term (v_i ...))
@ -816,7 +847,7 @@ For example, this expression
@racketblock[
(reduction-relation
lc-num-lang
(==> ((lambda (variable_i ...) e_body) v_i ...)
(==> ((λ (variable_i ...) e_body) v_i ...)
,(foldl lc-subst
(term e_body)
(term (v_i ...))
@ -829,7 +860,7 @@ For example, this expression
(==> a b)])
]
defines reductions for the lambda calculus with numbers,
defines reductions for the λ-calculus with numbers,
where the @tt{==>} shortcut is defined by reducing in the context
@tt{c}.
@ -1016,7 +1047,7 @@ an expression in the lc-lang above:
[(free-vars (e_1 e_2 ...))
(∪ (free-vars e_1) (free-vars e_2) ...)]
[(free-vars x) (x)]
[(free-vars (lambda (x ...) e))
[(free-vars (λ (x ...) e))
(- (free-vars e) (x ...))])
]
@ -1025,7 +1056,7 @@ The first argument to define-metafunction is the grammar
each variation of expressions (e in lc-lang). The free variables of an
application are the free variables of each of the subterms;
the free variables of a variable is just the variable
itself, and the free variables of a lambda expression are
itself, and the free variables of a λ expression are
the free variables of the body, minus the bound parameters.
Here are the helper metafunctions used above.
@ -1807,7 +1838,7 @@ exploring reduction sequences.
[#:pred pred
(or/c (-> sexp any)
(-> sexp term-node? any))
(lambda (x) #t)]
(λ (x) #t)]
[#:pp pp
(or/c (any -> string)
(any output-port number (is-a?/c text%) -> void))
@ -1816,11 +1847,11 @@ exploring reduction sequences.
(listof
(cons/c string?
(and/c (listof (or/c string? (is-a?/c color%)))
(lambda (x) (<= 0 (length x) 6)))))
(λ (x) (<= 0 (length x) 6)))))
'()]
[#:racket-colors? racket-colors? boolean? #t]
[#:scheme-colors? scheme-colors? boolean? racket-colors?]
[#:filter term-filter (-> any/c (or/c #f string?) any/c) (lambda (x y) #t)]
[#:filter term-filter (-> any/c (or/c #f string?) any/c) (λ (x y) #t)]
[#:x-spacing x-spacing number? 15]
[#:y-spacing y-spacing number? 15]
[#:layout layout (-> (listof term-node?) void) void]
@ -1926,7 +1957,7 @@ inserted into the editor by this library have a
[#:pred pred
(or/c (-> sexp any)
(-> sexp term-node? any))
(lambda (x) #t)]
(λ (x) #t)]
[#:pp pp
(or/c (any -> string)
(any output-port number (is-a?/c text%) -> void))
@ -1935,9 +1966,9 @@ inserted into the editor by this library have a
(listof
(cons/c string?
(and/c (listof (or/c string? (is-a?/c color%)))
(lambda (x) (<= 0 (length x) 6)))))
(λ (x) (<= 0 (length x) 6)))))
'()]
[#:filter term-filter (-> any/c (or/c #f string?) any/c) (lambda (x y) #t)]
[#:filter term-filter (-> any/c (or/c #f string?) any/c) (λ (x y) #t)]
[#:layout layout (-> (listof term-node?) void) void]
[#:x-spacing x-spacing number? 15]
[#:y-spacing y-spacing number? 15]

1
collects/redex/reduction-semantics.rkt
View File

@ -22,6 +22,7 @@
define-language
define-extended-language
define-union-language
plug
compiled-lang?
term

6
collects/redex/tests/run-err-tests/define-union-language.rktd Normal file
View File

@ -0,0 +1,6 @@
("render-language: cannot render the result of define-union-language"
([rl (render-language L2)]) ([L2 L2] [L L])
(let ()
(define-language L (e any))
(define-union-language L2 L)
rl))

20
collects/redex/tests/syn-err-tests/language-definition.rktd
View File

@ -26,4 +26,22 @@
(#rx"expected non-terminal name" ([not-nt (y)]) (define-language L (x not-nt ::= z)))
(#rx"expected production" ([not-prod ::=]) (define-language L (x ::= y not-prod z)))
(#rx"expected non-terminal definition" ([not-def q]) (define-language L not-def))
(#rx"expected non-terminal definition" ([not-def ()]) (define-language L not-def))
(#rx"expected non-terminal definition" ([not-def ()]) (define-language L not-def))
("define-union-language: two sublanguages both contribute the non-terminal: e"
([L1r L1] [L2r L2]) ([L1 L1] [L2 L2])
(let ()
(define-language L1
(e any))
(define-language L2
(e any))
(define-union-language L L1r L2r)))
("define-union-language: two sublanguages both contribute the non-terminal: -e"
([L1r L1] [L2r (- L2)]) ([L1 L1] [L2 L2])
(let ()
(define-language L1
(-e any))
(define-language L2
(e any))
(define-union-language L L1r L2r)))

25
collects/redex/tests/tl-test.rkt
View File

@ -405,6 +405,31 @@
(::= () (number ::=)))
(test (and (redex-match L ::= '(1 ())) #t) #t)))
(let ()
(define-language L1
((q x) 1 2 3)
((y w) 4 5 6 x)
(z 7 8 9))
(define-language L2
((x y) 100 101 102)
(b 103 x))
(define-union-language L L1 (- L2))
(test (and (redex-match L x 3) #t) #t)
(test (and (redex-match L y 2) #t) #t)
(test (redex-match L x 100) #f)
(test (and (redex-match L -x 100) #t) #t)
(test (and (redex-match L -b 100) #t) #t)
(test (redex-match L -b 3) #f))
(parameterize ([current-namespace (make-base-namespace)])
(eval '(require redex/reduction-semantics redex/pict))
(eval '(define-language L
(s a b c)))
(exec-runtime-error-tests "run-err-tests/define-union-language.rktd"))
(exec-syntax-error-tests "syn-err-tests/language-definition.rktd")
;
;

2
doc/release-notes/redex/HISTORY.txt
View File

@ -2,6 +2,8 @@ v5.2.2
* added the amb tutorial.
* added define-union-language
v5.2.1
* rewrote the internals of the pattern matcher to be more consistent