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

Add `racket/block'

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-11 10:56:25 -04:00
parent 92a4106877
commit 3965eab9c8
5 changed files with 132 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
collects/mzlib/etc.rkt
View File

@ -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 ...)

14
collects/mzlib/scribblings/etc.scrbl
View File

@ -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 ...)]{

90
collects/racket/block.rkt Normal file
View File

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

35
collects/scribblings/reference/block.scrbl Normal file
View File

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

2
collects/scribblings/reference/syntax.scrbl
View File

@ -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]