diff --git a/pkgs/racket-test-core/tests/racket/syntax.rktl b/pkgs/racket-test-core/tests/racket/syntax.rktl index 8113979396..c010dbe136 100644 --- a/pkgs/racket-test-core/tests/racket/syntax.rktl +++ b/pkgs/racket-test-core/tests/racket/syntax.rktl @@ -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) diff --git a/racket/collects/racket/private/cond.rkt b/racket/collects/racket/private/cond.rkt index 610766cbd2..87336bb227 100644 --- a/racket/collects/racket/private/cond.rkt +++ b/racket/collects/racket/private/cond.rkt @@ -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 =>))