namespaces: adding a "with-global" word to replace "global [ ] bind".
parent
928536be2a
commit
6417f36397
|
@ -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 -- )
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ( -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue