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

Removed support for the #:binds annotation.

Browse Source 
svn: r14319
This commit is contained in:
Casey Klein 2009-03-27 17:38:16 +00:00
parent 99aac7d745
commit 72c3ed943e
5 changed files with 132 additions and 317 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
collects/redex/private/matcher-test.ss
View File

@ -56,7 +56,7 @@
(test-empty '(variable-except x) 'x #f) (test-empty '(variable-except x) 'x #f)
(test-empty '(variable-except x) 'y (list (make-test-mtch (make-bindings null) 'y none))) (test-empty '(variable-except x) 'y (list (make-test-mtch (make-bindings null) 'y none)))
(test-lang 'x 'y (list (make-mtch (make-bindings (list (make-bind 'x 'y))) 'y none)) (test-lang 'x 'y (list (make-mtch (make-bindings (list (make-bind 'x 'y))) 'y none))
(list (make-nt 'x (list (make-rhs '(variable-except x) '()))))) (list (make-nt 'x (list (make-rhs '(variable-except x))))))
(test-empty '(variable-prefix x:) 'x: (list (make-test-mtch (make-bindings null) 'x: none))) (test-empty '(variable-prefix x:) 'x: (list (make-test-mtch (make-bindings null) 'x: none)))
(test-empty '(variable-prefix x:) 'x:x (list (make-test-mtch (make-bindings null) 'x:x none))) (test-empty '(variable-prefix x:) 'x:x (list (make-test-mtch (make-bindings null) 'x:x none)))
(test-empty '(variable-prefix x:) ': #f) (test-empty '(variable-prefix x:) ': #f)
@ -527,84 +527,84 @@
(build-compatible-context-language (build-compatible-context-language
(mk-hasheq '((exp . ()) (ctxt . ()))) (mk-hasheq '((exp . ()) (ctxt . ())))
(list (make-nt 'exp (list (make-nt 'exp
(list (make-rhs '(+ exp exp) '()) (list (make-rhs '(+ exp exp))
(make-rhs 'number '()))) (make-rhs 'number)))
(make-nt 'ctxt (make-nt 'ctxt
(list (make-rhs '(+ ctxt exp) '()) (list (make-rhs '(+ ctxt exp))
(make-rhs '(+ exp ctxt) '()) (make-rhs '(+ exp ctxt))
(make-rhs 'hole '()))))) (make-rhs 'hole)))))
(list (list
(make-nt 'ctxt-ctxt (make-nt 'ctxt-ctxt
(list (make-rhs 'hole '()) (list (make-rhs 'hole)
(make-rhs `(+ (cross ctxt-ctxt) exp) '()) (make-rhs `(+ (cross ctxt-ctxt) exp))
(make-rhs `(+ ctxt (cross ctxt-exp)) '()) (make-rhs `(+ ctxt (cross ctxt-exp)))
(make-rhs `(+ (cross ctxt-exp) ctxt) '()) (make-rhs `(+ (cross ctxt-exp) ctxt))
(make-rhs `(+ exp (cross ctxt-ctxt)) '()))) (make-rhs `(+ exp (cross ctxt-ctxt)))))
(make-nt 'ctxt-exp (make-nt 'ctxt-exp
(list (make-rhs `(+ (cross ctxt-exp) exp) '()) (list (make-rhs `(+ (cross ctxt-exp) exp))
(make-rhs `(+ exp (cross ctxt-exp)) '()))) (make-rhs `(+ exp (cross ctxt-exp)))))
(make-nt 'exp-ctxt (make-nt 'exp-ctxt
(list (make-rhs `(+ (cross exp-ctxt) exp) '()) (list (make-rhs `(+ (cross exp-ctxt) exp))
(make-rhs `(+ ctxt (cross exp-exp)) '()) (make-rhs `(+ ctxt (cross exp-exp)))
(make-rhs `(+ (cross exp-exp) ctxt) '()) (make-rhs `(+ (cross exp-exp) ctxt))
(make-rhs `(+ exp (cross exp-ctxt)) '()))) (make-rhs `(+ exp (cross exp-ctxt)))))
(make-nt 'exp-exp (make-nt 'exp-exp
(list (make-rhs 'hole '()) (list (make-rhs 'hole)
(make-rhs `(+ (cross exp-exp) exp) '()) (make-rhs `(+ (cross exp-exp) exp))
(make-rhs `(+ exp (cross exp-exp)) '()))))) (make-rhs `(+ exp (cross exp-exp)))))))
(run-test (run-test
'compatible-context-language2 'compatible-context-language2
(build-compatible-context-language (build-compatible-context-language
(mk-hasheq '((m . ()) (v . ()))) (mk-hasheq '((m . ()) (v . ())))
(list (make-nt 'm (list (make-rhs '(m m) '()) (make-rhs '(+ m m) '()) (make-rhs 'v '()))) (list (make-nt 'm (list (make-rhs '(m m)) (make-rhs '(+ m m)) (make-rhs 'v)))
(make-nt 'v (list (make-rhs 'number '()) (make-rhs '(lambda (x) m) '()))))) (make-nt 'v (list (make-rhs 'number) (make-rhs '(lambda (x) m))))))
(list (list
(make-nt 'v-v (list (make-rhs 'hole '()) (make-rhs (list 'lambda (list 'x) (list 'cross 'v-m)) '()))) (make-nt 'v-v (list (make-rhs 'hole) (make-rhs (list 'lambda (list 'x) (list 'cross 'v-m)))))
(make-nt 'v-m (make-nt 'v-m
(list (list
(make-rhs (list (list 'cross 'v-m) 'm) '()) (make-rhs (list (list 'cross 'v-m) 'm))
(make-rhs (list 'm (list 'cross 'v-m)) '()) (make-rhs (list 'm (list 'cross 'v-m)))
(make-rhs (list '+ (list 'cross 'v-m) 'm) '()) (make-rhs (list '+ (list 'cross 'v-m) 'm))
(make-rhs (list '+ 'm (list 'cross 'v-m)) '()) (make-rhs (list '+ 'm (list 'cross 'v-m)))
(make-rhs (list 'cross 'v-v) '()))) (make-rhs (list 'cross 'v-v))))
(make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m)) '()))) (make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m)))))
(make-nt 'm-m (make-nt 'm-m
(list (list
(make-rhs 'hole '()) (make-rhs 'hole)
(make-rhs (list (list 'cross 'm-m) 'm) '()) (make-rhs (list (list 'cross 'm-m) 'm))
(make-rhs (list 'm (list 'cross 'm-m)) '()) (make-rhs (list 'm (list 'cross 'm-m)))
(make-rhs (list '+ (list 'cross 'm-m) 'm) '()) (make-rhs (list '+ (list 'cross 'm-m) 'm))
(make-rhs (list '+ 'm (list 'cross 'm-m)) '()) (make-rhs (list '+ 'm (list 'cross 'm-m)))
(make-rhs (list 'cross 'm-v) '()))))) (make-rhs (list 'cross 'm-v))))))
(run-test (run-test
'compatible-context-language3 'compatible-context-language3
(build-compatible-context-language (build-compatible-context-language
(mk-hasheq '((m . ()) (seven . ()))) (mk-hasheq '((m . ()) (seven . ())))
(list (make-nt 'm (list (make-rhs '(m seven m) '()) (make-rhs 'number '()))) (list (make-nt 'm (list (make-rhs '(m seven m)) (make-rhs 'number)))
(make-nt 'seven (list (make-rhs 7 '()))))) (make-nt 'seven (list (make-rhs 7)))))
`(,(make-nt `(,(make-nt
'm-m 'm-m
`(,(make-rhs 'hole '()) ,(make-rhs `((cross m-m) seven m) '()) ,(make-rhs `(m seven (cross m-m)) '()))) `(,(make-rhs 'hole) ,(make-rhs `((cross m-m) seven m)) ,(make-rhs `(m seven (cross m-m)))))
,(make-nt ,(make-nt
'seven-m 'seven-m
`(,(make-rhs `((cross seven-m) seven m) '()) ,(make-rhs `(m (cross seven-seven) m) '()) ,(make-rhs `(m seven (cross seven-m)) '()))) `(,(make-rhs `((cross seven-m) seven m)) ,(make-rhs `(m (cross seven-seven) m)) ,(make-rhs `(m seven (cross seven-m)))))
,(make-nt 'seven-seven `(,(make-rhs 'hole '()))))) ,(make-nt 'seven-seven `(,(make-rhs 'hole)))))
(run-test (run-test
'compatible-context-language4 'compatible-context-language4
(build-compatible-context-language (build-compatible-context-language
(mk-hasheq '((a . ()) (b . ()) (c . ()))) (mk-hasheq '((a . ()) (b . ()) (c . ())))
(list (make-nt 'a (list (make-rhs 'b '()))) (list (make-nt 'a (list (make-rhs 'b)))
(make-nt 'b (list (make-rhs 'c '()))) (make-nt 'b (list (make-rhs 'c)))
(make-nt 'c (list (make-rhs 3 '()))))) (make-nt 'c (list (make-rhs 3)))))
(list (make-nt 'c-c (list (make-rhs 'hole '()))) (list (make-nt 'c-c (list (make-rhs 'hole)))
(make-nt 'c-b (list (make-rhs '(cross c-c) '()))) (make-nt 'c-b (list (make-rhs '(cross c-c))))
(make-nt 'c-a (list (make-rhs '(cross c-b) '()))) (make-nt 'c-a (list (make-rhs '(cross c-b))))
(make-nt 'b-b (list (make-rhs 'hole '()))) (make-nt 'b-b (list (make-rhs 'hole)))
(make-nt 'b-a (list (make-rhs '(cross b-b) '()))) (make-nt 'b-a (list (make-rhs '(cross b-b))))
(make-nt 'a-a (list (make-rhs 'hole '()))))) (make-nt 'a-a (list (make-rhs 'hole)))))
#; #;
(test-xab '(in-hole (cross exp) (+ number number)) (test-xab '(in-hole (cross exp) (+ number number))
@ -667,40 +667,40 @@
(unless xab-lang (unless xab-lang
(let ([nts (let ([nts
(list (make-nt 'exp (list (make-nt 'exp
(list (make-rhs '(+ exp exp) '()) (list (make-rhs '(+ exp exp))
(make-rhs 'number '()))) (make-rhs 'number)))
(make-nt 'ctxt (make-nt 'ctxt
(list (make-rhs '(+ ctxt exp) '()) (list (make-rhs '(+ ctxt exp))
(make-rhs '(+ exp ctxt) '()) (make-rhs '(+ exp ctxt))
(make-rhs 'hole '()))) (make-rhs 'hole)))
(make-nt 'ec-one (make-nt 'ec-one
(list (make-rhs '(+ (hole xx) exp) '()) (list (make-rhs '(+ (hole xx) exp))
(make-rhs '(+ exp (hole xx)) '()))) (make-rhs '(+ exp (hole xx)))))
(make-nt 'same-in-nt (list (make-rhs '((name x any) (name x any)) '()))) (make-nt 'same-in-nt (list (make-rhs '((name x any) (name x any)))))
(make-nt 'forever-list (list (make-rhs '(forever-list forever-list ...) '()) (make-nt 'forever-list (list (make-rhs '(forever-list forever-list ...))
(make-rhs 'x '()))) (make-rhs 'x)))
(make-nt 'lsts (make-nt 'lsts
(list (make-rhs '() '()) (list (make-rhs '())
(make-rhs '(x) '()) (make-rhs '(x))
(make-rhs 'x '()) (make-rhs 'x)
(make-rhs '#f '()))) (make-rhs '#f)))
(make-nt 'split-out (make-nt 'split-out
(list (make-rhs 'split-out2 '()))) (list (make-rhs 'split-out2)))
(make-nt 'split-out2 (make-nt 'split-out2
(list (make-rhs 'number '()))) (list (make-rhs 'number)))
(make-nt 'simple (list (make-rhs 'simple-rhs '()))) (make-nt 'simple (list (make-rhs 'simple-rhs)))
(make-nt 'nesting-names (make-nt 'nesting-names
(list (make-rhs '(a (name x nesting-names)) '()) (list (make-rhs '(a (name x nesting-names)))
(make-rhs 'b '()))) (make-rhs 'b)))
(make-nt 'var (list (make-rhs `variable-not-otherwise-mentioned '()))) (make-nt 'var (list (make-rhs `variable-not-otherwise-mentioned)))
(make-nt 'underscore (list (make-rhs 'exp_1 '()))) (make-nt 'underscore (list (make-rhs 'exp_1)))
)]) )])
(set! xab-lang (set! xab-lang
(compile-language 'pict-stuff-not-used (compile-language 'pict-stuff-not-used
@ -720,9 +720,9 @@
(compile-language (compile-language
'pict-stuff-not-used 'pict-stuff-not-used
(list (make-nt 'aa (list (make-nt 'aa
(list (make-rhs 'a '()))) (list (make-rhs 'a)))
(make-nt 'bb (make-nt 'bb
(list (make-rhs 'b '())))) (list (make-rhs 'b))))
'((aa) (bb))))) '((aa) (bb)))))
(run-match-test (run-match-test
`(match-pattern (compile-pattern ab-lang ',pat #t) ',exp) `(match-pattern (compile-pattern ab-lang ',pat #t) ',exp)

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

@ -22,10 +22,10 @@ before the pattern compiler is invoked.
;; lang = (listof nt) ;; lang = (listof nt)
;; nt = (make-nt sym (listof rhs)) ;; nt = (make-nt sym (listof rhs))
;; rhs = (make-rhs single-pattern (listof var-info??)) ;; rhs = (make-rhs single-pattern)
;; single-pattern = sexp ;; single-pattern = sexp
(define-struct nt (name rhs) #:inspector (make-inspector)) (define-struct nt (name rhs) #:inspector (make-inspector))
(define-struct rhs (pattern var-info) #:inspector (make-inspector)) (define-struct rhs (pattern) #:inspector (make-inspector))
;; var = (make-var sym sexp) ;; var = (make-var sym sexp)
;; patterns are sexps with `var's embedded ;; patterns are sexps with `var's embedded
@ -300,7 +300,7 @@ before the pattern compiler is invoked.
(if (eq? (nt-name nt1) (nt-name nt2)) (if (eq? (nt-name nt1) (nt-name nt2))
(make-nt (nt-name compat-nt) (make-nt (nt-name compat-nt)
(cons (cons
(make-rhs 'hole '()) (make-rhs 'hole)
(nt-rhs compat-nt))) (nt-rhs compat-nt)))
compat-nt))) compat-nt)))
lang)) lang))
@ -350,7 +350,7 @@ before the pattern compiler is invoked.
(cond (cond
[(zero? i) null] [(zero? i) null]
[else (let ([nts (build-across-nts (nt-name nt) count (- i 1))]) [else (let ([nts (build-across-nts (nt-name nt) count (- i 1))])
(cons (make-rhs (maker (box nts)) '()) (cons (make-rhs (maker (box nts)))
(loop (- i 1))))])))) (loop (- i 1))))]))))
(nt-rhs nt))))) (nt-rhs nt)))))

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

@ -1366,45 +1366,6 @@
[(_ lang-id (name rhs ...) ...) [(_ lang-id (name rhs ...) ...)
(let () (let ()
;; collect-binds-clauses : syntax syntax (cons syntax (listof syntax)) -> (values syntax (listof syntax))
;; extracts the #:binds part of a production and returns them (if any) as well as returning the
;; list of syntax objects that follow the binds clause.
;; production is the original production that this #:binds clause is modifying,
;; and lang is the name of the language
(define (collect-binds-clauses production lang rhss)
(let loop ([binds '()]
[rhss rhss])
(cond
[(or (null? (cdr rhss))
(not (equal? (syntax-e (cadr rhss)) '#:binds)))
(values #`(list #,@(reverse binds)) (cdr rhss))]
[else
(unless (>= (length rhss) 3)
(raise-syntax-error #f
"found a #:binds clause without two following expressions"
stx
(cadr rhss)))
(let ([binds-keyword (list-ref rhss 1)]
[var (list-ref rhss 2)]
[nt (list-ref rhss 3)])
(unless (identifier? var)
(raise-syntax-error #f
"the first argument to #:binds must be a non-terminal occurring in this right-hand side"
stx
var))
(unless (identifier? nt)
(raise-syntax-error #f
"the second argument to #:binds must be a non-terminal occurring in this right-hand side"
stx
nt))
(loop (cons #`(make-binds
;; thunking like this means that the pattern is compiled each time the fn
;; runs, ie inefficient
'#,var
'#,nt)
binds)
(cdddr rhss)))])))
;; verify `name' part has the right shape ;; verify `name' part has the right shape
(for-each (for-each
(λ (name) (λ (name)
@ -1450,21 +1411,15 @@
name)))) name))))
all-names) all-names)
(with-syntax ([(((r-rhs var-info) ...) ...) (with-syntax ([((r-rhs ...) ...)
(map (lambda (rhss) (map (lambda (rhss)
(let loop ([rhss (syntax->list rhss)]) (map (lambda (rhs)
(cond (rewrite-side-conditions/check-errs
[(null? rhss) '()] (map syntax-e all-names)
[else 'language
(let ([x (car rhss)]) #f
(let-values ([(var-info rest) (collect-binds-clauses x #'lang rhss)]) rhs))
(cons (list (rewrite-side-conditions/check-errs (syntax->list rhss)))
(map syntax-e all-names)
'language
#f
x)
var-info)
(loop rest))))])))
(syntax->list (syntax ((rhs ...) ...))))] (syntax->list (syntax ((rhs ...) ...))))]
[(refs ...) [(refs ...)
(let loop ([stx (syntax ((rhs ...) ...))]) (let loop ([stx (syntax ((rhs ...) ...))])
@ -1510,8 +1465,8 @@
(let ([all-names 1] ...) (let ([all-names 1] ...)
(begin (void) refs ...)) (begin (void) refs ...))
(compile-language (list (list '(uniform-names ...) (to-lw rhs) ...) ...) (compile-language (list (list '(uniform-names ...) (to-lw rhs) ...) ...)
(list (make-nt 'first-names (list (make-rhs `r-rhs var-info) ...)) ... (list (make-nt 'first-names (list (make-rhs `r-rhs) ...)) ...
(make-nt 'new-name (list (make-rhs 'orig-name '()))) ...) (make-nt 'new-name (list (make-rhs 'orig-name))) ...)
'((uniform-names ...) ...))))))))] '((uniform-names ...) ...))))))))]
[(_ (name rhs ...) ...) [(_ (name rhs ...) ...)
(for-each (for-each
@ -1596,7 +1551,7 @@
(syntax->list #'(name ...))))]) (syntax->list #'(name ...))))])
(syntax/loc stx (syntax/loc stx
(do-extend-language lang (do-extend-language lang
(list (make-nt '(uniform-names ...) (list (make-rhs `r-rhs '()) ...)) ...) (list (make-nt '(uniform-names ...) (list (make-rhs `r-rhs) ...)) ...)
(list (list '(uniform-names ...) (to-lw rhs) ...) ...))))] (list (list '(uniform-names ...) (to-lw rhs) ...) ...))))]
[(_ lang (name rhs ...) ...) [(_ lang (name rhs ...) ...)
(begin (begin
@ -1699,7 +1654,7 @@
(for-each (λ (shortcut-name) (for-each (λ (shortcut-name)
(hash-set! new-ht (hash-set! new-ht
shortcut-name shortcut-name
(make-nt shortcut-name (list (make-rhs (car names) '()))))) (make-nt shortcut-name (list (make-rhs (car names))))))
(cdr names))))) (cdr names)))))
new-nts) new-nts)

96
collects/redex/private/rg-test.ss
View File

@ -98,25 +98,24 @@
(test (random-string chars lits 3 0 (make-random 0 1)) "cbd") (test (random-string chars lits 3 0 (make-random 0 1)) "cbd")
(test (random-string chars lits 3 0 (make-random 1 2 1 0)) "dcb") (test (random-string chars lits 3 0 (make-random 1 2 1 0)) "dcb")
(test (pick-string chars lits 0 (make-random .5 1 2 1 0)) "dcb") (test (pick-string chars lits 0 (make-random .5 1 2 1 0)) "dcb")
(test (pick-var chars lits null 0 (make-random .01 1 2 1 0)) 'dcb) (test (pick-var chars lits 0 (make-random .01 1 2 1 0)) 'dcb)
(test (pick-var chars lits '(x) 0 (make-random .5 0)) 'x)
(test (pick-char 0 null (make-random 65)) #\a) (test (pick-char 0 null (make-random 65)) #\a)
(test (random-string null null 1 0 (make-random 65)) "a")) (test (random-string null null 1 0 (make-random 65)) "a"))
(let () (let ()
(define-language L (define-language L
(a 5 (x a) #:binds x a) (a 5 (x a))
(b 4)) (b 4))
(test (pick-nt 'a L '(x) 1 'dontcare) (test (pick-nt 'a L 1 'dontcare)
(nt-rhs (car (compiled-lang-lang L)))) (nt-rhs (car (compiled-lang-lang L))))
(test (pick-nt 'a L '(x) preferred-production-threshold 'dontcare (make-random 1)) (test (pick-nt 'a L preferred-production-threshold 'dontcare (make-random 1))
(nt-rhs (car (compiled-lang-lang L)))) (nt-rhs (car (compiled-lang-lang L))))
(let ([pref (car (nt-rhs (car (compiled-lang-lang L))))]) (let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
(test (pick-nt 'a L '(x) preferred-production-threshold (test (pick-nt 'a L preferred-production-threshold
(make-immutable-hash `((a ,pref))) (make-immutable-hash `((a ,pref)))
(make-random 0)) (make-random 0))
(list pref))) (list pref)))
(test (pick-nt 'b L null preferred-production-threshold #f) (test (pick-nt 'b L preferred-production-threshold #f)
(nt-rhs (cadr (compiled-lang-lang L))))) (nt-rhs (cadr (compiled-lang-lang L)))))
(define-syntax raised-exn-msg (define-syntax raised-exn-msg
@ -132,7 +131,7 @@
(define (patterns . selectors) (define (patterns . selectors)
(map (λ (selector) (map (λ (selector)
(λ (name lang vars size pref-prods) (λ (name lang size pref-prods)
(list (selector (nt-rhs (nt-by-name lang name)))))) (list (selector (nt-rhs (nt-by-name lang name))))))
selectors)) selectors))
@ -207,35 +206,6 @@
#:var (list (λ _ 'x) (λ _ 'y)))) #:var (list (λ _ 'x) (λ _ 'y))))
'(x y))) '(x y)))
;; #:binds
(let ()
(define-language lang
(a (b c d) #:binds b c #:binds b d)
(b variable)
(c variable)
(d variable))
(let* ([x null]
[prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))])
(test (begin
(generate-term/decisions
lang a 5 0
(decisions #:var (list (λ _ 'x) prepend! prepend!)))
x)
'(x x))))
;; Detection of binding kludge
(let ()
(define-language postfix
(e (e e) x (e (x) λ) #:binds x e)
(x (variable-except λ)))
(test
(raised-exn-msg
(generate-term/decisions
postfix e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))
#:nt (patterns third second first first))))
#rx"kludge"))
;; variable-except pattern ;; variable-except pattern
(let () (let ()
(define-language var (define-language var
@ -300,23 +270,6 @@
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5)))) (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5))))
'((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1)))) '((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1))))
(let ()
(define-language lc
(e (λ (x ...) e) #:binds x e
(e e)
x)
(x (variable-except λ)))
;; x and y bound in body
(test
(let/ec k
(generate-term/decisions
lc e 10 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))
#:nt (patterns first first first third first)
#:seq (list (λ (_) 2)))))
'(y x)))
(let () (let ()
(define-language lang (e (variable-prefix pf))) (define-language lang (e (variable-prefix pf)))
(test (test
@ -340,17 +293,6 @@
#:num (list (λ _ 2) (λ _ 3) (λ _ 4)))) #:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
'(2 3 4 2 3))) '(2 3 4 2 3)))
(let ()
(define-language lang
(e (x x_1 x_1) #:binds x x_1)
(x variable))
(test
(let/ec k
(generate-term/decisions
lang e 5 0
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x)))
(let () (let ()
(define-language lang (define-language lang
(a (number_!_1 number_!_2 number_!_1)) (a (number_!_1 number_!_2 number_!_1))
@ -387,19 +329,12 @@
(a 43) (a 43)
(b (side-condition a_1 (odd? (term a_1)))) (b (side-condition a_1 (odd? (term a_1))))
(c (side-condition a_1 (even? (term a_1)))) (c (side-condition a_1 (even? (term a_1))))
(d (side-condition (x_1 x_1 x) (not (eq? (term x_1) 'x))) #:binds x_1 x)
(e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x)))) (e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x))))
(x variable)) (x variable))
(test (generate-term lang b 5) 43) (test (generate-term lang b 5) 43)
(test (generate-term lang (side-condition a (odd? (term a))) 5) 43) (test (generate-term lang (side-condition a (odd? (term a))) 5) 43)
(test (raised-exn-msg exn:fail:redex? (generate-term lang c 5)) (test (raised-exn-msg exn:fail:redex? (generate-term lang c 5))
#rx"unable to generate") #rx"unable to generate")
(test ; binding works for with side-conditions failure/retry
(let/ec k
(generate-term/decisions
lang d 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))))))
'(y))
(test ; mismatch patterns work with side-condition failure/retry (test ; mismatch patterns work with side-condition failure/retry
(generate-term/decisions (generate-term/decisions
lang e 5 0 lang e 5 0
@ -409,14 +344,7 @@
(generate-term/decisions (generate-term/decisions
lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0 lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y)))) (decisions #:var (list (λ _ 'x) (λ _ 'y))))
'y) 'y))
(test ; bindings within ellipses collected properly
(let/ec k
(generate-term/decisions
lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4))
#:num (build-list 7 (λ (n) (λ (_) n))))))
'((0 1 2) (3 4 5 6))))
(let () (let ()
(define-language lang (define-language lang
@ -434,7 +362,6 @@
(a number (+ a a)) (a number (+ a a))
(A hole (+ a A) (+ A a)) (A hole (+ a A) (+ A a))
(C hole) (C hole)
(d (x (in-hole C y)) #:binds x y)
(e ((in-hole (in-hole f (number_1 hole)) number_1) number_1)) (e ((in-hole (in-hole f (number_1 hole)) number_1) number_1))
(f (in-hole C (number_1 hole))) (f (in-hole C (number_1 hole)))
(g (in-hole (side-condition (hole number_1) (zero? (term number_1))) number_2)) (g (in-hole (side-condition (hole number_1) (zero? (term number_1))) number_2))
@ -462,9 +389,6 @@
lang (variable_!_1 (in-hole C variable_!_1)) 5 0 lang (variable_!_1 (in-hole C variable_!_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y)))) (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y))))
'(x y)) '(x y))
(test (let/ec k
(generate-term/decisions lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x))
(test (generate-term/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2)))) (test (generate-term/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2))))
'((2 (1 1)) 1)) '((2 (1 1)) 1))
(test (generate-term/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0)))) (test (generate-term/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
@ -565,7 +489,7 @@
(test (test
(generate-term/decisions (generate-term/decisions
L (side-condition x (number? (term x))) 0 0 L (side-condition x (number? (term x))) 0 0
(decisions #:var (λ (lang-chars lang-lits bound-vars attempt) (decisions #:var (λ (lang-chars lang-lits attempt)
(if (>= attempt retry-threshold) 0 'x)))) (if (>= attempt retry-threshold) 0 'x))))
0) 0)
@ -574,7 +498,7 @@
[finish (+ retry-threshold post-threshold-incr)]) [finish (+ retry-threshold post-threshold-incr)])
(generate-term/decisions (generate-term/decisions
L (side-condition x (number? (term x))) 0 start L (side-condition x (number? (term x))) 0 start
(decisions #:var (λ (lang-chars lang-lits bound-vars attempt) (decisions #:var (λ (lang-chars lang-lits attempt)
(set! attempts (cons attempt attempts)) (set! attempts (cons attempt attempts))
(if (= attempt finish) 0 'x)))) (if (= attempt finish) 0 'x))))
(test attempts (list finish retry-threshold start)))) (test attempts (list finish retry-threshold start))))

132
collects/redex/private/rg.ss
View File

@ -1,18 +1,3 @@
#|
redex: disallow non-terminals on rhs of rules unless they are actually bound(?)
need support for:
- collecting statistics
- simplifying test cases
To do a better job of not generating programs with free variables,
keep track of which forms introduce binders
and prefer to generate that before generating any variables
(also get rid of kludge, as below)
|#
#lang scheme #lang scheme
(require "matcher.ss" (require "matcher.ss"
@ -27,13 +12,11 @@ To do a better job of not generating programs with free variables,
(for-syntax "keyword-macros.ss") (for-syntax "keyword-macros.ss")
mrlib/tex-table) mrlib/tex-table)
(define (allow-free-var? [random random]) (= 0 (random 30)))
(define (exotic-choice? [random random]) (= 0 (random 5))) (define (exotic-choice? [random random]) (= 0 (random 5)))
(define (use-lang-literal? [random random]) (= 0 (random 20))) (define (use-lang-literal? [random random]) (= 0 (random 20)))
(define (preferred-production? attempt [random random]) (define (preferred-production? attempt [random random])
(and (>= attempt preferred-production-threshold) (and (>= attempt preferred-production-threshold)
(zero? (random 2)))) (zero? (random 2))))
(define (try-to-introduce-binder?) (= 0 (random 2)) #f)
;; unique-chars : (listof string) -> (listof char) ;; unique-chars : (listof string) -> (listof char)
(define (unique-chars strings) (define (unique-chars strings)
@ -49,11 +32,9 @@ To do a better job of not generating programs with free variables,
(define tex-chars-threshold 500) (define tex-chars-threshold 500)
(define chinese-chars-threshold 2000) (define chinese-chars-threshold 2000)
(define (pick-var lang-chars lang-lits bound-vars attempt [random random]) (define (pick-var lang-chars lang-lits attempt [random random])
(if (or (null? bound-vars) (allow-free-var? random)) (let ([length (add1 (random-natural 4/5 random))])
(let ([length (add1 (random-natural 4/5 random))]) (string->symbol (random-string lang-chars lang-lits length attempt random))))
(string->symbol (random-string lang-chars lang-lits length attempt random)))
(pick-from-list bound-vars random)))
(define (pick-char attempt lang-chars [random random]) (define (pick-char attempt lang-chars [random random])
(if (and (not (null? lang-chars)) (if (and (not (null? lang-chars))
@ -83,16 +64,11 @@ To do a better job of not generating programs with free variables,
(define (pick-string lang-chars lang-lits attempt [random random]) (define (pick-string lang-chars lang-lits attempt [random random])
(random-string lang-chars lang-lits (random-natural 1/5 random) attempt random)) (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random))
(define (pick-nt name lang bound-vars attempt pref-prods (define (pick-nt name lang attempt pref-prods
[random random] [random random]
[pref-prod? preferred-production?]) [pref-prod? preferred-production?])
(let* ([prods (nt-rhs (nt-by-name lang name))] (let ([prods (nt-rhs (nt-by-name lang name))])
[binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)] (cond [(and pref-prods (pref-prod? attempt random))
[do-intro-binder? (and (null? bound-vars)
(not (null? binders))
(try-to-introduce-binder?))])
(cond [do-intro-binder? binders]
[(and pref-prods (pref-prod? attempt random))
(hash-ref pref-prods name)] (hash-ref pref-prods name)]
[else prods]))) [else prods])))
@ -197,23 +173,22 @@ To do a better job of not generating programs with free variables,
(import) (export decisions^)) (import) (export decisions^))
(define ((generate-nt lang generate base-table pref-prods) (define ((generate-nt lang generate base-table pref-prods)
name fvt-id bound-vars size attempt in-hole state) name size attempt in-hole state)
(let*-values (let*-values
([(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)] ([(term _)
[(term _)
(generate/pred (generate/pred
name name
(λ (size attempt) (λ (size attempt)
(let ([rhs (pick-from-list (let ([rhs (pick-from-list
(if (zero? size) (if (zero? size)
(min-prods (nt-by-name lang name) base-table) (min-prods (nt-by-name lang name) base-table)
((next-non-terminal-decision) name lang bound-vars attempt pref-prods)))]) ((next-non-terminal-decision) name lang attempt pref-prods)))])
(generate bound-vars (max 0 (sub1 size)) attempt (generate (max 0 (sub1 size)) attempt
(make-state (map fvt-entry (rhs-var-info rhs)) #hash()) (make-state #hash())
in-hole (rhs-pattern rhs)))) in-hole (rhs-pattern rhs))))
(λ (_ env) (mismatches-satisfied? env)) (λ (_ env) (mismatches-satisfied? env))
size attempt)]) size attempt)])
(values term (extend-found-vars fvt-id term state)))) term))
(define (generate-sequence ellipsis generate state length) (define (generate-sequence ellipsis generate state length)
(define (split-environment env) (define (split-environment env)
@ -228,16 +203,15 @@ To do a better job of not generating programs with free variables,
(hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs))) (hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs)))
(state-env state) (ellipsis-vars ellipsis))) (state-env state) (ellipsis-vars ellipsis)))
(let-values (let-values
([(seq envs fvt) ([(seq envs)
(let recur ([fvt (state-fvt state)] (let recur ([envs (split-environment (state-env state))])
[envs (split-environment (state-env state))])
(if (null? envs) (if (null? envs)
(values null null fvt) (values null null)
(let*-values (let*-values
([(term state) (generate (make-state fvt (car envs)) the-hole (ellipsis-pattern ellipsis))] ([(term state) (generate (make-state (car envs)) the-hole (ellipsis-pattern ellipsis))]
[(terms envs fvt) (recur (state-fvt state) (cdr envs))]) [(terms envs) (recur (cdr envs))])
(values (cons term terms) (cons (state-env state) envs) fvt))))]) (values (cons term terms) (cons (state-env state) envs)))))])
(values seq (make-state fvt (merge-environments envs))))) (values seq (make-state (merge-environments envs)))))
(define (generate/pred name gen pred init-sz init-att) (define (generate/pred name gen pred init-sz init-att)
(let ([pre-threshold-incr (let ([pre-threshold-incr
@ -290,10 +264,10 @@ To do a better job of not generating programs with free variables,
(and (not (hash-ref prior val #f)) (and (not (hash-ref prior val #f))
(hash-set! prior val #t))))))) (hash-set! prior val #t)))))))
(define-struct state (fvt env)) (define-struct state (env))
(define new-state (make-state null #hash())) (define new-state (make-state #hash()))
(define (set-env state name value) (define (set-env state name value)
(make-state (state-fvt state) (hash-set (state-env state) name value))) (make-state (hash-set (state-env state) name value)))
(define (bindings env) (define (bindings env)
(make-bindings (make-bindings
@ -302,15 +276,11 @@ To do a better job of not generating programs with free variables,
(cons (make-bind (binder-name key) val) bindings) (cons (make-bind (binder-name key) val) bindings)
bindings)))) bindings))))
(define-struct found-vars (nt source bound-vars found-nt?)) (define (generate-pat lang sexp pref-prods size attempt state in-hole pat)
(define (fvt-entry binds) (define recur (curry generate-pat lang sexp pref-prods size attempt))
(make-found-vars (binds-binds binds) (binds-source binds) '() #f))
(define (generate-pat lang sexp pref-prods bound-vars size attempt state in-hole pat)
(define recur (curry generate-pat lang sexp pref-prods bound-vars size attempt))
(define recur/pat (recur state in-hole)) (define recur/pat (recur state in-hole))
(define ((recur/pat/size-attempt pat) size attempt) (define ((recur/pat/size-attempt pat) size attempt)
(generate-pat lang sexp pref-prods bound-vars size attempt state in-hole pat)) (generate-pat lang sexp pref-prods size attempt state in-hole pat))
(define clang (rg-lang-clang lang)) (define clang (rg-lang-clang lang))
(define gen-nt (generate-nt (define gen-nt (generate-nt
@ -331,7 +301,7 @@ To do a better job of not generating programs with free variables,
size attempt)] size attempt)]
[`variable [`variable
(values ((next-variable-decision) (values ((next-variable-decision)
(rg-lang-chars lang) (rg-lang-lits lang) bound-vars attempt) (rg-lang-chars lang) (rg-lang-lits lang) attempt)
state)] state)]
[`variable-not-otherwise-mentioned [`variable-not-otherwise-mentioned
(generate/pred 'variable (generate/pred 'variable
@ -363,22 +333,22 @@ To do a better job of not generating programs with free variables,
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)] (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
; Don't use preferred productions for the sexp language. ; Don't use preferred productions for the sexp language.
[(pref-prods) (if (eq? new-lang lang) pref-prods #f)] [(pref-prods) (if (eq? new-lang lang) pref-prods #f)]
[(term _) (generate-pat new-lang sexp pref-prods null size attempt new-state the-hole nt)]) [(term _) (generate-pat new-lang sexp pref-prods size attempt new-state the-hole nt)])
(values term state))] (values term state))]
[(? (is-nt? clang)) [(? (is-nt? clang))
(gen-nt pat pat bound-vars size attempt in-hole state)] (values (gen-nt pat size attempt in-hole state) state)]
[(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))) [(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))))
(generate/prior pat state (λ () (gen-nt nt name bound-vars size attempt in-hole state)))] (generate/prior pat state (λ () (values (gen-nt nt size attempt in-hole state) state)))]
[(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b))))) [(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b)))))
(generate/prior pat state (λ () (recur/pat b)))] (generate/prior pat state (λ () (recur/pat b)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt))))) [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt)))))
(let-values ([(term state) (gen-nt nt pat bound-vars size attempt in-hole state)]) (let ([term (gen-nt nt size attempt in-hole state)])
(values term (set-env state pat term)))] (values term (set-env state pat term)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b))))) [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b)))))
(let-values ([(term state) (recur/pat b)]) (let-values ([(term state) (recur/pat b)])
(values term (set-env state pat term)))] (values term (set-env state pat term)))]
[`(cross ,(? symbol? cross-nt)) [`(cross ,(? symbol? cross-nt))
(gen-nt cross-nt #f bound-vars size attempt in-hole state)] (values (gen-nt cross-nt size attempt in-hole state) state)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)] [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)]
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)]) (let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)])
@ -395,40 +365,6 @@ To do a better job of not generating programs with free variables,
[else [else
(error what "unknown pattern ~s\n" pat)])) (error what "unknown pattern ~s\n" pat)]))
(define (extract-bound-vars pat state)
(let loop ([found-vars-table (state-fvt state)])
(cond
[(null? found-vars-table) '()]
[else (let ([found-vars (car found-vars-table)])
(if (eq? pat (found-vars-nt found-vars))
(found-vars-bound-vars found-vars)
(loop (cdr found-vars-table))))])))
(define (extend-found-vars pat res state)
(make-state
(map
(λ (found-vars)
(cond
[(eq? (found-vars-source found-vars) pat)
(let ([new-found-vars
(make-found-vars (found-vars-nt found-vars)
(found-vars-source found-vars)
(cons res (found-vars-bound-vars found-vars))
#f)])
(when (found-vars-found-nt? found-vars)
(error what "kludge in #:binds was exposed! #:binds ~s ~s"
(found-vars-nt found-vars)
(found-vars-source found-vars)))
new-found-vars)]
[(eq? (found-vars-nt found-vars) pat)
(make-found-vars (found-vars-nt found-vars)
(found-vars-source found-vars)
(found-vars-bound-vars found-vars)
#t)]
[else found-vars]))
(state-fvt state))
(state-env state)))
(let ([rg-lang (prepare-lang lang)] (let ([rg-lang (prepare-lang lang)]
[rg-sexp (prepare-lang sexp)]) [rg-sexp (prepare-lang sexp)])
(λ (pat) (λ (pat)
@ -440,7 +376,7 @@ To do a better job of not generating programs with free variables,
(λ (size attempt) (λ (size attempt)
(generate-pat (generate-pat
rg-lang rg-sexp ((next-pref-prods-decision) (rg-lang-clang rg-lang)) rg-lang rg-sexp ((next-pref-prods-decision) (rg-lang-clang rg-lang))
null size attempt new-state the-hole parsed)) size attempt new-state the-hole parsed))
(λ (_ env) (mismatches-satisfied? env)) (λ (_ env) (mismatches-satisfied? env))
size attempt)]) size attempt)])
(values term (bindings (state-env state))))))))) (values term (bindings (state-env state)))))))))
@ -615,8 +551,8 @@ To do a better job of not generating programs with free variables,
(define ((parse-nt mode) nt) (define ((parse-nt mode) nt)
(make-nt (nt-name nt) (map (parse-rhs mode) (nt-rhs nt)))) (make-nt (nt-name nt) (map (parse-rhs mode) (nt-rhs nt))))
(define ((parse-rhs mode) rhs) (define ((parse-rhs mode) rhs)
(make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) lang mode)) (make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) lang mode))))
(rhs-var-info rhs)))
(struct-copy (struct-copy
compiled-lang lang compiled-lang lang
[lang (map (parse-nt 'grammar) (compiled-lang-lang lang))] [lang (map (parse-nt 'grammar) (compiled-lang-lang lang))]