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

allow identifiers as names, not just strings

Browse Source
This commit is contained in:
Robby Findler 2012-08-09 15:28:23 -05:00
parent 0bd661d620
commit 40e5b63bbc
4 changed files with 33 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/redex/private/judgment-form.rkt
View File

@ -376,7 +376,10 @@
(define-syntax-class horizontal-line
(pattern x:id #:when (horizontal-line? #'x)))
(define-syntax-class name
(pattern x #:when (string? (syntax-e #'x))))
(pattern x #:when (or (and (symbol? (syntax-e #'x))
(not (horizontal-line? #'x))
(not (eq? '... (syntax-e #'x))))
(string? (syntax-e #'x)))))
(define (parse-rules rules)
(define-values (backward-rules backward-names)
(for/fold ([parsed-rules '()]
@ -432,14 +435,23 @@
(not extension?)
(raise-syntax-error #f "expected at least one rule" full-stx)]
[_ (defined-name (list name/mode name/contract) rules full-stx)]))
(values form-name dup-names mode-stx contract rules rule-names))
(define string-rule-names
(for/list ([name (in-list rule-names)])
(cond
[(not name) name]
[(symbol? (syntax-e name))
(symbol->string (syntax-e name))]
[else (syntax-e name)])))
(values form-name dup-names mode-stx contract rules string-rule-names))
;; names : (listof (or/c #f syntax[string]))
(define-for-syntax (check-dup-rule-names full-stx syn-err-name names)
(define tab (make-hash))
(for ([name (in-list names)])
(when (syntax? name)
(define k (syntax-e name))
(define k (if (symbol? (syntax-e name))
(symbol->string (syntax-e name))
(syntax-e name)))
(hash-set! tab k (cons name (hash-ref tab k '())))))
(for ([(k names) (in-hash tab)])
(unless (= 1 (length names))

3
collects/redex/scribblings/ref.scrbl
View File

@ -1161,7 +1161,8 @@ and @racket[#f] otherwise.
(side-condition @#,tttterm)
(side-condition/hidden @#,tttterm)]
[rule-name (code:line)
string]
string
non-ellipsis-non-hypens-var]
[pat/term @#,ttpattern
@#,tttterm]
[maybe-ellipsis (code:line)

3
collects/redex/tests/syn-err-tests/judgment-form-definition.rktd
View File

@ -68,7 +68,8 @@
(define-judgment-form syn-err-lang
#:mode (J I)
[(J number)
bad-prem])
bad-prem
q])
(void)))
(#rx"expected judgment form name"
([bad-judgment-form q])

15
collects/redex/tests/tl-test.rkt
View File

@ -2065,6 +2065,19 @@
(list (term (s (s (s z))))))
(test (judgment-holds (sumi ,'z (s z) (s z))) #t)
(define-judgment-form nats
#:mode (sumi2 I I O)
#:contract (sumi2 n n n)
[------------- sumz ;; symbol name
(sumi2 z n n)]
[(sumi2 n_1 n_2 n_3)
--------------------------- "sumn" ;; string name
(sumi2 (s n_1) n_2 (s n_3))])
(test (judgment-holds (sumi2 z (s z) n) n)
(list (term (s z))))
(test (judgment-holds (sumi2 (s (s z)) (s z) n) n)
(list (term (s (s (s z))))))
(define-judgment-form nats
#:mode (sumo O O I)
#:contract (sumo n n n)
@ -2201,7 +2214,7 @@
(test (judgment-holds (map-add-some-one (z (s z) (s (s z))) (n ...))
(n ...))
(list (term ((s z) (s (s z)) (s (s (s z)))))))
(list (term ((s z) (s (s z)) (s (s (s z)))))))
(define-judgment-form nats
#:mode (hyphens I)