reformatted
svn: r4916
This commit is contained in:
Eli Barzilay
parent
404fad489d
commit
11debcdcdc
|
|
@ -4,52 +4,52 @@
|
|||
(require (lib "main-collects.ss" "setup"))
|
||||
|
||||
(require-for-syntax (lib "kerncase.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax")
|
||||
(lib "context.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax")
|
||||
(lib "context.ss" "syntax")
|
||||
(lib "main-collects.ss" "setup")
|
||||
"private/stxset.ss")
|
||||
|
||||
|
||||
(provide true false
|
||||
boolean=? symbol=?
|
||||
identity
|
||||
compose
|
||||
|
||||
build-string
|
||||
build-vector
|
||||
build-list
|
||||
|
||||
loop-until
|
||||
|
||||
opt-lambda
|
||||
|
||||
local
|
||||
recur
|
||||
rec
|
||||
evcase
|
||||
nor
|
||||
nand
|
||||
let+
|
||||
|
||||
namespace-defined?
|
||||
this-expression-source-directory
|
||||
(provide true false
|
||||
boolean=? symbol=?
|
||||
identity
|
||||
compose
|
||||
|
||||
build-string
|
||||
build-vector
|
||||
build-list
|
||||
|
||||
loop-until
|
||||
|
||||
opt-lambda
|
||||
|
||||
local
|
||||
recur
|
||||
rec
|
||||
evcase
|
||||
nor
|
||||
nand
|
||||
let+
|
||||
|
||||
namespace-defined?
|
||||
this-expression-source-directory
|
||||
this-expression-file-name
|
||||
define-syntax-set
|
||||
|
||||
define-syntax-set
|
||||
|
||||
hash-table
|
||||
|
||||
begin-with-definitions
|
||||
begin-with-definitions
|
||||
|
||||
begin-lifted)
|
||||
|
||||
begin-lifted)
|
||||
|
||||
(define true #t)
|
||||
(define false #f)
|
||||
|
||||
|
||||
(define identity (lambda (x) x))
|
||||
|
||||
|
||||
(define compose
|
||||
(case-lambda
|
||||
(case-lambda
|
||||
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
|
||||
[(f g)
|
||||
(let ([f (compose f)]
|
||||
|
|
@ -188,7 +188,7 @@
|
|||
(let ([d (local-expand
|
||||
defn
|
||||
expand-context
|
||||
(kernel-form-identifier-list
|
||||
(kernel-form-identifier-list
|
||||
(quote-syntax here)))]
|
||||
[check-ids (lambda (ids)
|
||||
(for-each
|
||||
|
|
@ -240,7 +240,7 @@
|
|||
(define-syntax (recur stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest) (syntax/loc stx (let . rest))]))
|
||||
|
||||
|
||||
;; define a recursive value
|
||||
;; implementation by Jens Axel Soegaard
|
||||
(define-syntax (rec stx)
|
||||
|
|
@ -261,180 +261,186 @@
|
|||
(raise-syntax-error
|
||||
#f "expects either a variable followed by an expresion, or a (possibly dotted) sequence of variables followed by a body" stx)]))
|
||||
|
||||
(define-syntax (evcase stx)
|
||||
(syntax-case stx ()
|
||||
[(_ val [test body ...] ...)
|
||||
(let ([tests (syntax->list (syntax (test ...)))])
|
||||
(with-syntax ([(a-test ...)
|
||||
(map (lambda (t)
|
||||
(syntax-case t (else)
|
||||
[else (syntax #t)]
|
||||
[_else (with-syntax ([t t])
|
||||
(syntax (eqv? evcase-v t)))]))
|
||||
tests)])
|
||||
;; Make sure else is last:
|
||||
(unless (null? tests)
|
||||
(let loop ([tests tests])
|
||||
(unless (null? (cdr tests))
|
||||
(when (and (identifier? (car tests))
|
||||
(module-identifier=? (quote-syntax else) (car tests)))
|
||||
(raise-syntax-error
|
||||
#f "else is not in last clause" stx (car tests)))
|
||||
(loop (cdr tests)))))
|
||||
(syntax/loc stx
|
||||
(let ([evcase-v val])
|
||||
(cond [a-test (begin body ...)]
|
||||
...)))))]
|
||||
[(_ val something ...)
|
||||
;; Provide a good error message:
|
||||
(for-each
|
||||
(lambda (s)
|
||||
(syntax-case s ()
|
||||
[(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
|
||||
(syntax->list (syntax (something ...))))]))
|
||||
|
||||
(define-syntax (nor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
|
||||
|
||||
(define-syntax (nand stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
|
||||
|
||||
(define-syntax (let+ stx)
|
||||
(syntax-case stx ()
|
||||
[(_ [clause ...] body1 body ...)
|
||||
(let ([clauses (syntax->list (syntax (clause ...)))]
|
||||
[bad (lambda (c n)
|
||||
(define-syntax (evcase stx)
|
||||
(syntax-case stx ()
|
||||
[(_ val [test body ...] ...)
|
||||
(let ([tests (syntax->list (syntax (test ...)))])
|
||||
(with-syntax ([(a-test ...)
|
||||
(map (lambda (t)
|
||||
(syntax-case t (else)
|
||||
[else (syntax #t)]
|
||||
[_else (with-syntax ([t t])
|
||||
(syntax (eqv? evcase-v t)))]))
|
||||
tests)])
|
||||
;; Make sure else is last:
|
||||
(unless (null? tests)
|
||||
(let loop ([tests tests])
|
||||
(unless (null? (cdr tests))
|
||||
(when (and (identifier? (car tests))
|
||||
(module-identifier=? (quote-syntax else)
|
||||
(car tests)))
|
||||
(raise-syntax-error
|
||||
#f (format "illegal use of ~a for a clause" n) stx c))]
|
||||
[var? (lambda (x)
|
||||
(or (identifier? x)
|
||||
(let ([l (syntax->list x)])
|
||||
(and l
|
||||
(pair? l)
|
||||
(eq? (syntax-e (car l)) 'values)
|
||||
(andmap identifier? (cdr l))))))]
|
||||
[normal-var (lambda (x)
|
||||
(if (identifier? x)
|
||||
(list x)
|
||||
(cdr (syntax-e x))))])
|
||||
;; syntax checks
|
||||
(for-each
|
||||
(lambda (clause)
|
||||
(syntax-case* clause (val rec vals recs _)
|
||||
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
|
||||
[(val var expr)
|
||||
(var? (syntax var))
|
||||
'ok]
|
||||
[(rec var expr)
|
||||
(var? (syntax var))
|
||||
'ok]
|
||||
[(vals (var expr) ...)
|
||||
(andmap var? (syntax->list (syntax (var ...))))
|
||||
'ok]
|
||||
[(recs (var expr) ...)
|
||||
(andmap var? (syntax->list (syntax (var ...))))
|
||||
'ok]
|
||||
[(_ expr0 expr ...)
|
||||
'ok]
|
||||
[(val . __) (bad clause "val")]
|
||||
[(rec . __) (bad clause "rec")]
|
||||
[(vals . __) (bad clause "vals")]
|
||||
[(recs . __) (bad clause"recs")]
|
||||
[(_ . __) (bad clause "_")]
|
||||
[_else (raise-syntax-error #f "bad clause" stx clause)]))
|
||||
clauses)
|
||||
;; result
|
||||
(let loop ([clauses clauses])
|
||||
(if (null? clauses)
|
||||
(syntax (let () body1 body ...))
|
||||
(with-syntax ([rest (loop (cdr clauses))])
|
||||
(syntax-case* (car clauses) (val rec vals recs _)
|
||||
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
|
||||
[(val var expr)
|
||||
(with-syntax ([vars (normal-var (syntax var))])
|
||||
(syntax (let-values ([vars expr]) rest)))]
|
||||
[(rec var expr)
|
||||
(with-syntax ([vars (normal-var (syntax var))])
|
||||
(syntax (letrec-values ([vars expr]) rest)))]
|
||||
[(vals (var expr) ...)
|
||||
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
|
||||
(syntax (let-values ([vars expr] ...) rest)))]
|
||||
[(recs (var expr) ...)
|
||||
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
|
||||
(syntax (letrec-values ([vars expr] ...) rest)))]
|
||||
[(_ expr0 expr ...)
|
||||
(syntax (begin expr0 expr ... rest))])))))]))
|
||||
#f "else is not in last clause" stx (car tests)))
|
||||
(loop (cdr tests)))))
|
||||
(syntax/loc stx
|
||||
(let ([evcase-v val])
|
||||
(cond [a-test (begin body ...)]
|
||||
...)))))]
|
||||
[(_ val something ...)
|
||||
;; Provide a good error message:
|
||||
(for-each
|
||||
(lambda (s)
|
||||
(syntax-case s ()
|
||||
[(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
|
||||
(syntax->list (syntax (something ...))))]))
|
||||
|
||||
(define ns-undefined (gensym))
|
||||
(define-syntax (nor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
|
||||
|
||||
(define (namespace-defined? n)
|
||||
(unless (symbol? n)
|
||||
(raise-type-error 'namespace-defined? "symbol" n))
|
||||
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
|
||||
ns-undefined)))
|
||||
(define-syntax (nand stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
|
||||
|
||||
(define-syntax (this-expression-source-directory stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(let* ([source (syntax-source stx)]
|
||||
[source (and (path? source) source)]
|
||||
[local (or (current-load-relative-directory) (current-directory))]
|
||||
[dir (path->main-collects-relative
|
||||
(or (and source (file-exists? source)
|
||||
(let-values ([(base file dir?) (split-path source)])
|
||||
(and (path? base)
|
||||
(path->complete-path base local))))
|
||||
local))])
|
||||
(if (and (pair? dir) (eq? 'collects (car dir)))
|
||||
(with-syntax ([d dir])
|
||||
#'(main-collects-relative->path 'd))
|
||||
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
|
||||
#'(bytes->path d))))]))
|
||||
(define-syntax (let+ stx)
|
||||
(syntax-case stx ()
|
||||
[(_ [clause ...] body1 body ...)
|
||||
(let ([clauses (syntax->list (syntax (clause ...)))]
|
||||
[bad (lambda (c n)
|
||||
(raise-syntax-error
|
||||
#f (format "illegal use of ~a for a clause" n) stx c))]
|
||||
[var? (lambda (x)
|
||||
(or (identifier? x)
|
||||
(let ([l (syntax->list x)])
|
||||
(and l
|
||||
(pair? l)
|
||||
(eq? (syntax-e (car l)) 'values)
|
||||
(andmap identifier? (cdr l))))))]
|
||||
[normal-var (lambda (x)
|
||||
(if (identifier? x)
|
||||
(list x)
|
||||
(cdr (syntax-e x))))])
|
||||
;; syntax checks
|
||||
(for-each
|
||||
(lambda (clause)
|
||||
(syntax-case* clause (val rec vals recs _)
|
||||
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
|
||||
[(val var expr)
|
||||
(var? (syntax var))
|
||||
'ok]
|
||||
[(rec var expr)
|
||||
(var? (syntax var))
|
||||
'ok]
|
||||
[(vals (var expr) ...)
|
||||
(andmap var? (syntax->list (syntax (var ...))))
|
||||
'ok]
|
||||
[(recs (var expr) ...)
|
||||
(andmap var? (syntax->list (syntax (var ...))))
|
||||
'ok]
|
||||
[(_ expr0 expr ...)
|
||||
'ok]
|
||||
[(val . __) (bad clause "val")]
|
||||
[(rec . __) (bad clause "rec")]
|
||||
[(vals . __) (bad clause "vals")]
|
||||
[(recs . __) (bad clause"recs")]
|
||||
[(_ . __) (bad clause "_")]
|
||||
[_else (raise-syntax-error #f "bad clause" stx clause)]))
|
||||
clauses)
|
||||
;; result
|
||||
(let loop ([clauses clauses])
|
||||
(if (null? clauses)
|
||||
(syntax (let () body1 body ...))
|
||||
(with-syntax ([rest (loop (cdr clauses))])
|
||||
(syntax-case* (car clauses) (val rec vals recs _)
|
||||
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
|
||||
[(val var expr)
|
||||
(with-syntax ([vars (normal-var (syntax var))])
|
||||
(syntax (let-values ([vars expr]) rest)))]
|
||||
[(rec var expr)
|
||||
(with-syntax ([vars (normal-var (syntax var))])
|
||||
(syntax (letrec-values ([vars expr]) rest)))]
|
||||
[(vals (var expr) ...)
|
||||
(with-syntax ([(vars ...)
|
||||
(map normal-var
|
||||
(syntax->list (syntax (var ...))))])
|
||||
(syntax (let-values ([vars expr] ...) rest)))]
|
||||
[(recs (var expr) ...)
|
||||
(with-syntax ([(vars ...)
|
||||
(map normal-var
|
||||
(syntax->list (syntax (var ...))))])
|
||||
(syntax (letrec-values ([vars expr] ...) rest)))]
|
||||
[(_ expr0 expr ...)
|
||||
(syntax (begin expr0 expr ... rest))])))))]))
|
||||
|
||||
(define-syntax (this-expression-file-name stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(let* ([f (syntax-source stx)]
|
||||
[f (and f (path? f) (file-exists? f)
|
||||
(let-values ([(base file dir?) (split-path f)]) file))])
|
||||
(if f
|
||||
(with-syntax ([f (path->bytes f)]) #'(bytes->path f))
|
||||
#'#f))]))
|
||||
(define ns-undefined (gensym))
|
||||
|
||||
;; This is a macro-generating macro that wants to expand
|
||||
;; expressions used in the generated macro. So it's weird,
|
||||
;; and we put much of the work in a helper macro,
|
||||
;; `finish-syntax-set'.
|
||||
(define-syntax (define-syntax-set stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) defn ...)
|
||||
(let ([ids (syntax->list (syntax (id ...)))])
|
||||
;; Check ids ------------------------------
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier or two identifier in parentheses"
|
||||
stx
|
||||
id)))
|
||||
ids)
|
||||
(let ([dup (check-duplicate-identifier ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
dup)))
|
||||
(define (namespace-defined? n)
|
||||
(unless (symbol? n)
|
||||
(raise-type-error 'namespace-defined? "symbol" n))
|
||||
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
|
||||
ns-undefined)))
|
||||
|
||||
;; We'd like to check the `defns', but that requires
|
||||
;; and expansion in a different phase. So we move
|
||||
;; into that phase using `finish-syntax-set':
|
||||
(with-syntax ([orig-stx stx])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (id ...)
|
||||
(finish-syntax-set orig-stx)))))]))
|
||||
(define-syntax (this-expression-source-directory stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(let* ([source (syntax-source stx)]
|
||||
[source (and (path? source) source)]
|
||||
[local (or (current-load-relative-directory) (current-directory))]
|
||||
[dir (path->main-collects-relative
|
||||
(or (and source (file-exists? source)
|
||||
(let-values ([(base file dir?)
|
||||
(split-path source)])
|
||||
(and (path? base)
|
||||
(path->complete-path base local))))
|
||||
local))])
|
||||
(if (and (pair? dir) (eq? 'collects (car dir)))
|
||||
(with-syntax ([d dir])
|
||||
#'(main-collects-relative->path 'd))
|
||||
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
|
||||
#'(bytes->path d))))]))
|
||||
|
||||
(define-syntax (this-expression-file-name stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(let* ([f (syntax-source stx)]
|
||||
[f (and f (path? f) (file-exists? f)
|
||||
(let-values ([(base file dir?) (split-path f)]) file))])
|
||||
(if f
|
||||
(with-syntax ([f (path->bytes f)]) #'(bytes->path f))
|
||||
#'#f))]))
|
||||
|
||||
;; This is a macro-generating macro that wants to expand
|
||||
;; expressions used in the generated macro. So it's weird,
|
||||
;; and we put much of the work in a helper macro,
|
||||
;; `finish-syntax-set'.
|
||||
(define-syntax (define-syntax-set stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) defn ...)
|
||||
(let ([ids (syntax->list (syntax (id ...)))])
|
||||
;; Check ids ------------------------------
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier or two identifier in parentheses"
|
||||
stx
|
||||
id)))
|
||||
ids)
|
||||
(let ([dup (check-duplicate-identifier ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
dup)))
|
||||
|
||||
;; We'd like to check the `defns', but that requires
|
||||
;; and expansion in a different phase. So we move
|
||||
;; into that phase using `finish-syntax-set':
|
||||
(with-syntax ([orig-stx stx])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (id ...)
|
||||
(finish-syntax-set orig-stx)))))]))
|
||||
|
||||
(define-syntax (hash-table stx)
|
||||
(syntax-case stx (quote)
|
||||
|
|
@ -455,77 +461,87 @@
|
|||
;; `(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
|
||||
(quote-syntax here))]
|
||||
[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)))])
|
||||
(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))]))))
|
||||
[ctx (list (gensym 'intdef))]
|
||||
[kernel-forms (kernel-form-identifier-list
|
||||
(quote-syntax here))]
|
||||
[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)))])
|
||||
(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 ...)
|
||||
(let ([name (syntax-local-name)])
|
||||
(if name
|
||||
(with-syntax ([name name])
|
||||
(syntax-local-lift-expression
|
||||
#'(let ([name (begin expr0 expr ...)])
|
||||
name)))
|
||||
(syntax-local-lift-expression
|
||||
#'(begin expr0 expr ...))))])))
|
||||
(if name
|
||||
(with-syntax ([name name])
|
||||
(syntax-local-lift-expression
|
||||
#'(let ([name (begin expr0 expr ...)])
|
||||
name)))
|
||||
(syntax-local-lift-expression
|
||||
#'(begin expr0 expr ...))))])))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user