fixed label ordering for reductions when extracted via reduction-relation->rule names
svn: r14690
This commit is contained in:
Robby Findler
parent
5f2a62f37c
commit
7315ff502b
|
|
@ -453,12 +453,18 @@
|
|||
(for-each loop nexts)))))
|
||||
all-top-levels)
|
||||
|
||||
(let ([name-ht (make-hasheq)]
|
||||
(let ([name-table (make-hasheq)]
|
||||
[lang-nts (language-id-nts lang-id orig-name)])
|
||||
(hash-set! name-table #f 0)
|
||||
;; name table maps symbols for the rule names to their syntax objects and to a counter indicating what
|
||||
;; order the names were encountered in. The current value of the counter is stored in the table at key '#f'.
|
||||
(with-syntax ([lang-id lang-id]
|
||||
[(top-level ...) (get-choices stx orig-name ht lang-id main-arrow
|
||||
name-ht lang-id allow-zero-rules?)]
|
||||
[(rule-names ...) (hash-map name-ht (λ (k v) k))]
|
||||
name-table lang-id allow-zero-rules?)]
|
||||
[(rule-names ...)
|
||||
(begin
|
||||
(hash-remove! name-table #f)
|
||||
(map car (sort (hash-map name-table (λ (k v) (list k (list-ref v 1)))) < #:key cadr)))]
|
||||
[lws lws]
|
||||
|
||||
[domain-pattern-side-conditions-rewritten
|
||||
|
|
@ -660,9 +666,11 @@
|
|||
(raise-syntax-errors orig-name
|
||||
"same name on multiple rules"
|
||||
stx
|
||||
(list (hash-ref name-table name-sym)
|
||||
(list (car (hash-ref name-table name-sym))
|
||||
(syntax name))))
|
||||
(hash-set! name-table name-sym (syntax name))
|
||||
(let ([num (hash-ref name-table #f)])
|
||||
(hash-set! name-table #f (+ num 1))
|
||||
(hash-set! name-table name-sym (list (syntax name) num)))
|
||||
|
||||
(when the-name
|
||||
(raise-syntax-errors orig-name
|
||||
|
|
@ -773,6 +781,7 @@
|
|||
|
||||
(define (union-reduction-relations fst snd . rst)
|
||||
(let ([name-ht (make-hasheq)]
|
||||
[counter 0]
|
||||
[lst (list* fst snd rst)]
|
||||
[first-lang (reduction-relation-lang fst)])
|
||||
(for-each
|
||||
|
|
@ -783,14 +792,15 @@
|
|||
(for-each (λ (name)
|
||||
(when (hash-ref name-ht name #f)
|
||||
(error 'union-reduction-relations "multiple rules with the name ~s" name))
|
||||
(hash-set! name-ht name #t))
|
||||
(hash-set! name-ht name counter)
|
||||
(set! counter (+ counter 1)))
|
||||
(reduction-relation-rule-names red)))
|
||||
lst)
|
||||
(reverse lst)) ;; reverse here so the names get put into the hash in the proper (backwards) order
|
||||
(build-reduction-relation
|
||||
#f
|
||||
first-lang
|
||||
(reverse (apply append (map reduction-relation-make-procs lst)))
|
||||
(hash-map name-ht (λ (k v) k))
|
||||
(map car (sort (hash-map name-ht list) < #:key cadr))
|
||||
(apply append (map reduction-relation-lws lst))
|
||||
`any)))
|
||||
|
||||
|
|
@ -1772,10 +1782,7 @@
|
|||
(equal? str1 (substring str2 0 (string-length str1)))))
|
||||
|
||||
|
||||
;; The struct selector extracts the reduction relation rules, which
|
||||
;; are in reverse order compared to the way the reduction relation was written
|
||||
;; in the program text. So reverse them.
|
||||
(define (reduction-relation->rule-names x)
|
||||
(define (reduction-relation->rule-names x)
|
||||
(reverse (reduction-relation-rule-names x)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -82,8 +82,8 @@
|
|||
make-procs/check-domain)])
|
||||
(make-reduction-relation lang
|
||||
all-make-procs
|
||||
(append (reduction-relation-rule-names orig-reduction-relation)
|
||||
rule-names)
|
||||
(append rule-names
|
||||
(reduction-relation-rule-names orig-reduction-relation))
|
||||
lws ;; only keep new lws for typesetting
|
||||
(map (λ (make-proc) (make-proc lang)) all-make-procs)))]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -1131,6 +1131,58 @@
|
|||
(test (apply-reduction-relation red2 (term (X q))) (list (term (X z))
|
||||
(term (X w)))))
|
||||
|
||||
(test (reduction-relation->rule-names
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> x y a)))
|
||||
'(a))
|
||||
|
||||
(test (reduction-relation->rule-names
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> x y a)
|
||||
(--> y z b)
|
||||
(--> z w c)))
|
||||
'(a b c))
|
||||
|
||||
(test (reduction-relation->rule-names
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> x y a)
|
||||
(--> y z b)
|
||||
(--> z w c)
|
||||
(--> p q z)
|
||||
(--> q r y)
|
||||
(--> r p x)))
|
||||
'(a b c z y x))
|
||||
|
||||
(test (reduction-relation->rule-names
|
||||
(extend-reduction-relation
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> x y a)
|
||||
(--> y z b)
|
||||
(--> z w c))
|
||||
empty-language
|
||||
(--> p q z)
|
||||
(--> q r y)
|
||||
(--> r p x)))
|
||||
'(a b c z y x))
|
||||
|
||||
(test (reduction-relation->rule-names
|
||||
(union-reduction-relations
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> x y a)
|
||||
(--> y z b)
|
||||
(--> z w c))
|
||||
(reduction-relation
|
||||
empty-language
|
||||
(--> p q z)
|
||||
(--> q r y)
|
||||
(--> r p x))))
|
||||
'(a b c z y x))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; examples from doc.txt
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
scheme/pretty
|
||||
scheme/contract
|
||||
mrlib/graph
|
||||
(only-in slideshow/pict pict? text dc-for-text-size)
|
||||
(only-in slideshow/pict pict? text dc-for-text-size text-style/c)
|
||||
redex))
|
||||
|
||||
@(define-syntax (defpattech stx)
|
||||
|
|
@ -887,9 +887,7 @@ The @scheme[define-metafunction] form builds a function on
|
|||
sexpressions according to the pattern and right-hand-side
|
||||
expressions. The first argument indicates the language used
|
||||
to resolve non-terminals in the pattern expressions. Each of
|
||||
the rhs-expressions is implicitly wrapped in @|tttterm|. In
|
||||
addition, recursive calls in the right-hand side of the
|
||||
metafunction clauses should appear inside @|tttterm|.
|
||||
the rhs-expressions is implicitly wrapped in @|tttterm|.
|
||||
|
||||
If specified, the side-conditions are collected with
|
||||
@scheme[and] and used as guards on the case being matched. The
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user