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

Make cond track disappeared-uses for => and else

Browse Source
This commit is contained in:
Alexis King 2018-09-13 13:09:59 -05:00
parent d5aa191fb2
commit c0788127ae
2 changed files with 126 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
pkgs/racket-test-core/tests/racket/syntax.rktl
View File

@ -3,6 +3,9 @@
(Section 'syntax)
(require syntax/srcloc
syntax/strip-context)
;; ----------------------------------------
(test 0 'with-handlers (with-handlers () 0))
@ -2080,6 +2083,54 @@
(err/rt-test (eval '(module m 'provide-transformer-set!-and-broken-module-begin (set! x 1)))
exn:fail:syntax?)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check disappeared-uses for cond
(define (jumble->list v)
(cond
[(list? v) (append-map jumble->list v)]
[(pair? v) (append (jumble->list (car v)) (jumble->list (cdr v)))]
[else (list v)]))
(define (collect-property-jumble stx key)
(let loop ([stx stx])
(let ([outer-val (syntax-property stx key)]
[inner-vals (syntax-case stx ()
[(a . b)
(append (loop #'a) (loop #'b))]
[#(a ...)
(append-map loop (syntax->list #'(a ...)))]
[#&a
(loop #'a)]
[_
(prefab-struct-key (syntax-e stx))
(append-map loop (vector->list (struct->vector (syntax-e stx))))]
[_
(hash? (syntax-e stx))
(append-map loop (hash-values (syntax-e stx)))]
[_ '()])])
(if outer-val
(append (jumble->list outer-val) inner-vals)
inner-vals))))
(define (srclocs-equal? a b)
(equal? (build-source-location a)
(build-source-location b)))
(define (all-srclocs-equal? as bs)
(and (= (length as) (length bs))
(andmap srclocs-equal? as bs)))
(with-syntax ([=>1 #'=>] [=>2 #'=>] [else1 #'else])
(test
#t
all-srclocs-equal?
(collect-property-jumble
(parameterize ([current-namespace (make-base-namespace)])
(expand (strip-context #'(cond [#t =>1 values] [#f =>2 not] [else1 #f]))))
'disappeared-use)
(list #'=>1 #'=>2 #'else1)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

133
racket/collects/racket/private/cond.rkt
View File

@ -18,67 +18,84 @@
(define-syntaxes (cond old-cond)
(let ([go
(let ([here (quote-syntax here)])
(lambda (in-form =>-stx else-stx)
(lambda (in-form =>-stx else-stx track-disappeared-uses?)
(if (identifier? in-form)
(raise-syntax-error #f "bad syntax" in-form)
(void))
(datum->syntax
here
(let ([form (stx-cdr in-form)]
[serror
(lambda (msg at)
(raise-syntax-error #f msg in-form at))])
(let loop ([tests form][first? #t])
(if (stx-null? tests)
(quote-syntax (void))
(if (not (stx-pair? tests))
(serror
"bad syntax (body must contain a list of pairs)"
tests)
(let ([line (stx-car tests)]
[rest (stx-cdr tests)])
(if (not (stx-pair? line))
(serror
"bad syntax (clause is not a test-value pair)"
line)
(let* ([test (stx-car line)]
[value (stx-cdr line)]
[else? (and (identifier? test)
(free-identifier=? test else-stx))])
(if (and else? (stx-pair? rest))
(serror "bad syntax (`else' clause must be last)" line)
(void))
(if (and (not else?)
(stx-pair? value)
(identifier? (stx-car value))
(free-identifier=? (stx-car value) =>-stx))
(if (and (stx-pair? (stx-cdr value))
(stx-null? (stx-cdr (stx-cdr value))))
(let ([gen (gen-temp-id 'c)])
`(,(quote-syntax let-values) ([(,gen) ,test])
(,(quote-syntax if) ,gen
(,(stx-car (stx-cdr value)) ,gen)
,(loop rest #f))))
(serror
"bad syntax (bad clause form with =>)"
line))
(if else?
(if (stx-null? value)
(serror
"missing expressions in `else' clause"
line)
(list* (quote-syntax let-values) (quote-syntax ()) value))
(if (stx-null? value)
(let ([gen (gen-temp-id 'c)])
`(,(quote-syntax let-values) ([(,gen) ,test])
(,(quote-syntax if) ,gen ,gen ,(loop rest #f))))
(list
(quote-syntax if) test
(list* (quote-syntax let-values) (quote-syntax ()) value)
(loop rest #f))))))))))))
in-form)))])
(let-values
([(expansion disappeared-uses)
(let ([form (stx-cdr in-form)]
[serror
(lambda (msg at)
(raise-syntax-error #f msg in-form at))])
(let loop ([tests form])
(if (stx-null? tests)
(values (quote-syntax (void)) '())
(if (not (stx-pair? tests))
(serror
"bad syntax (body must contain a list of pairs)"
tests)
(let ([line (stx-car tests)]
[rest (stx-cdr tests)])
(if (not (stx-pair? line))
(serror
"bad syntax (clause is not a test-value pair)"
line)
(let* ([test (stx-car line)]
[value (stx-cdr line)]
[else? (and (identifier? test)
(free-identifier=? test else-stx))])
(if (and else? (stx-pair? rest))
(serror "bad syntax (`else' clause must be last)" line)
(void))
(if (and (not else?)
(stx-pair? value)
(identifier? (stx-car value))
(free-identifier=? (stx-car value) =>-stx))
(if (and (stx-pair? (stx-cdr value))
(stx-null? (stx-cdr (stx-cdr value))))
(let-values ([(exp d-u) (loop rest)])
(let ([gen (gen-temp-id 'c)])
(values
`(,(quote-syntax let-values) ([(,gen) ,test])
(,(quote-syntax if)
,gen
(,(stx-car (stx-cdr value)) ,gen)
,exp))
(cons (syntax-local-introduce (stx-car value))
d-u))))
(serror
"bad syntax (bad clause form with =>)"
line))
(if else?
(if (stx-null? value)
(serror
"missing expressions in `else' clause"
line)
(values (list* (quote-syntax let-values)
(quote-syntax ())
value)
(list (syntax-local-introduce test))))
(let-values ([(exp d-u) (loop rest)])
(values
(if (stx-null? value)
(let ([gen (gen-temp-id 'c)])
`(,(quote-syntax let-values)
([(,gen) ,test])
(,(quote-syntax if) ,gen ,gen ,exp)))
(list
(quote-syntax if) test
(list* (quote-syntax let-values)
(quote-syntax ())
value)
exp))
d-u)))))))))))])
(let ([expansion-stx (datum->syntax here expansion in-form)])
(if (or (not track-disappeared-uses?) (null? disappeared-uses))
expansion-stx
(syntax-property expansion-stx 'disappeared-use disappeared-uses))))))])
(values
(lambda (stx) (go stx (quote-syntax =>) (quote-syntax else)))
(lambda (stx) (go stx (datum->syntax #f '=>) (datum->syntax #f 'else))))))
(lambda (stx) (go stx (quote-syntax =>) (quote-syntax else) #t))
(lambda (stx) (go stx (datum->syntax #f '=>) (datum->syntax #f 'else) #f)))))
(#%provide cond old-cond else =>))