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