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

reformat

Browse Source 
svn: r9039

original commit: 02c33947263e79ecb3a3fea436f91d023b94d899
This commit is contained in:
Eli Barzilay 2008-03-21 13:13:31 +00:00
parent 0b86826a0d
commit 1e11cd39f8
1 changed files with 396 additions and 405 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

801
collects/mzlib/etc.ss
View File

@ -1,434 +1,425 @@
#lang mzscheme
(module etc mzscheme (require (lib "main-collects.ss" "setup")
scheme/local
scheme/bool
(only scheme/base
build-string
build-list
build-vector
compose)
"kw.ss")
(require (lib "main-collects.ss" "setup") (require-for-syntax syntax/kerncase
scheme/local syntax/stx
scheme/bool syntax/name
(only scheme/base (lib "main-collects.ss" "setup")
build-string "private/stxset.ss")
build-list
build-vector
compose)
"kw.ss")
(require-for-syntax syntax/kerncase (provide boolean=? symbol=?
syntax/stx identity
syntax/name compose
(lib "main-collects.ss" "setup")
"private/stxset.ss")
(provide boolean=? symbol=? true false
identity
compose
true false build-string
build-vector
build-list
build-string loop-until
build-vector
build-list
loop-until opt-lambda
opt-lambda local
recur
rec
evcase
nor
nand
let+
local namespace-defined?
recur this-expression-source-directory
rec this-expression-file-name
evcase define-syntax-set
nor
nand
let+
namespace-defined? hash-table
this-expression-source-directory
this-expression-file-name
define-syntax-set
hash-table begin-with-definitions
begin-with-definitions begin-lifted)
begin-lifted) (define identity (lambda (x) x))
(define identity (lambda (x) x)) (define (loop-until start done? next body)
(let loop ([i start])
(unless (done? i)
(body i)
(loop (next i)))))
(define (loop-until start done? next body) (define-syntax (opt-lambda stx)
(let loop ([i start]) (with-syntax ([name (or (syntax-local-infer-name stx)
(unless (done? i) (quote-syntax opt-lambda-proc))])
(body i)
(loop (next i)))))
(define-syntax (opt-lambda stx)
(with-syntax ([name (or (syntax-local-infer-name stx)
(quote-syntax opt-lambda-proc))])
(syntax-case stx ()
[(_ args body1 body ...)
(let ([clauses (let loop ([pre-args null]
[args (syntax args)]
[needs-default? #f])
(syntax-case args ()
[id
(identifier? (syntax id))
(with-syntax ([(pre-arg ...) pre-args])
(syntax ([(pre-arg ... . id)
body1 body ...])))]
[()
(with-syntax ([(pre-arg ...) pre-args])
(syntax ([(pre-arg ...)
body1 body ...])))]
[(id . rest)
(identifier? (syntax id))
(begin
(when needs-default?
(raise-syntax-error
#f "default value missing" stx (syntax id)))
(loop (append pre-args (list (syntax id)))
(syntax rest)
#f))]
[([id default] . rest)
(identifier? (syntax id))
(with-syntax ([rest (loop (append pre-args (list (syntax id)))
(syntax rest)
#t)]
[(pre-arg ...) pre-args])
(syntax ([(pre-arg ...) (name pre-arg ... default)]
. rest)))]
[(bad . rest)
(raise-syntax-error
#f
"not an identifier or identifier with default"
stx
(syntax bad))]
[else
(raise-syntax-error
#f "bad identifier sequence" stx (syntax args))]))])
(with-syntax ([clauses clauses])
(syntax/loc stx
(letrec ([name (case-lambda . clauses)]) name))))])))
;; recur is another name for 'let' in a named let
(define-syntax (recur stx)
(syntax-case stx () (syntax-case stx ()
[(_ . rest) (syntax/loc stx (let . rest))])) [(_ args body1 body ...)
(let ([clauses (let loop ([pre-args null]
;; define a recursive value [args (syntax args)]
;; implementation by Jens Axel Soegaard [needs-default? #f])
(define-syntax (rec stx) (syntax-case args ()
(syntax-case stx () [id
[(rec id expr) (identifier? (syntax id))
(identifier? #'id) (with-syntax ([(pre-arg ...) pre-args])
#`(letrec ((id expr)) (syntax ([(pre-arg ... . id)
#,(syntax-property #'id 'inferred-name (syntax-e #'id)))] body1 body ...])))]
[(rec (name id ...) body ...) [()
(andmap identifier? (syntax->list #'(name id ...))) (with-syntax ([(pre-arg ...) pre-args])
#`(letrec ((name (lambda (id ...) body ...))) (syntax ([(pre-arg ...)
#,(syntax-property #'name 'inferred-name (syntax-e #'name)))] body1 body ...])))]
[(rec (name id ... . did) body ...) [(id . rest)
(andmap identifier? (syntax->list #'(name did id ...))) (identifier? (syntax id))
#`(letrec ((name (lambda (id ... . did) body ...))) (begin
#,(syntax-property #'name 'inferred-name (syntax-e #'name)))] (when needs-default?
[_ (raise-syntax-error
(raise-syntax-error #f "default value missing" stx (syntax id)))
#f "expects either an identifier followed by an expresion, or a (possibly dotted) sequence of identifiers followed by a body" stx)])) (loop (append pre-args (list (syntax id)))
(syntax rest)
(define-syntax (evcase stx) #f))]
(syntax-case stx () [([id default] . rest)
[(_ val [test body ...] ...) (identifier? (syntax id))
(let ([tests (syntax->list (syntax (test ...)))]) (with-syntax ([rest (loop (append pre-args (list (syntax id)))
(with-syntax ([(a-test ...) (syntax rest)
(map (lambda (t) #t)]
(syntax-case t (else) [(pre-arg ...) pre-args])
[else (syntax #t)] (syntax ([(pre-arg ...) (name pre-arg ... default)]
[_else (with-syntax ([t t]) . rest)))]
(syntax (eqv? evcase-v t)))])) [(bad . rest)
tests)]) (raise-syntax-error
;; Make sure else is last: #f
(unless (null? tests) "not an identifier or identifier with default"
(let loop ([tests tests]) stx
(unless (null? (cdr tests)) (syntax bad))]
(when (and (identifier? (car tests)) [else
(module-identifier=? (quote-syntax else) (raise-syntax-error
(car tests))) #f "bad identifier sequence" stx (syntax args))]))])
(raise-syntax-error (with-syntax ([clauses clauses])
#f "else is not in last clause" stx (car tests)))
(loop (cdr tests)))))
(syntax/loc stx (syntax/loc stx
(let ([evcase-v val]) (letrec ([name (case-lambda . clauses)]) name))))])))
(cond [a-test (begin body ...)]
...)))))] ;; recur is another name for 'let' in a named let
[(_ val something ...) (define-syntax (recur stx)
;; Provide a good error message: (syntax-case stx ()
[(_ . rest) (syntax/loc stx (let . rest))]))
;; define a recursive value
;; implementation by Jens Axel Soegaard
(define-syntax (rec stx)
(syntax-case stx ()
[(rec id expr)
(identifier? #'id)
#`(letrec ((id expr))
#,(syntax-property #'id 'inferred-name (syntax-e #'id)))]
[(rec (name id ...) body ...)
(andmap identifier? (syntax->list #'(name id ...)))
#`(letrec ((name (lambda (id ...) body ...)))
#,(syntax-property #'name 'inferred-name (syntax-e #'name)))]
[(rec (name id ... . did) body ...)
(andmap identifier? (syntax->list #'(name did id ...)))
#`(letrec ((name (lambda (id ... . did) body ...)))
#,(syntax-property #'name 'inferred-name (syntax-e #'name)))]
[_
(raise-syntax-error
#f "expects either an identifier followed by an expresion, or a (possibly dotted) sequence of identifiers followed by a body" stx)]))
(define-syntax (evcase stx)
(syntax-case stx ()
[(_ val [test body ...] ...)
(let ([tests (syntax->list (syntax (test ...)))])
(with-syntax ([(a-test ...)
(map (lambda (t)
(syntax-case t (else)
[else (syntax #t)]
[_else (with-syntax ([t t])
(syntax (eqv? evcase-v t)))]))
tests)])
;; Make sure else is last:
(unless (null? tests)
(let loop ([tests tests])
(unless (null? (cdr tests))
(when (and (identifier? (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)))))
(syntax/loc stx
(let ([evcase-v val])
(cond [a-test (begin body ...)]
...)))))]
[(_ val something ...)
;; Provide a good error message:
(for-each
(lambda (s)
(syntax-case s ()
[(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
(syntax->list (syntax (something ...))))]))
(define-syntax (nor stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
(define-syntax (nand stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
(define-syntax (let+ stx)
(syntax-case stx ()
[(_ [clause ...] body1 body ...)
(let ([clauses (syntax->list (syntax (clause ...)))]
[bad (lambda (c n)
(raise-syntax-error
#f (format "illegal use of ~a for a clause" n) stx c))]
[var? (lambda (x)
(or (identifier? x)
(let ([l (syntax->list x)])
(and l
(pair? l)
(eq? (syntax-e (car l)) 'values)
(andmap identifier? (cdr l))))))]
[normal-var (lambda (x)
(if (identifier? x)
(list x)
(cdr (syntax-e x))))])
;; syntax checks
(for-each (for-each
(lambda (s) (lambda (clause)
(syntax-case s () (syntax-case* clause (val rec vals recs _)
[(t a ...) (raise-syntax-error #f "invalid clause" stx s)])) (lambda (a b) (eq? (syntax-e b) (syntax-e a)))
(syntax->list (syntax (something ...))))])) [(val var expr)
(var? (syntax var))
'ok]
[(rec var expr)
(var? (syntax var))
'ok]
[(vals (var expr) ...)
(andmap var? (syntax->list (syntax (var ...))))
'ok]
[(recs (var expr) ...)
(andmap var? (syntax->list (syntax (var ...))))
'ok]
[(_ expr0 expr ...)
'ok]
[(val . __) (bad clause "val")]
[(rec . __) (bad clause "rec")]
[(vals . __) (bad clause "vals")]
[(recs . __) (bad clause"recs")]
[(_ . __) (bad clause "_")]
[_else (raise-syntax-error #f "bad clause" stx clause)]))
clauses)
;; result
(let loop ([clauses clauses])
(if (null? clauses)
(syntax (let () body1 body ...))
(with-syntax ([rest (loop (cdr clauses))])
(syntax-case* (car clauses) (val rec vals recs _)
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
[(val var expr)
(with-syntax ([vars (normal-var (syntax var))])
(syntax (let-values ([vars expr]) rest)))]
[(rec var expr)
(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 ...))))])
(syntax (let-values ([vars expr] ...) rest)))]
[(recs (var expr) ...)
(with-syntax ([(vars ...)
(map normal-var
(syntax->list (syntax (var ...))))])
(syntax (letrec-values ([vars expr] ...) rest)))]
[(_ expr0 expr ...)
(syntax (begin expr0 expr ... rest))])))))]))
(define-syntax (nor stx) (define ns-undefined (gensym))
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
(define-syntax (nand stx) (define (namespace-defined? n)
(syntax-case stx () (unless (symbol? n)
[(_ expr ...) (syntax/loc stx (not (and expr ...)))])) (raise-type-error 'namespace-defined? "symbol" n))
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
ns-undefined)))
(define-syntax (let+ stx) (define (extract-module-directory stx)
(syntax-case stx () (let ([srcmod (let ([mpi (syntax-source-module stx)])
[(_ [clause ...] body1 body ...) (if (module-path-index? mpi)
(let ([clauses (syntax->list (syntax (clause ...)))] (module-path-index-resolve mpi)
[bad (lambda (c n) mpi))])
(raise-syntax-error (let ([name (resolved-module-path-name srcmod)])
#f (format "illegal use of ~a for a clause" n) stx c))] (and (path? name)
[var? (lambda (x) (let-values ([(base name dir?) (split-path name)])
(or (identifier? x) (and (path? base)
(let ([l (syntax->list x)]) base))))))
(and l
(pair? l)
(eq? (syntax-e (car l)) 'values)
(andmap identifier? (cdr l))))))]
[normal-var (lambda (x)
(if (identifier? x)
(list x)
(cdr (syntax-e x))))])
;; syntax checks
(for-each
(lambda (clause)
(syntax-case* clause (val rec vals recs _)
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
[(val var expr)
(var? (syntax var))
'ok]
[(rec var expr)
(var? (syntax var))
'ok]
[(vals (var expr) ...)
(andmap var? (syntax->list (syntax (var ...))))
'ok]
[(recs (var expr) ...)
(andmap var? (syntax->list (syntax (var ...))))
'ok]
[(_ expr0 expr ...)
'ok]
[(val . __) (bad clause "val")]
[(rec . __) (bad clause "rec")]
[(vals . __) (bad clause "vals")]
[(recs . __) (bad clause"recs")]
[(_ . __) (bad clause "_")]
[_else (raise-syntax-error #f "bad clause" stx clause)]))
clauses)
;; result
(let loop ([clauses clauses])
(if (null? clauses)
(syntax (let () body1 body ...))
(with-syntax ([rest (loop (cdr clauses))])
(syntax-case* (car clauses) (val rec vals recs _)
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
[(val var expr)
(with-syntax ([vars (normal-var (syntax var))])
(syntax (let-values ([vars expr]) rest)))]
[(rec var expr)
(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 ...))))])
(syntax (let-values ([vars expr] ...) rest)))]
[(recs (var expr) ...)
(with-syntax ([(vars ...)
(map normal-var
(syntax->list (syntax (var ...))))])
(syntax (letrec-values ([vars expr] ...) rest)))]
[(_ expr0 expr ...)
(syntax (begin expr0 expr ... rest))])))))]))
(define ns-undefined (gensym)) (define-syntax (this-expression-source-directory stx)
(syntax-case stx ()
[(_)
(let ([source-path
(let* ([source (syntax-source stx)]
[source (and (path? source) source)]
[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)])
(and (path? base)
(path->complete-path base local))))
local))])
(if (and (pair? dir) (eq? 'collects (car dir)))
(with-syntax ([d dir])
(syntax/loc stx (main-collects-relative->path 'd)))
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
(syntax/loc stx (bytes->path d)))))])
(let ([mpi (syntax-source-module stx)])
(if mpi
(quasisyntax/loc stx
(or (extract-module-directory (quote-syntax #,stx))
#,source-path))
source-path)))]))
(define (namespace-defined? n) (define-syntax (this-expression-file-name stx)
(unless (symbol? n) (syntax-case stx ()
(raise-type-error 'namespace-defined? "symbol" n)) [(_)
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) (let* ([f (syntax-source stx)]
ns-undefined))) [f (and f (path? f) (file-exists? f)
(let-values ([(base file dir?) (split-path f)]) file))])
(if f
(with-syntax ([f (path->bytes f)]) #'(bytes->path f))
#'#f))]))
(define (extract-module-directory stx) ;; This is a macro-generating macro that wants to expand
(let ([srcmod (let ([mpi (syntax-source-module stx)]) ;; expressions used in the generated macro. So it's weird,
(if (module-path-index? mpi) ;; and we put much of the work in a helper macro,
(module-path-index-resolve mpi) ;; `finish-syntax-set'.
mpi))]) (define-syntax (define-syntax-set stx)
(let ([name (resolved-module-path-name srcmod)]) (syntax-case stx ()
(and (path? name) [(_ (id ...) defn ...)
(let-values ([(base name dir?) (split-path name)]) (let ([ids (syntax->list (syntax (id ...)))])
(and (path? base) ;; Check ids ------------------------------
base)))))) (for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier or two identifier in parentheses"
stx
id)))
ids)
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error #f "duplicate identifier" stx dup)))
(define-syntax (this-expression-source-directory stx) ;; We'd like to check the `defns', but that requires
(syntax-case stx () ;; and expansion in a different phase. So we move
[(_) ;; into that phase using `finish-syntax-set':
(let ([source-path (with-syntax ([orig-stx stx])
(let* ([source (syntax-source stx)] (syntax/loc stx
[source (and (path? source) source)] (define-syntaxes (id ...)
[local (or (current-load-relative-directory) (current-directory))] (finish-syntax-set orig-stx)))))]))
[dir (path->main-collects-relative
(or (and source (file-exists? source)
(let-values ([(base file dir?)
(split-path source)])
(and (path? base)
(path->complete-path base local))))
local))])
(if (and (pair? dir) (eq? 'collects (car dir)))
(with-syntax ([d dir])
(syntax/loc stx (main-collects-relative->path 'd)))
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
(syntax/loc stx (bytes->path d)))))])
(let ([mpi (syntax-source-module stx)])
(if mpi
(quasisyntax/loc stx
(or (extract-module-directory (quote-syntax #,stx))
#,source-path))
source-path)))]))
(define-syntax (this-expression-file-name stx) (define-syntax (hash-table stx)
(syntax-case stx () (syntax-case stx (quote)
[(_) [(_ x ...)
(let* ([f (syntax-source stx)] (let loop ([xs #'(x ...)] [flags '()])
[f (and f (path? f) (file-exists? f) (syntax-case xs (quote)
(let-values ([(base file dir?) (split-path f)]) file))]) [('flag x ...) (loop #'(x ...) (cons #''flag flags))]
(if f [([key val] ...)
(with-syntax ([f (path->bytes f)]) #'(bytes->path f)) (with-syntax ([(flag ...) (reverse flags)])
#'#f))])) (syntax/loc stx
(let ([ht (make-hash-table flag ...)])
(hash-table-put! ht key val) ...
ht)))]
[_else (raise-syntax-error 'hash-table "bad syntax" stx)]))]))
;; This is a macro-generating macro that wants to expand (define-syntax (begin-with-definitions stx)
;; expressions used in the generated macro. So it's weird, ;; Body can have mixed exprs and defns. Wrap expressions with
;; and we put much of the work in a helper macro, ;; `(define-values () ... (values))' as needed, and add a (void)
;; `finish-syntax-set'. ;; at the end if needed.
(define-syntax (define-syntax-set stx) (let* ([def-ctx (syntax-local-make-definition-context)]
(syntax-case stx () [ctx (list (gensym 'intdef))]
[(_ (id ...) defn ...) [kernel-forms (kernel-form-identifier-list)]
(let ([ids (syntax->list (syntax (id ...)))]) [init-exprs (let ([v (syntax->list stx)])
;; Check ids ------------------------------ (unless v
(for-each (lambda (id) (raise-syntax-error #f "bad syntax" stx))
(unless (identifier? id) (cdr v))]
(raise-syntax-error [exprs (let loop ([exprs init-exprs])
#f (apply
"not an identifier or two identifier in parentheses" append
stx (map (lambda (expr)
id))) (let ([expr (local-expand expr ctx kernel-forms def-ctx)])
ids) (syntax-case expr (begin define-syntaxes define-values)
(let ([dup (check-duplicate-identifier ids)]) [(begin . rest)
(when dup (loop (syntax->list #'rest))]
(raise-syntax-error [(define-syntaxes (id ...) rhs)
#f (andmap identifier? (syntax->list #'(id ...)))
"duplicate identifier" (with-syntax ([rhs (local-transformer-expand
stx #'rhs
dup))) 'expression
null)])
(syntax-local-bind-syntaxes
(syntax->list #'(id ...))
#'rhs def-ctx)
(list #'(define-syntaxes (id ...) rhs)))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(let ([ids (syntax->list #'(id ...))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(list expr))]
[else
(list expr)])))
exprs)))])
(let loop ([exprs exprs]
[prev-stx-defns null]
[prev-defns null]
[prev-exprs null])
(cond
[(null? exprs)
#`(letrec-syntaxes+values
#,(map stx-cdr (reverse prev-stx-defns))
#,(map stx-cdr (reverse prev-defns))
#,@(if (null? prev-exprs)
(list #'(void))
(reverse prev-exprs)))]
[(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)]
[(and (stx-pair? (car exprs))
(identifier? (stx-car (car exprs)))
(module-identifier=? #'define-values (stx-car (car exprs))))
(loop (cdr exprs)
prev-stx-defns
(cons (car exprs)
(append
(map (lambda (expr)
#`(define-values () (begin #,expr (values))))
prev-exprs)
prev-defns))
null)]
[else (loop (cdr exprs)
prev-stx-defns
prev-defns
(cons (car exprs) prev-exprs))]))))
;; We'd like to check the `defns', but that requires (define-syntax (begin-lifted stx)
;; and expansion in a different phase. So we move (syntax-case stx ()
;; into that phase using `finish-syntax-set': [(_ expr0 expr ...)
(with-syntax ([orig-stx stx]) (let ([name (syntax-local-name)])
(syntax/loc stx (if name
(define-syntaxes (id ...) (with-syntax ([name name])
(finish-syntax-set orig-stx)))))]))
(define-syntax (hash-table stx)
(syntax-case stx (quote)
[(_ x ...)
(let loop ([xs #'(x ...)] [flags '()])
(syntax-case xs (quote)
[('flag x ...) (loop #'(x ...) (cons #''flag flags))]
[([key val] ...)
(with-syntax ([(flag ...) (reverse flags)])
(syntax/loc stx
(let ([ht (make-hash-table flag ...)])
(hash-table-put! ht key val) ...
ht)))]
[_else (raise-syntax-error 'hash-table "bad syntax" stx)]))]))
(define-syntax (begin-with-definitions stx)
;; Body can have mixed exprs and defns. Wrap expressions with
;; `(define-values () ... (values))' as needed, and add a (void)
;; at the end if needed.
(let* ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))]
[kernel-forms (kernel-form-identifier-list)]
[init-exprs (let ([v (syntax->list stx)])
(unless v
(raise-syntax-error #f "bad syntax" stx))
(cdr v))]
[exprs (let loop ([exprs init-exprs])
(apply
append
(map (lambda (expr)
(let ([expr (local-expand
expr
ctx
kernel-forms
def-ctx)])
(syntax-case expr (begin define-syntaxes define-values)
[(begin . rest)
(loop (syntax->list #'rest))]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(syntax-local-bind-syntaxes
(syntax->list #'(id ...))
#'rhs def-ctx)
(list #'(define-syntaxes (id ...) rhs)))]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
(let ([ids (syntax->list #'(id ...))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(list expr))]
[else
(list expr)])))
exprs)))])
(let loop ([exprs exprs]
[prev-stx-defns null]
[prev-defns null]
[prev-exprs null])
(cond
[(null? exprs)
#`(letrec-syntaxes+values
#,(map stx-cdr (reverse prev-stx-defns))
#,(map stx-cdr (reverse prev-defns))
#,@(if (null? prev-exprs)
(list #'(void))
(reverse prev-exprs)))]
[(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)]
[(and (stx-pair? (car exprs))
(identifier? (stx-car (car exprs)))
(module-identifier=? #'define-values (stx-car (car exprs))))
(loop (cdr exprs)
prev-stx-defns
(cons (car exprs)
(append
(map (lambda (expr)
#`(define-values () (begin #,expr (values))))
prev-exprs)
prev-defns))
null)]
[else (loop (cdr exprs)
prev-stx-defns
prev-defns
(cons (car exprs) prev-exprs))]))))
(define-syntax (begin-lifted stx)
(syntax-case stx ()
[(_ expr0 expr ...)
(let ([name (syntax-local-name)])
(if name
(with-syntax ([name name])
(syntax-local-lift-expression
#'(let ([name (begin expr0 expr ...)])
name)))
(syntax-local-lift-expression (syntax-local-lift-expression
#'(begin expr0 expr ...))))]))) #'(let ([name (begin expr0 expr ...)])
name)))
(syntax-local-lift-expression
#'(begin expr0 expr ...))))]))