107 lines
4.2 KiB
Scheme
107 lines
4.2 KiB
Scheme
#lang scheme/base
|
|
|
|
(require (for-syntax scheme/base
|
|
"parse.ss"
|
|
"parse-helper.ss"
|
|
"patterns.ss"
|
|
"gen-match.ss"))
|
|
|
|
(provide define-forms)
|
|
|
|
(define-syntax-rule (define-forms parse-id
|
|
match match* match-lambda match-lambda* match-lambda** match-let
|
|
match-let* match-define match-letrec)
|
|
(...
|
|
(begin
|
|
(provide match match* match-lambda match-lambda* match-lambda** match-let match-let*
|
|
match-define match-letrec)
|
|
(define-syntax (match* stx)
|
|
(syntax-case stx ()
|
|
[(_ es . clauses)
|
|
(go parse-id stx #'es #'clauses (syntax-local-certifier))]))
|
|
|
|
(define-syntax-rule (match arg [p . es] ...)
|
|
(match* (arg) [(p) . es] ...))
|
|
|
|
(define-syntax (match-lambda stx)
|
|
(syntax-case stx ()
|
|
[(k . clauses) (syntax/loc stx (lambda (exp) (match exp . clauses)))]))
|
|
|
|
(define-syntax (match-lambda* stx)
|
|
(syntax-case stx ()
|
|
[(k . clauses) (syntax/loc stx (lambda exp (match exp . clauses)))]))
|
|
|
|
(define-syntax (match-lambda** stx)
|
|
(syntax-case stx ()
|
|
[(k [pats . rhs] ...)
|
|
(let* ([pss (syntax->list #'(pats ...))]
|
|
[ps1 (car pss)]
|
|
[len (length (syntax->list ps1))])
|
|
(for/list ([ps pss])
|
|
(unless (= (length (syntax->list ps)) len)
|
|
(raise-syntax-error
|
|
'match "unequal number of patterns in match clauses"
|
|
stx ps ps1)))
|
|
(with-syntax ([(vars ...) (generate-temporaries (car pss))])
|
|
(syntax/loc stx
|
|
(lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))]))
|
|
|
|
;; there's lots of duplication here to handle named let
|
|
;; some factoring out would do a lot of good
|
|
(define-syntax (match-let stx)
|
|
(syntax-case stx ()
|
|
;; an empty body is an error
|
|
[(_ nm (clauses ...))
|
|
(identifier? #'nm)
|
|
(match:syntax-err stx "bad syntax (empty body)")]
|
|
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
|
|
;; with no bindings, there's nothing to do
|
|
[(_ name () body ...)
|
|
(identifier? #'name)
|
|
(syntax/loc stx (let name () body ...))]
|
|
[(_ () body ...) (syntax/loc stx (let () body ...))]
|
|
;; optimize the all-variable case
|
|
[(_ ([pat exp]...) body ...)
|
|
(andmap pattern-var? (syntax->list #'(pat ...)))
|
|
(syntax/loc stx (let name ([pat exp] ...) body ...))]
|
|
[(_ name ([pat exp]...) body ...)
|
|
(and (identifier? (syntax name))
|
|
(andmap pattern-var? (syntax->list #'(pat ...))))
|
|
(syntax/loc stx (let name ([pat exp] ...) body ...))]
|
|
;; now the real cases
|
|
[(_ name ([pat exp] ...) . body)
|
|
(syntax/loc stx (letrec ([name (match-lambda** ((pat ...) . body))])
|
|
(name exp ...)))]
|
|
[(_ ([pat exp] ...) . body)
|
|
(syntax/loc stx (match* (exp ...) [(pat ...) . body]))]))
|
|
|
|
(define-syntax (match-let* stx)
|
|
(syntax-case stx ()
|
|
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
|
|
[(_ () body ...)
|
|
(syntax/loc stx (let* () body ...))]
|
|
[(_ ([pat exp] rest ...) body ...)
|
|
(syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))]))
|
|
|
|
(define-syntax (match-letrec stx)
|
|
(syntax-case stx ()
|
|
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
|
|
[(_ ([pat exp] ...) . body)
|
|
(andmap pattern-var?
|
|
(syntax->list #'(pat ...)))
|
|
(syntax/loc stx (letrec ([pat exp] ...) . body))]
|
|
[(_ ([pat exp] ...) . body)
|
|
(syntax/loc stx (let () (match-define pat exp) ... . body))]))
|
|
|
|
(define-syntax (match-define stx)
|
|
(syntax-case stx ()
|
|
[(_ pat exp)
|
|
(pattern-var? #'pat)
|
|
(syntax/loc stx (define pat exp))]
|
|
[(_ pat rhs)
|
|
;; FIXME - calls parse twice
|
|
(let ([p (parse-id #'pat (syntax-local-certifier))])
|
|
(with-syntax ([vars (bound-vars p)])
|
|
(syntax/loc stx
|
|
(define-values vars (match rhs [pat (values . vars)])))))])))))
|