47 lines
1.5 KiB
Scheme
47 lines
1.5 KiB
Scheme
#lang scheme/base
|
|
(require (lib "list.ss")
|
|
scheme/contract)
|
|
|
|
(define default-to-be-copied-module-specs
|
|
'(mzscheme
|
|
(lib "mred.ss" "mred")))
|
|
|
|
(define (make-make-servlet-namespace
|
|
#:to-be-copied-module-specs [to-be-copied-module-specs empty])
|
|
;; get the names of those modules.
|
|
(define (get-name spec)
|
|
(if (symbol? spec)
|
|
spec
|
|
(with-handlers ([exn? (lambda _ #f)])
|
|
((current-module-name-resolver) spec #f #f))))
|
|
(define to-be-copied-module-names
|
|
(map get-name
|
|
(append default-to-be-copied-module-specs
|
|
to-be-copied-module-specs)))
|
|
(lambda (#:additional-specs [additional-specs empty])
|
|
(define server-namespace (current-namespace))
|
|
(define new-namespace (make-base-empty-namespace))
|
|
(define additional-names (map get-name additional-specs))
|
|
(parameterize ([current-namespace new-namespace])
|
|
(namespace-require 'scheme/base)
|
|
(for-each (lambda (name)
|
|
(with-handlers ([exn? void])
|
|
(when name
|
|
(namespace-attach-module server-namespace name))))
|
|
(append to-be-copied-module-names
|
|
additional-names))
|
|
new-namespace)))
|
|
|
|
; XXX
|
|
(define module-spec? any/c)
|
|
(define make-servlet-namespace?
|
|
(->* ()
|
|
(#:additional-specs (listof module-spec?))
|
|
namespace?))
|
|
|
|
(provide/contract
|
|
[make-servlet-namespace? contract?]
|
|
[make-make-servlet-namespace
|
|
(->* ()
|
|
(#:to-be-copied-module-specs (listof module-spec?))
|
|
make-servlet-namespace?)]) |