From b42a11d12dbff0a32779566f00f3f612ad47a356 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 12 Jul 2006 18:59:07 +0000 Subject: [PATCH] match.ss: abstract some boilerplate, and use syntax/loc when doing conversion to plt-match match-helper.ss: add helper macro render-test-list-impl.ss: fix hygiene bug in checking for non-linear patters (thanks to Ryan Culpepper) gen-match.ss: Fix error reporting location in match errors. (thanks to Ryan Culpepper) svn: r3689 --- collects/mzlib/match.ss | 89 ++++++++++--------- collects/mzlib/private/convert-pat.ss | 2 +- collects/mzlib/private/gen-match.ss | 2 +- collects/mzlib/private/match-helper.ss | 8 ++ .../mzlib/private/render-test-list-impl.ss | 6 +- 5 files changed, 61 insertions(+), 46 deletions(-) diff --git a/collects/mzlib/match.ss b/collects/mzlib/match.ss index 59c7316c59..f044af3184 100644 --- a/collects/mzlib/match.ss +++ b/collects/mzlib/match.ss @@ -125,61 +125,66 @@ (require-for-syntax "private/convert-pat.ss" "private/match-helper.ss") + (require-for-template mzscheme) + (require (prefix plt: "private/match-internal-func.ss") "private/match-expander.ss" "private/match-helper.ss" "private/match-error.ss" "private/test-no-order.ss") - (define-syntax (match-lambda stx) - (syntax-case stx () - [(k clause ...) - (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) - #'(plt:match-lambda new-clauses ...))])) - (define-syntax (match-lambda* stx) - (syntax-case stx () - [(k clause ...) - (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) - #'(plt:match-lambda* new-clauses ...))])) + (define-syntax match-definer + (syntax-rules () + [(match-definer name clauses ...) + (define-syntax (name stx) + (md-help syntax stx + (syntax-case stx () + clauses ...)))])) - (define-syntax (match-let stx) - (syntax-case stx () - [(k name (clauses ...) body ...) - (identifier? (syntax name)) - (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))]) - #'(plt:match-let name (new-clauses ...) body ...))] - [(k (clauses ...) body ...) - (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))]) - #'(plt:match-let (new-clauses ...) body ...))])) + (match-definer match-lambda + [(k clause ...) + (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) + #'(plt:match-lambda new-clauses ...))]) - (define-syntax (match-let* stx) - (syntax-case stx () - [(k (clauses ...) body ...) - (with-syntax - ([(new-clauses ...) (handle-clauses #'(clauses ...))]) - #'(plt:match-let* (new-clauses ...) body ...))])) + (match-definer match-lambda* + [(k clause ...) + (with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))]) + #'(plt:match-lambda* new-clauses ...))]) - (define-syntax (match stx) - (syntax-case stx () - [(_ exp clause ...) - (with-syntax - ([(new-clauses ...) (handle-clauses #'(clause ...))]) - #'(plt:match exp new-clauses ...))])) + (match-definer match-let + [(k name (clauses ...) body ...) + (identifier? (syntax name)) + (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))]) + #'(plt:match-let name (new-clauses ...) body ...))] + [(k (clauses ...) body ...) + (with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))]) + #'(plt:match-let (new-clauses ...) body ...))]) - (define-syntax (match-letrec stx) - (syntax-case stx () - [(k (clauses ...) body ...) - (with-syntax - ([(new-clauses ...) (handle-clauses #'(clauses ...))]) - #'(plt:match-letrec (new-clauses ...) body ...))])) + (match-definer match-let* + [(k (clauses ...) body ...) + (with-syntax + ([(new-clauses ...) (handle-clauses #'(clauses ...))]) + #'(plt:match-let* (new-clauses ...) body ...))]) + + (match-definer match + [(_ exp clause ...) + (with-syntax + ([(new-clauses ...) (handle-clauses #'(clause ...))]) + #'(plt:match exp new-clauses ...))]) + + + (match-definer match-letrec + [(k (clauses ...) body ...) + (with-syntax + ([(new-clauses ...) (handle-clauses #'(clauses ...))]) + #'(plt:match-letrec (new-clauses ...) body ...))]) - (define-syntax (match-define stx) - (syntax-case stx () - [(k pat exp) - (with-syntax ([new-pat (convert-pat #'pat)]) - #'(plt:match-define new-pat exp))])) + (match-definer match-define + [(k pat exp) + (with-syntax ([new-pat (convert-pat #'pat)]) + #'(plt:match-define new-pat exp))]) diff --git a/collects/mzlib/private/convert-pat.ss b/collects/mzlib/private/convert-pat.ss index 9c94e771f8..a3c1dceac2 100644 --- a/collects/mzlib/private/convert-pat.ss +++ b/collects/mzlib/private/convert-pat.ss @@ -13,7 +13,7 @@ (define (handle-clause stx) (syntax-case stx () - [(pat . rest) #`(#,(convert-pat (syntax pat)) . rest)])) + [(pat . rest) (quasisyntax/loc stx (#,(convert-pat #'pat) . rest))])) (define (handle-clauses stx) (syntax-map handle-clause stx)) diff --git a/collects/mzlib/private/gen-match.ss b/collects/mzlib/private/gen-match.ss index 4441df02a1..f54b0721cb 100644 --- a/collects/mzlib/private/gen-match.ss +++ b/collects/mzlib/private/gen-match.ss @@ -169,7 +169,7 @@ (match:syntax-err stx "null clause list")) (let* ([marked-clauses (mark-patlist patlist)] [compiled-match - #`(let ([match-failure (lambda () (match:error #,exp '#,stx))]) + #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) #,(gen exp tsf marked-clauses stx #'(match-failure) diff --git a/collects/mzlib/private/match-helper.ss b/collects/mzlib/private/match-helper.ss index f68293d2d1..bb8936ac5e 100644 --- a/collects/mzlib/private/match-helper.ss +++ b/collects/mzlib/private/match-helper.ss @@ -18,6 +18,14 @@ [(_ nm func) (define-syntax (nm stx) (func stx stx))])) + ;; bind an identifier to be syntax/loc with a particular location, in an expression + (define-syntax md-help + (syntax-rules () + [(md-help id stx e) + (let-syntax ([id (syntax-rules () [(id arg) (syntax/loc stx arg)])]) + e)])) + + ;;!(function symbol-append ;; (form (symbol-append . args) -> symbol) diff --git a/collects/mzlib/private/render-test-list-impl.ss b/collects/mzlib/private/render-test-list-impl.ss index 1b8fe3a4e0..f300453895 100644 --- a/collects/mzlib/private/render-test-list-impl.ss +++ b/collects/mzlib/private/render-test-list-impl.ss @@ -180,8 +180,10 @@ (lambda (ks kf let-bound) (lambda (sf bv) (cond [(ormap (lambda (x) - (if (stx-equal? #'pt (car x)) - (cdr x) #f)) bv) + (if (bound-identifier=? #'pt (car x)) + (cdr x) + #f)) + bv) => (lambda (bound-exp) (emit (lambda (exp) #`((match-equality-test) #,exp #,(subst-bindings bound-exp let-bound)))