Add `racket/block'

collects/mzlib/etc.rkt

@@ -3,6 +3,7 @@
 (require setup/main-collects
          racket/local
          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 ...)

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,
+The same as @racket[(block defn-or-expr ...)].}
-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|.}
-
-
 
 @defform[(define-syntax-set (id ...) defn ...)]{
 

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))]))))
+
+)

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)
+]}
+

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]