From 3965eab9c88806ed2034bdf38fefcb410b5f1a6d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 11 May 2010 10:56:25 -0400 Subject: [PATCH] Add `racket/block' --- collects/mzlib/etc.rkt | 79 +----------------- collects/mzlib/scribblings/etc.scrbl | 14 +--- collects/racket/block.rkt | 90 +++++++++++++++++++++ collects/scribblings/reference/block.scrbl | 35 ++++++++ collects/scribblings/reference/syntax.scrbl | 2 + 5 files changed, 132 insertions(+), 88 deletions(-) create mode 100644 collects/racket/block.rkt create mode 100644 collects/scribblings/reference/block.scrbl diff --git a/collects/mzlib/etc.rkt b/collects/mzlib/etc.rkt index 9add9b9fdc..36941232c4 100644 --- a/collects/mzlib/etc.rkt +++ b/collects/mzlib/etc.rkt @@ -2,7 +2,8 @@ (require setup/main-collects racket/local - racket/bool + racket/bool + racket/block (only scheme/base build-string build-list @@ -46,7 +47,7 @@ hash-table - begin-with-definitions + (rename block begin-with-definitions) begin-lifted) @@ -349,80 +350,6 @@ 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)))]) - (internal-definition-context-seal def-ctx) - (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 ...) diff --git a/collects/mzlib/scribblings/etc.scrbl b/collects/mzlib/scribblings/etc.scrbl index dd0612a5df..5aba5d0244 100644 --- a/collects/mzlib/scribblings/etc.scrbl +++ b/collects/mzlib/scribblings/etc.scrbl @@ -5,6 +5,7 @@ scheme/bool scheme/local setup/dirs + racket/block (only-in scheme build-list build-string build-vector symbol=?))) @@ -54,20 +55,9 @@ binding's right-hand side. Other forms may redefine ``top level'' (using @scheme[local-expand/capture-lifts]) for the expressions that they enclose. - @defform[(begin-with-definitions defn-or-expr ...)]{ -Supports a mixture of expressions and mutually recursive definitions, -much like a @scheme[module] body. Unlike in a @scheme[module], -however, syntax definitions cannot be used to generate other immediate -definitions (though they can be used for expressions). - -The result of the @scheme[begin-with-definitions] form is the result -of the last @scheme[defn-or-expr] if it is an expression, -@|void-const| otherwise. If no @scheme[defn-or-expr] is provided -(after flattening @scheme[begin] forms), the result is @|void-const|.} - - +The same as @racket[(block defn-or-expr ...)].} @defform[(define-syntax-set (id ...) defn ...)]{ diff --git a/collects/racket/block.rkt b/collects/racket/block.rkt new file mode 100644 index 0000000000..ce53ee1813 --- /dev/null +++ b/collects/racket/block.rkt @@ -0,0 +1,90 @@ +(module block '#%kernel + (#%require "private/define.rkt" + "private/small-scheme.rkt" + "private/more-scheme.rkt" + (for-syntax '#%kernel + "private/stx.rkt" + "private/small-scheme.rkt" + "private/stxcase-scheme.rkt" + "private/name.rkt" + "private/norm-define.rkt" + "private/qqstx.rkt" + "private/sort.rkt")) + +(#%provide block) + +(define-syntax (block 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 (list #'begin #'define-syntaxes #'define-values) 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)))]) + (internal-definition-context-seal def-ctx) + (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))) + (free-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))) + (free-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))])))) + +) \ No newline at end of file diff --git a/collects/scribblings/reference/block.scrbl b/collects/scribblings/reference/block.scrbl new file mode 100644 index 0000000000..56c6209bae --- /dev/null +++ b/collects/scribblings/reference/block.scrbl @@ -0,0 +1,35 @@ +#lang scribble/doc +@(require "mz.ss" + scribble/eval + (for-label racket/block)) + +@(define ev (make-base-eval)) +@(ev '(require racket/block)) + +@title[#:tag "block"]{Blocks} + +@note-lib-only[racket/block] + +@defform[(block defn-or-expr ...)]{ + +Supports a mixture of expressions and mutually recursive definitions, +much like a @scheme[module] body. Unlike in a @scheme[module], +however, syntax definitions cannot be used to generate other immediate +definitions (though they can be used for expressions). + +The result of the @scheme[block] form is the result +of the last @scheme[defn-or-expr] if it is an expression, +@|void-const| otherwise. If no @scheme[defn-or-expr] is provided +(after flattening @scheme[begin] forms), the result is @|void-const|. + + +@examples[#:eval ev +(define (f x) + (block + (define y (add1 x)) + (displayln y) + (define z (* 2 y)) + (+ 3 z))) +(f 12) +]} + diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 884be10580..1ce4e9d77f 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -2418,6 +2418,8 @@ provides a hook to control interactive evaluation through @;------------------------------------------------------------------------ @include-section["package.scrbl"] +@;------------------------------------------------------------------------ +@include-section["block.scrbl"] @close-eval[require-eval] @close-eval[meta-in-eval]