- Fixed bug in pick-char' and random-string'.
- Added support for hole and in-hole patterns. - Fixed infinite loop triggered by `any' pattern. - Removed schemeunit-test from run-all-tests.ss. svn: r10978
This commit is contained in:
Casey Klein
parent
ff8578ca13
commit
ba4b0b6301
|
|
@ -5,7 +5,7 @@
|
|||
"matcher.ss"
|
||||
"term.ss"
|
||||
"rg.ss")
|
||||
|
||||
|
||||
(reset-count)
|
||||
|
||||
|
||||
|
|
@ -58,7 +58,8 @@
|
|||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(a (side-condition "strin_g" #t) 1/2 #t))
|
||||
(a (side-condition "strin_g" #t) 1/2 #t)
|
||||
(b ()))
|
||||
(let* ([literals (sort (lang-literals lang) string<=?)]
|
||||
[chars (sort (unique-chars literals) char<=?)])
|
||||
(test literals '("1/2" "side-condition" "strin_g"))
|
||||
|
|
@ -94,22 +95,40 @@
|
|||
(test (pick-var chars lits null 0 (make-random '(0 0 1 1 2 1 0))) 'dcb)
|
||||
(test (pick-var chars lits '(x) 0 (make-random '(1 0))) 'x)))
|
||||
|
||||
(let ()
|
||||
(define-language empty)
|
||||
(let* ([lits (sort (lang-literals empty) string<=?)]
|
||||
[chars (sort (unique-chars lits) char<=?)])
|
||||
(test (pick-char 0 chars (make-random '(65))) #\a)
|
||||
(test (random-string chars lits 1 0 (make-random '(65))) "a")))
|
||||
|
||||
(define (rhs-matching pat prods)
|
||||
(cond [(null? prods) (error 'rhs-matching "no rhs matching ~s" pat)]
|
||||
[(equal? (rhs-pattern (car prods)) pat) (car prods)]
|
||||
[else (rhs-matching pat (cdr prods))]))
|
||||
|
||||
(define-syntax expect-exn
|
||||
(syntax-rules ()
|
||||
[(_ expr)
|
||||
(with-handlers ([exn:fail? (λ (x) x)])
|
||||
(begin
|
||||
expr
|
||||
(let ()
|
||||
(define-struct exn-not-raised ())
|
||||
(make-exn-not-raised))))]))
|
||||
|
||||
(let ()
|
||||
(define-language l (a (a b) (a b c) c))
|
||||
(test (rhs-matching '(a b c) (nt-rhs (car (compiled-lang-lang l))))
|
||||
(cadr (nt-rhs (car (compiled-lang-lang l)))))
|
||||
(test (with-handlers ([exn:fail? exn-message])
|
||||
(rhs-matching '(a c) (nt-rhs (car (compiled-lang-lang l)))))
|
||||
(test (exn-message (expect-exn (rhs-matching '(a c) (nt-rhs (car (compiled-lang-lang l))))))
|
||||
#rx"no rhs matching"))
|
||||
|
||||
(define (select-pattern pat)
|
||||
(λ (prods . _) (rhs-matching pat prods)))
|
||||
|
||||
(define (patterns . ps) (map select-pattern ps))
|
||||
|
||||
(define (iterator name items)
|
||||
(let ([bi (box items)])
|
||||
(λ ()
|
||||
|
|
@ -120,7 +139,7 @@
|
|||
(let ([iter (iterator 'test-iterator '(a b))])
|
||||
(test (iter) 'a)
|
||||
(test (iter) 'b)
|
||||
(test (with-handlers ([exn:fail? exn-message]) (iter)) #rx"empty"))
|
||||
(test (exn-message (expect-exn (iter))) #rx"empty"))
|
||||
|
||||
(define (decisions #:var [var pick-var]
|
||||
#:nt [nt pick-nt]
|
||||
|
|
@ -147,10 +166,10 @@
|
|||
(generate
|
||||
lc 'e 1 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _'x))
|
||||
#:nt (list (select-pattern '(λ (x) e))
|
||||
(select-pattern '(variable-except λ))
|
||||
(select-pattern 'x)
|
||||
(select-pattern '(variable-except λ)))))
|
||||
#:nt (patterns '(λ (x) e)
|
||||
'(variable-except λ)
|
||||
'x
|
||||
'(variable-except λ))))
|
||||
'(λ (x) x))
|
||||
|
||||
;; Generate pattern that's not a non-terminal
|
||||
|
|
@ -183,14 +202,15 @@
|
|||
(e (e e) x (e (x) λ) #:binds x e)
|
||||
(x (variable-except λ)))
|
||||
(test
|
||||
(with-handlers ([exn:fail? exn-message])
|
||||
(exn-message
|
||||
(expect-exn
|
||||
(generate
|
||||
postfix 'e 2 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y))
|
||||
#:nt (list (select-pattern '(e (x) λ))
|
||||
(select-pattern 'x)
|
||||
(select-pattern '(variable-except λ))
|
||||
(select-pattern '(variable-except λ))))))
|
||||
#:nt (patterns '(e (x) λ)
|
||||
'x
|
||||
'(variable-except λ)
|
||||
'(variable-except λ))))))
|
||||
#rx"kludge"))
|
||||
|
||||
;; variable-except pattern
|
||||
|
|
@ -200,7 +220,7 @@
|
|||
(test
|
||||
(generate
|
||||
var 'e 2 0
|
||||
(decisions #:nt (list (select-pattern '(variable-except x y)))
|
||||
(decisions #:nt (patterns '(variable-except x y))
|
||||
#:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z))))
|
||||
'z))
|
||||
|
||||
|
|
@ -227,11 +247,11 @@
|
|||
(generate
|
||||
lc 'e 10 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))
|
||||
#:nt (list (select-pattern '(λ (x ...) e))
|
||||
(select-pattern '(variable-except λ))
|
||||
(select-pattern '(variable-except λ))
|
||||
(select-pattern 'x)
|
||||
(select-pattern '(variable-except λ)))
|
||||
#:nt (patterns '(λ (x ...) e)
|
||||
'(variable-except λ)
|
||||
'(variable-except λ)
|
||||
'x
|
||||
'(variable-except λ))
|
||||
#:seq (list (λ () 2)))))
|
||||
'(y x)))
|
||||
|
||||
|
|
@ -241,7 +261,7 @@
|
|||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x))
|
||||
#:nt (list (select-pattern '(variable-prefix pf)))))
|
||||
#:nt (patterns '(variable-prefix pf))))
|
||||
'pfx))
|
||||
|
||||
(let ()
|
||||
|
|
@ -257,25 +277,33 @@
|
|||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:nt (list (select-pattern '(e_1 e_2 e e_1 e_2))
|
||||
(select-pattern 'number)
|
||||
(select-pattern 'number)
|
||||
(select-pattern 'number))
|
||||
(decisions #:nt (patterns '(e_1 e_2 e e_1 e_2)
|
||||
'number
|
||||
'number
|
||||
'number)
|
||||
#:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
|
||||
'(2 3 4 2 3)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e (x x_1 x_1) #:binds x x_1)
|
||||
(e (x x_1 x_1) #:binds x x_1
|
||||
(x variable_1) #:binds x variable_1)
|
||||
(x variable))
|
||||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))
|
||||
#:nt (list (select-pattern '(x x_1 x_1))
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)))))
|
||||
#:nt (patterns '(x x_1 x_1)
|
||||
'variable
|
||||
'variable))))
|
||||
'(x))
|
||||
(test
|
||||
(let/ec k
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))
|
||||
#:nt (patterns '(x variable_1) 'variable))))
|
||||
'(x)))
|
||||
|
||||
(let ()
|
||||
|
|
@ -284,7 +312,7 @@
|
|||
(test
|
||||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:nt (list (select-pattern '(number_!_1 number_!_2 number_!_1 number_!_2)))
|
||||
(decisions #:nt (patterns '(number_!_1 number_!_2 number_!_1 number_!_2))
|
||||
#:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2) (λ _ 3))))
|
||||
'(1 1 2 3)))
|
||||
|
||||
|
|
@ -293,7 +321,7 @@
|
|||
(a (b_!_1 b_!_1 b_!_1))
|
||||
(b 1 2))
|
||||
(test
|
||||
(with-handlers ([exn:fail? exn-message]) (generate lang 'a 5000 0))
|
||||
(exn-message (expect-exn (generate lang 'a 5000 0)))
|
||||
#rx"unable"))
|
||||
|
||||
(let ()
|
||||
|
|
@ -304,13 +332,13 @@
|
|||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'y) (λ _ 'z))
|
||||
#:nt (list (select-pattern '(x_!_1 ...))
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable)
|
||||
(select-pattern 'variable))
|
||||
#:nt (patterns '(x_!_1 ...)
|
||||
'variable
|
||||
'variable
|
||||
'variable
|
||||
'variable
|
||||
'variable
|
||||
'variable)
|
||||
#:seq (list (λ _ 3))))
|
||||
'(x y z)))
|
||||
|
||||
|
|
@ -334,8 +362,7 @@
|
|||
(e (side-condition (x_1 x_!_2 x_!_2) (not (eq? (term x_1) 'x))))
|
||||
(x variable))
|
||||
(test (generate lang 'b 5 0) 43)
|
||||
(test (with-handlers ([exn:fail? exn-message])
|
||||
(generate lang 'c 5 0))
|
||||
(test (exn-message (expect-exn (generate lang 'c 5 0)))
|
||||
#rx"unable to generate")
|
||||
(test ; binding works for with side-conditions failure/retry
|
||||
(let/ec k
|
||||
|
|
@ -347,7 +374,7 @@
|
|||
(generate
|
||||
lang 'e 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y))))
|
||||
'(y x y)))
|
||||
'(y x y)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
|
|
@ -362,6 +389,35 @@
|
|||
(test (generate lang 'e 5 0) '(0 0))
|
||||
(test (generate lang 'f 5 0) '(0 0)))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(a number (+ a a))
|
||||
(A hole (+ a A) (+ A a))
|
||||
(B (6 (hole h)))
|
||||
(C hole)
|
||||
(d (x (in-hole C y)) #:binds x y)
|
||||
(x variable)
|
||||
(y variable))
|
||||
(test
|
||||
(generate
|
||||
lang '(in-hole A number ) 5 0
|
||||
(decisions
|
||||
#:nt (patterns '(+ a A) '(+ a a) 'number 'number '(+ A a) 'hole '(+ a a) 'number 'number)
|
||||
#:num (build-list 5 (λ (x) (λ (_) x)))))
|
||||
'(+ (+ 0 1) (+ 2 (+ 3 4))))
|
||||
(test (generate lang '(in-named-hole h B 3) 5 0) '(6 3))
|
||||
(test (generate lang '(in-hole (in-hole ((in-hole hole 4) hole) 3) 5) 5 0) '(4 3))
|
||||
(test (generate lang 'hole 5 0) (term hole))
|
||||
(test (generate lang '(hole h) 5 0) (term (hole h)))
|
||||
(test (generate lang '(variable_1 (in-hole C variable_1)) 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x))))
|
||||
'(x x))
|
||||
(test (generate lang '(variable_!_1 (in-hole C variable_!_1) variable_!_1) 5 0
|
||||
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'z))))
|
||||
'(x y z))
|
||||
(test (let/ec k (generate lang 'd 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
|
||||
'(x)))
|
||||
|
||||
(define (output-error-port thunk)
|
||||
(let ([port (open-output-string)])
|
||||
(parameterize ([current-error-port port])
|
||||
|
|
@ -375,7 +431,7 @@
|
|||
(test (output-error-port (λ () (try lang 'e (λ (x) #t))))
|
||||
#rx"No failures")
|
||||
(test (output-error-port (λ () (try lang 'e (λ (x) #f))))
|
||||
"FAILED!\n4\n")
|
||||
#rx"FAILED")
|
||||
(test (output-error-port
|
||||
(λ () (check lang (d_1 e d_2) (equal? '(5 5 4) (term (d_2 d_1 e))) 1 5)))
|
||||
#rx"No failures"))
|
||||
|
|
|
|||
|
|
@ -86,23 +86,20 @@ To do a better job of not generating programs with free variables,
|
|||
(pick-from-list bound-vars random)))
|
||||
|
||||
(define (pick-char attempt lang-chars [random random])
|
||||
(let ([lang (< attempt 50)]
|
||||
[ascii (and (>= attempt ascii-chars-threshold)
|
||||
(< attempt tex-chars-threshold))]
|
||||
[tex (and (>= attempt tex-chars-threshold)
|
||||
(< attempt chinese-chars-threshold))])
|
||||
(if (or lang (not (exotic-char? random)))
|
||||
(pick-from-list lang-chars random)
|
||||
(if (or ascii (not (exotic-char? random)))
|
||||
(let ([i (random (- #x7E #x20 1))]
|
||||
[_ (- (char->integer #\_) #x20)])
|
||||
(integer->char (+ #x20 (if (= i _) (add1 i) i))))
|
||||
(if (or tex (not (exotic-char? random)))
|
||||
(car (string->list (pick-from-list (map cadr tex-shortcut-table) random)))
|
||||
(integer->char (+ #x4E00 (random (- #x9FCF #x4E00)))))))))
|
||||
(if (and (not (null? lang-chars))
|
||||
(or (< attempt ascii-chars-threshold)
|
||||
(not (exotic-char? random))))
|
||||
(pick-from-list lang-chars random)
|
||||
(if (or (< attempt tex-chars-threshold) (not (exotic-char? random)))
|
||||
(let ([i (random (- #x7E #x20 1))]
|
||||
[_ (- (char->integer #\_) #x20)])
|
||||
(integer->char (+ #x20 (if (= i _) (add1 i) i))))
|
||||
(if (or (< attempt chinese-chars-threshold) (not (exotic-char? random)))
|
||||
(car (string->list (pick-from-list (map cadr tex-shortcut-table) random)))
|
||||
(integer->char (+ #x4E00 (random (- #x9FCF #x4E00))))))))
|
||||
|
||||
(define (random-string lang-chars lang-lits length attempt [random random])
|
||||
(if (use-lang-literal? random)
|
||||
(if (and (not (null? lang-lits)) (use-lang-literal? random))
|
||||
(pick-from-list lang-lits random)
|
||||
(list->string (build-list length (λ (_) (pick-char attempt lang-chars random))))))
|
||||
|
||||
|
|
@ -135,96 +132,110 @@ To do a better job of not generating programs with free variables,
|
|||
(define lang-chars (unique-chars lang-lits))
|
||||
(define base-table (find-base-cases lang))
|
||||
|
||||
(define (generate-nt nt bound-vars size)
|
||||
(define (generate-nt nt bound-vars size holes)
|
||||
(let loop ([nts (compiled-lang-lang lang)])
|
||||
(cond
|
||||
[(null? nts) (error 'generate-nt "didn't find non-terminal ~s" nt)]
|
||||
[(eq? (nt-name (car nts)) nt)
|
||||
(let* ([prods (if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts)))]
|
||||
[rhs ((next-non-terminal-decision) prods bound-vars size)])
|
||||
(generate-pat (rhs-pattern rhs) bound-vars (rhs-var-info rhs) (max 0 (sub1 size))))]
|
||||
[rhs ((next-non-terminal-decision) prods bound-vars size)]
|
||||
[size (max 0 (sub1 size))])
|
||||
(generate-pat (rhs-pattern rhs) bound-vars (rhs-var-info rhs) size holes))]
|
||||
[else (loop (cdr nts))])))
|
||||
|
||||
(define-struct found-vars (nt source bound-vars found-nt?))
|
||||
(define (generate-pat pat bound-vars var-info size)
|
||||
(define (generate-pat pat bound-vars var-info size holes)
|
||||
(let* ([found-vars-table (map (λ (binds) (make-found-vars (binds-binds binds) (binds-source binds) '() #f))
|
||||
var-info)]
|
||||
[found-nt? #f]
|
||||
[bindings (make-immutable-hasheq null)]
|
||||
[mismatches (make-immutable-hasheq null)])
|
||||
(let loop ([pat pat])
|
||||
(let loop ([pat pat] [holes holes])
|
||||
(define (generate/retry #:gen [gen (λ (p) (loop p holes))] success? . subpatterns)
|
||||
(let ([old-fvt found-vars-table]
|
||||
[old-bindings bindings]
|
||||
[old-mismatches mismatches])
|
||||
(let retry ([remaining generation-retries])
|
||||
(if (zero? remaining)
|
||||
(generation-failure pat)
|
||||
(let ([generated (map gen subpatterns)])
|
||||
(if (apply success? generated)
|
||||
(if (= 1 (length generated))
|
||||
(car generated)
|
||||
generated)
|
||||
(begin
|
||||
(set! found-vars-table old-fvt)
|
||||
(set! bindings old-bindings)
|
||||
(set! mismatches old-mismatches)
|
||||
(retry (sub1 remaining)))))))))
|
||||
|
||||
(define (generate-hole name)
|
||||
(let* ([not-in-hole (gensym)]
|
||||
[generate-contractum (hash-ref holes name not-in-hole)])
|
||||
(if (eq? generate-contractum not-in-hole)
|
||||
(if name (make-hole/intern name) (term hole))
|
||||
(generate-contractum))))
|
||||
(match pat
|
||||
[`number ((next-number-decision) random-numbers)]
|
||||
[`(variable-except ,vars ...)
|
||||
(let try () (let ([var (loop 'variable)]) (if (memq var vars) (try) var)))]
|
||||
(generate/retry (λ (var) (not (memq var vars))) 'variable)]
|
||||
[`variable ((next-variable-decision) lang-chars lang-lits bound-vars attempt)]
|
||||
[`(variable-prefix ,prefix)
|
||||
(string->symbol (string-append (symbol->string prefix) (symbol->string (loop 'variable))))]
|
||||
(string->symbol (string-append (symbol->string prefix)
|
||||
(symbol->string (loop 'variable holes))))]
|
||||
[`string ((next-string-decision) lang-chars lang-lits attempt)]
|
||||
[`(side-condition ,pattern ,(? procedure? condition))
|
||||
(let ([old-fvt found-vars-table]
|
||||
[old-bindings bindings]
|
||||
[old-mismatches mismatches])
|
||||
(let retry ([remaining generation-retries])
|
||||
(if (zero? remaining)
|
||||
(generation-failure pat)
|
||||
(let ([term (loop pattern)])
|
||||
(if (condition (make-bindings (hash-map bindings (λ (name exp) (make-bind name exp)))))
|
||||
term
|
||||
(begin
|
||||
(set! found-vars-table old-fvt)
|
||||
(set! bindings old-bindings)
|
||||
(set! mismatches old-mismatches)
|
||||
(retry (sub1 remaining))))))))]
|
||||
(define (condition-bindings bindings)
|
||||
(make-bindings (hash-map bindings (λ (name exp) (make-bind name exp)))))
|
||||
(generate/retry (λ _ (condition (condition-bindings bindings))) pattern)]
|
||||
[`(side-condition ,pattern ,uncompiled-condition)
|
||||
(error 'generate "side-condition not compiled: ~s" pat)]
|
||||
[`(name ,id ,p)
|
||||
[`(name ,(? symbol? id) ,p)
|
||||
(define (generate/record)
|
||||
(let ([term (loop p)])
|
||||
(let ([term (loop p holes)])
|
||||
(set! bindings (hash-set bindings id term))
|
||||
term))
|
||||
(hash-ref bindings id generate/record)]
|
||||
[`hole (generate-hole #f)]
|
||||
[`(in-hole ,context ,contractum)
|
||||
(loop context (hash-set holes #f (λ () (loop contractum holes))))]
|
||||
[`(hole ,(? symbol? name)) (generate-hole name)]
|
||||
[`(in-named-hole ,name ,context ,contractum)
|
||||
(loop context (hash-set holes name (λ () (loop contractum holes))))]
|
||||
[(and (? symbol?) (? (λ (x) (or (is-nt? lang x) (underscored-built-in? x)))))
|
||||
(define (update/generate undecorated decorated)
|
||||
(let* ([new-bound-vars (append (extract-bound-vars decorated found-vars-table) bound-vars)]
|
||||
[term (if (underscored-built-in? pat)
|
||||
(loop undecorated)
|
||||
(generate-nt undecorated new-bound-vars size))])
|
||||
(values term (extend-found-vars decorated term found-vars-table))))
|
||||
(define ((generate-nt/underscored decorated) undecorated)
|
||||
(let* ([vars (append (extract-bound-vars decorated found-vars-table) bound-vars)]
|
||||
[term (if (is-nt? lang undecorated)
|
||||
(generate-nt undecorated vars size holes)
|
||||
(generate-pat undecorated vars null size holes))])
|
||||
(begin
|
||||
(set! found-vars-table (extend-found-vars decorated term found-vars-table))
|
||||
term)))
|
||||
(match (symbol->string pat)
|
||||
[(regexp #rx"^([^_]*)_[^_]*$" (list _ undecorated))
|
||||
(hash-ref
|
||||
(hash-ref
|
||||
bindings pat
|
||||
(λ ()
|
||||
(let-values ([(term fvt) (update/generate (string->symbol undecorated) pat)])
|
||||
(set! found-vars-table fvt)
|
||||
(λ ()
|
||||
(let ([term ((generate-nt/underscored pat) (string->symbol undecorated))])
|
||||
(set! bindings (hash-set bindings pat term))
|
||||
term)))]
|
||||
[(regexp #rx"([^_]*)_!_[^_]*$" (list _ undecorated))
|
||||
(let loop ([remaining generation-retries])
|
||||
(if (zero? remaining)
|
||||
(generation-failure pat)
|
||||
(let-values ([(term fvt) (update/generate (string->symbol undecorated) pat)])
|
||||
(let ([others (hash-ref mismatches pat (λ () null))])
|
||||
(if (member term others)
|
||||
(loop (sub1 remaining))
|
||||
(begin
|
||||
(set! found-vars-table fvt)
|
||||
(set! mismatches
|
||||
(hash-set mismatches pat (cons term others)))
|
||||
term))))))]
|
||||
[else
|
||||
(let-values ([(term fvt) (update/generate pat pat)])
|
||||
(begin (set! found-vars-table fvt) term))])]
|
||||
[(regexp #rx"([^_]*)_!_[^_]*$" (list _ undecorated))
|
||||
(let* ([prior (hash-ref mismatches pat null)]
|
||||
[term (generate/retry
|
||||
(λ (t) (not (member t prior)))
|
||||
(string->symbol undecorated)
|
||||
#:gen (generate-nt/underscored pat))])
|
||||
(set! mismatches (hash-set mismatches pat (cons term prior)))
|
||||
term)]
|
||||
[else ((generate-nt/underscored pat) pat)])]
|
||||
[(or (? symbol?) (? number?) (? string?) (? boolean?)) pat]
|
||||
[(? null? pat) '()]
|
||||
[(? pair? pat)
|
||||
(if (or (null? (cdr pat))
|
||||
(not (eq? '... (cadr pat))))
|
||||
(cons (loop (car pat))
|
||||
(loop (cdr pat)))
|
||||
(append (build-list ((next-sequence-decision)) (λ (i) (loop (car pat))))
|
||||
(loop (cddr pat))))]
|
||||
(cons (loop (car pat) holes)
|
||||
(loop (cdr pat) holes))
|
||||
(append (build-list ((next-sequence-decision)) (λ (i) (loop (car pat) holes)))
|
||||
(loop (cddr pat) holes)))]
|
||||
[else
|
||||
(error 'generate "unknown pattern ~s\n" pat)]))))
|
||||
|
||||
|
|
@ -260,7 +271,7 @@ To do a better job of not generating programs with free variables,
|
|||
[else found-vars]))
|
||||
found-vars-table))
|
||||
|
||||
(generate-pat nt '() '() size))
|
||||
(generate-pat nt '() '() size (make-immutable-hash null)))
|
||||
|
||||
;; find-base-cases : compiled-language -> hash-table
|
||||
(define (find-base-cases lang)
|
||||
|
|
@ -340,7 +351,8 @@ To do a better job of not generating programs with free variables,
|
|||
|
||||
;; underscored-built-in? : symbol -> boolean
|
||||
(define (underscored-built-in? sym)
|
||||
(not (false? (memq (symbol->nt sym) underscore-allowed))))
|
||||
(not (false? (and (memq #\_ (string->list (symbol->string sym)))
|
||||
(memq (symbol->nt sym) underscore-allowed)))))
|
||||
|
||||
(define (try lang nt pred? #:attempts [attempts 1000] #:size [size 6])
|
||||
(let loop ([i attempts])
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@
|
|||
"term-test.ss"
|
||||
"tl-test.ss"
|
||||
"matcher-test.ss"
|
||||
"schemeunit-test.ss"
|
||||
"lw-test.ss")
|
||||
|
||||
(printf "\nWARNING: didn't run color-test.ss or subst-test.ss\n"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user