namespaces: Rename ``bind`` to ``with-variables``. Update a few places that called ``global [ ] with-variables`` to use ``with-global``.
parent
ac9fc4035f
commit
42f4dc36b2
|
@ -68,21 +68,21 @@ IN: compiler.cfg.intrinsics.simd.tests
|
||||||
: test-emit ( cpu rep quot -- node )
|
: test-emit ( cpu rep quot -- node )
|
||||||
[
|
[
|
||||||
[ new \ cpu ] 2dip '[
|
[ new \ cpu ] 2dip '[
|
||||||
test-compiler-env [ _ test-node @ ] bind
|
test-compiler-env [ _ test-node @ ] with-variables
|
||||||
] with-variable
|
] with-variable
|
||||||
] make-classes ; inline
|
] make-classes ; inline
|
||||||
|
|
||||||
: test-emit-literal ( cpu lit rep quot -- node )
|
: test-emit-literal ( cpu lit rep quot -- node )
|
||||||
[
|
[
|
||||||
[ new \ cpu ] 3dip '[
|
[ new \ cpu ] 3dip '[
|
||||||
test-compiler-env [ _ _ test-node-literal @ ] bind
|
test-compiler-env [ _ _ test-node-literal @ ] with-variables
|
||||||
] with-variable
|
] with-variable
|
||||||
] make-classes ; inline
|
] make-classes ; inline
|
||||||
|
|
||||||
: test-emit-nonliteral-rep ( cpu quot -- node )
|
: test-emit-nonliteral-rep ( cpu quot -- node )
|
||||||
[
|
[
|
||||||
[ new \ cpu ] dip '[
|
[ new \ cpu ] dip '[
|
||||||
test-compiler-env [ test-node-nonliteral-rep @ ] bind
|
test-compiler-env [ test-node-nonliteral-rep @ ] with-variables
|
||||||
] with-variable
|
] with-variable
|
||||||
] make-classes ; inline
|
] make-classes ; inline
|
||||||
|
|
||||||
|
|
|
@ -51,7 +51,7 @@ unit-test
|
||||||
|
|
||||||
[ 3 ]
|
[ 3 ]
|
||||||
[
|
[
|
||||||
global [ 3 \ foo set ] bind
|
global [ 3 \ foo set ] with-variables
|
||||||
\ foo [ global >n get namespaces.private:ndrop ] compile-call
|
\ foo [ global >n get namespaces.private:ndrop ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -59,20 +59,20 @@ unit-test
|
||||||
|
|
||||||
[ 3 ]
|
[ 3 ]
|
||||||
[
|
[
|
||||||
global [ 3 \ foo set ] bind
|
global [ 3 \ foo set ] with-variables
|
||||||
\ foo [ global [ get ] swap blech call ] compile-call
|
\ foo [ global [ get ] swap blech call ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 3 ]
|
[ 3 ]
|
||||||
[
|
[
|
||||||
global [ 3 \ foo set ] bind
|
global [ 3 \ foo set ] with-variables
|
||||||
\ foo [ global [ get ] swap >n call namespaces.private:ndrop ] compile-call
|
\ foo [ global [ get ] swap >n call namespaces.private:ndrop ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 3 ]
|
[ 3 ]
|
||||||
[
|
[
|
||||||
global [ 3 \ foo set ] bind
|
global [ 3 \ foo set ] with-variables
|
||||||
\ foo [ global [ get ] bind ] compile-call
|
\ foo [ global [ get ] with-variables ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 12 13 ] [
|
[ 12 13 ] [
|
||||||
|
|
|
@ -187,7 +187,7 @@ SYMBOL: node-count
|
||||||
} [
|
} [
|
||||||
nl print get keys natural-sort stack.
|
nl print get keys natural-sort stack.
|
||||||
] assoc-each
|
] assoc-each
|
||||||
] bind ;
|
] with-variables ;
|
||||||
|
|
||||||
: optimizer-report. ( word -- )
|
: optimizer-report. ( word -- )
|
||||||
make-report report. ;
|
make-report report. ;
|
||||||
|
|
|
@ -74,7 +74,7 @@ SYMBOL: infer-children-data
|
||||||
_ [
|
_ [
|
||||||
dup +bottom+ eq?
|
dup +bottom+ eq?
|
||||||
[ drop null-info ] [ value-info ] if
|
[ drop null-info ] [ value-info ] if
|
||||||
] bind
|
] with-variables
|
||||||
] map
|
] map
|
||||||
] 2map ;
|
] 2map ;
|
||||||
|
|
||||||
|
|
|
@ -26,7 +26,7 @@ M: mock-io-backend (monitor)
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: mock-io-backend link-info
|
M: mock-io-backend link-info
|
||||||
global [ link-info ] bind ;
|
global [ link-info ] with-variables ;
|
||||||
|
|
||||||
[ ] [ 0 counter boa dummy-monitor-created set ] unit-test
|
[ ] [ 0 counter boa dummy-monitor-created set ] unit-test
|
||||||
[ ] [ 0 counter boa dummy-monitor-disposed set ] unit-test
|
[ ] [ 0 counter boa dummy-monitor-disposed set ] unit-test
|
||||||
|
|
|
@ -7,7 +7,6 @@ io.encodings.utf8 io.files.private io.pathnames
|
||||||
io.sockets.private io.streams.duplex kernel libc locals math
|
io.sockets.private io.streams.duplex kernel libc locals math
|
||||||
math.parser sequences system threads unix unix.ffi
|
math.parser sequences system threads unix unix.ffi
|
||||||
vocabs ;
|
vocabs ;
|
||||||
EXCLUDE: namespaces => bind ;
|
|
||||||
EXCLUDE: io => read write ;
|
EXCLUDE: io => read write ;
|
||||||
EXCLUDE: io.sockets => accept ;
|
EXCLUDE: io.sockets => accept ;
|
||||||
IN: io.sockets.unix
|
IN: io.sockets.unix
|
||||||
|
|
|
@ -46,10 +46,10 @@ SYMBOL: locals
|
||||||
?rewrite-closures ;
|
?rewrite-closures ;
|
||||||
|
|
||||||
: parse-multi-def ( locals -- multi-def )
|
: parse-multi-def ( locals -- multi-def )
|
||||||
[ ")" [ make-local ] map-tokens ] bind <multi-def> ;
|
[ ")" [ make-local ] map-tokens ] with-variables <multi-def> ;
|
||||||
|
|
||||||
: parse-def ( name/paren locals -- def )
|
: parse-def ( name/paren locals -- def )
|
||||||
over "(" = [ nip parse-multi-def ] [ [ make-local ] bind <def> ] if ;
|
over "(" = [ nip parse-multi-def ] [ [ make-local ] with-variables <def> ] if ;
|
||||||
|
|
||||||
M: lambda-parser parse-quotation ( -- quotation )
|
M: lambda-parser parse-quotation ( -- quotation )
|
||||||
H{ } clone (parse-lambda) ;
|
H{ } clone (parse-lambda) ;
|
||||||
|
|
|
@ -50,13 +50,13 @@ C: <foo> foo
|
||||||
{ 1 2 } [
|
{ 1 2 } [
|
||||||
1 2 <foo> T{ foo f ?a ?b } match [
|
1 2 <foo> T{ foo f ?a ?b } match [
|
||||||
?a ?b
|
?a ?b
|
||||||
] bind
|
] with-variables
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ 1 2 } [
|
{ 1 2 } [
|
||||||
1 2 <foo> \ ?a \ ?b <foo> match [
|
1 2 <foo> \ ?a \ ?b <foo> match [
|
||||||
?a ?b
|
?a ?b
|
||||||
] bind
|
] with-variables
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ H{ { ?a ?a } } } [
|
{ H{ { ?a ?a } } } [
|
||||||
|
|
|
@ -48,7 +48,7 @@ MACRO: match-cond ( assoc -- )
|
||||||
[
|
[
|
||||||
first2
|
first2
|
||||||
[ [ dupd match ] curry ] dip
|
[ [ dupd match ] curry ] dip
|
||||||
[ bind ] curry rot
|
[ with-variables ] curry rot
|
||||||
[ ?if ] 2curry append
|
[ ?if ] 2curry append
|
||||||
] reduce ;
|
] reduce ;
|
||||||
|
|
||||||
|
@ -63,7 +63,7 @@ MACRO: match-cond ( assoc -- )
|
||||||
|
|
||||||
: match-replace ( object pattern1 pattern2 -- result )
|
: match-replace ( object pattern1 pattern2 -- result )
|
||||||
[ match [ "Pattern does not match" throw ] unless* ] dip swap
|
[ match [ "Pattern does not match" throw ] unless* ] dip swap
|
||||||
[ replace-patterns ] bind ;
|
[ replace-patterns ] with-variables ;
|
||||||
|
|
||||||
: ?1-tail ( seq -- tail/f )
|
: ?1-tail ( seq -- tail/f )
|
||||||
dup length zero? not [ rest ] [ drop f ] if ;
|
dup length zero? not [ rest ] [ drop f ] if ;
|
||||||
|
|
|
@ -26,11 +26,11 @@ C: <foo> foo
|
||||||
gensym [
|
gensym [
|
||||||
<mirror> [
|
<mirror> [
|
||||||
"foo" "name" set
|
"foo" "name" set
|
||||||
] bind
|
] with-variables
|
||||||
] [ name>> ] bi
|
] [ name>> ] bi
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ gensym <mirror> [ "compiled" off ] bind ] must-fail
|
[ gensym <mirror> [ "compiled" off ] with-variables ] must-fail
|
||||||
|
|
||||||
TUPLE: declared-mirror-test
|
TUPLE: declared-mirror-test
|
||||||
{ a integer initial: 0 } ;
|
{ a integer initial: 0 } ;
|
||||||
|
@ -39,10 +39,10 @@ TUPLE: declared-mirror-test
|
||||||
3 declared-mirror-test boa <mirror> [
|
3 declared-mirror-test boa <mirror> [
|
||||||
5 "a" set
|
5 "a" set
|
||||||
"a" get
|
"a" get
|
||||||
] bind
|
] with-variables
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 3 declared-mirror-test boa <mirror> [ t "a" set ] bind ] must-fail
|
[ 3 declared-mirror-test boa <mirror> [ t "a" set ] with-variables ] must-fail
|
||||||
|
|
||||||
TUPLE: color
|
TUPLE: color
|
||||||
{ red integer }
|
{ red integer }
|
||||||
|
|
|
@ -381,7 +381,7 @@ SYMBOL: ignore-ws
|
||||||
parser set
|
parser set
|
||||||
swap (transform)
|
swap (transform)
|
||||||
main set
|
main set
|
||||||
] bind ;
|
] with-variables ;
|
||||||
|
|
||||||
M: ebnf (transform) ( ast -- parser )
|
M: ebnf (transform) ( ast -- parser )
|
||||||
rules>> [ (transform) ] map last ;
|
rules>> [ (transform) ] map last ;
|
||||||
|
|
|
@ -112,7 +112,7 @@ DEFER: ?make-staging-image
|
||||||
"-output-image=" prepend ,
|
"-output-image=" prepend ,
|
||||||
"-pic=0" ,
|
"-pic=0" ,
|
||||||
] { } make
|
] { } make
|
||||||
] bind ;
|
] with-variables ;
|
||||||
|
|
||||||
: parse-vocab-manifest-file ( path -- vocab-manifest )
|
: parse-vocab-manifest-file ( path -- vocab-manifest )
|
||||||
utf8 file-lines [ "empty vocab manifest!" throw ] [
|
utf8 file-lines [ "empty vocab manifest!" throw ] [
|
||||||
|
|
|
@ -30,7 +30,7 @@ cache-directory [
|
||||||
"hello-ui" deploy-config [
|
"hello-ui" deploy-config [
|
||||||
bootstrap-profile staging-image-name file-name
|
bootstrap-profile staging-image-name file-name
|
||||||
"." split second
|
"." split second
|
||||||
] bind
|
] with-variables
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
|
[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
|
||||||
|
|
|
@ -84,11 +84,11 @@ IN: tools.deploy.macosx
|
||||||
[ "Contents/Resources" copy-resources ]
|
[ "Contents/Resources" copy-resources ]
|
||||||
[ "Contents/Frameworks" copy-libraries ] 2bi
|
[ "Contents/Frameworks" copy-libraries ] 2bi
|
||||||
bundle-name show-in-finder
|
bundle-name show-in-finder
|
||||||
] bind
|
] with-variables
|
||||||
] with-directory ;
|
] with-directory ;
|
||||||
|
|
||||||
: deploy-app-bundle? ( vocab -- ? )
|
: deploy-app-bundle? ( vocab -- ? )
|
||||||
deploy-config [ deploy-console? get not deploy-ui? get or ] bind ;
|
deploy-config [ deploy-console? get not deploy-ui? get or ] with-variables ;
|
||||||
|
|
||||||
M: macosx deploy* ( vocab -- )
|
M: macosx deploy* ( vocab -- )
|
||||||
! pass off to M: unix deploy* if we're building a console app
|
! pass off to M: unix deploy* if we're building a console app
|
||||||
|
|
|
@ -640,7 +640,7 @@ SYMBOL: deploy-vocab
|
||||||
"Saving final image" show
|
"Saving final image" show
|
||||||
save-image-and-exit
|
save-image-and-exit
|
||||||
] deploy-error-handler
|
] deploy-error-handler
|
||||||
] bind ;
|
] with-variables ;
|
||||||
|
|
||||||
: do-deploy ( -- )
|
: do-deploy ( -- )
|
||||||
"output-image" get
|
"output-image" get
|
||||||
|
|
|
@ -14,7 +14,7 @@ IN: tools.deploy.shaker.cocoa
|
||||||
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
|
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
|
||||||
|
|
||||||
H{ } clone \ pool [
|
H{ } clone \ pool [
|
||||||
global [
|
[
|
||||||
! Only keeps those methods that we actually call
|
! Only keeps those methods that we actually call
|
||||||
sent-messages get super-sent-messages get assoc-union
|
sent-messages get super-sent-messages get assoc-union
|
||||||
objc-methods [ assoc-intersect pool-values ] change
|
objc-methods [ assoc-intersect pool-values ] change
|
||||||
|
@ -34,7 +34,7 @@ H{ } clone \ pool [
|
||||||
! We need this for strip-stack-traces to work fully
|
! We need this for strip-stack-traces to work fully
|
||||||
{ message-senders super-message-senders }
|
{ message-senders super-message-senders }
|
||||||
[ get values compile ] each
|
[ get values compile ] each
|
||||||
] bind
|
] with-global
|
||||||
] with-variable
|
] with-variable
|
||||||
|
|
||||||
\ make-prepare-send reset-memoized
|
\ make-prepare-send reset-memoized
|
||||||
|
|
|
@ -22,5 +22,5 @@ M: unix deploy* ( vocab -- )
|
||||||
bundle-name "" [ copy-resources ] [ copy-libraries ] 3bi
|
bundle-name "" [ copy-resources ] [ copy-libraries ] 3bi
|
||||||
bundle-name normalize-path "Binary deployed to " "." surround print
|
bundle-name normalize-path "Binary deployed to " "." surround print
|
||||||
bundle-name webbrowser:open-file
|
bundle-name webbrowser:open-file
|
||||||
] bind
|
] with-variables
|
||||||
] with-directory ;
|
] with-directory ;
|
||||||
|
|
|
@ -40,5 +40,5 @@ M: windows deploy*
|
||||||
[ nip "" [ copy-resources ] [ copy-libraries ] 3bi ]
|
[ nip "" [ copy-resources ] [ copy-libraries ] 3bi ]
|
||||||
[ nip open-in-explorer ]
|
[ nip open-in-explorer ]
|
||||||
} 2cleave
|
} 2cleave
|
||||||
] bind
|
] with-variables
|
||||||
] with-directory ;
|
] with-directory ;
|
||||||
|
|
|
@ -49,7 +49,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
|
||||||
|
|
||||||
deploy-settings-theme
|
deploy-settings-theme
|
||||||
namespace <mapping> >>model
|
namespace <mapping> >>model
|
||||||
] bind ;
|
] with-variables ;
|
||||||
|
|
||||||
: find-deploy-gadget ( gadget -- deploy-gadget )
|
: find-deploy-gadget ( gadget -- deploy-gadget )
|
||||||
[ deploy-gadget? ] find-parent ;
|
[ deploy-gadget? ] find-parent ;
|
||||||
|
|
|
@ -161,7 +161,7 @@ TAG: array xml>item
|
||||||
|
|
||||||
: parse-fault ( xml -- fault-code fault-string )
|
: parse-fault ( xml -- fault-code fault-string )
|
||||||
first-child-tag first-child-tag first-child-tag
|
first-child-tag first-child-tag first-child-tag
|
||||||
xml>item [ "faultCode" get "faultString" get ] bind ;
|
xml>item [ "faultCode" get "faultString" get ] with-variables ;
|
||||||
|
|
||||||
: receive-rpc ( xml -- rpc )
|
: receive-rpc ( xml -- rpc )
|
||||||
dup main>> dup "methodCall" =
|
dup main>> dup "methodCall" =
|
||||||
|
|
|
@ -69,6 +69,6 @@ M: interpolated [undo-xml]
|
||||||
sort-keys values <enum> ;
|
sort-keys values <enum> ;
|
||||||
|
|
||||||
: undo-xml ( xml -- quot )
|
: undo-xml ( xml -- quot )
|
||||||
[undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
|
[undo-xml] '[ H{ } clone [ _ with-variables ] keep >enum ] ;
|
||||||
|
|
||||||
\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
|
\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
|
||||||
|
|
|
@ -120,7 +120,7 @@ TUPLE: pull-xml scope ;
|
||||||
text-now? get [ parse-text f ] [
|
text-now? get [ parse-text f ] [
|
||||||
get-char [ make-tag t ] [ f f ] if
|
get-char [ make-tag t ] [ f f ] if
|
||||||
] if text-now? set
|
] if text-now? set
|
||||||
] bind ;
|
] with-variables ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
|
|
@ -8,7 +8,7 @@ ARTICLE: "namespaces-combinators" "Namespace combinators"
|
||||||
make-assoc
|
make-assoc
|
||||||
with-scope
|
with-scope
|
||||||
with-variable
|
with-variable
|
||||||
bind
|
with-variables
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "namespaces-change" "Changing variable values"
|
ARTICLE: "namespaces-change" "Changing variable values"
|
||||||
|
@ -150,7 +150,7 @@ HELP: make-assoc
|
||||||
{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } }
|
{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } }
|
||||||
{ $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ;
|
{ $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ;
|
||||||
|
|
||||||
HELP: bind
|
HELP: with-variables
|
||||||
{ $values { "ns" assoc } { "quot" quotation } }
|
{ $values { "ns" assoc } { "quot" quotation } }
|
||||||
{ $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ;
|
{ $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ;
|
||||||
|
|
||||||
|
|
|
@ -5,13 +5,13 @@ IN: namespaces.tests
|
||||||
H{ } clone "test-namespace" set
|
H{ } clone "test-namespace" set
|
||||||
|
|
||||||
: test-namespace ( -- ? )
|
: test-namespace ( -- ? )
|
||||||
H{ } clone dup [ namespace = ] bind ;
|
H{ } clone dup [ namespace = ] with-variables ;
|
||||||
|
|
||||||
[ t ] [ test-namespace ] unit-test
|
[ t ] [ test-namespace ] unit-test
|
||||||
|
|
||||||
10 "some-global" set
|
10 "some-global" set
|
||||||
[ f ]
|
[ f ]
|
||||||
[ H{ } clone [ f "some-global" set "some-global" get ] bind ]
|
[ H{ } clone [ f "some-global" set "some-global" get ] with-variables ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
SYMBOL: test-initialize
|
SYMBOL: test-initialize
|
||||||
|
|
|
@ -55,10 +55,11 @@ PRIVATE>
|
||||||
: +@ ( n variable -- ) [ 0 or + ] change ; inline
|
: +@ ( n variable -- ) [ 0 or + ] change ; inline
|
||||||
: inc ( variable -- ) 1 swap +@ ; inline
|
: inc ( variable -- ) 1 swap +@ ; inline
|
||||||
: dec ( variable -- ) -1 swap +@ ; inline
|
: dec ( variable -- ) -1 swap +@ ; inline
|
||||||
: bind ( ns quot -- ) swap >n call ndrop ; inline
|
: with-variables ( ns quot -- ) swap >n call ndrop ; inline
|
||||||
: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ;
|
: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ;
|
||||||
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
|
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap with-variables ] keep ; inline
|
||||||
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
|
: with-scope ( quot -- ) 5 <hashtable> swap with-variables ; inline
|
||||||
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
|
: with-variable ( value key quot -- ) [ associate ] dip with-variables ; inline
|
||||||
: with-global ( quot -- ) global swap bind ; inline
|
: with-new-scope ( quot -- ) 5 <hashtable> swap with-variables ; inline
|
||||||
|
: with-global ( quot -- ) [ global ] dip with-variables ; inline
|
||||||
: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
|
: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
USING: namespaces parser ;
|
USING: namespaces parser ;
|
||||||
IN: vocabs.loader.test.a
|
IN: vocabs.loader.test.a
|
||||||
|
|
||||||
<< global [ "count-me" inc ] bind >>
|
<< global [ "count-me" inc ] with-variables >>
|
||||||
|
|
||||||
: v-l-t-a-hello ( -- a ) 4 ;
|
: v-l-t-a-hello ( -- a ) 4 ;
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: namespaces ;
|
USING: namespaces ;
|
||||||
IN: vocabs.loader.test.b
|
IN: vocabs.loader.test.b
|
||||||
|
|
||||||
<< global [ "count-me" inc ] bind >>
|
<< global [ "count-me" inc ] with-variables >>
|
||||||
|
|
||||||
: fred bob ;
|
: fred bob ;
|
|
@ -1,4 +1,4 @@
|
||||||
IN: vocabs.loader.test.g
|
IN: vocabs.loader.test.g
|
||||||
USING: vocabs.loader.test.f namespaces ;
|
USING: vocabs.loader.test.f namespaces ;
|
||||||
|
|
||||||
global [ "vocabs.loader.test.g" inc ] bind
|
[ "vocabs.loader.test.g" inc ] with-global
|
||||||
|
|
|
@ -11,7 +11,7 @@ TUPLE: coroutine resumecc exitcc originalcc ;
|
||||||
: cocreate ( quot -- co )
|
: cocreate ( quot -- co )
|
||||||
coroutine new
|
coroutine new
|
||||||
dup current-coro associate
|
dup current-coro associate
|
||||||
[ swapd , , \ bind ,
|
[ swapd , , \ with-variables ,
|
||||||
"Coroutine has terminated illegally." , \ throw ,
|
"Coroutine has terminated illegally." , \ throw ,
|
||||||
] [ ] make
|
] [ ] make
|
||||||
[ >>resumecc ] [ >>originalcc ] bi ;
|
[ >>resumecc ] [ >>originalcc ] bi ;
|
||||||
|
|
|
@ -63,7 +63,7 @@ ENUM: fcgi-protocol-status
|
||||||
FCGI_UNKNOWN_ROLE ;
|
FCGI_UNKNOWN_ROLE ;
|
||||||
|
|
||||||
:: debug-print ( print-quot -- )
|
:: debug-print ( print-quot -- )
|
||||||
global [ print-quot call flush ] bind ; inline
|
[ print-quot call flush ] with-global ; inline
|
||||||
|
|
||||||
! read either a 1 byte or 4 byte big endian integer
|
! read either a 1 byte or 4 byte big endian integer
|
||||||
: read-var-int ( -- n/f )
|
: read-var-int ( -- n/f )
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
IN: namespaces
|
IN: namespaces
|
||||||
USE: kernel-internals
|
USE: kernel-internals
|
||||||
: bind ( ns quot -- )
|
: with-variables ( ns quot -- )
|
||||||
swap >n call n> drop ;
|
swap >n call n> drop ;
|
||||||
|
|
||||||
"browser-dom" set-in
|
"browser-dom" set-in
|
||||||
|
@ -14,7 +14,7 @@ USE: kernel-internals
|
||||||
{ } "" "html" { "string" } alien-invoke ;
|
{ } "" "html" { "string" } alien-invoke ;
|
||||||
|
|
||||||
: bind-event ( name element quot -- )
|
: bind-event ( name element quot -- )
|
||||||
>function swap { } "" "bind" { "string" "function" } alien-invoke ;
|
>function swap { } "" "with-variables" { "string" "function" } alien-invoke ;
|
||||||
|
|
||||||
"scratchpad" set-in
|
"scratchpad" set-in
|
||||||
|
|
||||||
|
|
|
@ -159,7 +159,7 @@ VERTEX-FORMAT: collada-vertex-format
|
||||||
[
|
[
|
||||||
{ { up-axis y-up } { unit-ratio 1 } } [
|
{ { up-axis y-up } { unit-ratio 1 } } [
|
||||||
mesh>sources
|
mesh>sources
|
||||||
] bind
|
] with-variables
|
||||||
]
|
]
|
||||||
[ mesh>vertices ]
|
[ mesh>vertices ]
|
||||||
[ mesh>triangles ] tri ;
|
[ mesh>triangles ] tri ;
|
||||||
|
|
|
@ -82,7 +82,7 @@ TUPLE: material
|
||||||
[
|
[
|
||||||
ascii file-lines [ line>mtl ] each
|
ascii file-lines [ line>mtl ] each
|
||||||
md
|
md
|
||||||
] bind ;
|
] with-variables ;
|
||||||
|
|
||||||
VERTEX-FORMAT: obj-vertex-format
|
VERTEX-FORMAT: obj-vertex-format
|
||||||
{ "POSITION" float-components 3 f }
|
{ "POSITION" float-components 3 f }
|
||||||
|
@ -162,5 +162,5 @@ M: obj-models stream>models
|
||||||
[
|
[
|
||||||
[ line>obj ] each-stream-line push-current-model
|
[ line>obj ] each-stream-line push-current-model
|
||||||
models get
|
models get
|
||||||
] bind ;
|
] with-variables ;
|
||||||
|
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: monads.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ nothing ] [
|
[ nothing ] [
|
||||||
111 just [ maybe-monad fail ] bind
|
111 just [ maybe-monad fail ] with-variables
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 100 ] [
|
[ 100 ] [
|
||||||
|
@ -26,7 +26,7 @@ IN: monads.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ { } ] [
|
[ { } ] [
|
||||||
{ 1 2 3 } [ drop "OOPS" array-monad fail ] bind
|
{ 1 2 3 } [ drop "OOPS" array-monad fail ] with-variables
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 5 ] [
|
[ 5 ] [
|
||||||
|
@ -34,7 +34,7 @@ IN: monads.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 8 ] [
|
[ 8 ] [
|
||||||
5 state-monad return [ 3 + state-monad return ] bind
|
5 state-monad return [ 3 + state-monad return ] with-variables
|
||||||
"initial state" run-st
|
"initial state" run-st
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -52,9 +52,9 @@ IN: monads.tests
|
||||||
|
|
||||||
[ 15 ] [
|
[ 15 ] [
|
||||||
f state-monad return
|
f state-monad return
|
||||||
[ drop get-st ] bind
|
[ drop get-st ] with-variables
|
||||||
[ 4 + put-st ] bind
|
[ 4 + put-st ] with-variables
|
||||||
[ drop get-st ] bind
|
[ drop get-st ] with-variables
|
||||||
11 run-st
|
11 run-st
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -104,12 +104,12 @@ LAZY: nats-from ( n -- list )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 6 ] [
|
[ 6 ] [
|
||||||
f reader-monad return [ drop ask ] bind [ 1 + ] local 5 run-reader
|
f reader-monad return [ drop ask ] with-variables [ 1 + ] local 5 run-reader
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f { 1 2 3 } ] [
|
[ f { 1 2 3 } ] [
|
||||||
5 writer-monad return
|
5 writer-monad return
|
||||||
[ drop { 1 2 3 } tell ] bind
|
[ drop { 1 2 3 } tell ] with-variables
|
||||||
run-writer
|
run-writer
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -423,7 +423,7 @@ PRIVATE>
|
||||||
[ cl-current-device set ] when*
|
[ cl-current-device set ] when*
|
||||||
[ cl-current-context set ] when*
|
[ cl-current-context set ] when*
|
||||||
] 3curry H{ } make-assoc
|
] 3curry H{ } make-assoc
|
||||||
] dip bind ; inline
|
] dip with-variable ; inline
|
||||||
|
|
||||||
: cl-platforms ( -- platforms )
|
: cl-platforms ( -- platforms )
|
||||||
0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
|
0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
|
||||||
|
|
|
@ -68,7 +68,7 @@ CONSTANT: stylesheet
|
||||||
[
|
[
|
||||||
stylesheet clone [
|
stylesheet clone [
|
||||||
[ print-element ] with-default-style
|
[ print-element ] with-default-style
|
||||||
] bind
|
] with-variables
|
||||||
] make-pane
|
] make-pane
|
||||||
dup page-theme ;
|
dup page-theme ;
|
||||||
|
|
||||||
|
|
|
@ -115,7 +115,7 @@ M: circle perimeter radius>> pi * 2 * ;"""
|
||||||
{ "Useful words are " { $link get-global } ", " { $link set-global } }
|
{ "Useful words are " { $link get-global } ", " { $link set-global } }
|
||||||
"Factor idiom for changing a particular namespace"
|
"Factor idiom for changing a particular namespace"
|
||||||
{ $code """SYMBOL: king
|
{ $code """SYMBOL: king
|
||||||
global [ "Henry VIII" king set ] bind"""
|
global [ "Henry VIII" king set ] with-variables"""
|
||||||
}
|
}
|
||||||
{ $code "with-scope" }
|
{ $code "with-scope" }
|
||||||
{ $code "namestack" }
|
{ $code "namestack" }
|
||||||
|
|
Loading…
Reference in New Issue