Removed support for the #:binds annotation.
svn: r14319
This commit is contained in:
Casey Klein
parent
99aac7d745
commit
72c3ed943e
|
|
@ -56,7 +56,7 @@
|
|||
(test-empty '(variable-except x) 'x #f)
|
||||
(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))
|
||||
(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:x (list (make-test-mtch (make-bindings null) 'x:x none)))
|
||||
(test-empty '(variable-prefix x:) ': #f)
|
||||
|
|
@ -527,84 +527,84 @@
|
|||
(build-compatible-context-language
|
||||
(mk-hasheq '((exp . ()) (ctxt . ())))
|
||||
(list (make-nt 'exp
|
||||
(list (make-rhs '(+ exp exp) '())
|
||||
(make-rhs 'number '())))
|
||||
(list (make-rhs '(+ exp exp))
|
||||
(make-rhs 'number)))
|
||||
(make-nt 'ctxt
|
||||
(list (make-rhs '(+ ctxt exp) '())
|
||||
(make-rhs '(+ exp ctxt) '())
|
||||
(make-rhs 'hole '())))))
|
||||
(list (make-rhs '(+ ctxt exp))
|
||||
(make-rhs '(+ exp ctxt))
|
||||
(make-rhs 'hole)))))
|
||||
(list
|
||||
(make-nt 'ctxt-ctxt
|
||||
(list (make-rhs 'hole '())
|
||||
(make-rhs `(+ (cross ctxt-ctxt) exp) '())
|
||||
(make-rhs `(+ ctxt (cross ctxt-exp)) '())
|
||||
(make-rhs `(+ (cross ctxt-exp) ctxt) '())
|
||||
(make-rhs `(+ exp (cross ctxt-ctxt)) '())))
|
||||
(list (make-rhs 'hole)
|
||||
(make-rhs `(+ (cross ctxt-ctxt) exp))
|
||||
(make-rhs `(+ ctxt (cross ctxt-exp)))
|
||||
(make-rhs `(+ (cross ctxt-exp) ctxt))
|
||||
(make-rhs `(+ exp (cross ctxt-ctxt)))))
|
||||
(make-nt 'ctxt-exp
|
||||
(list (make-rhs `(+ (cross ctxt-exp) exp) '())
|
||||
(make-rhs `(+ exp (cross ctxt-exp)) '())))
|
||||
(list (make-rhs `(+ (cross ctxt-exp) exp))
|
||||
(make-rhs `(+ exp (cross ctxt-exp)))))
|
||||
(make-nt 'exp-ctxt
|
||||
(list (make-rhs `(+ (cross exp-ctxt) exp) '())
|
||||
(make-rhs `(+ ctxt (cross exp-exp)) '())
|
||||
(make-rhs `(+ (cross exp-exp) ctxt) '())
|
||||
(make-rhs `(+ exp (cross exp-ctxt)) '())))
|
||||
(list (make-rhs `(+ (cross exp-ctxt) exp))
|
||||
(make-rhs `(+ ctxt (cross exp-exp)))
|
||||
(make-rhs `(+ (cross exp-exp) ctxt))
|
||||
(make-rhs `(+ exp (cross exp-ctxt)))))
|
||||
(make-nt 'exp-exp
|
||||
(list (make-rhs 'hole '())
|
||||
(make-rhs `(+ (cross exp-exp) exp) '())
|
||||
(make-rhs `(+ exp (cross exp-exp)) '())))))
|
||||
(list (make-rhs 'hole)
|
||||
(make-rhs `(+ (cross exp-exp) exp))
|
||||
(make-rhs `(+ exp (cross exp-exp)))))))
|
||||
|
||||
(run-test
|
||||
'compatible-context-language2
|
||||
(build-compatible-context-language
|
||||
(mk-hasheq '((m . ()) (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) '())))))
|
||||
(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))))))
|
||||
(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
|
||||
(list
|
||||
(make-rhs (list (list 'cross 'v-m) 'm) '())
|
||||
(make-rhs (list 'm (list 'cross 'v-m)) '())
|
||||
(make-rhs (list '+ (list 'cross 'v-m) 'm) '())
|
||||
(make-rhs (list '+ 'm (list 'cross 'v-m)) '())
|
||||
(make-rhs (list 'cross 'v-v) '())))
|
||||
(make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m)) '())))
|
||||
(make-rhs (list (list 'cross 'v-m) 'm))
|
||||
(make-rhs (list 'm (list 'cross 'v-m)))
|
||||
(make-rhs (list '+ (list 'cross 'v-m) 'm))
|
||||
(make-rhs (list '+ 'm (list 'cross 'v-m)))
|
||||
(make-rhs (list 'cross 'v-v))))
|
||||
(make-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-m)))))
|
||||
(make-nt 'm-m
|
||||
(list
|
||||
(make-rhs 'hole '())
|
||||
(make-rhs (list (list 'cross 'm-m) 'm) '())
|
||||
(make-rhs (list 'm (list 'cross 'm-m)) '())
|
||||
(make-rhs (list '+ (list 'cross 'm-m) 'm) '())
|
||||
(make-rhs (list '+ 'm (list 'cross 'm-m)) '())
|
||||
(make-rhs (list 'cross 'm-v) '())))))
|
||||
(make-rhs 'hole)
|
||||
(make-rhs (list (list 'cross 'm-m) 'm))
|
||||
(make-rhs (list 'm (list 'cross 'm-m)))
|
||||
(make-rhs (list '+ (list 'cross 'm-m) 'm))
|
||||
(make-rhs (list '+ 'm (list 'cross 'm-m)))
|
||||
(make-rhs (list 'cross 'm-v))))))
|
||||
|
||||
(run-test
|
||||
'compatible-context-language3
|
||||
(build-compatible-context-language
|
||||
(mk-hasheq '((m . ()) (seven . ())))
|
||||
(list (make-nt 'm (list (make-rhs '(m seven m) '()) (make-rhs 'number '())))
|
||||
(make-nt 'seven (list (make-rhs 7 '())))))
|
||||
(list (make-nt 'm (list (make-rhs '(m seven m)) (make-rhs 'number)))
|
||||
(make-nt 'seven (list (make-rhs 7)))))
|
||||
`(,(make-nt
|
||||
'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
|
||||
'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-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)))))
|
||||
|
||||
(run-test
|
||||
'compatible-context-language4
|
||||
(build-compatible-context-language
|
||||
(mk-hasheq '((a . ()) (b . ()) (c . ())))
|
||||
(list (make-nt 'a (list (make-rhs 'b '())))
|
||||
(make-nt 'b (list (make-rhs 'c '())))
|
||||
(make-nt 'c (list (make-rhs 3 '())))))
|
||||
(list (make-nt 'c-c (list (make-rhs 'hole '())))
|
||||
(make-nt 'c-b (list (make-rhs '(cross c-c) '())))
|
||||
(make-nt 'c-a (list (make-rhs '(cross c-b) '())))
|
||||
(make-nt 'b-b (list (make-rhs 'hole '())))
|
||||
(make-nt 'b-a (list (make-rhs '(cross b-b) '())))
|
||||
(make-nt 'a-a (list (make-rhs 'hole '())))))
|
||||
(list (make-nt 'a (list (make-rhs 'b)))
|
||||
(make-nt 'b (list (make-rhs 'c)))
|
||||
(make-nt 'c (list (make-rhs 3)))))
|
||||
(list (make-nt 'c-c (list (make-rhs 'hole)))
|
||||
(make-nt 'c-b (list (make-rhs '(cross c-c))))
|
||||
(make-nt 'c-a (list (make-rhs '(cross c-b))))
|
||||
(make-nt 'b-b (list (make-rhs 'hole)))
|
||||
(make-nt 'b-a (list (make-rhs '(cross b-b))))
|
||||
(make-nt 'a-a (list (make-rhs 'hole)))))
|
||||
|
||||
#;
|
||||
(test-xab '(in-hole (cross exp) (+ number number))
|
||||
|
|
@ -667,40 +667,40 @@
|
|||
(unless xab-lang
|
||||
(let ([nts
|
||||
(list (make-nt 'exp
|
||||
(list (make-rhs '(+ exp exp) '())
|
||||
(make-rhs 'number '())))
|
||||
(list (make-rhs '(+ exp exp))
|
||||
(make-rhs 'number)))
|
||||
(make-nt 'ctxt
|
||||
(list (make-rhs '(+ ctxt exp) '())
|
||||
(make-rhs '(+ exp ctxt) '())
|
||||
(make-rhs 'hole '())))
|
||||
(list (make-rhs '(+ ctxt exp))
|
||||
(make-rhs '(+ exp ctxt))
|
||||
(make-rhs 'hole)))
|
||||
|
||||
(make-nt 'ec-one
|
||||
(list (make-rhs '(+ (hole xx) exp) '())
|
||||
(make-rhs '(+ exp (hole xx)) '())))
|
||||
(list (make-rhs '(+ (hole xx) exp))
|
||||
(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-rhs 'x '())))
|
||||
(make-nt 'forever-list (list (make-rhs '(forever-list forever-list ...))
|
||||
(make-rhs 'x)))
|
||||
|
||||
(make-nt 'lsts
|
||||
(list (make-rhs '() '())
|
||||
(make-rhs '(x) '())
|
||||
(make-rhs 'x '())
|
||||
(make-rhs '#f '())))
|
||||
(list (make-rhs '())
|
||||
(make-rhs '(x))
|
||||
(make-rhs 'x)
|
||||
(make-rhs '#f)))
|
||||
(make-nt 'split-out
|
||||
(list (make-rhs 'split-out2 '())))
|
||||
(list (make-rhs '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
|
||||
(list (make-rhs '(a (name x nesting-names)) '())
|
||||
(make-rhs 'b '())))
|
||||
(make-nt 'var (list (make-rhs `variable-not-otherwise-mentioned '())))
|
||||
(list (make-rhs '(a (name x nesting-names)))
|
||||
(make-rhs 'b)))
|
||||
(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
|
||||
(compile-language 'pict-stuff-not-used
|
||||
|
|
@ -720,9 +720,9 @@
|
|||
(compile-language
|
||||
'pict-stuff-not-used
|
||||
(list (make-nt 'aa
|
||||
(list (make-rhs 'a '())))
|
||||
(list (make-rhs 'a)))
|
||||
(make-nt 'bb
|
||||
(list (make-rhs 'b '()))))
|
||||
(list (make-rhs 'b))))
|
||||
'((aa) (bb)))))
|
||||
(run-match-test
|
||||
`(match-pattern (compile-pattern ab-lang ',pat #t) ',exp)
|
||||
|
|
|
|||
|
|
@ -22,10 +22,10 @@ before the pattern compiler is invoked.
|
|||
|
||||
;; lang = (listof nt)
|
||||
;; nt = (make-nt sym (listof rhs))
|
||||
;; rhs = (make-rhs single-pattern (listof var-info??))
|
||||
;; rhs = (make-rhs single-pattern)
|
||||
;; single-pattern = sexp
|
||||
(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)
|
||||
;; 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))
|
||||
(make-nt (nt-name compat-nt)
|
||||
(cons
|
||||
(make-rhs 'hole '())
|
||||
(make-rhs 'hole)
|
||||
(nt-rhs compat-nt)))
|
||||
compat-nt)))
|
||||
lang))
|
||||
|
|
@ -350,7 +350,7 @@ before the pattern compiler is invoked.
|
|||
(cond
|
||||
[(zero? i) null]
|
||||
[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))))]))))
|
||||
(nt-rhs nt)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1366,45 +1366,6 @@
|
|||
[(_ lang-id (name rhs ...) ...)
|
||||
(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
|
||||
(for-each
|
||||
(λ (name)
|
||||
|
|
@ -1450,21 +1411,15 @@
|
|||
name))))
|
||||
all-names)
|
||||
|
||||
(with-syntax ([(((r-rhs var-info) ...) ...)
|
||||
(with-syntax ([((r-rhs ...) ...)
|
||||
(map (lambda (rhss)
|
||||
(let loop ([rhss (syntax->list rhss)])
|
||||
(cond
|
||||
[(null? rhss) '()]
|
||||
[else
|
||||
(let ([x (car rhss)])
|
||||
(let-values ([(var-info rest) (collect-binds-clauses x #'lang rhss)])
|
||||
(cons (list (rewrite-side-conditions/check-errs
|
||||
(map syntax-e all-names)
|
||||
'language
|
||||
#f
|
||||
x)
|
||||
var-info)
|
||||
(loop rest))))])))
|
||||
(map (lambda (rhs)
|
||||
(rewrite-side-conditions/check-errs
|
||||
(map syntax-e all-names)
|
||||
'language
|
||||
#f
|
||||
rhs))
|
||||
(syntax->list rhss)))
|
||||
(syntax->list (syntax ((rhs ...) ...))))]
|
||||
[(refs ...)
|
||||
(let loop ([stx (syntax ((rhs ...) ...))])
|
||||
|
|
@ -1510,8 +1465,8 @@
|
|||
(let ([all-names 1] ...)
|
||||
(begin (void) refs ...))
|
||||
(compile-language (list (list '(uniform-names ...) (to-lw rhs) ...) ...)
|
||||
(list (make-nt 'first-names (list (make-rhs `r-rhs var-info) ...)) ...
|
||||
(make-nt 'new-name (list (make-rhs 'orig-name '()))) ...)
|
||||
(list (make-nt 'first-names (list (make-rhs `r-rhs) ...)) ...
|
||||
(make-nt 'new-name (list (make-rhs 'orig-name))) ...)
|
||||
'((uniform-names ...) ...))))))))]
|
||||
[(_ (name rhs ...) ...)
|
||||
(for-each
|
||||
|
|
@ -1596,7 +1551,7 @@
|
|||
(syntax->list #'(name ...))))])
|
||||
(syntax/loc stx
|
||||
(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) ...) ...))))]
|
||||
[(_ lang (name rhs ...) ...)
|
||||
(begin
|
||||
|
|
@ -1699,7 +1654,7 @@
|
|||
(for-each (λ (shortcut-name)
|
||||
(hash-set! new-ht
|
||||
shortcut-name
|
||||
(make-nt shortcut-name (list (make-rhs (car names) '())))))
|
||||
(make-nt shortcut-name (list (make-rhs (car names))))))
|
||||
(cdr names)))))
|
||||
|
||||
new-nts)
|
||||
|
|
|
|||
|
|
@ -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 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 '(x) 0 (make-random .5 0)) 'x)
|
||||
(test (pick-var chars lits 0 (make-random .01 1 2 1 0)) 'dcb)
|
||||
(test (pick-char 0 null (make-random 65)) #\a)
|
||||
(test (random-string null null 1 0 (make-random 65)) "a"))
|
||||
|
||||
(let ()
|
||||
(define-language L
|
||||
(a 5 (x a) #:binds x a)
|
||||
(a 5 (x a))
|
||||
(b 4))
|
||||
(test (pick-nt 'a L '(x) 1 'dontcare)
|
||||
(test (pick-nt 'a L 1 'dontcare)
|
||||
(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))))
|
||||
(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-random 0))
|
||||
(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)))))
|
||||
|
||||
(define-syntax raised-exn-msg
|
||||
|
|
@ -132,7 +131,7 @@
|
|||
|
||||
(define (patterns . selectors)
|
||||
(map (λ (selector)
|
||||
(λ (name lang vars size pref-prods)
|
||||
(λ (name lang size pref-prods)
|
||||
(list (selector (nt-rhs (nt-by-name lang name))))))
|
||||
selectors))
|
||||
|
||||
|
|
@ -207,35 +206,6 @@
|
|||
#:var (list (λ _ '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
|
||||
(let ()
|
||||
(define-language var
|
||||
|
|
@ -300,23 +270,6 @@
|
|||
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5))))
|
||||
'((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 ()
|
||||
(define-language lang (e (variable-prefix pf)))
|
||||
(test
|
||||
|
|
@ -340,17 +293,6 @@
|
|||
#:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
|
||||
'(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 ()
|
||||
(define-language lang
|
||||
(a (number_!_1 number_!_2 number_!_1))
|
||||
|
|
@ -387,19 +329,12 @@
|
|||
(a 43)
|
||||
(b (side-condition a_1 (odd? (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))))
|
||||
(x variable))
|
||||
(test (generate-term lang b 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))
|
||||
#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
|
||||
(generate-term/decisions
|
||||
lang e 5 0
|
||||
|
|
@ -409,14 +344,7 @@
|
|||
(generate-term/decisions
|
||||
lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ '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))))
|
||||
'y))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
|
|
@ -434,7 +362,6 @@
|
|||
(a number (+ a a))
|
||||
(A hole (+ a A) (+ A a))
|
||||
(C hole)
|
||||
(d (x (in-hole C y)) #:binds x y)
|
||||
(e ((in-hole (in-hole f (number_1 hole)) number_1) number_1))
|
||||
(f (in-hole C (number_1 hole)))
|
||||
(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
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ '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))))
|
||||
'((2 (1 1)) 1))
|
||||
(test (generate-term/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
|
||||
|
|
@ -565,7 +489,7 @@
|
|||
(test
|
||||
(generate-term/decisions
|
||||
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))))
|
||||
0)
|
||||
|
||||
|
|
@ -574,7 +498,7 @@
|
|||
[finish (+ retry-threshold post-threshold-incr)])
|
||||
(generate-term/decisions
|
||||
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))
|
||||
(if (= attempt finish) 0 'x))))
|
||||
(test attempts (list finish retry-threshold start))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
(require "matcher.ss"
|
||||
|
|
@ -27,13 +12,11 @@ To do a better job of not generating programs with free variables,
|
|||
(for-syntax "keyword-macros.ss")
|
||||
mrlib/tex-table)
|
||||
|
||||
(define (allow-free-var? [random random]) (= 0 (random 30)))
|
||||
(define (exotic-choice? [random random]) (= 0 (random 5)))
|
||||
(define (use-lang-literal? [random random]) (= 0 (random 20)))
|
||||
(define (preferred-production? attempt [random random])
|
||||
(and (>= attempt preferred-production-threshold)
|
||||
(zero? (random 2))))
|
||||
(define (try-to-introduce-binder?) (= 0 (random 2)) #f)
|
||||
|
||||
;; unique-chars : (listof string) -> (listof char)
|
||||
(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 chinese-chars-threshold 2000)
|
||||
|
||||
(define (pick-var lang-chars lang-lits bound-vars attempt [random random])
|
||||
(if (or (null? bound-vars) (allow-free-var? random))
|
||||
(let ([length (add1 (random-natural 4/5 random))])
|
||||
(string->symbol (random-string lang-chars lang-lits length attempt random)))
|
||||
(pick-from-list bound-vars random)))
|
||||
(define (pick-var lang-chars lang-lits attempt [random random])
|
||||
(let ([length (add1 (random-natural 4/5 random))])
|
||||
(string->symbol (random-string lang-chars lang-lits length attempt random))))
|
||||
|
||||
(define (pick-char attempt lang-chars [random random])
|
||||
(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])
|
||||
(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]
|
||||
[pref-prod? preferred-production?])
|
||||
(let* ([prods (nt-rhs (nt-by-name lang name))]
|
||||
[binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)]
|
||||
[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))
|
||||
(let ([prods (nt-rhs (nt-by-name lang name))])
|
||||
(cond [(and pref-prods (pref-prod? attempt random))
|
||||
(hash-ref pref-prods name)]
|
||||
[else prods])))
|
||||
|
||||
|
|
@ -197,23 +173,22 @@ To do a better job of not generating programs with free variables,
|
|||
(import) (export decisions^))
|
||||
|
||||
(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
|
||||
([(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
|
||||
[(term _)
|
||||
([(term _)
|
||||
(generate/pred
|
||||
name
|
||||
(λ (size attempt)
|
||||
(let ([rhs (pick-from-list
|
||||
(if (zero? size)
|
||||
(min-prods (nt-by-name lang name) base-table)
|
||||
((next-non-terminal-decision) name lang bound-vars attempt pref-prods)))])
|
||||
(generate bound-vars (max 0 (sub1 size)) attempt
|
||||
(make-state (map fvt-entry (rhs-var-info rhs)) #hash())
|
||||
((next-non-terminal-decision) name lang attempt pref-prods)))])
|
||||
(generate (max 0 (sub1 size)) attempt
|
||||
(make-state #hash())
|
||||
in-hole (rhs-pattern rhs))))
|
||||
(λ (_ env) (mismatches-satisfied? env))
|
||||
size attempt)])
|
||||
(values term (extend-found-vars fvt-id term state))))
|
||||
term))
|
||||
|
||||
(define (generate-sequence ellipsis generate state length)
|
||||
(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)))
|
||||
(state-env state) (ellipsis-vars ellipsis)))
|
||||
(let-values
|
||||
([(seq envs fvt)
|
||||
(let recur ([fvt (state-fvt state)]
|
||||
[envs (split-environment (state-env state))])
|
||||
([(seq envs)
|
||||
(let recur ([envs (split-environment (state-env state))])
|
||||
(if (null? envs)
|
||||
(values null null fvt)
|
||||
(values null null)
|
||||
(let*-values
|
||||
([(term state) (generate (make-state fvt (car envs)) the-hole (ellipsis-pattern ellipsis))]
|
||||
[(terms envs fvt) (recur (state-fvt state) (cdr envs))])
|
||||
(values (cons term terms) (cons (state-env state) envs) fvt))))])
|
||||
(values seq (make-state fvt (merge-environments envs)))))
|
||||
([(term state) (generate (make-state (car envs)) the-hole (ellipsis-pattern ellipsis))]
|
||||
[(terms envs) (recur (cdr envs))])
|
||||
(values (cons term terms) (cons (state-env state) envs)))))])
|
||||
(values seq (make-state (merge-environments envs)))))
|
||||
|
||||
(define (generate/pred name gen pred init-sz init-att)
|
||||
(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))
|
||||
(hash-set! prior val #t)))))))
|
||||
|
||||
(define-struct state (fvt env))
|
||||
(define new-state (make-state null #hash()))
|
||||
(define-struct state (env))
|
||||
(define new-state (make-state #hash()))
|
||||
(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)
|
||||
(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)
|
||||
bindings))))
|
||||
|
||||
(define-struct found-vars (nt source bound-vars found-nt?))
|
||||
(define (fvt-entry binds)
|
||||
(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 (generate-pat lang sexp pref-prods size attempt state in-hole pat)
|
||||
(define recur (curry generate-pat lang sexp pref-prods size attempt))
|
||||
(define recur/pat (recur state in-hole))
|
||||
(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 gen-nt (generate-nt
|
||||
|
|
@ -331,7 +301,7 @@ To do a better job of not generating programs with free variables,
|
|||
size attempt)]
|
||||
[`variable
|
||||
(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)]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(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)]
|
||||
; Don't use preferred productions for the sexp language.
|
||||
[(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))]
|
||||
[(? (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))))))
|
||||
(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)))))
|
||||
(generate/prior pat state (λ () (recur/pat b)))]
|
||||
[(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)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b)))))
|
||||
(let-values ([(term state) (recur/pat b)])
|
||||
(values term (set-env state pat term)))]
|
||||
[`(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)]
|
||||
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
|
||||
(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
|
||||
(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)]
|
||||
[rg-sexp (prepare-lang sexp)])
|
||||
(λ (pat)
|
||||
|
|
@ -440,7 +376,7 @@ To do a better job of not generating programs with free variables,
|
|||
(λ (size attempt)
|
||||
(generate-pat
|
||||
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))
|
||||
size attempt)])
|
||||
(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)
|
||||
(make-nt (nt-name nt) (map (parse-rhs mode) (nt-rhs nt))))
|
||||
(define ((parse-rhs mode) rhs)
|
||||
(make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) lang mode))
|
||||
(rhs-var-info rhs)))
|
||||
(make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) lang mode))))
|
||||
|
||||
(struct-copy
|
||||
compiled-lang lang
|
||||
[lang (map (parse-nt 'grammar) (compiled-lang-lang lang))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user