89 lines
3.6 KiB
Racket
89 lines
3.6 KiB
Racket
(module block '#%kernel
|
|
(#%require "private/define.rkt"
|
|
(for-syntax '#%kernel
|
|
"private/stx.rkt"
|
|
"private/small-scheme.rkt"
|
|
"private/stxcase-scheme.rkt"
|
|
"private/qqstx.rkt"))
|
|
|
|
(#%provide block)
|
|
|
|
(define-values-for-syntax (make-context)
|
|
(let-values ([(struct: mk ? ref set)
|
|
(make-struct-type 'in-liberal-define-context #f 0 0 #f
|
|
(list (cons prop:liberal-define-context #t)))])
|
|
mk))
|
|
|
|
(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 (make-context))]
|
|
;; [kernel-forms (kernel-form-identifier-list)]
|
|
[stoplist (list #'begin #'define-syntaxes #'define-values)]
|
|
[init-exprs (let ([v (syntax->list stx)])
|
|
(unless v (raise-syntax-error #f "bad syntax" stx))
|
|
(cdr v))]
|
|
[exprs
|
|
(let loop ([todo init-exprs] [r '()])
|
|
(if (null? todo)
|
|
(reverse r)
|
|
(let ([expr (local-expand (car todo) ctx stoplist def-ctx)]
|
|
[todo (cdr todo)])
|
|
(syntax-case expr (begin define-syntaxes define-values)
|
|
[(begin . rest)
|
|
(loop (append (syntax->list #'rest) todo) r)]
|
|
[(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)
|
|
(loop todo (cons #'(define-syntaxes (id ...) rhs) r)))]
|
|
[(define-values (id ...) rhs)
|
|
(andmap identifier? (syntax->list #'(id ...)))
|
|
(let ([ids (syntax->list #'(id ...))])
|
|
(syntax-local-bind-syntaxes ids #f def-ctx)
|
|
(loop todo (cons expr r)))]
|
|
[else (loop todo (cons expr r))]))))])
|
|
(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))]))))
|
|
|
|
)
|