diff --git a/collects/scheme/local.ss b/collects/scheme/local.ss index cb037855e0..88bd7fff69 100644 --- a/collects/scheme/local.ss +++ b/collects/scheme/local.ss @@ -1,66 +1,7 @@ #lang scheme/base - -(require (for-syntax scheme/base - syntax/context - syntax/kerncase)) - +(require (for-syntax scheme/base) + "private/local.ss") (provide local) (define-syntax (local stx) - (syntax-case stx () - [(_ (defn ...) body1 body ...) - (let ([defs (let ([expand-context (generate-expand-context)]) - (let loop ([defns (syntax->list (syntax (defn ...)))]) - (apply - append - (map - (lambda (defn) - (let ([d (local-expand - defn - expand-context - (kernel-form-identifier-list))] - [check-ids (lambda (ids) - (for-each - (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "not an identifier for definition" - stx - id))) - ids))]) - (syntax-case d (define-values define-syntaxes begin) - [(begin defn ...) - (loop (syntax->list (syntax (defn ...))))] - [(define-values (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-values . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [(define-syntaxes (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-syntaxes . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [_else - (raise-syntax-error - #f "not a definition" stx defn)]))) - defns))))]) - (let ([ids (apply append - (map - (lambda (d) - (syntax-case d () - [(_ ids . __) (syntax->list (syntax ids))])) - defs))]) - (let ([dup (check-duplicate-identifier ids)]) - (when dup - (raise-syntax-error #f "duplicate identifier" stx dup))) - (with-syntax ([(def ...) defs]) - (syntax/loc stx - (let () def ... (let () body1 body ...))))))] - [(_ x body1 body ...) - (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) + (do-local stx #'letrec-syntaxes+values)) diff --git a/collects/scheme/private/local.ss b/collects/scheme/private/local.ss new file mode 100644 index 0000000000..7c0c27fbef --- /dev/null +++ b/collects/scheme/private/local.ss @@ -0,0 +1,81 @@ +#lang scheme/base +(require (for-syntax scheme/base) + (for-syntax syntax/context) + (for-syntax syntax/kerncase)) +(provide (for-syntax do-local)) + +(define-for-syntax (do-local stx letrec-syntaxes+values-id) + (syntax-case stx () + [(_ (defn ...) body1 body ...) + (let ([defs (let ([expand-context (generate-expand-context)]) + (let loop ([defns (syntax->list (syntax (defn ...)))]) + (apply + append + (map + (lambda (defn) + (let ([d (local-expand + defn + expand-context + (kernel-form-identifier-list))] + [check-ids (lambda (ids) + (for-each + (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "not an identifier for definition" + stx + id))) + ids))]) + (syntax-case d (define-values define-syntaxes begin) + [(begin defn ...) + (loop (syntax->list (syntax (defn ...))))] + [(define-values (id ...) body) + (begin + (check-ids (syntax->list (syntax (id ...)))) + (list d))] + [(define-values . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [(define-syntaxes (id ...) body) + (begin + (check-ids (syntax->list (syntax (id ...)))) + (list d))] + [(define-syntaxes . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [_else + (raise-syntax-error + #f "not a definition" stx defn)]))) + defns))))]) + (let ([ids (apply append + (map + (lambda (d) + (syntax-case d () + [(_ ids . __) (syntax->list (syntax ids))])) + defs))] + [vbindings (apply append + (map (lambda (d) + (syntax-case d (define-values) + [(define-values ids rhs) + (list #'(ids rhs))] + [_ null])) + defs))] + [sbindings (apply append + (map (lambda (d) + (syntax-case d (define-syntaxes) + [(define-syntaxes ids rhs) + (list #'(ids rhs))] + [_ null])) + defs))]) + (let ([dup (check-duplicate-identifier ids)]) + (when dup + (raise-syntax-error #f "duplicate identifier" stx dup))) + (with-syntax ([sbindings sbindings] + [vbindings vbindings] + [LSV letrec-syntaxes+values-id]) + (syntax/loc stx + (LSV sbindings vbindings + body1 body ...)))))] + [(_ x body1 body ...) + (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index d0ad785a61..da675688ac 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -2,7 +2,8 @@ (require (for-syntax scheme/base syntax/kerncase) "stxparam.ss" - "private/stxparam.ss") + "private/stxparam.ss" + "private/local.ss") (provide splicing-let-syntax splicing-let-syntaxes @@ -12,45 +13,43 @@ splicing-let-values splicing-letrec splicing-letrec-values + splicing-letrec-syntaxes+values + splicing-local splicing-syntax-parameterize) +(define-for-syntax ((check-id stx) id-stx) + (unless (identifier? id-stx) + (raise-syntax-error #f "expected an identifier" stx id-stx)) + (list id-stx)) + +(define-for-syntax ((check-ids stx) ids-stx) + (let ([ids (syntax->list ids-stx)]) + (unless ids + (raise-syntax-error + #f + "expected a parenthesized sequence of identifiers" + stx + ids-stx)) + (for-each (check-id stx) ids) + ids)) + +(define-for-syntax (check-dup-binding stx idss) + (let ([dup-id (check-duplicate-identifier (apply append idss))]) + (when dup-id + (raise-syntax-error #f "duplicate binding" stx dup-id)))) + (define-for-syntax (do-let-syntax stx rec? multi? let-id def-id need-top-decl?) (syntax-case stx () [(_ ([ids expr] ...) body ...) - (let ([all-ids (map (lambda (ids-stx) - (let ([ids (if multi? - (syntax->list ids-stx) - (list ids-stx))]) - (unless ids - (raise-syntax-error - #f - "expected a parenthesized sequence of identifiers" - stx - ids-stx)) - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "expected an identifier" - stx - id))) - ids) - ids)) + (let ([all-ids (map ((if multi? check-ids check-id) stx) (syntax->list #'(ids ...)))]) - (let ([dup-id (check-duplicate-identifier - (apply append all-ids))]) - (when dup-id - (raise-syntax-error - #f - "duplicate binding" - stx - dup-id))) + (check-dup-binding stx all-ids) (if (eq? 'expression (syntax-local-context)) (with-syntax ([LET let-id]) (syntax/loc stx (LET ([ids expr] ...) - (#%expression body) - ...))) + (#%expression body) + ...))) (let ([def-ctx (syntax-local-make-definition-context)] [ctx (list (gensym 'intdef))]) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) @@ -111,6 +110,62 @@ ;; ---------------------------------------- +(define-syntax (splicing-letrec-syntaxes+values stx) + (syntax-case stx () + [(_ ([sids sexpr] ...) ([vids vexpr] ...) body ...) + (let* ([all-sids (map (check-ids stx) + (syntax->list #'(sids ...)))] + [all-vids (map (check-ids stx) + (syntax->list #'(vids ...)))] + [all-ids (append all-sids all-vids)]) + (check-dup-binding stx all-ids) + (if (eq? 'expression (syntax-local-context)) + (syntax/loc stx + (letrec-syntaxes+values ([sids sexpr] ...) ([vids vexpr] ...) + (#%expression body) ...)) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (list (gensym 'intdef))]) + (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (internal-definition-context-seal def-ctx) + (let* ([add-context + (lambda (expr) + (let ([q (local-expand #`(quote #,expr) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ expr) #'expr])))] + [add-context-to-idss + (lambda (idss) + (map add-context idss))]) + (with-syntax ([((sid ...) ...) + (map add-context-to-idss all-sids)] + [((vid ...) ...) + (map add-context-to-idss all-vids)] + [(sexpr ...) + (map add-context (syntax->list #'(sexpr ...)))] + [(vexpr ...) + (map add-context (syntax->list #'(vexpr ...)))] + [(body ...) + (map add-context (syntax->list #'(body ...)))]) + (with-syntax ([top-decl + (if (equal? 'top-level (syntax-local-context)) + #'(define-syntaxes (vid ... ...) (values)) + #'(begin))]) + (syntax/loc stx + (begin + top-decl + (define-syntaxes (sid ...) sexpr) ... + (define-values (vid ...) vexpr) ... + body ...))))))))])) + + + +(define-syntax (splicing-local stx) + (do-local stx #'splicing-letrec-syntaxes+values)) + +;; ---------------------------------------- + (define-syntax (splicing-syntax-parameterize stx) (if (eq? 'expression (syntax-local-context)) ;; Splicing is no help in an expression context: diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index 432281dbc3..c9f7b6a1ad 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1249,7 +1249,77 @@ x))) exn:fail:contract:variable?) +(test 82 'splicing-letrec-syntaxes+values + (let () + (define q 77) + (splicing-letrec-syntaxes+values + ([(mx) (lambda (stx) (quote-syntax (x)))] + [(m) (lambda (stx) (quote-syntax (mx)))]) + ([(x) (lambda () (q))] + [(q) (lambda () 82)]) + (define (a) (m))) + (a))) + +(test 82 'splicing-letrec-syntaxes+values + (eval + '(begin + (define q 77) + (splicing-letrec-syntaxes+values + ([(mx) (lambda (stx) (quote-syntax (x)))] + [(m) (lambda (stx) (quote-syntax (mx)))]) + ([(x) (lambda () (q))] + [(q) (lambda () 82)]) + (define (a) (m))) + (a)))) + +(test 82 'splicing-local + (let () + (define (x) q) + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (mx))) + (define (x) (q)) + (define-syntax (mx stx) (quote-syntax (x))) + (define (q) 82)] + (define (a) (m))) + (a))) + +(test 82 'splicing-local + (eval + '(begin + (define (x) q) + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (mx))) + (define (x) (q)) + (define-syntax (mx stx) (quote-syntax (x))) + (define (q) 82)] + (define (a) (m))) + (a)))) + +;; local names are not visible outside +(test 77 'splicing-local + (let () + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (q))) + (define (q) 82)] + (define (a) (m))) + (m))) +(test 77 'splicing-local + (eval + '(begin + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (q))) + (define (q) 82)] + (define (a) (m))) + (m)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) -