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

match.ss: abstract some boilerplate, and use syntax/loc when doing conversion to plt-match

Browse Source 
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
This commit is contained in:
Sam Tobin-Hochstadt 2006-07-12 18:59:07 +00:00
parent 495e879820
commit b42a11d12d
5 changed files with 61 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/mzlib/match.ss
View File

@ -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))])

2
collects/mzlib/private/convert-pat.ss
View File

@ -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))

2
collects/mzlib/private/gen-match.ss
View File

@ -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)

8
collects/mzlib/private/match-helper.ss
View File

@ -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)

6
collects/mzlib/private/render-test-list-impl.ss
View File

@ -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)))