c28d032620
Some tests failed after commit 6e80609998, which adjusted the macro system's handling of use-site scopes so that they're preserved by `quote-syntax`. Those scopes get in the way of the test, which is using macros to juggle syntax objects that include pieces used as bindings via `eval`.
390 lines
10 KiB
Racket
390 lines
10 KiB
Racket
#lang racket/load
|
|
(require rackunit
|
|
racket/package
|
|
syntax/strip-context
|
|
(for-syntax racket/base))
|
|
|
|
(define-syntax test
|
|
(syntax-rules ()
|
|
[(_ #t p? args ...) (check-true (p? args ...))]
|
|
[(_ #f p? args ...) (check-false (p? args ...))]
|
|
[(_ e n args ...) (if (procedure? n)
|
|
(check-equal? e (n args ...))
|
|
(check-equal? e args ...))]))
|
|
|
|
(define-syntax err/rt-test
|
|
(syntax-rules ()
|
|
[(_ e) (check-exn exn:fail? (λ () e))]
|
|
[(_ e ty?) (check-exn ty? (λ () e))]))
|
|
|
|
;; Need to remove use-site scopes on syntax objects
|
|
;; that we're going to pass on to `eval`.
|
|
(define-for-syntax (remove-use-site stx)
|
|
(cond
|
|
[(identifier? stx) (syntax-local-identifier-as-binding stx)]
|
|
[(syntax? stx)
|
|
(datum->syntax (syntax-local-identifier-as-binding (datum->syntax stx 'x))
|
|
(remove-use-site (syntax-e stx))
|
|
stx
|
|
stx)]
|
|
[(pair? stx)
|
|
(cons (remove-use-site (car stx))
|
|
(remove-use-site (cdr stx)))]
|
|
[else stx]))
|
|
|
|
(define-syntax (test-pack-seq stx)
|
|
(syntax-case stx ()
|
|
[(_ result form ...)
|
|
(let loop ([forms #'(form ...)]
|
|
[pre null])
|
|
(syntax-case forms ()
|
|
[([#:fail expr exn?])
|
|
(with-syntax ([(form ...) (reverse pre)]
|
|
[expr (remove-use-site #'expr)])
|
|
#`(test-pack-seq* (list (quote-syntax form) ...)
|
|
(quote-syntax [#:fail expr])
|
|
'expr
|
|
exn?))]
|
|
[(expr)
|
|
(with-syntax ([(form ...) (reverse pre)]
|
|
[expr (remove-use-site #'expr)])
|
|
#`(test-pack-seq* (list (quote-syntax form) ...)
|
|
(quote-syntax expr)
|
|
'expr
|
|
result))]
|
|
[([#:fail expr exn?] . more)
|
|
#`(begin
|
|
#,(loop #'([#:fail expr exn?]) pre)
|
|
#,(loop #'more pre))]
|
|
[(form . more)
|
|
(loop #'more (cons (remove-use-site #'form) pre))]))]))
|
|
|
|
(define (fail? e)
|
|
(syntax-case e ()
|
|
[(#:fail e) #'e]
|
|
[_ #f]))
|
|
|
|
(define (fail-expr e)
|
|
(or (fail? e) e))
|
|
|
|
(define (test-pack-seq* forms expr q-expr result)
|
|
(test-pack-seq** forms expr q-expr result)
|
|
(test-pack-seq** (map syntax->datum forms) (syntax->datum expr) q-expr result))
|
|
|
|
(define (test-pack-seq** forms expr q-expr result)
|
|
(printf "As ~a: ~s\n"
|
|
(if (syntax? (car forms))
|
|
"syntax"
|
|
"datum")
|
|
forms)
|
|
(let ([orig (current-namespace)])
|
|
;; top level
|
|
(printf "top\n")
|
|
(let ([ns (make-base-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-attach-module orig 'racket/package)
|
|
(namespace-require '(for-syntax racket/base))
|
|
(namespace-require 'racket/package)
|
|
(for-each eval forms)
|
|
(if (fail? expr)
|
|
(err/rt-test (eval (fail-expr expr)) result)
|
|
(test result q-expr (eval expr)))))
|
|
;; let
|
|
(printf "let\n")
|
|
(let ([ns (make-base-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-attach-module orig 'racket/package)
|
|
(namespace-require '(for-syntax racket/base))
|
|
(namespace-require 'racket/package)
|
|
(let ([e `(let () (begin . ,forms) ,(fail-expr expr))])
|
|
(if (fail? expr)
|
|
(err/rt-test (eval e) result)
|
|
(test result `(let ... ,q-expr) (eval e))))))
|
|
;; nested let
|
|
(printf "nested let\n")
|
|
(let ([ns (make-base-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-attach-module orig 'racket/package)
|
|
(namespace-require '(for-syntax racket/base))
|
|
(namespace-require 'racket/package)
|
|
(let ([e (let loop ([forms forms])
|
|
(if (null? (cdr forms))
|
|
`(let () (begin . ,forms) ,(fail-expr expr))
|
|
`(let () ,(car forms)
|
|
,(loop (cdr forms)))))])
|
|
(if (fail? expr)
|
|
(err/rt-test (eval e) result)
|
|
(test result `(let ... ,q-expr) (eval e))))))
|
|
;; module
|
|
(printf "module\n")
|
|
(let ([ns (make-base-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-attach-module orig 'racket/package)
|
|
(let ([m `(module m racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/package)
|
|
(begin . ,forms)
|
|
(define result ,(fail-expr expr))
|
|
(provide result))])
|
|
(if (fail? expr)
|
|
(err/rt-test (eval m) exn:fail:syntax?)
|
|
(begin
|
|
(eval m)
|
|
(test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))
|
|
;; multiple modules
|
|
(printf "2 modules\n")
|
|
(let ([ns (make-base-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-attach-module orig 'racket/package)
|
|
(let ([m `(begin
|
|
(module m0 racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/package)
|
|
(begin . ,forms)
|
|
(provide ,#'(all-defined-out)))
|
|
(module m racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/package
|
|
'm0)
|
|
(define result ,(fail-expr expr))
|
|
(provide result)))])
|
|
(if (fail? expr)
|
|
(err/rt-test (eval m) exn:fail:syntax?)
|
|
(begin
|
|
(eval m)
|
|
(test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))
|
|
;; more modules
|
|
(printf "3 modules\n")
|
|
(let ([ns (make-base-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-attach-module orig 'racket/package)
|
|
(let ([m `(begin
|
|
(module m0 racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/package)
|
|
,(car forms)
|
|
(provide ,#'(all-defined-out)))
|
|
(module m1 racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/package
|
|
'm0)
|
|
(begin . ,(cdr forms))
|
|
(provide ,#'(all-defined-out)))
|
|
(module m racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/package
|
|
'm0 'm1)
|
|
(define result ,(fail-expr expr))
|
|
(provide result)))])
|
|
(if (fail? expr)
|
|
(err/rt-test (eval m) exn:fail:syntax?)
|
|
(begin
|
|
(eval m)
|
|
(test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(test-pack-seq
|
|
12
|
|
(define-package p (x)
|
|
(define y 5)
|
|
(define x 12))
|
|
[#:fail x exn:fail:contract:variable?]
|
|
(open-package p)
|
|
x
|
|
[#:fail y exn:fail:contract:variable?])
|
|
|
|
(test-pack-seq
|
|
13
|
|
(define-package p (q)
|
|
(define-package q (x)
|
|
(define y 8)
|
|
(define x 13)))
|
|
[#:fail x exn:fail:contract:variable?]
|
|
[#:fail (open-package q) exn:fail:syntax?]
|
|
(open-package p)
|
|
[#:fail x exn:fail:contract:variable?]
|
|
(open-package q)
|
|
x
|
|
[#:fail y exn:fail:contract:variable?])
|
|
|
|
(test-pack-seq
|
|
14
|
|
(define-package p (q)
|
|
(define-package q (r)
|
|
(define-package r (x)
|
|
(define x 14))))
|
|
[#:fail x exn:fail:contract:variable?]
|
|
[#:fail (open-package q) exn:fail:syntax?]
|
|
[#:fail (open-package r) exn:fail:syntax?]
|
|
(open-package p)
|
|
(open-package q)
|
|
(open-package r)
|
|
x)
|
|
|
|
(test-pack-seq
|
|
15
|
|
(define-package p (x)
|
|
(define x 15))
|
|
[#:fail x exn:fail:contract:variable?]
|
|
(define-package q #:all-defined
|
|
(open-package p))
|
|
[#:fail x exn:fail:contract:variable?]
|
|
(open-package q)
|
|
x)
|
|
|
|
(test-pack-seq
|
|
'(16 160)
|
|
(define-package p #:all-defined
|
|
(define x 16)
|
|
(define y 160))
|
|
(open-package p)
|
|
(list x y))
|
|
|
|
(test-pack-seq
|
|
170
|
|
(define-package p #:all-defined-except (x)
|
|
(define x 17)
|
|
(define y 170))
|
|
(open-package p)
|
|
[#:fail x exn:fail:contract:variable?]
|
|
y)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(test-pack-seq
|
|
2
|
|
(define-package p (x)
|
|
(define* x 1)
|
|
(define* x 2))
|
|
(open-package p)
|
|
x)
|
|
|
|
(test-pack-seq
|
|
14
|
|
(define-package p (z)
|
|
(define* x (lambda () y))
|
|
(define z x)
|
|
(define* x 2)
|
|
(define y 14))
|
|
(open-package p)
|
|
(z))
|
|
|
|
(test-pack-seq
|
|
21
|
|
(define-package p (x)
|
|
(define* x (lambda () y))
|
|
(define* x2 0)
|
|
(define* x3 1)
|
|
(define* x4 1)
|
|
(define y 21))
|
|
(open-package p)
|
|
(x))
|
|
|
|
(test-pack-seq
|
|
'(2 1)
|
|
(define-package p (x y)
|
|
(define* x 1)
|
|
(define y x)
|
|
(define* x 2))
|
|
(open-package p)
|
|
(list x y))
|
|
|
|
(test-pack-seq
|
|
'(2 1)
|
|
(define-package p (x y)
|
|
(define* x 1)
|
|
(define y x)
|
|
(define* x 2))
|
|
(open-package p)
|
|
(list x y))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(test-pack-seq
|
|
5
|
|
(define-package p1 #:all-defined
|
|
(define-package p2 ()
|
|
(define x 10))
|
|
(open-package p2))
|
|
(open-package p1)
|
|
[#:fail x exn:fail:contract:variable?]
|
|
5)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(test-pack-seq
|
|
'(17 12)
|
|
(define-syntax-rule (mk id)
|
|
(begin
|
|
(define-package p (x)
|
|
(define x 17))
|
|
(open-package p)
|
|
(define id x)))
|
|
(define x 12)
|
|
(mk z)
|
|
(list z x))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(test-pack-seq
|
|
10
|
|
(define-package p5 (q)
|
|
(define* x 10)
|
|
(define-syntax (y stx)
|
|
(syntax-case stx ()
|
|
[(_ z) #'(begin (define z x))]))
|
|
(define* x 12)
|
|
(define* z 13)
|
|
(y q))
|
|
(open-package p5)
|
|
q)
|
|
|
|
;; ----------------------------------------
|
|
;; In a submodule
|
|
|
|
(module package-in-a-submodule racket/base
|
|
(require racket/package)
|
|
|
|
(define-package pkg (foo)
|
|
(define foo 5))
|
|
|
|
(module+ main
|
|
(open-package pkg)
|
|
(define out foo)
|
|
(provide out)))
|
|
|
|
(test 5 dynamic-require '(submod 'package-in-a-submodule main) 'out)
|
|
|
|
;; ----------------------------------------
|
|
;; `package-begin`
|
|
|
|
(package-begin)
|
|
|
|
(package-begin
|
|
(define pbx 1)
|
|
(test 1 'use-package-begin pbx))
|
|
(err/rt-test pbx)
|
|
|
|
(package-begin
|
|
(define pbx 2)
|
|
(define (use-pbx) pbx)
|
|
(test 2 'use-package-begin (use-pbx)))
|
|
(err/rt-test pbx)
|
|
(err/rt-test use-pbx)
|
|
|
|
(package-begin
|
|
(define pbx 3)
|
|
(define (use-pbx) pbx)
|
|
(define* pbx 4)
|
|
(test 3 'use-package-begin (use-pbx))
|
|
(test 4 'use-package-begin pbx))
|
|
(err/rt-test pbx)
|
|
(err/rt-test use-pbx)
|
|
|
|
(test 3 'expr (+ (package-begin
|
|
(define x 1)
|
|
x)
|
|
2))
|
|
|