namespaces: adding a "with-global" word to replace "global [ ] bind".

db4
John Benediktsson 2011-10-13 17:21:59 -07:00
parent 928536be2a
commit 6417f36397
11 changed files with 19 additions and 18 deletions

View File

@ -330,7 +330,7 @@ M: f ' drop \ f type-number ;
! Words
: word-sub-primitive ( word -- obj )
global [ target-word ] bind sub-primitives get at ;
[ target-word ] with-global sub-primitives get at ;
: emit-word ( word -- )
[

View File

@ -62,10 +62,10 @@ SYMBOL: main-vocab-hook
] if ;
: default-cli-args ( -- )
global [
[
"e" off
"user-init" on
main-vocab "run" set
] bind ;
] with-global ;
[ default-cli-args ] "command-line" add-startup-hook

View File

@ -33,7 +33,7 @@ SYMBOL: compiled
} 1|| not ;
: compiler-message ( string -- )
"trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
"trace-compilation" get [ [ print flush ] with-global ] [ drop ] if ;
: start ( word -- )
dup name>> compiler-message

View File

@ -10,7 +10,7 @@ classes compiler.units generic.standard generic.single vocabs
init kernel.private io.encodings accessors math.order
destructors source-files parser classes.tuple.parser
effects.parser lexer generic.parser strings.parser vocabs.loader
vocabs.parser source-files.errors ;
vocabs.parser source-files.errors namespaces ;
IN: debugger
GENERIC: error-help ( error -- topic )
@ -65,7 +65,7 @@ M: string error. print ;
: print-error ( error -- )
[ error. flush ] curry
[ global [ "Error in print-error!" print drop ] bind ]
[ [ "Error in print-error!" print drop ] with-global ]
recover ;
: :error ( -- )

View File

@ -15,12 +15,12 @@ IN: debugger.threads
! ( error thread -- )
[
dup initial-thread get-global eq? [ die ] [
global [
[
error-in-thread. nl
print-error nl
:c
flush
] bind
] with-global
stop
] if
] thread-error-hook set-global

View File

@ -272,7 +272,7 @@ SYMBOL: params
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )
development? get-global [ global [ refresh-all ] bind ] when ;
development? get-global [ [ refresh-all ] with-global ] when ;
LOG: httpd-benchmark DEBUG

View File

@ -66,7 +66,7 @@ SYMBOL: data-mode
"220 OK\r\n" write flush t
]
}
{ [ data-mode get ] [ dup global [ print ] bind t ] }
{ [ data-mode get ] [ dup [ print ] with-global t ] }
[ "500 ERROR\r\n" write flush t ]
} cond nip [ process ] when ;
@ -80,7 +80,7 @@ SYMBOL: data-mode
1 minutes timeouts
"220 hello\r\n" write flush
process
global [ flush ] bind
[ flush ] with-global
] with-stream
] with-disposal
] with-test-context

View File

@ -267,7 +267,7 @@ SYMBOL: drag-timer
} 0&& nip ;
: update-click# ( button -- )
global [
[
dup multi-click? [
hand-click# inc
] [
@ -275,7 +275,7 @@ SYMBOL: drag-timer
] if
hand-last-button set
nano-count hand-last-time set
] bind ;
] with-global ;
: update-clicked ( -- )
hand-gadget get-global hand-clicked set-global

View File

@ -21,11 +21,11 @@ PRIVATE>
: set ( value variable -- ) namespace set-at ;
: on ( variable -- ) t swap set ; inline
: off ( variable -- ) f swap set ; inline
: get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-at ;
: get-global ( variable -- value ) global at ; inline
: set-global ( value variable -- ) global set-at ; inline
: change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
: change-global ( variable quot -- ) [ global ] dip change-at ; inline
: +@ ( n variable -- ) [ 0 or + ] change ;
: +@ ( n variable -- ) [ 0 or + ] change ; inline
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; inline
@ -33,4 +33,5 @@ PRIVATE>
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
: with-global ( quot -- ) global swap bind ; inline
: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline

View File

@ -59,6 +59,6 @@ INSTANCE: curses-listener-stream plain-writer
] with-curses ;
: test-listener ( -- )
global [ run-listener ] bind ;
[ run-listener ] with-global ;
MAIN: run-listener

View File

@ -254,7 +254,7 @@ This is the body of the second test.
1 minutes timeouts
"+OK POP3 server ready\r\n" write flush
process
global [ flush ] bind
[ flush ] with-global
] with-stream
] with-disposal
] with-test-context