123 lines
3.3 KiB
Scheme
123 lines
3.3 KiB
Scheme
|
|
;; Like PLAI advanced, but with dynamic scope.
|
|
;; No `let', `let*', or `letrec'.
|
|
;;`local' expects ;; all definitions to have the
|
|
;; form `(define id expr)'.
|
|
|
|
(module plai-dynamic mzscheme
|
|
(require (rename (lib "htdp-advanced.ss" "lang") plai-else else)
|
|
(rename (lib "htdp-advanced.ss" "lang") advanced-define define)
|
|
"private/datatype.ss"
|
|
"test-harness.ss")
|
|
|
|
;; This macro requires & provides bindings without
|
|
;; making them locally visible:
|
|
(define-syntax (provide-advanced stx)
|
|
#'(begin
|
|
(require (all-except (lib "htdp-advanced.ss" "lang")
|
|
#%top define local let let* letrec lambda))
|
|
(provide (all-from-except (lib "htdp-advanced.ss" "lang")
|
|
plai-else advanced-define))))
|
|
(provide-advanced)
|
|
|
|
(define-for-syntax (make-dynamic k)
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx (set!)
|
|
[id
|
|
(identifier? #'id)
|
|
#'(lookup-dynamic 'id)]
|
|
[(set! id val)
|
|
#'(set-dynamic! 'id val)]
|
|
[(id expr ...)
|
|
#'((lookup-dynamic 'id) expr ...)]))))
|
|
|
|
(define-syntax to-dynamic
|
|
(syntax-rules ()
|
|
[(_ (id ...) expr)
|
|
(with-continuation-mark*
|
|
('id ...) ((box id) ...)
|
|
(let-syntax ([id (make-dynamic (quote-syntax id))]
|
|
...)
|
|
expr))]))
|
|
|
|
(define-syntax (dynamic-type-case stx)
|
|
(syntax-case stx ()
|
|
[(_ type expr
|
|
[id (param ...) body-expr]
|
|
...)
|
|
#'(advanced-type-case
|
|
type expr
|
|
[id (param ...)
|
|
(to-dynamic (param ...)
|
|
body-expr)] ...)]
|
|
[(_ . rest)
|
|
#'(advanced-type-case . rest)]))
|
|
|
|
(define-syntax (dynamic-define stx)
|
|
(syntax-case stx ()
|
|
[(_ (id arg ...) body-expr)
|
|
#'(advanced-define (id arg ...)
|
|
(to-dynamic
|
|
(arg ...)
|
|
body-expr))]
|
|
[(_ . rest)
|
|
#'(advanced-define . rest)]))
|
|
|
|
(define-syntax (dynamic-lambda stx)
|
|
(syntax-case stx ()
|
|
[(_ (id ...) expr)
|
|
#'(lambda (id ...)
|
|
(to-dynamic (id ...)
|
|
expr))]))
|
|
|
|
(define-syntax (dynamic-local stx)
|
|
(syntax-case stx (dynamic-define)
|
|
[(_ [(dynamic-define id val) ...] body-expr)
|
|
(andmap identifier? (syntax->list #'(id ...)))
|
|
#'(let [(id val) ...]
|
|
(to-dynamic (id ...)
|
|
body-expr))]))
|
|
|
|
(define-syntax (dynamic-top stx)
|
|
(syntax-case stx ()
|
|
[(_ . id)
|
|
(identifier? #'id)
|
|
#'(lookup-dynamic 'id)]))
|
|
|
|
(define (lookup-dynamic id)
|
|
(let ([v (continuation-mark-set-first #f id)])
|
|
(if v
|
|
(unbox v)
|
|
(namespace-variable-value id #f (lambda ()
|
|
(error 'eval
|
|
"no dynamic value for identifier: ~a"
|
|
id))))))
|
|
|
|
(define (set-dynamic! id val)
|
|
(let ([v (continuation-mark-set-first #f id)])
|
|
(if v
|
|
(set-box! v val)
|
|
(namespace-set-variable-value! id val))))
|
|
|
|
(define-syntax with-continuation-mark*
|
|
(syntax-rules ()
|
|
[(_ () () expr) expr]
|
|
[(_ (key . krest) (val . vrest) expr)
|
|
(with-continuation-mark key val
|
|
(with-continuation-mark* krest vrest expr))]))
|
|
|
|
(provide (rename dynamic-type-case type-case)
|
|
(rename dynamic-define define)
|
|
(rename dynamic-lambda lambda)
|
|
(rename dynamic-local local)
|
|
(rename dynamic-top #%top)
|
|
define-type
|
|
require provide provide-type
|
|
(all-from "test-harness.ss")
|
|
|
|
;; Hack to avoid certification bug :(
|
|
lookup-dynamic)
|
|
|
|
(define-type-case advanced-type-case plai-else))
|