.
original commit: 24955de0f7e89a4d94461fe8d30ed8186ec1500a
This commit is contained in:
parent
1922e08073
commit
0c4a60ec11
|
@ -105,6 +105,7 @@
|
||||||
list-box%
|
list-box%
|
||||||
list-control<%>
|
list-control<%>
|
||||||
make-eventspace
|
make-eventspace
|
||||||
|
make-namespace-with-mred
|
||||||
menu%
|
menu%
|
||||||
menu-bar%
|
menu-bar%
|
||||||
menu-item%
|
menu-item%
|
||||||
|
|
|
@ -6920,6 +6920,25 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define make-namespace-with-mred
|
||||||
|
(opt-lambda ([flag 'mred])
|
||||||
|
(unless (memq flag '(initial mred empty))
|
||||||
|
(raise-type-error 'make-namespace-with-mred
|
||||||
|
"flag symbol, one of 'mred, 'initial, or 'empty"
|
||||||
|
flag))
|
||||||
|
(let ([orig (current-namespace)]
|
||||||
|
[mred-name ((current-module-name-resolver)
|
||||||
|
'(lib "mred.ss" "mred") #f #f)]
|
||||||
|
[ns (make-namespace (if (eq? flag 'empty) 'empty 'initial))])
|
||||||
|
(parameterize ([current-namespace ns])
|
||||||
|
(namespace-attach-module orig mred-name)
|
||||||
|
(when (eq? flag 'mred)
|
||||||
|
(namespace-require '(lib "mred.ss" "mred"))
|
||||||
|
(namespace-require '(lib "class.ss"))))
|
||||||
|
ns)))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-syntax propagate
|
(define-syntax propagate
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
|
@ -7119,7 +7138,8 @@
|
||||||
text-editor-load-handler
|
text-editor-load-handler
|
||||||
application-about-handler
|
application-about-handler
|
||||||
application-preferences-handler
|
application-preferences-handler
|
||||||
current-eventspace-has-standard-menus?)
|
current-eventspace-has-standard-menus?
|
||||||
|
make-namespace-with-mred)
|
||||||
|
|
||||||
|
|
||||||
) ;; end of module
|
) ;; end of module
|
||||||
|
|
Loading…
Reference in New Issue
Block a user