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

reformatted

Browse Source 
svn: r4916
This commit is contained in:
Eli Barzilay 2006-11-22 00:06:01 +00:00
parent 404fad489d
commit 11debcdcdc
1 changed files with 288 additions and 272 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/mzlib/etc.ss
View File

@ -277,7 +277,8 @@
(let loop ([tests tests]) (let loop ([tests tests])
(unless (null? (cdr tests)) (unless (null? (cdr tests))
(when (and (identifier? (car tests)) (when (and (identifier? (car tests))
(module-identifier=? (quote-syntax else) (car tests))) (module-identifier=? (quote-syntax else)
(car tests)))
(raise-syntax-error (raise-syntax-error
#f "else is not in last clause" stx (car tests))) #f "else is not in last clause" stx (car tests)))
(loop (cdr tests))))) (loop (cdr tests)))))
@ -359,10 +360,14 @@
(with-syntax ([vars (normal-var (syntax var))]) (with-syntax ([vars (normal-var (syntax var))])
(syntax (letrec-values ([vars expr]) rest)))] (syntax (letrec-values ([vars expr]) rest)))]
[(vals (var expr) ...) [(vals (var expr) ...)
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))]) (with-syntax ([(vars ...)
(map normal-var
(syntax->list (syntax (var ...))))])
(syntax (let-values ([vars expr] ...) rest)))] (syntax (let-values ([vars expr] ...) rest)))]
[(recs (var expr) ...) [(recs (var expr) ...)
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))]) (with-syntax ([(vars ...)
(map normal-var
(syntax->list (syntax (var ...))))])
(syntax (letrec-values ([vars expr] ...) rest)))] (syntax (letrec-values ([vars expr] ...) rest)))]
[(_ expr0 expr ...) [(_ expr0 expr ...)
(syntax (begin expr0 expr ... rest))])))))])) (syntax (begin expr0 expr ... rest))])))))]))
@ -383,7 +388,8 @@
[local (or (current-load-relative-directory) (current-directory))] [local (or (current-load-relative-directory) (current-directory))]
[dir (path->main-collects-relative [dir (path->main-collects-relative
(or (and source (file-exists? source) (or (and source (file-exists? source)
(let-values ([(base file dir?) (split-path source)]) (let-values ([(base file dir?)
(split-path source)])
(and (path? base) (and (path? base)
(path->complete-path base local)))) (path->complete-path base local))))
local))]) local))])
@ -480,7 +486,9 @@
#'rhs #'rhs
'expression 'expression
null)]) null)])
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx) (syntax-local-bind-syntaxes
(syntax->list #'(id ...))
#'rhs def-ctx)
(list #'(define-syntaxes (id ...) rhs)))] (list #'(define-syntaxes (id ...) rhs)))]
[(define-values (id ...) rhs) [(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...))) (andmap identifier? (syntax->list #'(id ...)))
@ -490,7 +498,10 @@
[else [else
(list expr)]))) (list expr)])))
exprs)))]) exprs)))])
(let loop ([exprs exprs][prev-stx-defns null][prev-defns null][prev-exprs null]) (let loop ([exprs exprs]
[prev-stx-defns null]
[prev-defns null]
[prev-exprs null])
(cond (cond
[(null? exprs) [(null? exprs)
#`(letrec-syntaxes+values #`(letrec-syntaxes+values
@ -502,7 +513,10 @@
[(and (stx-pair? (car exprs)) [(and (stx-pair? (car exprs))
(identifier? (stx-car (car exprs))) (identifier? (stx-car (car exprs)))
(module-identifier=? #'define-syntaxes (stx-car (car exprs)))) (module-identifier=? #'define-syntaxes (stx-car (car exprs))))
(loop (cdr exprs) (cons (car exprs) prev-stx-defns) prev-defns prev-exprs)] (loop (cdr exprs)
(cons (car exprs) prev-stx-defns)
prev-defns
prev-exprs)]
[(and (stx-pair? (car exprs)) [(and (stx-pair? (car exprs))
(identifier? (stx-car (car exprs))) (identifier? (stx-car (car exprs)))
(module-identifier=? #'define-values (stx-car (car exprs)))) (module-identifier=? #'define-values (stx-car (car exprs))))
@ -515,8 +529,10 @@
prev-exprs) prev-exprs)
prev-defns)) prev-defns))
null)] null)]
[else [else (loop (cdr exprs)
(loop (cdr exprs) prev-stx-defns prev-defns (cons (car exprs) prev-exprs))])))) prev-stx-defns
prev-defns
(cons (car exprs) prev-exprs))]))))
(define-syntax (begin-lifted stx) (define-syntax (begin-lifted stx)
(syntax-case stx () (syntax-case stx ()