Generator support for `cross' pattern and syntax errors for non-terminals
with no productions. svn: r11588
This commit is contained in:
Casey Klein
parent
3ce9fd1953
commit
823338e262
|
|
@ -516,24 +516,24 @@
|
|||
(make-rhs '(+ exp ctxt) '())
|
||||
(make-rhs 'hole '())))))
|
||||
(list
|
||||
(make-nt 'exp-exp
|
||||
(list (make-rhs 'hole '())
|
||||
(make-rhs `(+ (cross exp-exp) exp) '())
|
||||
(make-rhs `(+ exp (cross exp-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)) '())))
|
||||
(make-nt 'ctxt-exp
|
||||
(list (make-rhs `(+ (cross ctxt-exp) exp) '())
|
||||
(make-rhs `(+ exp (cross ctxt-exp)) '())))
|
||||
(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)) '())))))
|
||||
(make-rhs `(+ exp (cross ctxt-ctxt)) '())))
|
||||
(make-nt '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)) '())))
|
||||
(make-nt 'exp-exp
|
||||
(list (make-rhs 'hole '())
|
||||
(make-rhs `(+ (cross exp-exp) exp) '())
|
||||
(make-rhs `(+ exp (cross exp-exp)) '())))))
|
||||
|
||||
(run-test
|
||||
'compatible-context-language2
|
||||
|
|
@ -542,15 +542,7 @@
|
|||
(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-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-nt 'm-v (list (make-rhs (list 'lambda (list 'x) (list 'cross 'm-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) '())
|
||||
|
|
@ -558,7 +550,15 @@
|
|||
(make-rhs (list '+ (list 'cross 'v-m) 'm) '())
|
||||
(make-rhs (list '+ 'm (list 'cross 'v-m)) '())
|
||||
(make-rhs (list 'cross 'v-v) '())))
|
||||
(make-nt 'v-v (list (make-rhs 'hole '()) (make-rhs (list 'lambda (list 'x) (list 'cross 'v-m)) '())))))
|
||||
(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) '())))))
|
||||
|
||||
(run-test
|
||||
'compatible-context-language3
|
||||
|
|
@ -568,13 +568,26 @@
|
|||
(make-nt 'seven (list (make-rhs 7 '())))))
|
||||
`(,(make-nt
|
||||
'm-m
|
||||
`(,(make-rhs 'hole '()) ,(make-rhs `((cross m-m) seven m) '()) ,(make-rhs `(m (cross m-seven) m) '()) ,(make-rhs `(m seven (cross m-m)) '())))
|
||||
,(make-nt 'm-seven `())
|
||||
`(,(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 '())))))
|
||||
|
||||
(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 '())))))
|
||||
|
||||
#;
|
||||
(test-xab '(in-hole (cross exp) (+ number number))
|
||||
'(+ (+ 1 2) 3)
|
||||
|
|
|
|||
|
|
@ -147,7 +147,7 @@ before the pattern compiler is invoked.
|
|||
(when may-be-list? (add-to-ht list-ht))
|
||||
(unless (or may-be-non-list? may-be-list?)
|
||||
(error 'compile-language
|
||||
"unable to determine whether pattern matches lists, non-lists, or both: ~s"
|
||||
"internal error: unable to determine whether pattern matches lists, non-lists, or both: ~s"
|
||||
(rhs-pattern rhs))))))
|
||||
(nt-rhs nt)))
|
||||
lang))]
|
||||
|
|
@ -283,22 +283,52 @@ before the pattern compiler is invoked.
|
|||
|
||||
;; build-compatible-context-language : lang -> lang
|
||||
(define (build-compatible-context-language clang-ht lang)
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (nt1)
|
||||
(map
|
||||
(lambda (nt2)
|
||||
(let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)])
|
||||
(if (eq? (nt-name nt1) (nt-name nt2))
|
||||
(make-nt (nt-name compat-nt)
|
||||
(cons
|
||||
(make-rhs 'hole '())
|
||||
(nt-rhs compat-nt)))
|
||||
compat-nt)))
|
||||
lang))
|
||||
lang)))
|
||||
(remove-empty-compatible-contexts
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (nt1)
|
||||
(map
|
||||
(lambda (nt2)
|
||||
(let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)])
|
||||
(if (eq? (nt-name nt1) (nt-name nt2))
|
||||
(make-nt (nt-name compat-nt)
|
||||
(cons
|
||||
(make-rhs 'hole '())
|
||||
(nt-rhs compat-nt)))
|
||||
compat-nt)))
|
||||
lang))
|
||||
lang))))
|
||||
|
||||
;; remove-empty-compatible-contexts : lang -> lang
|
||||
;; Removes the empty compatible context non-terminals and the
|
||||
;; rhss that reference them.
|
||||
(define (remove-empty-compatible-contexts lang)
|
||||
(define (has-cross? pattern crosses)
|
||||
(match pattern
|
||||
[`(cross ,(? symbol? nt)) (memq nt crosses)]
|
||||
[(list-rest p '... rest) (has-cross? rest crosses)]
|
||||
[(cons first rest) (or (has-cross? first crosses)
|
||||
(has-cross? rest crosses))]
|
||||
[_ #f]))
|
||||
(define (delete-empty nts)
|
||||
(for/fold ([deleted null] [kept null]) ([nt nts])
|
||||
(if (null? (nt-rhs nt))
|
||||
(values (cons nt deleted) kept)
|
||||
(values deleted (cons nt kept)))))
|
||||
(define (delete-references deleted-names remaining-nts)
|
||||
(map (λ (nt)
|
||||
(make-nt (nt-name nt)
|
||||
(filter (λ (rhs) (not (has-cross? (rhs-pattern rhs) deleted-names)))
|
||||
(nt-rhs nt))))
|
||||
remaining-nts))
|
||||
|
||||
(let loop ([nts lang])
|
||||
(let-values ([(deleted kept) (delete-empty nts)])
|
||||
(if (null? deleted)
|
||||
kept
|
||||
(loop (delete-references (map nt-name deleted) kept))))))
|
||||
|
||||
;; build-compatible-contexts : clang-ht prefix nt -> nt
|
||||
;; constructs the compatible closure evaluation context from nt.
|
||||
(define (build-compatible-contexts/nt clang-ht prefix nt)
|
||||
|
|
|
|||
|
|
@ -1128,27 +1128,37 @@
|
|||
stx
|
||||
name)]))])))
|
||||
|
||||
;; check-rhss-not-empty : syntax (listof syntax) -> void
|
||||
(define-for-syntax (check-rhss-not-empty def-lang-stx nt-def-stxs)
|
||||
(for-each
|
||||
(λ (nt-def-stx)
|
||||
(when (null? (cdr (syntax-e nt-def-stx)))
|
||||
(raise-syntax-error 'define-language "non-terminal with no productions" def-lang-stx nt-def-stx)))
|
||||
nt-def-stxs))
|
||||
|
||||
(define-syntax (define-language stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name (names rhs ...) ...)
|
||||
(identifier? (syntax name))
|
||||
(with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))])
|
||||
(with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-language-id
|
||||
(case-lambda
|
||||
[(stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! x e) (raise-syntax-error 'define-language "cannot set! identifier" stx #'e)]
|
||||
[(x e (... ...)) #'(define-language-name e (... ...))]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#'define-language-name])])
|
||||
'(nt-names ...))))
|
||||
(define define-language-name (language name (names rhs ...) ...))))))]))
|
||||
(begin
|
||||
(check-rhss-not-empty stx (cddr (syntax-e stx)))
|
||||
(with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))])
|
||||
(with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-syntax name
|
||||
(make-set!-transformer
|
||||
(make-language-id
|
||||
(case-lambda
|
||||
[(stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! x e) (raise-syntax-error 'define-language "cannot set! identifier" stx #'e)]
|
||||
[(x e (... ...)) #'(define-language-name e (... ...))]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#'define-language-name])])
|
||||
'(nt-names ...))))
|
||||
(define define-language-name (language name (names rhs ...) ...)))))))]))
|
||||
|
||||
(define-struct binds (source binds))
|
||||
|
||||
|
|
@ -1328,6 +1338,7 @@
|
|||
(raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'name))
|
||||
(unless (identifier? (syntax orig-lang))
|
||||
(raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'orig-lang))
|
||||
(check-rhss-not-empty stx (cdddr (syntax-e stx)))
|
||||
(let ([old-names (language-id-nts #'orig-lang 'define-extended-language)])
|
||||
(with-syntax ([((new-nt-names orig) ...) (append (pull-out-names 'define-language stx #'(names ...))
|
||||
(map (λ (x) #`(#,x #f)) old-names))])
|
||||
|
|
|
|||
|
|
@ -21,20 +21,20 @@
|
|||
(e x (e e) (λ (x) e))
|
||||
(x variable))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((e . (1 2 2)) (x . (0)))))
|
||||
'((e . (1 2 2)) (e-e . (0 2 2 1)) (x . (0)) (x-e . (1 2 2 2 2)) (x-x . (0)))))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
(define-language lang
|
||||
(e (e e)))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((e . (inf)))))
|
||||
(test (to-table (find-base-cases lang))
|
||||
'((e . (inf)) (e-e . (0 inf inf)))))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
(define-language lang
|
||||
(a 1 2 3)
|
||||
(b a (a_1 b_!_1)))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((a . (0 0 0)) (b . (1 2)))))
|
||||
(test (to-table (find-base-cases lang))
|
||||
'((a . (0 0 0)) (a-a . (0)) (a-b . (1)) (b . (1 2)) (b-b . (0)))))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
|
|
@ -46,7 +46,9 @@
|
|||
number)
|
||||
(x variable))
|
||||
(test (to-table (find-base-cases lc))
|
||||
'((e . (2 2 1 1)) (v . (2 0)) (x . (0)))))
|
||||
'((e . (2 2 1 1)) (e-e . (0 2 2 2 2 2)) (e-v . (1))
|
||||
(v . (2 0)) (v-e . (2 2 2 2 1)) (v-v . (0 2))
|
||||
(x . (0)) (x-e . (2 2 2 2 1 3)) (x-v . (2 2)) (x-x . (0)))))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
|
|
@ -278,8 +280,8 @@
|
|||
|
||||
(let ()
|
||||
(define-language lang (x variable literal))
|
||||
(test (is-nt? lang 'x) #t)
|
||||
(test (is-nt? lang 'y) #f))
|
||||
(test ((is-nt? lang) 'x) #t)
|
||||
(test ((is-nt? lang) 'y) #f))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
|
|
@ -454,6 +456,17 @@
|
|||
(thunk))
|
||||
(get-output-string port)))
|
||||
|
||||
;; `cross' pattern
|
||||
(let ()
|
||||
(define-language lang
|
||||
(e x (e e) v)
|
||||
(v (λ (x) e))
|
||||
(x variable-not-otherwise-mentioned))
|
||||
(test (generate lang (cross e) 3 0
|
||||
(decisions #:nt (patterns fourth first first second first first first)
|
||||
#:var (list (λ _ 'x) (λ _ 'y))))
|
||||
(term (λ (x) (hole y)))))
|
||||
|
||||
(let ()
|
||||
(define-language lang
|
||||
(d 5)
|
||||
|
|
@ -500,7 +513,9 @@
|
|||
_
|
||||
(list (struct class (c_1)) (struct mismatch (i_1 '..._!_1)) 'x_1)))
|
||||
(car (parse-pattern pattern)))
|
||||
(test (unparse-pattern (parse-pattern pattern)) pattern)))
|
||||
(test (unparse-pattern (parse-pattern pattern)) pattern)
|
||||
(test (parse-pattern '(cross e)) '(cross e-e))
|
||||
(test (parse-pattern '(cross e) #t) '(cross e))))
|
||||
|
||||
(let ()
|
||||
(define-syntax test-class-reassignments
|
||||
|
|
|
|||
|
|
@ -137,25 +137,23 @@ 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 fvt-id bound-vars size in-hole state)
|
||||
(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*-values
|
||||
([(rhs)
|
||||
((next-non-terminal-decision)
|
||||
(if (zero? size) (min-prods (car nts) base-table) (nt-rhs (car nts)))
|
||||
bound-vars size)]
|
||||
[(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
|
||||
[(nt-state) (make-state (map fvt-entry (rhs-var-info rhs)) #hash())]
|
||||
[(term _)
|
||||
(generate/pred
|
||||
(rhs-pattern rhs)
|
||||
(λ (pat) (((generate-pat bound-vars (max 0 (sub1 size))) pat in-hole) nt-state))
|
||||
(λ (_ env) (mismatches-satisfied? env)))])
|
||||
(values term (extend-found-vars fvt-id term state)))]
|
||||
[else (loop (cdr nts))])))
|
||||
(define (generate-nt name fvt-id bound-vars size in-hole state)
|
||||
(let*-values
|
||||
([(nt) (findf (λ (nt) (eq? name (nt-name nt)))
|
||||
(append (compiled-lang-lang lang)
|
||||
(compiled-lang-cclang lang)))]
|
||||
[(rhs)
|
||||
((next-non-terminal-decision)
|
||||
(if (zero? size) (min-prods nt base-table) (nt-rhs nt))
|
||||
bound-vars size)]
|
||||
[(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
|
||||
[(nt-state) (make-state (map fvt-entry (rhs-var-info rhs)) #hash())]
|
||||
[(term _)
|
||||
(generate/pred
|
||||
(rhs-pattern rhs)
|
||||
(λ (pat) (((generate-pat bound-vars (max 0 (sub1 size))) pat in-hole) nt-state))
|
||||
(λ (_ env) (mismatches-satisfied? env)))])
|
||||
(values term (extend-found-vars fvt-id term state))))
|
||||
|
||||
(define (generate-sequence ellipsis generate state length)
|
||||
(define (split-environment env)
|
||||
|
|
@ -213,9 +211,13 @@ To do a better job of not generating programs with free variables,
|
|||
(define (fvt-entry binds)
|
||||
(make-found-vars (binds-binds binds) (binds-source binds) '() #f))
|
||||
|
||||
(define (((generate-pat bound-vars size) pat in-hole [fvt-id pat]) state)
|
||||
(define (((generate-pat bound-vars size) pat in-hole) state)
|
||||
(define recur (generate-pat bound-vars size))
|
||||
(define (recur/pat pat) ((recur pat in-hole) state))
|
||||
(define (generate-nt/built-in undecorated decorated)
|
||||
(if ((is-nt? lang) undecorated)
|
||||
(generate-nt undecorated decorated bound-vars size in-hole state)
|
||||
(recur/pat undecorated)))
|
||||
|
||||
(match pat
|
||||
[`number (values ((next-number-decision) random-numbers) state)]
|
||||
|
|
@ -249,21 +251,22 @@ To do a better job of not generating programs with free variables,
|
|||
[`any
|
||||
(let-values ([(lang nt) ((next-any-decision) lang)])
|
||||
(values (generate* lang nt size attempt decisions@) state))]
|
||||
[(? (λ (p) (is-nt? lang p)))
|
||||
(generate-nt pat fvt-id bound-vars size in-hole state)]
|
||||
[(? (is-nt? lang))
|
||||
(generate-nt pat pat bound-vars size in-hole state)]
|
||||
[(and (? symbol?) (app symbol->string (regexp named-nt-rx (list _ nt))))
|
||||
(let* ([undecorated (string->symbol nt)]
|
||||
[none (gensym)]
|
||||
[prior (hash-ref (state-env state) pat none)])
|
||||
(if (eq? prior none)
|
||||
(let-values
|
||||
([(term state) ((recur undecorated in-hole pat) state)])
|
||||
(let-values ([(term state) (generate-nt/built-in undecorated pat)])
|
||||
(values term (set-env state pat term)))
|
||||
(values prior state)))]
|
||||
[(struct mismatch (name group))
|
||||
(let ([nt (string->symbol (cadr (regexp-match mismatch-nt-rx (symbol->string group))))])
|
||||
(let-values ([(term state) ((recur nt in-hole name) state)])
|
||||
(let ([undecorated (string->symbol (cadr (regexp-match mismatch-nt-rx (symbol->string group))))])
|
||||
(let-values ([(term state) (generate-nt/built-in undecorated name)])
|
||||
(values term (set-env state pat term))))]
|
||||
[`(cross ,(? symbol? cross-nt))
|
||||
(generate-nt cross-nt #f bound-vars size in-hole 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)])
|
||||
|
|
@ -323,55 +326,58 @@ To do a better job of not generating programs with free variables,
|
|||
term))
|
||||
|
||||
;; find-base-cases : compiled-language -> hash-table
|
||||
(define (find-base-cases lang)
|
||||
(define nt-table (make-hasheq))
|
||||
(define changed? #f)
|
||||
(define (nt-get nt) (hash-ref nt-table nt 'inf))
|
||||
(define (nt-set nt new)
|
||||
(let ([old (nt-get nt)])
|
||||
(unless (equal? new old)
|
||||
(set! changed? #t)
|
||||
(hash-set! nt-table nt new))))
|
||||
|
||||
(define (process-nt nt)
|
||||
(nt-set (nt-name nt) (apply min/f (map process-rhs (nt-rhs nt)))))
|
||||
|
||||
(define (process-rhs rhs)
|
||||
(let ([nts (rhs->nts (rhs-pattern rhs))])
|
||||
(if (null? nts)
|
||||
0
|
||||
(add1/f (apply max/f (map nt-get nts))))))
|
||||
|
||||
;; rhs->path : pattern -> (listof symbol)
|
||||
;; determines all of the non-terminals in a pattern
|
||||
(define (rhs->nts pat)
|
||||
(let ([nts '()])
|
||||
(let loop ([pat pat])
|
||||
(match pat
|
||||
[(? symbol? pat)
|
||||
(when (is-nt? lang (symbol->nt pat))
|
||||
(set! nts (cons (symbol->nt pat) nts)))]
|
||||
[`() (void)]
|
||||
[`(,a ,'... . ,b)
|
||||
(loop a)
|
||||
(loop b)]
|
||||
[`(,a . ,b)
|
||||
(loop a)
|
||||
(loop b)]
|
||||
[_ (void)]))
|
||||
nts))
|
||||
|
||||
(define (find-base-cases lang)
|
||||
(define nt-table (make-hasheq))
|
||||
(define changed? #f)
|
||||
(define (nt-get nt) (hash-ref nt-table nt 'inf))
|
||||
(define (nt-set nt new)
|
||||
(let ([old (nt-get nt)])
|
||||
(unless (equal? new old)
|
||||
(set! changed? #t)
|
||||
(hash-set! nt-table nt new))))
|
||||
|
||||
(define (process-nt nt)
|
||||
(nt-set (nt-name nt) (apply min/f (map process-rhs (nt-rhs nt)))))
|
||||
|
||||
(define (process-rhs rhs)
|
||||
(let ([nts (rhs->nts (rhs-pattern rhs))])
|
||||
(if (null? nts)
|
||||
0
|
||||
(add1/f (apply max/f (map nt-get nts))))))
|
||||
|
||||
;; rhs->path : pattern -> (listof symbol)
|
||||
;; determines all of the non-terminals in a pattern
|
||||
(define (rhs->nts pat)
|
||||
(let ([nts '()])
|
||||
(let loop ([pat pat])
|
||||
(match pat
|
||||
[(? symbol? pat)
|
||||
(when ((is-nt? lang) (symbol->nt pat))
|
||||
(set! nts (cons (symbol->nt pat) nts)))]
|
||||
[`(cross ,(? symbol? x-nt))
|
||||
(set! nts (cons x-nt nts))]
|
||||
[`() (void)]
|
||||
[`(,a ,'... . ,b)
|
||||
(loop a)
|
||||
(loop b)]
|
||||
[`(,a . ,b)
|
||||
(loop a)
|
||||
(loop b)]
|
||||
[_ (void)]))
|
||||
nts))
|
||||
|
||||
(let ([nts (append (compiled-lang-lang lang) (compiled-lang-cclang lang))])
|
||||
(let loop ()
|
||||
(set! changed? #f)
|
||||
(for-each process-nt (compiled-lang-lang lang))
|
||||
(for-each process-nt nts)
|
||||
(when changed?
|
||||
(loop)))
|
||||
|
||||
(let ([ht (make-hash)])
|
||||
(for-each
|
||||
(λ (nt) (hash-set! ht (nt-name nt) (map process-rhs (nt-rhs nt))))
|
||||
(compiled-lang-lang lang))
|
||||
ht))
|
||||
nts)
|
||||
ht)))
|
||||
|
||||
(define min/f
|
||||
(case-lambda
|
||||
|
|
@ -394,7 +400,7 @@ To do a better job of not generating programs with free variables,
|
|||
(define (add1/f a) (if (eq? a 'inf) 'inf (+ a 1)))
|
||||
|
||||
;; is-nt? : compiled-lang any -> boolean
|
||||
(define (is-nt? lang x)
|
||||
(define ((is-nt? lang) x)
|
||||
(and (hash-ref (compiled-lang-ht lang) x #f) #t))
|
||||
|
||||
(define named-nt-rx #rx"^([^_]+)_[^_]*$")
|
||||
|
|
@ -419,7 +425,7 @@ To do a better job of not generating programs with free variables,
|
|||
;; parse-pattern : pattern -> parsed-pattern
|
||||
;; Turns "pat ...", "pat ..._id", and "pat ..._!_id" into ellipsis structs
|
||||
;; and "nt_!_id" into mismatch structs.
|
||||
(define (parse-pattern pattern)
|
||||
(define (parse-pattern pattern [cross? #f])
|
||||
(define (recur pat vars)
|
||||
(match pat
|
||||
[(and (? symbol?) (app symbol->string (regexp named-nt-rx)))
|
||||
|
|
@ -450,6 +456,9 @@ To do a better job of not generating programs with free variables,
|
|||
[(vars) (append (list* class mismatch sub-pat-vars) vars)]
|
||||
[(rest-parsed vars) (recur rest vars)])
|
||||
(values (cons seq rest-parsed) vars))]
|
||||
[(and (? (λ (_) (not cross?))) `(cross ,(and (? symbol?) nt)))
|
||||
(let ([nt-str (symbol->string nt)])
|
||||
(values `(cross ,(string->symbol (string-append nt-str "-" nt-str))) vars))]
|
||||
[(cons first rest)
|
||||
(let-values ([(first-parsed vars) (recur first vars)])
|
||||
(let-values ([(rest-parsed vars) (recur rest vars)])
|
||||
|
|
@ -460,16 +469,15 @@ To do a better job of not generating programs with free variables,
|
|||
|
||||
;; parse-language: compiled-lang -> compiled-lang
|
||||
(define (parse-language lang)
|
||||
(define ((parse-nt cross?) nt)
|
||||
(make-nt (nt-name nt) (map (parse-rhs cross?) (nt-rhs nt))))
|
||||
(define ((parse-rhs cross?) rhs)
|
||||
(make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs) cross?))
|
||||
(rhs-var-info rhs)))
|
||||
(struct-copy
|
||||
compiled-lang lang
|
||||
[lang
|
||||
(map (λ (nt)
|
||||
(make-nt (nt-name nt)
|
||||
(map (λ (rhs)
|
||||
(make-rhs (reassign-classes (parse-pattern (rhs-pattern rhs)))
|
||||
(rhs-var-info rhs)))
|
||||
(nt-rhs nt))))
|
||||
(compiled-lang-lang lang))]))
|
||||
[lang (map (parse-nt #f) (compiled-lang-lang lang))]
|
||||
[cclang (map (parse-nt #t) (compiled-lang-cclang lang))]))
|
||||
|
||||
;; unparse-pattern: parsed-pattern -> pattern
|
||||
(define unparse-pattern
|
||||
|
|
|
|||
|
|
@ -690,6 +690,11 @@
|
|||
(test-syn-err (define-language bad-lang1 (e name)) #rx"name")
|
||||
(test-syn-err (define-language bad-lang2 (name x)) #rx"name")
|
||||
(test-syn-err (define-language bad-lang3 (x_y x)) #rx"x_y")
|
||||
(test-syn-err (define-language bad-lang4 (a 1 2) (b)) #rx"no productions")
|
||||
(test-syn-err (let ()
|
||||
(define-language good-lang (a 1 2))
|
||||
(define-extended-language bad-lang5 good-lang (a) (b 2)))
|
||||
#rx"no productions")
|
||||
|
||||
;; expect union with duplicate names to fail
|
||||
(test (with-handlers ((exn? (λ (x) 'passed)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user