272 lines
6.1 KiB
Scheme
272 lines
6.1 KiB
Scheme
|
|
;; Run this file with -r, and inspect the
|
|
;; printouts.
|
|
|
|
(module helpers mzscheme
|
|
(require scheme/package)
|
|
|
|
(provide identifier-syntax with-implicit
|
|
(rename define-package module)
|
|
(rename open-package import))
|
|
|
|
(define-syntax (identifier-syntax stx)
|
|
(syntax-case stx ()
|
|
[(_ id) (if (identifier? #'id)
|
|
#'(make-rename-transformer (quote-syntax id))
|
|
;; Cheating in this case... examples only
|
|
;; use this in a non-applied position
|
|
#'(lambda (stx) (quote-syntax id)))]))
|
|
|
|
(define-syntax with-implicit
|
|
(syntax-rules ()
|
|
[(_ (orig id ...) body)
|
|
(with-syntax ([id (datum->syntax-object #'orig (syntax-e #'id))]
|
|
...)
|
|
body)])))
|
|
|
|
|
|
(require 'helpers)
|
|
(require (for-syntax 'helpers))
|
|
|
|
;; Make evaluation print the result, for testing
|
|
(let ([eh (current-eval)])
|
|
(current-eval (lambda (x)
|
|
(let ([v (eh x)])
|
|
(unless (void? v)
|
|
(printf "~s~n" v))
|
|
v))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; From "Extending the Scope of Syntactic Abstraction"
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(let ((x 1))
|
|
(module M (x setter)
|
|
(define-syntax x (identifier-syntax z))
|
|
(define setter (lambda (x) (set! z x)))
|
|
(define z 5))
|
|
(let ((y x) (z 0))
|
|
(import M)
|
|
(setter 3)
|
|
(list x y z)))
|
|
"(3 1 0) is correct"
|
|
|
|
|
|
(define-syntax from
|
|
(syntax-rules ()
|
|
((_ M id) (let () (import M) id))))
|
|
(let ((x 10))
|
|
(module m1 (x) (define x 1))
|
|
(module m2 (x) (define x 2))
|
|
(list (from m1 x) (from m2 x)))
|
|
"(1 2) is correct"
|
|
|
|
(define-syntax module*
|
|
(syntax-rules ()
|
|
[(_ (id ...) form ...)
|
|
(begin
|
|
(module tmp (id ...) form ...)
|
|
(import tmp))]
|
|
[(_ name (id ...) form ...)
|
|
(module name (id ...) form ...)]))
|
|
(let ([w 88])
|
|
(module* (f)
|
|
(define (f) w)
|
|
(define w 17))
|
|
(list (f) w))
|
|
"(17 88) is correct"
|
|
|
|
(define-syntax define-alias
|
|
(syntax-rules ()
|
|
[(_ x y)
|
|
(define-syntax x
|
|
(identifier-syntax y))]))
|
|
|
|
(define-syntax import*
|
|
(syntax-rules ()
|
|
[(_ M) (begin)]
|
|
[(_ M (new old))
|
|
(module* (new)
|
|
(define-alias new tmp)
|
|
(module* (tmp)
|
|
(import M)
|
|
(define-alias tmp old)))]
|
|
[(_ M id) (module* (id) (import M))]
|
|
[(_ M spec0 spec1 ...)
|
|
(begin (import* M spec0)
|
|
(import* M spec1 ...))]))
|
|
(module m (x y z)
|
|
(define x 'x)
|
|
(define y 'y)
|
|
(define z 'z))
|
|
(import* m x (y z) (z y))
|
|
(list x y z)
|
|
"(x z y) is correct"
|
|
|
|
(module A (x y)
|
|
(define x 1)
|
|
(define y 2))
|
|
(module B (y z)
|
|
(define y 3)
|
|
(define z 4))
|
|
(module C (a b c d)
|
|
(import* A (a x) (b y))
|
|
(import* B (c y) (d z)))
|
|
(module D (a c)
|
|
(import C))
|
|
(module E (b d)
|
|
(import C))
|
|
(let ([a 'a]
|
|
[b 'b]
|
|
[c 'c]
|
|
[d 'd])
|
|
(import D)
|
|
(list a b c d))
|
|
"(1 b 3 d) is correct"
|
|
(let ([a 'a]
|
|
[b 'b]
|
|
[c 'c]
|
|
[d 'd])
|
|
(import E)
|
|
(list a b c d))
|
|
"(a 2 c 4) is correct"
|
|
|
|
(module* (A B)
|
|
(module A (x)
|
|
(define x (lambda () y)))
|
|
(module B (y)
|
|
(define y (lambda () x)))
|
|
(import A)
|
|
(import B))
|
|
(import A)
|
|
(import B)
|
|
(and (eq? x (y)) (eq? (y) x))
|
|
"#t is correct"
|
|
|
|
|
|
(define-syntax rec-modules
|
|
(syntax-rules ()
|
|
((_ (module N (id ...) form ...) ...)
|
|
(module* (N ...)
|
|
(module N (id ...) form ...) ...
|
|
(import N) ...))))
|
|
(rec-modules
|
|
(module O (odd)
|
|
(define (odd x)
|
|
(if (zero? x) #f (even (sub1 x)))))
|
|
(module E (even)
|
|
(define (even x)
|
|
(if (zero? x) #t (odd (sub1 x))))))
|
|
(import O)
|
|
(list (odd 17) (odd 32))
|
|
"(#t #f) is correct"
|
|
|
|
|
|
(define-syntax define-interface
|
|
(syntax-rules ()
|
|
[(_ name (export ...))
|
|
(define-syntax name
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ n defs)
|
|
(with-implicit (n export ...)
|
|
#'(module n (export ...) . defs))])))]))
|
|
(define-syntax define-module
|
|
(syntax-rules ()
|
|
[(_ name interface defn ...)
|
|
(interface name (defn ...))]))
|
|
(define-interface simple (a b))
|
|
(define-module M simple
|
|
(define-syntax a (identifier-syntax 1))
|
|
(define b (lambda () c))
|
|
(define c 2))
|
|
(let ()
|
|
(import M)
|
|
(list a (b)))
|
|
"(1 2) is right"
|
|
|
|
(define-syntax define-interface
|
|
(syntax-rules (compound-interface)
|
|
[(_ name (compound-interface i0 i1 ...))
|
|
(d-i-help name (i0 i1 ...) ())]
|
|
[(_ name (export ...))
|
|
(define-syntax name
|
|
(lambda (x)
|
|
(syntax-case x (expand-exports)
|
|
[(_ n defs)
|
|
(with-implicit (n export ...)
|
|
#'(module n (export ...) . defs))]
|
|
[(_ (expand-exports i-name mac))
|
|
(with-implicit (i-name export ...)
|
|
#'(mac i-name export ...))])))]))
|
|
(define-syntax d-i-help
|
|
(syntax-rules ()
|
|
[(_ name () (export ...))
|
|
(define-interface name (export ...))]
|
|
[(_ name (i0 i1 ...) (e ...))
|
|
(begin
|
|
(define-syntax tmp
|
|
(syntax-rules ()
|
|
[(_ name expt (... ...))
|
|
(d-i-help name (i1 ...)
|
|
(e ... expt (... ...)))]))
|
|
(i0 (expand-exports name tmp)))]))
|
|
(define-syntax define-module
|
|
(syntax-rules (compound-interface)
|
|
[(_ name (compound-interface i ...) defn ...)
|
|
(begin
|
|
(define-interface tmp(compound-interface i ...))
|
|
(define-module name tmp defn ...))]
|
|
[(_ name interface defn ...) (interface name (defn ...))]))
|
|
(define-interface one (a b))
|
|
(define-interface two (c d))
|
|
(define-interface both
|
|
(compound-interface one two))
|
|
(define-module M (compound-interface one two)
|
|
(define a 1)
|
|
(define b 2)
|
|
(define c 3)
|
|
(define d 4))
|
|
(let ()
|
|
(import M)
|
|
(list a b c d))
|
|
"(1 2 3 4) is correct"
|
|
|
|
(define-syntax declare
|
|
(syntax-rules ()
|
|
[(_ id) (define id (void))]))
|
|
(define-syntax satisfy
|
|
(syntax-rules ()
|
|
[(_ id val) (set! id val)]))
|
|
|
|
(define-syntax abstract-module
|
|
(syntax-rules ()
|
|
((_ name (ex ...) (mac ...) defn ...)
|
|
(module name (ex ... mac ...)
|
|
(declare ex)
|
|
... defn ...))))
|
|
(define-syntax implement
|
|
(syntax-rules ()
|
|
((_ name form ...)
|
|
(module* ()
|
|
(import name)
|
|
form ...))))
|
|
(abstract-module E (even?) ())
|
|
(abstract-module
|
|
O (odd?) (pred)
|
|
(define-syntax pred
|
|
(syntax-rules () ((_ exp) (- exp 1)))))
|
|
(implement E
|
|
(import O)
|
|
(satisfy even?
|
|
(lambda (x) (or (zero? x) (odd? (pred x))))))
|
|
(implement O
|
|
(import E)
|
|
(satisfy
|
|
odd?
|
|
(lambda (x) (not (even? x)))))
|
|
(import O)
|
|
(list (odd? 10) (odd? 13))
|
|
"(#f #t) is correct"
|
|
|