#lang scheme
(require (for-syntax scheme/list scheme/match syntax/kerncase "syntax.ss"))
(provide
in-phase1 in-phase1/pass2
block
declare-names
define-renamings
define-single-definition
define-with-parameter
define-if-unbound
define-values-if-unbound
define-syntax-if-unbound
define-syntaxes-if-unbound)
(define-syntax-rule (define-with-parameter name parameter)
(define-syntax-rule (name value body (... ...))
(parameterize ([parameter value]) body (... ...))))
(define-syntax (#%definition stx0)
(syntax-case stx0 ()
[(_ form)
(let* ([stx (head-expand #'form)])
(syntax-case stx ( module
#%require
#%provide
define-values
define-syntaxes
define-values-for-syntax
begin )
[(module . _) stx]
[(#%require . _) stx]
[(#%provide . _) stx]
[(define-values . _) stx]
[(define-syntaxes . _) stx]
[(define-values-for-syntax . _) stx]
[(begin d ...) (syntax/loc stx0 (begin (#%definition d) ...))]
[_ (raise-syntax-error '#%definition "not a definition" stx0 stx)]))]))
(define-syntax (#%as-definition stx0)
(syntax-case stx0 ()
[(_ form)
(let* ([stx (head-expand #'form)])
(syntax-case stx ( module
#%require
#%provide
define-values
define-syntaxes
define-values-for-syntax
begin )
[(module . _) stx]
[(#%require . _) stx]
[(#%provide . _) stx]
[(define-values . _) stx]
[(define-syntaxes . _) stx]
[(define-values-for-syntax . _) stx]
[(begin d ...) (syntax/loc stx0 (begin (#%as-definition d) ...))]
[e
(syntax/loc stx0
(define-values [] (begin e (#%plain-app values))))]))]))
(define-syntax (#%as-expression stx0)
(syntax-case stx0 ()
[(_ form)
(let* ([stx (head-expand #'form)]
[done (quasisyntax/loc stx0 (begin #,stx (#%plain-app void)))])
(syntax-case stx ( module
#%require
#%provide
define-values
define-syntaxes
define-values-for-syntax
begin )
[(module . _) done]
[(#%require . _) done]
[(#%provide . _) done]
[(define-values . _) done]
[(define-syntaxes . _) done]
[(define-values-for-syntax . _) done]
[(begin) (syntax/loc stx0 (#%plain-app void))]
[(begin d ... e)
(syntax/loc stx0 (begin (#%as-definition d) ... (#%as-expression e)))]
[_ stx]))]))
(define-syntax-rule (block form ...)
(let-values () (#%as-expression (begin form ...))))
(define-syntax (declare-names stx)
(match (syntax-local-context)
['top-level
(syntax-case stx []
[(_ name ...) (syntax/loc stx (define-syntaxes [name ...] (values)))])]
[_ (syntax/loc stx (begin))]))
(define-syntax-rule (define-renamings [new old] ...)
(define-syntaxes [new ...] (values (make-rename-transformer #'old) ...)))
(define-syntax (in-phase1 stx)
(syntax-case stx []
[(_ e)
(match (syntax-local-context)
['expression (syntax/loc stx (let-syntax ([dummy e]) (void)))]
[(or 'module 'top-level (? pair?))
(syntax/loc stx
(begin
(define-syntax (macro stx*) (begin e (syntax/loc stx* (begin))))
(macro)))]
['module-begin (syntax-error stx "cannot be used as module body")])]))
(define-syntax (in-phase1/pass2 stx)
(syntax-case stx []
[(_ e)
(match (syntax-local-context)
[(? pair?)
(syntax/loc stx (define-values [] (begin (in-phase1 e) (values))))]
[(or 'expression 'top-level 'module 'module-begin)
(syntax/loc stx (#%expression (in-phase1 e)))])]))
(define-syntax-rule (define-single-definition define-one define-many)
(define-syntax define-one
(syntax-rules []
[(_ (head . args) . body) (define-one head (lambda args . body))]
[(_ name expr) (define-many [name] expr)])))
(define-syntax (define-many-if-unbound stx)
(syntax-case stx []
[(_ def [name ...] expr)
(let* ([ids (syntax->list #'(name ...))])
(for ([bad (in-list ids)] #:when (not (identifier? bad)))
(syntax-error bad "expected an identifier"))
(let*-values ([(bound unbound) (partition identifier-binding ids)])
(cond
[(null? bound) (syntax/loc stx (def [name ...] expr))]
[(null? unbound) (syntax/loc stx (def [] (values)))]
[else (syntax-error
stx
"conflicting definitions for ~s; none for ~s"
(map syntax-e bound)
(map syntax-e unbound))])))]))
(define-syntax-rule (define-values-if-unbound [name ...] expr)
(define-many-if-unbound define-values [name ...] expr))
(define-single-definition define-if-unbound define-values-if-unbound)
(define-syntax-rule (define-syntaxes-if-unbound [name ...] expr)
(define-many-if-unbound define-syntaxes [name ...] expr))
(define-single-definition define-syntax-if-unbound define-syntaxes-if-unbound)