diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 8abb437..c05767d 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -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") - scheme/local - scheme/bool - (only scheme/base - build-string - build-list - build-vector - compose) - "kw.ss") +(require-for-syntax syntax/kerncase + syntax/stx + syntax/name + (lib "main-collects.ss" "setup") + "private/stxset.ss") - (require-for-syntax syntax/kerncase - syntax/stx - syntax/name - (lib "main-collects.ss" "setup") - "private/stxset.ss") +(provide boolean=? symbol=? + identity + compose - (provide boolean=? symbol=? - identity - compose + true false - true false + build-string + build-vector + build-list - build-string - build-vector - build-list + loop-until - loop-until + opt-lambda - opt-lambda + local + recur + rec + evcase + nor + nand + let+ - local - recur - rec - evcase - nor - nand - let+ + namespace-defined? + this-expression-source-directory + this-expression-file-name + define-syntax-set - namespace-defined? - this-expression-source-directory - this-expression-file-name - define-syntax-set + hash-table - 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) - (let loop ([i start]) - (unless (done? i) - (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) +(define-syntax (opt-lambda stx) + (with-syntax ([name (or (syntax-local-infer-name stx) + (quote-syntax opt-lambda-proc))]) (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))))) + [(_ 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 - (let ([evcase-v val]) - (cond [a-test (begin body ...)] - ...)))))] - [(_ val something ...) - ;; Provide a good error message: + (letrec ([name (case-lambda . clauses)]) name))))]))) + +;; recur is another name for 'let' in a named let +(define-syntax (recur stx) + (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 - (lambda (s) - (syntax-case s () - [(t a ...) (raise-syntax-error #f "invalid clause" stx s)])) - (syntax->list (syntax (something ...))))])) + (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-syntax (nor stx) - (syntax-case stx () - [(_ expr ...) (syntax/loc stx (not (or expr ...)))])) +(define ns-undefined (gensym)) - (define-syntax (nand stx) - (syntax-case stx () - [(_ expr ...) (syntax/loc stx (not (and expr ...)))])) +(define (namespace-defined? n) + (unless (symbol? n) + (raise-type-error 'namespace-defined? "symbol" n)) + (not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) + ns-undefined))) - (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 - (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 (extract-module-directory stx) + (let ([srcmod (let ([mpi (syntax-source-module stx)]) + (if (module-path-index? mpi) + (module-path-index-resolve mpi) + mpi))]) + (let ([name (resolved-module-path-name srcmod)]) + (and (path? name) + (let-values ([(base name dir?) (split-path name)]) + (and (path? base) + base)))))) - (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) - (unless (symbol? n) - (raise-type-error 'namespace-defined? "symbol" n)) - (not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) - ns-undefined))) +(define-syntax (this-expression-file-name stx) + (syntax-case stx () + [(_) + (let* ([f (syntax-source stx)] + [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) - (let ([srcmod (let ([mpi (syntax-source-module stx)]) - (if (module-path-index? mpi) - (module-path-index-resolve mpi) - mpi))]) - (let ([name (resolved-module-path-name srcmod)]) - (and (path? name) - (let-values ([(base name dir?) (split-path name)]) - (and (path? base) - base)))))) +;; This is a macro-generating macro that wants to expand +;; expressions used in the generated macro. So it's weird, +;; and we put much of the work in a helper macro, +;; `finish-syntax-set'. +(define-syntax (define-syntax-set stx) + (syntax-case stx () + [(_ (id ...) defn ...) + (let ([ids (syntax->list (syntax (id ...)))]) + ;; Check ids ------------------------------ + (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) - (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)))])) + ;; We'd like to check the `defns', but that requires + ;; and expansion in a different phase. So we move + ;; into that phase using `finish-syntax-set': + (with-syntax ([orig-stx stx]) + (syntax/loc stx + (define-syntaxes (id ...) + (finish-syntax-set orig-stx)))))])) - (define-syntax (this-expression-file-name stx) - (syntax-case stx () - [(_) - (let* ([f (syntax-source stx)] - [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-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)]))])) - ;; This is a macro-generating macro that wants to expand - ;; expressions used in the generated macro. So it's weird, - ;; and we put much of the work in a helper macro, - ;; `finish-syntax-set'. - (define-syntax (define-syntax-set stx) - (syntax-case stx () - [(_ (id ...) defn ...) - (let ([ids (syntax->list (syntax (id ...)))]) - ;; Check ids ------------------------------ - (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 (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))])))) - ;; We'd like to check the `defns', but that requires - ;; and expansion in a different phase. So we move - ;; into that phase using `finish-syntax-set': - (with-syntax ([orig-stx stx]) - (syntax/loc stx - (define-syntaxes (id ...) - (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))) +(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 - #'(begin expr0 expr ...))))]))) + #'(let ([name (begin expr0 expr ...)]) + name))) + (syntax-local-lift-expression + #'(begin expr0 expr ...))))]))