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

untabity and minor formatting

Browse Source 
svn: r17222
This commit is contained in:
Eli Barzilay 2009-12-06 05:06:40 +00:00
parent eb95fbfda3
commit 259350a7e1
1 changed files with 328 additions and 314 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

566
collects/tests/mzscheme/stx.ss
View File

@ -72,41 +72,46 @@
(test 'yes 'dot-literal (syntax-case #'(1 . #t) () [(_ . #t) 'yes] [_ 'no])) (test 'yes 'dot-literal (syntax-case #'(1 . #t) () [(_ . #t) 'yes] [_ 'no]))
(test '(((x 3) (y 3) (z 3)) ;; each line should be x y z, not x x x... (test '(((x 3) (y 3) (z 3)) ;; each line should be x y z, not x x x...
((x 4) (y 4) (z 4)) ((x 4) (y 4) (z 4))
((x 5) (y 5) (z 5))) ((x 5) (y 5) (z 5)))
'ellipses 'ellipses
(syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) ()
[(_ x (a ...) ((b ...) ...)) #'(((a b) ...) ...)]))) [(_ x (a ...) ((b ...) ...)) #'(((a b) ...) ...)])))
(test '(((x y z 3) (x y z 3) (x y z 3)) (test '(((x y z 3) (x y z 3) (x y z 3))
((x y z 4) (x y z 4) (x y z 4)) ((x y z 4) (x y z 4) (x y z 4))
((x y z 5) (x y z 5) (x y z 5))) ((x y z 5) (x y z 5) (x y z 5)))
'ellipses 'ellipses
(syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) ()
[(_ x (a ...) ((b ...) ...)) #'(((a ... b) ...) ...)]))) [(_ x (a ...) ((b ...) ...)) #'(((a ... b) ...) ...)])))
(test '((1 z) (2 w) (x z) (y w)) (test '((1 z) (2 w) (x z) (y w))
'ellipses 'ellipses
(syntax->datum (syntax-case '(((1 2) (x y)) (z w)) () (syntax->datum (syntax-case '(((1 2) (x y)) (z w)) ()
[(((a ...) ...) (b ...)) #'((a b) ... ...)]))) [(((a ...) ...) (b ...)) #'((a b) ... ...)])))
(test '(#(1) #(2 3)) (test '(#(1) #(2 3))
'ellipses+vector 'ellipses+vector
(syntax->datum (syntax->datum
(syntax-case '((1) (2 3)) () [((a ...) ...) #'(#(a ...) ...)]))) (syntax-case '((1) (2 3)) ()
[((a ...) ...) #'(#(a ...) ...)])))
(test '(1 2 3 6 8 9 0 1 2 3) (test '(1 2 3 6 8 9 0 1 2 3)
syntax->datum syntax->datum
(syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'(a ... ... ...)])) (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) ()
[(((a ...) ...) ...) #'(a ... ... ...)]))
(test '((1 2 3) (6) (8 9 0 1 2 3)) (test '((1 2 3) (6) (8 9 0 1 2 3))
syntax->datum syntax->datum
(syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'((a ... ...) ...)])) (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) ()
[(((a ...) ...) ...) #'((a ... ...) ...)]))
(test '((1) (2 3) (6) (8 9 0) (1 2 3)) (test '((1) (2 3) (6) (8 9 0) (1 2 3))
syntax->datum syntax->datum
(syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'((a ...) ... ...)])) (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) ()
[(((a ...) ...) ...) #'((a ...) ... ...)]))
(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20])) (([nn -1] [mm -2]) ([pp -10] [qq -20]))) () (test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20]))
(([nn -1] [mm -2]) ([pp -10] [qq -20]))) ()
[((([x y] ...) ...) ...) [((([x y] ...) ...) ...)
(syntax->datum #'(ell ((ull (+ x ...) (syntax->datum #'(ell ((ull (+ x ...)
((- x ... y ...) ...)) ((- x ... y ...) ...))
@ -118,7 +123,8 @@
((ull (+ nn mm) ((- n m 1 2) (- p q 10 20))) ((ull (+ nn mm) ((- n m 1 2) (- p q 10 20)))
(ull (+ pp qq) ((- nn mm -1 -2) (- pp qq -10 -20)))))) (ull (+ pp qq) ((- nn mm -1 -2) (- pp qq -10 -20))))))
(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20])) (([nn -1] [mm -2]) ([pp -10] [qq -20]))) () (test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20]))
(([nn -1] [mm -2]) ([pp -10] [qq -20]))) ()
[((([x y] ...) ...) ...) [((([x y] ...) ...) ...)
(syntax->datum #'(ell ((ull (+ x ...) (syntax->datum #'(ell ((ull (+ x ...)
((- x ...) ...)) ((- x ...) ...))
@ -137,11 +143,11 @@
(define (tree-map f) (define (tree-map f)
(lambda (l) (lambda (l)
(if (pair? l) (if (pair? l)
(cons ((tree-map f) (car l)) (cons ((tree-map f) (car l))
((tree-map f) (cdr l))) ((tree-map f) (cdr l)))
(if (null? l) (if (null? l)
null null
(f l))))) (f l)))))
(define-syntax mcr (define-syntax mcr
(lambda (stx) (lambda (stx)
@ -154,7 +160,7 @@
(syntax-case se () (syntax-case se ()
[(bg five) [(bg five)
(let ([bg (syntax bg)] (let ([bg (syntax bg)]
[five (syntax five)]) [five (syntax five)])
(test 'begin syntax-e bg) (test 'begin syntax-e bg)
(test 5 syntax-e five) (test 5 syntax-e five)
@ -203,11 +209,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Constructed s, se is part of s, part of s tagged ;; Constructed s, se is part of s, part of s tagged
(define s (syntax-property (with-syntax ([five (syntax-property (quote-syntax 5) (define s
'testing (syntax-property
12)]) (with-syntax ([five (syntax-property (quote-syntax 5) 'testing 12)])
(syntax (mcr2 five))) (syntax (mcr2 five)))
'testing 10)) 'testing 10))
(define se (expand-once s)) (define se (expand-once s))
(test (syntax-e (cadr (syntax-e s))) syntax-e se) (test (syntax-e (cadr (syntax-e s))) syntax-e se)
@ -223,14 +229,14 @@
;; paren-shape: ;; paren-shape:
(let ([s (with-syntax ([a (quote-syntax [x y])]) (let ([s (with-syntax ([a (quote-syntax [x y])])
#'[a 10])]) #'[a 10])])
(test #f syntax-property #'(x) 'paren-shape) (test #f syntax-property #'(x) 'paren-shape)
(test #\[ syntax-property #'[x] 'paren-shape) (test #\[ syntax-property #'[x] 'paren-shape)
(test #\[ syntax-property s 'paren-shape) (test #\[ syntax-property s 'paren-shape)
(test #\[ syntax-property (syntax-case s () [(b _) #'b]) 'paren-shape)) (test #\[ syntax-property (syntax-case s () [(b _) #'b]) 'paren-shape))
(let ([s (with-syntax ([(a ...) '(1 2 3)]) (let ([s (with-syntax ([(a ...) '(1 2 3)])
#'[a ...])]) #'[a ...])])
(test #\[ syntax-property s 'paren-shape)) (test #\[ syntax-property s 'paren-shape))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -317,16 +323,17 @@
;; Symbol Keys ;; Symbol Keys
(test null syntax-property-symbol-keys #'a) (test null syntax-property-symbol-keys #'a)
(let ([ssort (lambda (l) (let ([ssort (lambda (l)
(if (equal? l '(yep aha)) (if (equal? l '(yep aha))
'(aha yep) '(aha yep)
l))]) l))])
(test '(aha) syntax-property-symbol-keys (syntax-property #'a 'aha 1)) (test '(aha) syntax-property-symbol-keys (syntax-property #'a 'aha 1))
(test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property (syntax-property #'a 'aha 1) 'yep 2))) (test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property (syntax-property #'a 'aha 1) 'yep 2)))
(test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property (test '(aha yep) ssort (syntax-property-symbol-keys
(syntax-property (syntax-property
(syntax-property #'a 'aha 1) (syntax-property
'yep 2) (syntax-property #'a 'aha 1)
'aha 3)))) 'yep 2)
'aha 3))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test free-identifier=? on different phases via syntax-case* ;; Test free-identifier=? on different phases via syntax-case*
@ -349,15 +356,15 @@
(define-syntax ck (define-syntax ck
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ id et?) [(_ id et?)
(with-syntax ([cmp (if (syntax-e (syntax et?)) (with-syntax ([cmp (if (syntax-e (syntax et?))
(syntax free-transformer-identifier=?) (syntax free-transformer-identifier=?)
(syntax free-identifier=?))]) (syntax free-identifier=?))])
(syntax (syntax
(lambda (x) (lambda (x)
(syntax-case* x (id) cmp (syntax-case* x (id) cmp
[(_ id) #t] [(_ id) #t]
[else #f]))))]))) [else #f]))))])))
(define has-lam? (ck case-lambda #f)) (define has-lam? (ck case-lambda #f))
(define has-mz:lam? (ck mz:case-lambda #f)) (define has-mz:lam? (ck mz:case-lambda #f))
@ -370,7 +377,7 @@
(define has-et-mtby? (ck b:mtby #t)) (define has-et-mtby? (ck b:mtby #t))
(provide has-lam? has-mz:lam? has-mtax? has-mtby? (provide has-lam? has-mz:lam? has-mtax? has-mtby?
has-et-lam? has-et-mz:lam? has-et-mtax? has-et-mtby?)) has-et-lam? has-et-mz:lam? has-et-mtax? has-et-mtby?))
(require 'mt1) (require 'mt1)
(require (for-syntax 'mtb)) (require (for-syntax 'mtb))
@ -410,8 +417,8 @@
(datum->syntax (datum->syntax
stx stx
(cons (cons
(quote-syntax quote-syntax) (quote-syntax quote-syntax)
(cdr (syntax-e stx))) (cdr (syntax-e stx)))
stx))) stx)))
(define-values (run-mt2-test) (define-values (run-mt2-test)
@ -469,34 +476,40 @@
(cdddr b)) (cdddr b))
b))) b)))
(test '('#%kernel case-lambda (lib "scheme/init") case-lambda 0 0 0) identifier-binding* #'case-lambda) (test '('#%kernel case-lambda (lib "scheme/init") case-lambda 0 0 0)
(test '(scheme/promise delay* (lib "scheme/init") delay 0 0 0) identifier-binding* #'delay) identifier-binding* #'case-lambda)
(test '('#%kernel #%module-begin (lib "scheme/init") #%plain-module-begin 0 0 0) identifier-binding* #'#%plain-module-begin) (test '(scheme/promise delay* (lib "scheme/init") delay 0 0 0)
identifier-binding* #'delay)
(test '('#%kernel #%module-begin (lib "scheme/init") #%plain-module-begin 0 0 0)
identifier-binding* #'#%plain-module-begin)
(require (only-in scheme/base [#%plain-module-begin #%pmb])) (require (only-in scheme/base [#%plain-module-begin #%pmb]))
(test '('#%kernel #%module-begin scheme/base #%plain-module-begin 0 0 0) identifier-binding* #'#%pmb) (test '('#%kernel #%module-begin scheme/base #%plain-module-begin 0 0 0)
identifier-binding* #'#%pmb)
(let ([b (identifier-binding (syntax-case (expand #'(module m scheme/base (let ([b (identifier-binding
(require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons])) (syntax-case (expand #'(module m scheme/base
bcons)) () (require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons]))
[(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print))) bcons)) ()
(let ([s (syntax cons)]) [(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print)))
(test 'bcons syntax-e s) (let ([s (syntax cons)])
s)]))]) (test 'bcons syntax-e s)
s)]))])
(let-values ([(real real-base) (module-path-index-split (car b))] (let-values ([(real real-base) (module-path-index-split (car b))]
[(nominal nominal-base) (module-path-index-split (caddr b))]) [(nominal nominal-base) (module-path-index-split (caddr b))])
(test '"teachprims.ss" values real) (test '"teachprims.ss" values real)
(test 'beginner-cons cadr b) (test 'beginner-cons cadr b)
(test '(lib "lang/htdp-intermediate.ss") values nominal) (test '(lib "lang/htdp-intermediate.ss") values nominal)
(test 'cons cadddr b))) (test 'cons cadddr b)))
(let ([b (identifier-binding (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss") (let ([b (identifier-binding
cons)) () (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss")
[(mod m beg (#%mod-beg (app call-w-vals (lam () cons) prnt))) cons)) ()
(let ([s (syntax cons)]) [(mod m beg (#%mod-beg (app call-w-vals (lam () cons) prnt)))
(test 'cons syntax-e s) (let ([s (syntax cons)])
s)]))]) (test 'cons syntax-e s)
s)]))])
(let-values ([(real real-base) (module-path-index-split (car b))] (let-values ([(real real-base) (module-path-index-split (car b))]
[(nominal nominal-base) (module-path-index-split (caddr b))]) [(nominal nominal-base) (module-path-index-split (caddr b))])
(test '"teachprims.ss" values real) (test '"teachprims.ss" values real)
(test 'beginner-cons cadr b) (test 'beginner-cons cadr b)
(test '(lib "lang/htdp-intermediate.ss") values nominal) (test '(lib "lang/htdp-intermediate.ss") values nominal)
@ -517,17 +530,17 @@
(err/rt-test (eval-syntax eval)) (err/rt-test (eval-syntax eval))
(test eval eval-syntax #'eval) (test eval eval-syntax #'eval)
(test #t (test #t
'eval-syntax 'eval-syntax
(with-handlers ([exn:fail:syntax? (lambda (x) #t)]) (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
(eval-syntax (datum->syntax #f 'eval)))) (eval-syntax (datum->syntax #f 'eval))))
(test eval (current-eval) 'eval) (test eval (current-eval) 'eval)
(test eval (current-eval) eval) (test eval (current-eval) eval)
(test eval (current-eval) #'eval) (test eval (current-eval) #'eval)
(test #t (test #t
'current-eval-syntax 'current-eval-syntax
(with-handlers ([exn:fail:syntax? (lambda (x) #t)]) (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
((current-eval) (datum->syntax #f 'eval)))) ((current-eval) (datum->syntax #f 'eval))))
(test eval 'compile (eval (compile 'eval))) (test eval 'compile (eval (compile 'eval)))
(test eval 'compile (eval (compile eval))) (test eval 'compile (eval (compile eval)))
@ -538,9 +551,9 @@
(err/rt-test (compile-syntax eval)) (err/rt-test (compile-syntax eval))
(test eval 'compile (eval (compile-syntax #'eval))) (test eval 'compile (eval (compile-syntax #'eval)))
(test #t (test #t
'compile-syntax 'compile-syntax
(with-handlers ([exn:fail:syntax? (lambda (x) #t)]) (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
(compile-syntax (datum->syntax #f 'eval)))) (compile-syntax (datum->syntax #f 'eval))))
(test eval 'expand (eval (expand 'eval))) (test eval 'expand (eval (expand 'eval)))
(test eval 'expand (eval (expand eval))) (test eval 'expand (eval (expand eval)))
@ -551,9 +564,9 @@
(err/rt-test (expand-syntax eval)) (err/rt-test (expand-syntax eval))
(test eval 'expand (eval (expand-syntax #'eval))) (test eval 'expand (eval (expand-syntax #'eval)))
(test #t (test #t
'expand-syntax 'expand-syntax
(with-handlers ([exn:fail:syntax? (lambda (x) #t)]) (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
(expand-syntax (datum->syntax #f 'eval)))) (expand-syntax (datum->syntax #f 'eval))))
(test eval 'expand-once (eval (expand-once 'eval))) (test eval 'expand-once (eval (expand-once 'eval)))
(test eval 'expand-once (eval (expand-once eval))) (test eval 'expand-once (eval (expand-once eval)))
@ -564,9 +577,9 @@
(err/rt-test (expand-syntax-once eval)) (err/rt-test (expand-syntax-once eval))
(test eval 'expand-once (eval (expand-syntax-once #'eval))) (test eval 'expand-once (eval (expand-syntax-once #'eval)))
(test #t (test #t
'expand-syntax-once 'expand-syntax-once
(with-handlers ([exn:fail:syntax? (lambda (x) #t)]) (with-handlers ([exn:fail:syntax? (lambda (x) #t)])
(expand-syntax-once (datum->syntax #f 'eval)))) (expand-syntax-once (datum->syntax #f 'eval))))
(test eval 'expand-to-top-form (eval (expand-to-top-form 'eval))) (test eval 'expand-to-top-form (eval (expand-to-top-form 'eval)))
(test eval 'expand-to-top-form (eval (expand-to-top-form eval))) (test eval 'expand-to-top-form (eval (expand-to-top-form eval)))
@ -591,58 +604,58 @@
(define (has-p? stx) (define (has-p? stx)
(let ([p (syntax-property stx prop)]) (let ([p (syntax-property stx prop)])
(and p (and p
(let loop ([p p]) (let loop ([p p])
(cond (cond
[(pair? p) (or (loop (car p)) [(pair? p) (or (loop (car p))
(loop (cdr p)))] (loop (cdr p)))]
[else (and (identifier? p) [else (and (identifier? p)
(eq? what (syntax-e p)))]))))) (eq? what (syntax-e p)))])))))
(let loop ([stx stx]) (let loop ([stx stx])
(or (and (has-p? stx) (or (and (has-p? stx)
(or (eq? #t where) (or (eq? #t where)
(eq? (syntax-e stx) where) (eq? (syntax-e stx) where)
(and (pair? (syntax-e stx)) (and (pair? (syntax-e stx))
(eq? (syntax-e (car (syntax-e stx))) (eq? (syntax-e (car (syntax-e stx)))
where)))) where))))
(syntax-case stx (#%plain-lambda case-lambda begin begin0 (syntax-case stx (#%plain-lambda case-lambda begin begin0
set! with-continuation-mark set! with-continuation-mark
if #%plain-app module #%plain-module-begin if #%plain-app module #%plain-module-begin
define-values) define-values)
[(#%plain-lambda formals expr ...) [(#%plain-lambda formals expr ...)
(ormap loop (syntax->list #'(expr ...)))] (ormap loop (syntax->list #'(expr ...)))]
[(case-lambda [formals expr ...] ...) [(case-lambda [formals expr ...] ...)
(ormap (lambda (l) (ormap (lambda (l)
(ormap loop (syntax->list l))) (ormap loop (syntax->list l)))
(syntax->list #'((expr ...) ...)))] (syntax->list #'((expr ...) ...)))]
[(let ([(id ...) rhs] ...) expr ...) [(let ([(id ...) rhs] ...) expr ...)
(or (free-identifier=? #'let #'let-values) (or (free-identifier=? #'let #'let-values)
(free-identifier=? #'let #'letrec-values)) (free-identifier=? #'let #'letrec-values))
(or (and (boolean? where) (or (and (boolean? where)
(syntax-case stx () (syntax-case stx ()
[(let [clause ...] expr) [(let [clause ...] expr)
(ormap has-p? (syntax->list #'(clause ...)))])) (ormap has-p? (syntax->list #'(clause ...)))]))
(ormap loop (syntax->list #'(expr ...))) (ormap loop (syntax->list #'(expr ...)))
(ormap loop (syntax->list #'(rhs ...))))] (ormap loop (syntax->list #'(rhs ...))))]
[(begin expr ...) [(begin expr ...)
(ormap loop (syntax->list #'(expr ...)))] (ormap loop (syntax->list #'(expr ...)))]
[(begin0 expr ...) [(begin0 expr ...)
(ormap loop (syntax->list #'(expr ...)))] (ormap loop (syntax->list #'(expr ...)))]
[(set! id expr) [(set! id expr)
(loop #'expr)] (loop #'expr)]
[(with-continuation-mark key val expr) [(with-continuation-mark key val expr)
(or (loop #'key) (loop #'val) (loop #'expr))] (or (loop #'key) (loop #'val) (loop #'expr))]
[(if test then else) [(if test then else)
(or (loop #'test) (loop #'then) (loop #'else))] (or (loop #'test) (loop #'then) (loop #'else))]
[(#%plain-app expr ...) [(#%plain-app expr ...)
(ormap loop (syntax->list #'(expr ...)))] (ormap loop (syntax->list #'(expr ...)))]
[(module name init body) [(module name init body)
(loop #'body)] (loop #'body)]
[(#%plain-module-begin expr ...) [(#%plain-module-begin expr ...)
(ormap loop (syntax->list #'(expr ...)))] (ormap loop (syntax->list #'(expr ...)))]
[(define-values (id ...) expr) [(define-values (id ...) expr)
(loop #'expr)] (loop #'expr)]
[_ #f])))) [_ #f]))))
(test #t has-stx-property? (expand #'(let ([x 1]) 2)) 'let-values 'let 'origin) (test #t has-stx-property? (expand #'(let ([x 1]) 2)) 'let-values 'let 'origin)
@ -688,10 +701,10 @@
(test #t has-stx-property? (expand #'(let () (define-syntax (x stx) #'(quote y)) x)) 'quote 'x 'origin) (test #t has-stx-property? (expand #'(let () (define-syntax (x stx) #'(quote y)) x)) 'quote 'x 'origin)
(let ([check-expr (let ([check-expr
(lambda (expr) (lambda (expr)
(let ([e (expand expr)]) (let ([e (expand expr)])
(syntax-case e () (syntax-case e ()
[(lv (bind ...) beg) [(lv (bind ...) beg)
(let ([db (syntax-property #'beg 'disappeared-binding)]) (let ([db (syntax-property #'beg 'disappeared-binding)])
(let-values ([(bg e) (let-values ([(bg e)
(syntax-case #'beg (#%plain-app list) (syntax-case #'beg (#%plain-app list)
[(bg () (#%plain-app list e)) [(bg () (#%plain-app list e))
@ -736,7 +749,7 @@
(define-syntax (++s stx) (define-syntax (++s stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) #'(define-syntax (id stx) [(_ id) #'(define-syntax (id stx)
(datum->syntax #'here (++goo)))])) (datum->syntax #'here (++goo)))]))
(define-syntax (++t stx) (syntax-case stx () [(_ id) #'(define-values (id) ++d)])) (define-syntax (++t stx) (syntax-case stx () [(_ id) #'(define-values (id) ++d)]))
(define-syntax (++t2 stx) #'(begin ++d)) (define-syntax (++t2 stx) #'(begin ++d))
(define-syntax (++t3 stx) (syntax-property #'(begin0 ++d) 'certify-mode 'transparent)) (define-syntax (++t3 stx) (syntax-property #'(begin0 ++d) 'certify-mode 'transparent))
@ -756,7 +769,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ id) #'(id ++d)])) [(_ id) #'(id ++d)]))
(provide ++o ++o2 ++s ++t ++t2 ++t3 ++t4 ++v ++v2 ++v3 (provide ++o ++o2 ++s ++t ++t2 ++t3 ++t4 ++v ++v2 ++v3
++apply-to-d ++apply-to-ds)) ++apply-to-d ++apply-to-ds))
(require '++q) (require '++q)
(++s ++ack) (++s ++ack)
@ -767,31 +780,31 @@
(test 13 values (let () (++t id) 13)) (test 13 values (let () (++t id) 13))
(let-syntax ([goo (lambda (stx) (let-syntax ([goo (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) (datum->syntax #'here (sub1 (syntax-local-value #'id)))]))]) [(_ id) (datum->syntax #'here (sub1 (syntax-local-value #'id)))]))])
(test 16 'goo (++apply-to-ds goo))) (test 16 'goo (++apply-to-ds goo)))
(unless building-flat-tests? (unless building-flat-tests?
(test 11 eval-syntax (expand-syntax #'++o)) (test 11 eval-syntax (expand-syntax #'++o))
(test 11 eval-syntax (syntax-case (expand-syntax #'++t2) () (test 11 eval-syntax (syntax-case (expand-syntax #'++t2) ()
[(_ x) #'x])) [(_ x) #'x]))
(test 11 eval-syntax (syntax-case (expand #'(++t z)) () (test 11 eval-syntax (syntax-case (expand #'(++t z)) ()
[(d-v (_) x) #'x])) [(d-v (_) x) #'x]))
(test 11 eval-syntax (syntax-case (expand-syntax #'++t3) () (test 11 eval-syntax (syntax-case (expand-syntax #'++t3) ()
[(_ x) #'x])) [(_ x) #'x]))
(test 11 eval-syntax (syntax-case (expand #'(++t4 z)) () (test 11 eval-syntax (syntax-case (expand #'(++t4 z)) ()
[(d-v (_) x) #'x])) [(d-v (_) x) #'x]))
(err/rt-test (teval (syntax-case (expand #'++v) () (err/rt-test (teval (syntax-case (expand #'++v) ()
[(_ x) #'x])) [(_ x) #'x]))
exn:fail:syntax?) exn:fail:syntax?)
(err/rt-test (teval (syntax-case (expand #'++v2) () (err/rt-test (teval (syntax-case (expand #'++v2) ()
[(_ x) #'x])) [(_ x) #'x]))
exn:fail:syntax?) exn:fail:syntax?)
(err/rt-test (teval (syntax-case (expand #'++v3) () (err/rt-test (teval (syntax-case (expand #'++v3) ()
[(_ x) #'x])) [(_ x) #'x]))
exn:fail:syntax?)) exn:fail:syntax?))
(let ([expr (expand-syntax #'++v)]) (let ([expr (expand-syntax #'++v)])
(test expr syntax-recertify expr expr (current-inspector) #f) (test expr syntax-recertify expr expr (current-inspector) #f)
@ -799,43 +812,43 @@
(test #t syntax? new) (test #t syntax? new)
(test 'no-marks syntax-e new)) (test 'no-marks syntax-e new))
(test #t syntax? (syntax-recertify (syntax-case expr () (test #t syntax? (syntax-recertify (syntax-case expr ()
[(beg id) #'beg]) [(beg id) #'beg])
expr (current-inspector) #f)) expr (current-inspector) #f))
;; we'd prefer this to fail, but it's defined to succeed: ;; we'd prefer this to fail, but it's defined to succeed:
(test #t syntax? (syntax-recertify (syntax-case expr () (test #t syntax? (syntax-recertify (syntax-case expr ()
[(beg id) #'id]) [(beg id) #'id])
expr (current-inspector) #f)) expr (current-inspector) #f))
(test #t syntax? (syntax-recertify (datum->syntax expr (syntax-e expr)) (test #t syntax? (syntax-recertify (datum->syntax expr (syntax-e expr))
expr (current-inspector) #f)) expr (current-inspector) #f))
;; we'd prefer this to fail, but it's defined to succeed: ;; we'd prefer this to fail, but it's defined to succeed:
(test #t syntax? (syntax-recertify (syntax-case expr () (test #t syntax? (syntax-recertify (syntax-case expr ()
[(beg id) #'(ack id)]) [(beg id) #'(ack id)])
expr (current-inspector) #f))) expr (current-inspector) #f)))
(let ([expr (expand-syntax #'(++apply-to-d ack))]) (let ([expr (expand-syntax #'(++apply-to-d ack))])
(test '(#%app (#%top . ack) ++d) syntax->datum expr) (test '(#%app (#%top . ack) ++d) syntax->datum expr)
(let ([try (lambda (cvt? other) (let ([try (lambda (cvt? other)
(syntax-recertify (datum->syntax (syntax-recertify (datum->syntax
expr expr
(cons (car (syntax-e expr)) (cons (car (syntax-e expr))
((if cvt? ((if cvt?
(lambda (x) (datum->syntax (lambda (x) (datum->syntax
(cdr (syntax-e expr)) (cdr (syntax-e expr))
x)) x))
values) values)
(cons (cons
other other
(cdr (syntax-e (cdr (syntax-e expr)))))))) (cdr (syntax-e (cdr (syntax-e expr))))))))
expr expr
(current-inspector) (current-inspector)
#f))]) #f))])
(test #t syntax? (try #f #'other!)) (test #t syntax? (try #f #'other!))
(let ([new (try #t #'other!)]) (let ([new (try #t #'other!)])
(test #t syntax? new) (test #t syntax? new)
(test '(#%app other! ++d) syntax->datum new)) (test '(#%app other! ++d) syntax->datum new))
;; we'd prefer this to fail, but it's defined to succeed: ;; we'd prefer this to fail, but it's defined to succeed:
(test #t syntax? (try #t (syntax-case expr () (test #t syntax? (try #t (syntax-case expr ()
[(ap _ d) #'d]))))) [(ap _ d) #'d])))))
;; ---------------------------------------- ;; ----------------------------------------
@ -878,7 +891,7 @@
(namespace-attach-module n ''++n)) (namespace-attach-module n ''++n))
(parameterize ([current-code-inspector i] (parameterize ([current-code-inspector i]
[current-namespace n2]) [current-namespace n2])
(namespace-require 'scheme/base) (namespace-require 'scheme/base)
(teval '(require '++n)) (teval '(require '++n))
@ -897,20 +910,20 @@
(err/rt-test (teval '++y-macro2) exn:fail:syntax?) (err/rt-test (teval '++y-macro2) exn:fail:syntax?)
(teval '(module zrt scheme/base (teval '(module zrt scheme/base
(require '++n) (require '++n)
(define (vy) ++y) (define (vy) ++y)
(define (vy2) ++y-macro) (define (vy2) ++y-macro)
(define (vu) ++u-macro) (define (vu) ++u-macro)
(define (vu2) ++u2) (define (vu2) ++u2)
(provide vy vy2 vu vu2))) (provide vy vy2 vu vu2)))
(teval '(module zct scheme/base (teval '(module zct scheme/base
(require (for-syntax scheme/base (require (for-syntax scheme/base
'++n)) '++n))
(define-syntax (wy stx) (datum->syntax #'here ++y)) (define-syntax (wy stx) (datum->syntax #'here ++y))
(let-syntax ([goo ++y-macro]) 10) (let-syntax ([goo ++y-macro]) 10)
(define-syntax (wy2 stx) (datum->syntax #'here ++y-macro)) (define-syntax (wy2 stx) (datum->syntax #'here ++y-macro))
(define-syntax (wu stx) (datum->syntax #'here ++u-macro)) (define-syntax (wu stx) (datum->syntax #'here ++u-macro))
(provide wy wy2 wu))) (provide wy wy2 wu)))
(teval '(require 'zct)) (teval '(require 'zct))
@ -927,11 +940,11 @@
(let ([old-insp (current-code-inspector)]) (let ([old-insp (current-code-inspector)])
(parameterize ([current-code-inspector i] (parameterize ([current-code-inspector i]
[current-namespace n2]) [current-namespace n2])
(namespace-unprotect-module old-insp ''++m))) (namespace-unprotect-module old-insp ''++m)))
(parameterize ([current-code-inspector i] (parameterize ([current-code-inspector i]
[current-namespace n2]) [current-namespace n2])
(test 10 teval '++y-macro) (test 10 teval '++y-macro)
(test 10 teval '++y-macro2))) (test 10 teval '++y-macro2)))
@ -953,7 +966,7 @@
(syntax-rules () (syntax-rules ()
[(_ get-foo) [(_ get-foo)
(define-syntax (get-foo stx) (define-syntax (get-foo stx)
(syntax-local-value #'foo))]))) (syntax-local-value #'foo))])))
(require '++//n) (require '++//n)
(++//def ++//get-foo) (++//def ++//get-foo)
(test 17 values ++//get-foo) (test 17 values ++//get-foo)
@ -966,8 +979,8 @@
(syntax-case stx () (syntax-case stx ()
[(_ n) [(_ n)
(if (zero? (syntax-e #'n)) (if (zero? (syntax-e #'n))
#'(list #f 0) #'(list #f 0)
(with-syntax ([m (sub1 (syntax-e #'n))]) (with-syntax ([m (sub1 (syntax-e #'n))])
#`(list '#,(syntax-local-lift-context) #`(list '#,(syntax-local-lift-context)
#,(syntax-local-lift-expression #'(add1 (cadr (@@foo m)))))))])) #,(syntax-local-lift-expression #'(add1 (cadr (@@foo m)))))))]))
@ -999,9 +1012,9 @@
(syntax-case stx () (syntax-case stx ()
[(_ n) [(_ n)
(if (zero? (syntax-e #'n)) (if (zero? (syntax-e #'n))
#'0 #'0
(with-syntax ([m (sub1 (syntax-e #'n))]) (with-syntax ([m (sub1 (syntax-e #'n))])
(syntax-local-lift-expression #'(add1 (@@foo m)))))])) (syntax-local-lift-expression #'(add1 (@@foo m)))))]))
(define-syntax (@@foox stx) (define-syntax (@@foox stx)
(syntax-case stx () (syntax-case stx ()
[(_ n) [(_ n)
@ -1024,7 +1037,7 @@
(test 3 (test 3
'ls-foo 'ls-foo
(let-syntax ([z (lambda (stx) #`#,(@@foo 3))]) (let-syntax ([z (lambda (stx) #`#,(@@foo 3))])
z)) z))
(test (void) eval (expand #'(begin-for-syntax (define @@zoo (@@foo 2))))) (test (void) eval (expand #'(begin-for-syntax (define @@zoo (@@foo 2)))))
(define-syntax (@@x stx) #`#, @@zoo) (define-syntax (@@x stx) #`#, @@zoo)
@ -1052,8 +1065,8 @@
(syntax-case stx () (syntax-case stx ()
[(_ n) [(_ n)
(if (zero? (syntax-e #'n)) (if (zero? (syntax-e #'n))
#'(list #f 0) #'(list #f 0)
(with-syntax ([m (sub1 (syntax-e #'n))]) (with-syntax ([m (sub1 (syntax-e #'n))])
(let ([prev prev-ctx]) (let ([prev prev-ctx])
(if prev (if prev
(unless (eq? prev (syntax-local-lift-context)) (unless (eq? prev (syntax-local-lift-context))
@ -1107,45 +1120,45 @@
(let ([go-once (let ([go-once
(lambda (eval) (lambda (eval)
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(eval '(module mm scheme/base (eval '(module mm scheme/base
(require (for-syntax scheme/base)) (require (for-syntax scheme/base))
(define-syntax (define$ stx) (define-syntax (define$ stx)
(syntax-case stx () (syntax-case stx ()
[(_ id val) [(_ id val)
(with-syntax ([x (datum->syntax #f 'x)]) (with-syntax ([x (datum->syntax #f 'x)])
#'(begin #'(begin
(define x val) (define x val)
(define-syntax (id stx) #'x)))])) (define-syntax (id stx) #'x)))]))
(define$ a 1) (define$ a 1)
(define$ b 2) (define$ b 2)
(printf "~a ~a~n" a b))) (printf "~a ~a~n" a b)))
(eval '(require 'mm)) (eval '(require 'mm))
(eval '(current-namespace (module->namespace ''mm))) (eval '(current-namespace (module->namespace ''mm)))
(eval '(define$ c 7)) (eval '(define$ c 7))
(test '(1 2 7) eval '(list a b c)) (test '(1 2 7) eval '(list a b c))
(eval '(define$ d 8)) (eval '(define$ d 8))
(test '(1 2 7 8) eval '(list a b c d))) (test '(1 2 7 8) eval '(list a b c d)))
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(eval '(module mm scheme/base (eval '(module mm scheme/base
(require (for-syntax scheme/base)) (require (for-syntax scheme/base))
(define-syntax (define$ stx) (define-syntax (define$ stx)
(syntax-case stx () (syntax-case stx ()
[(_ id val) [(_ id val)
(with-syntax ([x (syntax-local-lift-expression #'val)]) (with-syntax ([x (syntax-local-lift-expression #'val)])
#'(define-syntax (id stx) #'x))])) #'(define-syntax (id stx) #'x))]))
(define$ a 1) (define$ a 1)
(define$ b 2) (define$ b 2)
(printf "~a ~a~n" a b))) (printf "~a ~a~n" a b)))
(eval '(require 'mm)) (eval '(require 'mm))
(eval '(current-namespace (module->namespace ''mm))) (eval '(current-namespace (module->namespace ''mm)))
(eval '(define$ c 7)) (eval '(define$ c 7))
(test '(1 2 7) eval '(list a b c)) (test '(1 2 7) eval '(list a b c))
(eval '(define$ d 8)) (eval '(define$ d 8))
(test '(1 2 7 8) eval '(list a b c d))))]) (test '(1 2 7 8) eval '(list a b c d))))])
(go-once eval) (go-once eval)
(go-once (lambda (e) (eval (expand e))))) (go-once (lambda (e) (eval (expand e)))))
@ -1154,14 +1167,14 @@
(test '(1 2) 'macro-nested-lexical (test '(1 2) 'macro-nested-lexical
(let () (let ()
(define-syntax (m stx) (define-syntax (m stx)
(with-syntax ([x1 (let ([x 0]) #'x)] (with-syntax ([x1 (let ([x 0]) #'x)]
[x2 (let ([x 0]) #'x)]) [x2 (let ([x 0]) #'x)])
#'(begin #'(begin
(define x1 1) (define x1 1)
(define x2 2) (define x2 2)
(list x1 x2)))) (list x1 x2))))
(m))) (m)))
(module @!$m scheme/base (module @!$m scheme/base
(require (for-syntax scheme/base)) (require (for-syntax scheme/base))
@ -1169,12 +1182,12 @@
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
(with-syntax ([x1 (let ([x 0]) #'x)] (with-syntax ([x1 (let ([x 0]) #'x)]
[x2 (let ([x 0]) #'x)]) [x2 (let ([x 0]) #'x)])
#'(begin #'(begin
(define x1 10) (define x1 10)
(define x2 20) (define x2 20)
(define id (list x1 x2 (define id (list x1 x2
(list? (identifier-binding (quote-syntax x1)))))))])) (list? (identifier-binding (quote-syntax x1)))))))]))
(d @!$get) (d @!$get)
(provide @!$get)) (provide @!$get))
(require '@!$m) (require '@!$m)
@ -1198,14 +1211,14 @@
(let ([load-ok? #t] (let ([load-ok? #t]
[old (current-module-name-resolver)]) [old (current-module-name-resolver)])
(parameterize ([current-namespace (make-base-namespace)] (parameterize ([current-namespace (make-base-namespace)]
[current-module-name-resolver [current-module-name-resolver
(case-lambda (case-lambda
[(name) [(name)
(if (equal? name "a") (if (equal? name "a")
(void) (void)
(old name))] (old name))]
[(name _ __) (make-resolved-module-path 'huh?)] [(name _ __) (make-resolved-module-path 'huh?)]
[(name base stx load?) [(name base stx load?)
(if (equal? name "a") (if (equal? name "a")
(begin (begin
(unless load-ok? (unless load-ok?
@ -1213,43 +1226,43 @@
(make-resolved-module-path 'a)) (make-resolved-module-path 'a))
(old name base stx load?))])]) (old name base stx load?))])])
(let ([a-code '(module a scheme/base (let ([a-code '(module a scheme/base
(provide x y) (provide x y)
(define x 1) (define x 1)
(define y #'x))]) (define y #'x))])
(eval a-code) (eval a-code)
(let ([b-code (let ([p (open-output-bytes)]) (let ([b-code (let ([p (open-output-bytes)])
(write (compile (write (compile
'(module b scheme/base '(module b scheme/base
(require "a") (require "a")
(provide f) (provide f)
(define (f) #'x))) (define (f) #'x)))
p) p)
(lambda () (lambda ()
(parameterize ([read-accept-compiled #t]) (parameterize ([read-accept-compiled #t])
(read (open-input-bytes (get-output-bytes p))))))] (read (open-input-bytes (get-output-bytes p))))))]
[x-id (parameterize ([current-namespace (make-base-namespace)]) [x-id (parameterize ([current-namespace (make-base-namespace)])
(printf "here\n") (printf "here\n")
(eval a-code) (eval a-code)
(eval '(require 'a)) (eval '(require 'a))
(eval '#'x))]) (eval '#'x))])
(eval (b-code)) (eval (b-code))
(eval '(require 'b)) (eval '(require 'b))
(set! load-ok? #f) (set! load-ok? #f)
(test #f eval '(free-identifier=? (f) #'x)) (test #f eval '(free-identifier=? (f) #'x))
(test #t eval `(free-identifier=? (f) (quote-syntax ,x-id))) (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
(eval '(require 'a)) (eval '(require 'a))
(test #t eval '(free-identifier=? (f) #'x)) (test #t eval '(free-identifier=? (f) #'x))
(test #t eval `(free-identifier=? (f) (quote-syntax ,x-id))) (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(eval '(module a scheme/base (eval '(module a scheme/base
(provide y) (provide y)
(define y 3))) (define y 3)))
(set! load-ok? #t) (set! load-ok? #t)
(eval (b-code)) (eval (b-code))
(eval '(require 'b)) (eval '(require 'b))
(set! load-ok? #f) (set! load-ok? #f)
(test #t eval '(free-identifier=? (f) #'x)) (test #t eval '(free-identifier=? (f) #'x))
(test #f eval `(free-identifier=? (f) (quote-syntax ,x-id)))))))) (test #f eval `(free-identifier=? (f) (quote-syntax ,x-id))))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; certification example from the manual ;; certification example from the manual
@ -1275,7 +1288,8 @@
(require '@-n) (require '@-n)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Propagating inactive certificates through a transparent macro-expansion result: ;; Propagating inactive certificates through a transparent macro-expansion
;; result:
(module @!m scheme/base (module @!m scheme/base
(require (for-syntax scheme/base)) (require (for-syntax scheme/base))