68 lines
2.4 KiB
Scheme
68 lines
2.4 KiB
Scheme
(module namespace "pre-base.ss"
|
|
(require (for-syntax '#%kernel "define.ss"
|
|
"stx.ss" "stxcase-scheme.ss" "small-scheme.ss"
|
|
"stxloc.ss"))
|
|
|
|
(provide make-base-empty-namespace
|
|
make-base-namespace
|
|
define-namespace-anchor
|
|
namespace-anchor?
|
|
namespace-anchor->empty-namespace
|
|
namespace-anchor->namespace)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define orig-varref (#%variable-reference orig-varref))
|
|
|
|
(define (make-base-empty-namespace)
|
|
(let* ([this-ns (variable-reference->empty-namespace orig-varref)]
|
|
[ns (parameterize ([current-namespace this-ns]) ; ensures correct phase
|
|
(make-empty-namespace))])
|
|
(namespace-attach-module this-ns
|
|
'scheme/base
|
|
ns)
|
|
ns))
|
|
|
|
(define (make-base-namespace)
|
|
(let ([ns (make-base-empty-namespace)])
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-require 'scheme/base))
|
|
ns))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-syntax (define-namespace-anchor stx)
|
|
(unless (memq (syntax-local-context) '(top-level module))
|
|
(raise-syntax-error #f
|
|
"allowed only in a top-level or module context"
|
|
stx))
|
|
(syntax-case stx ()
|
|
[(_ id)
|
|
(let ([id-stx #'id])
|
|
(unless (identifier? id-stx)
|
|
(raise-syntax-error #f
|
|
"expected an identifier"
|
|
stx
|
|
id-stx))
|
|
(syntax/loc stx
|
|
;; two-step definition allows this to work in for-syntax contexts:
|
|
(begin
|
|
(define tmp #f)
|
|
(define id (make-namespace-anchor (#%variable-reference tmp))))))]))
|
|
|
|
(define-struct namespace-anchor (var))
|
|
|
|
(define (namespace-anchor->empty-namespace ra)
|
|
(unless (namespace-anchor? ra)
|
|
(raise-type-error 'anchor->empty-namespace
|
|
"namespace anchor"
|
|
ra))
|
|
(variable-reference->empty-namespace (namespace-anchor-var ra)))
|
|
|
|
(define (namespace-anchor->namespace ra)
|
|
(unless (namespace-anchor? ra)
|
|
(raise-type-error 'anchor->namespace
|
|
"namespace anchor"
|
|
ra))
|
|
(variable-reference->namespace (namespace-anchor-var ra))))
|