] 3keep filter ;
:: (sieve) ( prime c -- )
- [let | p [ c from ]
- newc [ <channel> ] |
- p prime to
- [ newc p c filter ] "Filter" spawn drop
- prime newc (sieve)
- ] ;
+ c from :> p
+ <channel> :> newc
+ p prime to
+ [ newc p c filter ] "Filter" spawn drop
+ prime newc (sieve) ;
: sieve ( prime -- )
#! Send prime numbers to 'prime' channel
] [ emit-primitive ] if ;
:: inline-alien ( node quot test -- )
- [let | infos [ node node-input-infos ] |
- infos test call
- [ infos quot call ]
- [ node emit-primitive ]
- if
- ] ; inline
+ node node-input-infos :> infos
+ infos test call
+ [ infos quot call ]
+ [ node emit-primitive ] if ;
: inline-alien-getter? ( infos -- ? )
[ first class>> c-ptr class<= ]
2 + cells array ^^allot ;
:: emit-<array> ( node -- )
- [let | len [ node node-input-infos first literal>> ] |
- len expand-<array>? [
- [let | elt [ ds-pop ]
- reg [ len ^^allot-array ] |
- ds-drop
- len reg array store-length
- len reg elt array store-initial-element
- reg ds-push
- ]
- ] [ node emit-primitive ] if
- ] ;
+ node node-input-infos first literal>> :> len
+ len expand-<array>? [
+ ds-pop :> elt
+ len ^^allot-array :> reg
+ ds-drop
+ len reg array store-length
+ len reg elt array store-initial-element
+ reg ds-push
+ ] [ node emit-primitive ] if ;
: expand-(byte-array)? ( obj -- ? )
dup integer? [ 0 1024 between? ] [ drop f ] if ;
PRIVATE>
:: live-out? ( vreg node -- ? )
- [let | def [ vreg def-of ] |
- {
- { [ node def eq? ] [ vreg uses-of def only? not ] }
- { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
- [ f ]
- } cond
- ] ;
+ vreg def-of :> def
+ {
+ { [ node def eq? ] [ vreg uses-of def only? not ] }
+ { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
+ [ f ]
+ } cond ;
2bi ;
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
- [let* | new-live-outputs [ inputs outputs filter-corresponding make-values ]
- live-outputs [ outputs filter-live ] |
- new-live-outputs
- live-outputs
- live-outputs
- new-live-outputs
- drop-values
- ] ;
+ inputs outputs filter-corresponding make-values :> new-live-outputs
+ outputs filter-live :> live-outputs
+ new-live-outputs
+ live-outputs
+ live-outputs
+ new-live-outputs
+ drop-values ;
: drop-call-recursive-outputs ( node -- #shuffle )
dup [ label>> return>> in-d>> ] [ out-d>> ] bi
tri 3array ;
:: drop-recursive-inputs ( node -- shuffle )
- [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
- new-outputs [ shuffle out-d>> ] |
- node new-outputs
- [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
- shuffle
- ] ;
+ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs :> shuffle
+ shuffle out-d>> :> new-outputs
+ node new-outputs
+ [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
+ shuffle ;
:: drop-recursive-outputs ( node -- shuffle )
- [let* | return [ node label>> return>> ]
- new-inputs [ return in-d>> filter-live ]
- new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
- return
- [ new-inputs >>in-d new-outputs >>out-d drop ]
- [ drop-dead-outputs ]
- bi
- ] ;
+ node label>> return>> :> return
+ return in-d>> filter-live :> new-inputs
+ return [ in-d>> ] [ out-d>> ] bi filter-corresponding :> new-outputs
+ return
+ [ new-inputs >>in-d new-outputs >>out-d drop ]
+ [ drop-dead-outputs ]
+ bi ;
M: #recursive remove-dead-code* ( node -- nodes )
[ drop-recursive-inputs ]
filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
- [let* | new-outputs [ outputs make-values ]
- live-outputs [ outputs filter-live ] |
- new-outputs
- live-outputs
- outputs
- new-outputs
- drop-values
- ] ;
+ outputs make-values :> new-outputs
+ outputs filter-live :> live-outputs
+ new-outputs
+ live-outputs
+ outputs
+ new-outputs
+ drop-values ;
: drop-dead-outputs ( node -- #shuffle )
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
\ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
:: (comparison-constraints) ( in1 in2 op -- constraint )
- [let | i1 [ in1 value-info interval>> ]
- i2 [ in2 value-info interval>> ] |
- in1 i1 i2 op assumption is-in-interval
- in2 i2 i1 op swap-comparison assumption is-in-interval
- /\
- ] ;
+ in1 value-info interval>> :> i1
+ in2 value-info interval>> :> i2
+ in1 i1 i2 op assumption is-in-interval
+ in2 i2 i1 op swap-comparison assumption is-in-interval
+ /\ ;
:: comparison-constraints ( in1 in2 out op -- constraint )
in1 in2 op (comparison-constraints) out t-->
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
:: compress-path ( source assoc -- destination )
- [let | destination [ source assoc at ] |
- source destination = [ source ] [
- [let | destination' [ destination assoc compress-path ] |
- destination' destination = [
- destination' source assoc set-at
- ] unless
- destination'
- ]
- ] if
- ] ;
+ source assoc at :> destination
+ source destination = [ source ] [
+ destination assoc compress-path :> destination'
+ destination' destination = [
+ destination' source assoc set-at
+ ] unless
+ destination'
+ ] if ;
IN: concurrency.exchangers.tests\r
\r
:: exchanger-test ( -- string )\r
- [let |\r
- ex [ <exchanger> ]\r
- c [ 2 <count-down> ]\r
- v1! [ f ]\r
- v2! [ f ]\r
- pr [ <promise> ] |\r
+ <exchanger> :> ex\r
+ 2 <count-down> :> c\r
+ f :> v1!\r
+ f :> v2!\r
+ <promise> :> pr\r
\r
- [\r
- c await\r
- v1 ", " v2 3append pr fulfill\r
- ] "Awaiter" spawn drop\r
+ [\r
+ c await\r
+ v1 ", " v2 3append pr fulfill\r
+ ] "Awaiter" spawn drop\r
\r
- [\r
- "Goodbye world" ex exchange v1! c count-down\r
- ] "Exchanger 1" spawn drop\r
+ [\r
+ "Goodbye world" ex exchange v1! c count-down\r
+ ] "Exchanger 1" spawn drop\r
\r
- [\r
- "Hello world" ex exchange v2! c count-down\r
- ] "Exchanger 2" spawn drop\r
+ [\r
+ "Hello world" ex exchange v2! c count-down\r
+ ] "Exchanger 2" spawn drop\r
\r
- pr ?promise\r
- ] ;\r
+ pr ?promise ;\r
\r
[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test\r
IN: concurrency.flags.tests\r
\r
:: flag-test-1 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ f raise-flag ] "Flag test" spawn drop\r
- f lower-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ f raise-flag ] "Flag test" spawn drop\r
+ f lower-flag\r
+ f value>> ;\r
\r
[ f ] [ flag-test-1 ] unit-test\r
\r
:: flag-test-2 ( -- ? )\r
- [let | f [ <flag> ] |\r
- [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
- f lower-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
+ f lower-flag\r
+ f value>> ;\r
\r
[ f ] [ flag-test-2 ] unit-test\r
\r
:: flag-test-3 ( -- val )\r
- [let | f [ <flag> ] |\r
- f raise-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ f raise-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-3 ] unit-test\r
\r
:: flag-test-4 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ f raise-flag ] "Flag test" spawn drop\r
- f wait-for-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ f raise-flag ] "Flag test" spawn drop\r
+ f wait-for-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-4 ] unit-test\r
\r
:: flag-test-5 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
- f wait-for-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
+ f wait-for-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-5 ] unit-test\r
\r
IN: concurrency.locks.tests\r
\r
:: lock-test-0 ( -- v )\r
- [let | v [ V{ } clone ]\r
- c [ 2 <count-down> ] |\r
-\r
- [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v\r
- ] ;\r
+ V{ } clone :> v\r
+ 2 <count-down> :> c\r
+\r
+ [\r
+ yield\r
+ 1 v push\r
+ yield\r
+ 2 v push\r
+ c count-down\r
+ ] "Lock test 1" spawn drop\r
+\r
+ [\r
+ yield\r
+ 3 v push\r
+ yield\r
+ 4 v push\r
+ c count-down\r
+ ] "Lock test 2" spawn drop\r
+\r
+ c await\r
+ v ;\r
\r
:: lock-test-1 ( -- v )\r
- [let | v [ V{ } clone ]\r
- l [ <lock> ]\r
- c [ 2 <count-down> ] |\r
-\r
- [\r
- l [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- l [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v\r
- ] ;\r
+ V{ } clone :> v\r
+ <lock> :> l\r
+ 2 <count-down> :> c\r
+\r
+ [\r
+ l [\r
+ yield\r
+ 1 v push\r
+ yield\r
+ 2 v push\r
+ ] with-lock\r
+ c count-down\r
+ ] "Lock test 1" spawn drop\r
+\r
+ [\r
+ l [\r
+ yield\r
+ 3 v push\r
+ yield\r
+ 4 v push\r
+ ] with-lock\r
+ c count-down\r
+ ] "Lock test 2" spawn drop\r
+\r
+ c await\r
+ v ;\r
\r
[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test\r
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test\r
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test\r
\r
:: rw-lock-test-1 ( -- v )\r
- [let | l [ <rw-lock> ]\r
- c [ 1 <count-down> ]\r
- c' [ 1 <count-down> ]\r
- c'' [ 4 <count-down> ]\r
- v [ V{ } clone ] |\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- yield\r
- 3 v push\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 4 v push\r
- 1 seconds sleep\r
- 5 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 2 v push\r
- c' count-down\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 4" spawn drop\r
-\r
- [\r
- c' await\r
- l [\r
- 6 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 5" spawn drop\r
-\r
- c'' await\r
- v\r
- ] ;\r
+ <rw-lock> :> l\r
+ 1 <count-down> :> c\r
+ 1 <count-down> :> c'\r
+ 4 <count-down> :> c''\r
+ V{ } clone :> v\r
+\r
+ [\r
+ l [\r
+ 1 v push\r
+ c count-down\r
+ yield\r
+ 3 v push\r
+ ] with-read-lock\r
+ c'' count-down\r
+ ] "R/W lock test 1" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 4 v push\r
+ 1 seconds sleep\r
+ 5 v push\r
+ ] with-write-lock\r
+ c'' count-down\r
+ ] "R/W lock test 2" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 2 v push\r
+ c' count-down\r
+ ] with-read-lock\r
+ c'' count-down\r
+ ] "R/W lock test 4" spawn drop\r
+\r
+ [\r
+ c' await\r
+ l [\r
+ 6 v push\r
+ ] with-write-lock\r
+ c'' count-down\r
+ ] "R/W lock test 5" spawn drop\r
+\r
+ c'' await\r
+ v ;\r
\r
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test\r
\r
:: rw-lock-test-2 ( -- v )\r
- [let | l [ <rw-lock> ]\r
- c [ 1 <count-down> ]\r
- c' [ 2 <count-down> ]\r
- v [ V{ } clone ] |\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- 1 seconds sleep\r
- 2 v push\r
- ] with-write-lock\r
- c' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 3 v push\r
- ] with-read-lock\r
- c' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- c' await\r
- v\r
- ] ;\r
+ <rw-lock> :> l\r
+ 1 <count-down> :> c\r
+ 2 <count-down> :> c'\r
+ V{ } clone :> v\r
+\r
+ [\r
+ l [\r
+ 1 v push\r
+ c count-down\r
+ 1 seconds sleep\r
+ 2 v push\r
+ ] with-write-lock\r
+ c' count-down\r
+ ] "R/W lock test 1" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 3 v push\r
+ ] with-read-lock\r
+ c' count-down\r
+ ] "R/W lock test 2" spawn drop\r
+\r
+ c' await\r
+ v ;\r
\r
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test\r
\r
! Test lock timeouts\r
:: lock-timeout-test ( -- v )\r
- [let | l [ <lock> ] |\r
- [\r
- l [ 1 seconds sleep ] with-lock\r
- ] "Lock holder" spawn drop\r
+ <lock> :> l\r
\r
- [\r
- l 1/10 seconds [ ] with-lock-timeout\r
- ] "Lock timeout-er" spawn-linked drop\r
+ [\r
+ l [ 1 seconds sleep ] with-lock\r
+ ] "Lock holder" spawn drop\r
+\r
+ [\r
+ l 1/10 seconds [ ] with-lock-timeout\r
+ ] "Lock timeout-er" spawn-linked drop\r
\r
- receive\r
- ] ;\r
+ receive ;\r
\r
[ lock-timeout-test ] [\r
thread>> name>> "Lock timeout-er" =\r
[
line new-disposable
- [let* | open-font [ font cache-font ]
- line [ string open-font font foreground>> <CTLine> |CFRelease ]
-
- rect [ line line-rect ]
- (loc) [ rect origin>> CGPoint>loc ]
- (dim) [ rect size>> CGSize>dim ]
- (ext) [ (loc) (dim) v+ ]
- loc [ (loc) [ floor ] map ]
- ext [ (loc) (dim) [ + ceiling ] 2map ]
- dim [ ext loc [ - >integer 1 max ] 2map ]
- metrics [ open-font line compute-line-metrics ] |
-
- line >>line
-
- metrics >>metrics
-
- dim [
- {
- [ font dim fill-background ]
- [ loc dim line string fill-selection-background ]
- [ loc set-text-position ]
- [ [ line ] dip CTLineDraw ]
- } cleave
- ] make-bitmap-image >>image
-
- metrics loc dim line-loc >>loc
-
- metrics metrics>dim >>dim
- ]
+ font cache-font :> open-font
+ string open-font font foreground>> <CTLine> |CFRelease :> line
+
+ line line-rect :> rect
+ rect origin>> CGPoint>loc :> (loc)
+ rect size>> CGSize>dim :> (dim)
+ (loc) (dim) v+ :> (ext)
+ (loc) [ floor ] map :> loc
+ (loc) (dim) [ + ceiling ] 2map :> ext
+ ext loc [ - >integer 1 max ] 2map :> dim
+ open-font line compute-line-metrics :> metrics
+
+ line >>line
+
+ metrics >>metrics
+
+ dim [
+ {
+ [ font dim fill-background ]
+ [ loc dim line string fill-selection-background ]
+ [ loc set-text-position ]
+ [ [ line ] dip CTLineDraw ]
+ } cleave
+ ] make-bitmap-image >>image
+
+ metrics loc dim line-loc >>loc
+
+ metrics metrics>dim >>dim
] with-destructors ;
M: line dispose* line>> CFRelease ;
"'[ [ _ key? ] all? ] filter"\r
"[ [ key? ] curry all? ] curry filter"\r
}\r
-"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a “let” form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"\r
+"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"\r
{ $code\r
"'[ 3 _ + 4 _ / ]"\r
- "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"\r
+ "[| a b | 3 a + 4 b / ]"\r
} ;\r
\r
ARTICLE: "fry" "Fried quotations"\r
! Password recovery support\r
\r
:: issue-ticket ( email username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user email>> length 0 > [\r
- user email>> email = [\r
- user\r
- 256 random-bits >hex >>ticket\r
- dup provider update-user\r
- ] [ f ] if\r
+ username provider get-user :> user\r
+ user [\r
+ user email>> length 0 > [\r
+ user email>> email = [\r
+ user\r
+ 256 random-bits >hex >>ticket\r
+ dup provider update-user\r
] [ f ] if\r
] [ f ] if\r
- ] ;\r
+ ] [ f ] if ;\r
\r
:: claim-ticket ( ticket username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user ticket>> ticket = [\r
- user f >>ticket dup provider update-user\r
- ] [ f ] if\r
+ username provider get-user :> user\r
+ user [\r
+ user ticket>> ticket = [\r
+ user f >>ticket dup provider update-user\r
] [ f ] if\r
- ] ;\r
+ ] [ f ] if ;\r
\r
! For configuration\r
\r
] unit-test
[ "Oops, I accidentally the whole economy..." ] [
- [let | noun [ "economy" ] |
+ [let
+ "economy" :> noun
[ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer
]
] unit-test
] dip set-at ;
: xml>gb-data ( stream -- mapping ranges )
- [let | mapping [ H{ } clone ] ranges [ V{ } clone ] |
+ [let
+ H{ } clone :> mapping V{ } clone :> ranges
[
dup contained? [
dup name>> main>> {
[ 2drop ]
} case
] [ drop ] if
- ] each-element mapping ranges
+ ] each-element mapping ranges
] ;
: unlinear ( num -- bytes )
! Killed processes were exiting with code 0 on FreeBSD
[ f ] [
- [let | p [ <promise> ]
- s [ <promise> ] |
- [
- "sleep 1000" run-detached
- [ p fulfill ] [ wait-for-process s fulfill ] bi
- ] in-thread
-
- p ?promise handle>> 9 kill drop
- s ?promise 0 =
+ [let
+ <promise> :> p
+ <promise> :> s
+ [
+ "sleep 1000" run-detached
+ [ p fulfill ] [ wait-for-process s fulfill ] bi
+ ] in-thread
+
+ p ?promise handle>> 9 kill drop
+ s ?promise 0 =
]
] unit-test
MapViewOfFile [ win32-error=0/f ] keep ;
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
- [let | lo [ length 32 bits ]
- hi [ length -32 shift 32 bits ] |
- { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
- path access-mode create-mode 0 open-file |dispose
- dup handle>> f protect hi lo f create-file-mapping |dispose
- dup handle>> access 0 0 0 map-view-of-file
- ] with-privileges
- ] ;
+ length 32 bits :> lo
+ length -32 shift 32 bits :> hi
+ { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
+ path access-mode create-mode 0 open-file |dispose
+ dup handle>> f protect hi lo f create-file-mapping |dispose
+ dup handle>> access 0 0 0 map-view-of-file
+ ] with-privileges ;
TUPLE: win32-mapped-file file mapping ;
'[ first { +modify-file+ } _ queue-change ] each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
- [let | path [ path normalize-path ] |
- path mailbox macosx-monitor new-monitor
- dup [ enqueue-notifications ] curry
- path 1array 0 0 <event-stream> >>handle
- ] ;
+ path normalize-path :> path
+ path mailbox macosx-monitor new-monitor
+ dup [ enqueue-notifications ] curry
+ path 1array 0 0 <event-stream> >>handle ;
M: macosx-monitor dispose* handle>> dispose ;
[| buf size rwflag password! |
password [ B{ 0 } password! ] unless
- [let | len [ password strlen ] |
- buf password len 1 + size min memcpy
- len
- ]
+ password strlen :> len
+ buf password len 1 + size min memcpy
+ len
] alien-callback ;
: default-pasword ( ctx -- alien )
[ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
- [let | matrix [ old length 1 + new length 1 + init call ] |\r
- old length [| i |\r
- new length\r
- [| j | i j matrix old new step loop-step ] each\r
- ] each matrix ] ; inline\r
+ old length 1 + new length 1 + init call :> matrix\r
+ old length [| i |\r
+ new length\r
+ [| j | i j matrix old new step loop-step ] each\r
+ ] each matrix ; inline\r
PRIVATE>\r
\r
: levenshtein ( old new -- n )\r
M: an-observer model-changed nip [ 1 + ] change-i drop ;\r
\r
[ 1 0 ] [\r
- [let* | m1 [ 1 <model> ]\r
- m2 [ 2 <model> ]\r
- c [ { m1 m2 } <product> ]\r
- o1 [ an-observer new ]\r
- o2 [ an-observer new ] |\r
+ [let\r
+ 1 <model> :> m1\r
+ 2 <model> :> m2\r
+ { m1 m2 } <product> :> c\r
+ an-observer new :> o1\r
+ an-observer new :> o2\r
\r
o1 m1 add-connection\r
o2 m2 add-connection\r
: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline
M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
- [let* | shift [ bitmap-node shift>> ]
- bit [ hashcode shift bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- nodes [ bitmap-node nodes>> ] |
- bitmap bit bitand 0 eq? [ f ] [
- key hashcode
- bit bitmap index nodes nth-unsafe
- (entry-at)
- ] if
- ] ;
+ bitmap-node shift>> :> shift
+ hashcode shift bitpos :> bit
+ bitmap-node bitmap>> :> bitmap
+ bitmap-node nodes>> :> nodes
+ bitmap bit bitand 0 eq? [ f ] [
+ key hashcode
+ bit bitmap index nodes nth-unsafe
+ (entry-at)
+ ] if ;
M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf )
- [let* | shift [ bitmap-node shift>> ]
- bit [ hashcode shift bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- idx [ bit bitmap index ]
- nodes [ bitmap-node nodes>> ] |
- bitmap bit bitand 0 eq? [
- [let | new-leaf [ value key hashcode <leaf-node> ] |
- bitmap bit bitor
- new-leaf idx nodes insert-nth
+ bitmap-node shift>> :> shift
+ hashcode shift bitpos :> bit
+ bitmap-node bitmap>> :> bitmap
+ bit bitmap index :> idx
+ bitmap-node nodes>> :> nodes
+
+ bitmap bit bitand 0 eq? [
+ value key hashcode <leaf-node> :> new-leaf
+ bitmap bit bitor
+ new-leaf idx nodes insert-nth
+ shift
+ <bitmap-node>
+ new-leaf
+ ] [
+ idx nodes nth :> n
+ shift radix-bits + value key hashcode n (new-at) :> new-leaf :> n'
+ n n' eq? [
+ bitmap-node
+ ] [
+ bitmap
+ n' idx nodes new-nth
shift
<bitmap-node>
- new-leaf
- ]
- ] [
- [let | n [ idx nodes nth ] |
- shift radix-bits + value key hashcode n (new-at)
- [let | new-leaf [ ] n' [ ] |
- n n' eq? [
- bitmap-node
- ] [
- bitmap
- n' idx nodes new-nth
- shift
- <bitmap-node>
- ] if
- new-leaf
- ]
- ]
- ] if
- ] ;
+ ] if
+ new-leaf
+ ]
+ ] if ;
M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
- [let | bit [ hashcode bitmap-node shift>> bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- nodes [ bitmap-node nodes>> ]
- shift [ bitmap-node shift>> ] |
- bit bitmap bitand 0 eq? [ bitmap-node ] [
- [let* | idx [ bit bitmap index ]
- n [ idx nodes nth-unsafe ]
- n' [ key hashcode n (pluck-at) ] |
- n n' eq? [
- bitmap-node
- ] [
- n' [
- bitmap
- n' idx nodes new-nth
- shift
- <bitmap-node>
- ] [
- bitmap bit eq? [ f ] [
- bitmap bit bitnot bitand
- idx nodes remove-nth
- shift
- <bitmap-node>
- ] if
- ] if
+ hashcode bitmap-node shift>> bitpos :> bit
+ bitmap-node bitmap>> :> bitmap
+ bitmap-node nodes>> :> nodes
+ bitmap-node shift>> :> shift
+ bit bitmap bitand 0 eq? [ bitmap-node ] [
+ bit bitmap index :> idx
+ idx nodes nth-unsafe :> n
+ key hashcode n (pluck-at) :> n'
+ n n' eq? [
+ bitmap-node
+ ] [
+ n' [
+ bitmap
+ n' idx nodes new-nth
+ shift
+ <bitmap-node>
+ ] [
+ bitmap bit eq? [ f ] [
+ bitmap bit bitnot bitand
+ idx nodes remove-nth
+ shift
+ <bitmap-node>
] if
- ]
+ ] if
] if
- ] ;
+ ] if ;
M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ;
M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node )
hashcode collision-node hashcode>> eq? [
- [let | idx [ key hashcode collision-node find-index drop ] |
- idx [
- idx collision-node leaves>> smash [
- collision-node hashcode>>
- <collision-node>
- ] when
- ] [ collision-node ] if
- ]
+ key hashcode collision-node find-index drop :> idx
+ idx [
+ idx collision-node leaves>> smash [
+ collision-node hashcode>>
+ <collision-node>
+ ] when
+ ] [ collision-node ] if
] [ collision-node ] if ;
M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf )
hashcode collision-node hashcode>> eq? [
- key hashcode collision-node find-index
- [let | leaf-node [ ] idx [ ] |
- idx [
- value leaf-node value>> = [
- collision-node f
- ] [
- hashcode
- value key hashcode <leaf-node>
- idx
- collision-node leaves>>
- new-nth
- <collision-node>
- f
- ] if
+ key hashcode collision-node find-index :> leaf-node :> idx
+ idx [
+ value leaf-node value>> = [
+ collision-node f
] [
- [let | new-leaf-node [ value key hashcode <leaf-node> ] |
- hashcode
- collision-node leaves>>
- new-leaf-node
- suffix
- <collision-node>
- new-leaf-node
- ]
+ hashcode
+ value key hashcode <leaf-node>
+ idx
+ collision-node leaves>>
+ new-nth
+ <collision-node>
+ f
] if
- ]
+ ] [
+ value key hashcode <leaf-node> :> new-leaf-node
+ hashcode
+ collision-node leaves>>
+ new-leaf-node
+ suffix
+ <collision-node>
+ new-leaf-node
+ ] if
] [
shift collision-node value key hashcode make-bitmap-node
] if ;
IN: persistent.hashtables.nodes.full
M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf )
- [let* | nodes [ full-node nodes>> ]
- idx [ hashcode full-node shift>> mask ]
- n [ idx nodes nth-unsafe ] |
- shift radix-bits + value key hashcode n (new-at)
- [let | new-leaf [ ] n' [ ] |
- n n' eq? [
- full-node
- ] [
- n' idx nodes new-nth shift <full-node>
- ] if
- new-leaf
- ]
- ] ;
+ full-node nodes>> :> nodes
+ hashcode full-node shift>> mask :> idx
+ idx nodes nth-unsafe :> n
+
+ shift radix-bits + value key hashcode n (new-at) :> new-leaf :> n'
+ n n' eq? [
+ full-node
+ ] [
+ n' idx nodes new-nth shift <full-node>
+ ] if
+ new-leaf ;
M:: full-node (pluck-at) ( key hashcode full-node -- node' )
- [let* | idx [ hashcode full-node shift>> mask ]
- n [ idx full-node nodes>> nth ]
- n' [ key hashcode n (pluck-at) ] |
- n n' eq? [
- full-node
+ hashcode full-node shift>> mask :> idx
+ idx full-node nodes>> nth :> n
+ key hashcode n (pluck-at) :> n'
+
+ n n' eq? [
+ full-node
+ ] [
+ n' [
+ n' idx full-node nodes>> new-nth
+ full-node shift>>
+ <full-node>
] [
- n' [
- n' idx full-node nodes>> new-nth
- full-node shift>>
- <full-node>
- ] [
- hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
- idx full-node nodes>> remove-nth
- full-node shift>>
- <bitmap-node>
- ] if
+ hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
+ idx full-node nodes>> remove-nth
+ full-node shift>>
+ <bitmap-node>
] if
- ] ;
+ ] if ;
M:: full-node (entry-at) ( key hashcode full-node -- node' )
key hashcode
value leaf-node value>> =
[ leaf-node f ] [ value key hashcode <leaf-node> f ] if
] [
- [let | new-leaf [ value key hashcode <leaf-node> ] |
- hashcode leaf-node new-leaf 2array <collision-node>
- new-leaf
- ]
+ value key hashcode <leaf-node> :> new-leaf
+ hashcode leaf-node new-leaf 2array <collision-node>
+ new-leaf
] if
] [ shift leaf-node value key hashcode make-bitmap-node ] if ;
\ load-local [ infer-load-local ] "special" set-word-prop
: infer-get-local ( -- )
- [let* | n [ pop-literal nip 1 swap - ]
- in-r [ n consume-r ]
- out-d [ in-r first copy-value 1array ]
- out-r [ in-r copy-values ] |
- out-d output-d
- out-r output-r
- f out-d in-r out-r
- out-r in-r zip out-d first in-r first 2array suffix
- #shuffle,
- ] ;
+ pop-literal nip 1 swap - :> n
+ n consume-r :> in-r
+ in-r first copy-value 1array :> out-d
+ in-r copy-values :> out-r
+
+ out-d output-d
+ out-r output-r
+ f out-d in-r out-r
+ out-r in-r zip out-d first in-r first 2array suffix
+ #shuffle, ;
\ get-local [ infer-get-local ] "special" set-word-prop
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
:: spawn-namespace-test ( -- ? )
- [let | p [ <promise> ] g [ gensym ] |
- [
- g "x" set
- [ "x" get p fulfill ] "B" spawn drop
- ] with-scope
- p ?promise g eq?
- ] ;
+ <promise> :> p gensym :> g
+ [
+ g "x" set
+ [ "x" get p fulfill ] "B" spawn drop
+ ] with-scope
+ p ?promise g eq? ;
[ t ] [ spawn-namespace-test ] unit-test
IN: tools.walker.debug
:: test-walker ( quot -- data )
- [let | p [ <promise> ] |
- [
- H{ } clone >n
+ <promise> :> p
+ [
+ H{ } clone >n
- [
- p promise-fulfilled?
- [ drop ] [ p fulfill ] if
- 2drop
- ] show-walker-hook set
+ [
+ p promise-fulfilled?
+ [ drop ] [ p fulfill ] if
+ 2drop
+ ] show-walker-hook set
- break
+ break
- quot call
- ] "Walker test" spawn drop
+ quot call
+ ] "Walker test" spawn drop
- step-into-all
- p ?promise
- send-synchronous drop
+ step-into-all
+ p ?promise
+ send-synchronous drop
- p ?promise
- variables>> walker-continuation swap at
- value>> data>>
- ] ;
+ p ?promise
+ variables>> walker-continuation swap at
+ value>> data>> ;
drop [ 0 ] unless* tail-slice ;\r
\r
:: ?combine ( char slice i -- ? )\r
- [let | str [ i slice nth char suffix ] |\r
- str ducet key? dup\r
- [ str i slice set-nth ] when\r
- ] ;\r
+ i slice nth char suffix :> str\r
+ str ducet key? dup\r
+ [ str i slice set-nth ] when ;\r
\r
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
ERROR: unix-system-call-error args errno message word ;
MACRO:: unix-system-call ( quot -- )
- [let | n [ quot infer in>> ]
- word [ quot first ] |
- [
- n ndup quot call dup 0 < [
- drop
- n narray
- errno dup strerror
- word unix-system-call-error
- ] [
- n nnip
- ] if
- ]
+ quot infer in>> :> n
+ quot first :> word
+ [
+ n ndup quot call dup 0 < [
+ drop
+ n narray
+ errno dup strerror
+ word unix-system-call-error
+ ] [
+ n nnip
+ ] if
] ;
HOOK: open-file os ( path flags mode -- fd )
DIOBJECTDATAFORMAT <struct-boa> ;
:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
- [let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
- array [| args i |
- struct args <DIOBJECTDATAFORMAT>
- i alien set-nth
- ] each-index
- alien
- ] ;
+ array length malloc-DIOBJECTDATAFORMAT-array :> alien
+ array [| args i |
+ struct args <DIOBJECTDATAFORMAT>
+ i alien set-nth
+ ] each-index
+ alien ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
"Here is an example of the locals version:"
{ $example
"""USING: locals urls xml.syntax xml.writer ;
-[let |
- number [ 3 ]
- false [ f ]
- url [ URL" http://factorcode.org/" ]
- string [ "hello" ]
- word [ \\ drop ] |
+[let
+ 3 :> number [ 3 ]
+ f :> false [ f ]
+ URL" http://factorcode.org/" :> url
+ "hello" :> string
+ \\ drop :> world
<XML
<x
number=<-number->
y
<foo/>
</x>""" ] [
- [let* | a [ "one" ] c [ "two" ] x [ "y" ]
- d [ [XML <-x-> <foo/> XML] ] |
+ [let "one" :> a "two" :> c "y" :> x [XML <-x-> <foo/> XML] :> d
<XML
<x> <-a-> <b val=<-c->/> <-d-> </x>
XML> pprint-xml>string
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
10 first - iota [| i |
- [let* | digit [ i first + ]
- mask [ digit 2^ ]
- value' [ i value + ] |
- used mask bitand zero? [
- value max > [ t ] [
- remaining 1 <= [
- listener call f
- ] [
- remaining 1 -
- 0
- value' 10 *
- used mask bitor
- max
- listener
- (count-numbers)
- ] if
+ i first + :> digit
+ digit 2^ :> mask
+ i value + :> value'
+ used mask bitand zero? [
+ value max > [ t ] [
+ remaining 1 <= [
+ listener call f
+ ] [
+ remaining 1 -
+ 0
+ value' 10 *
+ used mask bitor
+ max
+ listener
+ (count-numbers)
] if
- ] [ f ] if
- ]
+ ] if
+ ] [ f ] if
] any? ; inline recursive
:: count-numbers ( max listener -- )
inline
:: beust ( -- )
- [let | i! [ 0 ] |
- 5000000000 [ i 1 + i! ] count-numbers
- i number>string " unique numbers." append print
- ] ;
+ 0 :> i!
+ 5000000000 [ i 1 + i! ] count-numbers
+ i number>string " unique numbers." append print ;
MAIN: beust
[ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta ( k len alu -- k' )
- [let | kn [ alu length ] |
- len [ k + kn mod alu nth-unsafe ] "" map-as print
- k len +
- ] ; inline
+ alu length :> kn
+ len [ k + kn mod alu nth-unsafe ] "" map-as print
+ k len + ; inline
: write-repeat-fasta ( n alu desc id -- )
write-description
- [let | k! [ 0 ] alu [ ] |
- [| len | k len alu make-repeat-fasta k! ] split-lines
- ] ; inline
+ 0 :> k! :> alu
+ [| len | k len alu make-repeat-fasta k! ] split-lines ; inline
: fasta ( n out -- )
homo-sapiens make-cumulative
IUB make-cumulative
- [let | homo-sapiens-floats [ ]
- homo-sapiens-chars [ ]
- IUB-floats [ ]
- IUB-chars [ ]
- out [ ]
- n [ ]
- seed [ initial-seed ] |
-
- out ascii [
- n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
-
- initial-seed
- n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
- n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
- drop
- ] with-file-writer
-
- ] ;
+ :> homo-sapiens-floats
+ :> homo-sapiens-chars
+ :> IUB-floats
+ :> IUB-chars
+ :> out
+ :> n
+ initial-seed :> seed
+
+ out ascii [
+ n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
+
+ initial-seed
+ n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
+ n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
+ drop
+ ] with-file-writer ;
: run-fasta ( -- ) 2500000 reverse-complement-in fasta ;
{ v void* } ;
:: fake-data ( -- rgb yuv )
- [let* | w [ 1600 ]
- h [ 1200 ]
- buffer [ yuv_buffer <struct> ]
- rgb [ w h * 3 * <byte-array> ] |
- rgb buffer
- w >>y_width
- h >>y_height
- h >>uv_height
- w >>y_stride
- w >>uv_stride
- w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
- w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
- w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v
- ] ;
+ 1600 :> w
+ 1200 :> h
+ yuv_buffer <struct> :> buffer
+ w h * 3 * <byte-array> :> rgb
+ rgb buffer
+ w >>y_width
+ h >>y_height
+ h >>uv_height
+ w >>y_stride
+ w >>uv_stride
+ w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
+ w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
+ w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ;
: clamp ( n -- n )
255 min 0 max ; inline
bitor bitor bitor 32 bits ;
:: set-t ( T i -- )
- [let* |
- a1 [ i sbox nth ]
- a2 [ a1 xtime ]
- a3 [ a1 a2 bitxor ] |
- a2 a1 a1 a3 ui32 i T set-nth
- a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth
- a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth
- a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth
- ] ;
+ i sbox nth :> a1
+ a1 xtime :> a2
+ a1 a2 bitxor :> a3
+ a2 a1 a1 a3 ui32 i T set-nth
+ a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth
+ a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth
+ a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth ;
MEMO:: t-table ( -- array )
1024 0 <array>
dup 256 [ set-t ] with each ;
:: set-d ( D i -- )
- [let* |
- a1 [ i inv-sbox nth ]
- a2 [ a1 xtime ]
- a4 [ a2 xtime ]
- a8 [ a4 xtime ]
- a9 [ a8 a1 bitxor ]
- ab [ a9 a2 bitxor ]
- ad [ a9 a4 bitxor ]
- ae [ a8 a4 a2 bitxor bitxor ]
- |
- ae a9 ad ab ui32 i D set-nth
- ab ae a9 ad ui32 i HEX: 100 + D set-nth
- ad ab ae a9 ui32 i HEX: 200 + D set-nth
- a9 ad ab ae ui32 i HEX: 300 + D set-nth
- ] ;
+ i inv-sbox nth :> a1
+ a1 xtime :> a2
+ a2 xtime :> a4
+ a4 xtime :> a8
+ a8 a1 bitxor :> a9
+ a9 a2 bitxor :> ab
+ a9 a4 bitxor :> ad
+ a8 a4 a2 bitxor bitxor :> ae
+
+ ae a9 ad ab ui32 i D set-nth
+ ab ae a9 ad ui32 i HEX: 100 + D set-nth
+ ad ab ae a9 ui32 i HEX: 200 + D set-nth
+ a9 ad ab ae ui32 i HEX: 300 + D set-nth ;
MEMO:: d-table ( -- array )
1024 0 <array>
PRIVATE>
:: passwd-md5 ( magic salt password -- bytes )
- [let* | final! [ password magic salt 3append
- salt password tuck 3append md5 checksum-bytes
- password length
- [ 16 / ceiling swap <repetition> concat ] keep
- head-slice append
- password [ length make-bits ] [ first ] bi
- '[ CHAR: \0 _ ? ] "" map-as append
- md5 checksum-bytes ] |
- 1000 [
- "" swap
- {
- [ 0 bit? password final ? append ]
- [ 3 mod 0 > [ salt append ] when ]
- [ 7 mod 0 > [ password append ] when ]
- [ 0 bit? final password ? append ]
- } cleave md5 checksum-bytes final!
- ] each
+ password magic salt 3append
+ salt password tuck 3append md5 checksum-bytes
+ password length
+ [ 16 / ceiling swap <repetition> concat ] keep
+ head-slice append
+ password [ length make-bits ] [ first ] bi
+ '[ CHAR: \0 _ ? ] "" map-as append
+ md5 checksum-bytes :> final!
- magic salt "$" 3append
- { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group
- [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat
- 11 final nth 2 to64 3append ] ;
+ 1000 iota [
+ "" swap
+ {
+ [ 0 bit? password final ? append ]
+ [ 3 mod 0 > [ salt append ] when ]
+ [ 7 mod 0 > [ password append ] when ]
+ [ 0 bit? final password ? append ]
+ } cleave md5 checksum-bytes final!
+ ] each
+
+ magic salt "$" 3append
+ { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group
+ [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat
+ 11 final nth 2 to64 3append ;
: parse-shadow-password ( string -- magic salt password )
"$" split harvest first3 [ "$" tuck 3append ] 2dip ;
}
{ $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } }
- { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
"Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures"
}
{ $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } }
- { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
"Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures"
] B{ } map-as ;
:: permute ( bytes src-order dst-order -- new-bytes )
- [let | src [ src-order name>> ]
- dst [ dst-order name>> ] |
- bytes src length group
- [ pad4 src dst permutation shuffle dst length head ]
- map concat ] ;
+ src-order name>> :> src
+ dst-order name>> :> dst
+ bytes src length group
+ [ pad4 src dst permutation shuffle dst length head ]
+ map concat ;
: (reorder-components) ( image src-order dest-order -- image )
[ permute ] 2curry change-bitmap ;
}
} ;
-HELP: [infix|
-{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" }
-{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." }
-{ $examples
- { $example
- "USING: infix prettyprint ;"
- "IN: scratchpad"
- "[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ."
- "452.16"
- }
-} ;
-
-{ POSTPONE: [infix POSTPONE: [infix| } related-words
-
ARTICLE: "infix" "Infix notation"
"The " { $vocab-link "infix" } " vocabulary implements support for infix notation in Factor source code."
{ $subsections
POSTPONE: [infix
- POSTPONE: [infix|
}
$nl
"The usual infix math operators are supported:"
"You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation."
{ $example
"USING: arrays infix ;"
- "[infix| myarr [ { 1 2 3 4 } ] | myarr[4/2]*3 infix] ."
+ "[let { 1 2 3 4 } :> myarr [infix myarr[4/2]*3 infix] ] ."
"9"
}
"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
-5*
0 infix] ] unit-test
-[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] |
- r*r*pi infix] ] unit-test
-[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test
-[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test
-[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test
-
-[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test
-[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test
-[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test
-[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test
-
[ 0.0 ] [ [infix sin(0) infix] ] unit-test
[ 10 ] [ [infix lcm(2,5) infix] ] unit-test
[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test
[ t ] [ 5 \ stupid_function check-word ] unit-test
[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test
-[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test
+[ -1 ] [ [let 1 :> a [infix -a infix] ] ] unit-test
SYNTAX: [infix
"infix]" [infix-parse parsed \ call parsed ;
-
-<PRIVATE
-
-: parse-infix-locals ( assoc end -- quot )
- '[ _ [infix-parse prepare-operand ] ((parse-lambda)) ;
-
-PRIVATE>
-
-SYNTAX: [infix|
- "|" parse-bindings "infix]" parse-infix-locals <let>
- ?rewrite-closures over push-all ;
] if ;
:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- [let* | d-to-move [ d-left distance min ]
- move-v [ d-to-move heading n*v ] |
- move-v player location+
- heading player update-nearest-segment2
- d-left d-to-move - player ] ;
+ d-left distance min :> d-to-move
+ d-to-move heading n*v :> move-v
+
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ;
: distance-to-move-freely ( player -- distance )
[ almost-to-collision ]
} case ;
:: distance-to-next-segment ( current next location heading -- distance )
- [let | cf [ current forward>> ] |
- cf next location>> v. cf location v. - cf heading v. / ] ;
+ current forward>> :> cf
+ cf next location>> v. cf location v. - cf heading v. / ;
:: distance-to-next-segment-area ( current next location heading -- distance )
- [let | cf [ current forward>> ]
- h [ next current half-way-between-oints ] |
- cf h v. cf location v. - cf heading v. / ] ;
+ current forward>> :> cf
+ next current half-way-between-oints :> h
+ cf h v. cf location v. - cf heading v. / ;
: vector-to-centre ( seg loc -- v )
over location>> swap v- swap forward>> proj-perp ;
v norm 0 = [
distant
] [
- [let* | a [ v dup v. ]
- b [ v w v. 2 * ]
- c [ w dup v. r sq - ] |
- c b a quadratic max-real ]
+ v dup v. :> a
+ v w v. 2 * :> b
+ w dup v. r sq - :> c
+ c b a quadratic max-real
] if ;
: sideways-heading ( oint segment -- v )
'[ drop @ f ] attempt-all drop ; inline
:: upload-safely ( local username host remote -- )
- [let* | temp [ remote ".incomplete" append ]
- scp-remote [ { username "@" host ":" temp } concat ]
- scp [ scp-command get ]
- ssh [ ssh-command get ] |
- 5 [ { scp local scp-remote } short-running-process ] retry
- 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
- ] ;
+ remote ".incomplete" append :> temp
+ { username "@" host ":" temp } concat :> scp-remote
+ scp-command get :> scp
+ ssh-command get :> ssh
+ 5 [ { scp local scp-remote } short-running-process ] retry
+ 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ;
: eval-file ( file -- obj )
dup utf8 file-lines parse-fresh
PRIVATE>
:: verify-nodes ( mdb -- )
- [ [let* | acc [ V{ } clone ]
- node1 [ mdb dup master-node [ check-node ] keep ]
- node2 [ mdb node1 remote>>
- [ [ check-node ] keep ]
- [ drop f ] if* ]
- | node1 [ acc push ] when*
- node2 [ acc push ] when*
- mdb acc nodelist>table >>nodes drop
- ]
+ [
+ V{ } clone :> acc
+ mdb dup master-node [ check-node ] keep :> node1
+ mdb node1 remote>>
+ [ [ check-node ] keep ]
+ [ drop f ] if* :> node2
+
+ node1 [ acc push ] when*
+ node2 [ acc push ] when*
+ mdb acc nodelist>table >>nodes drop
] with-destructors ;
: mdb-open ( mdb -- mdb-connection )
[ dispose f ] change-handle drop ;
M: mdb-connection dispose
- mdb-close ;
\ No newline at end of file
+ mdb-close ;
[ "$cmd" = ] [ "system" head? ] bi or ;
: check-collection ( collection -- fq-collection )
- [let* | instance [ mdb-instance ]
- instance-name [ instance name>> ] |
- dup mdb-collection? [ name>> ] when
- "." split1 over instance-name =
- [ nip ] [ drop ] if
- [ ] [ reserved-namespace? ] bi
- [ instance (ensure-collection) ] unless
- [ instance-name ] dip "." glue ] ;
+ mdb-instance :> instance
+ instance name>> :> instance-name
+ dup mdb-collection? [ name>> ] when
+ "." split1 over instance-name =
+ [ nip ] [ drop ] if
+ [ ] [ reserved-namespace? ] bi
+ [ instance (ensure-collection) ] unless
+ [ instance-name ] dip "." glue ;
: fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline
write flush ; inline
: build-query-object ( query -- selector )
- [let | selector [ H{ } clone ] |
- { [ orderby>> [ "orderby" selector set-at ] when* ]
- [ explain>> [ "$explain" selector set-at ] when* ]
- [ hint>> [ "$hint" selector set-at ] when* ]
- [ query>> "query" selector set-at ]
- } cleave
- selector
- ] ;
+ H{ } clone :> selector
+ { [ orderby>> [ "orderby" selector set-at ] when* ]
+ [ explain>> [ "$explain" selector set-at ] when* ]
+ [ hint>> [ "$hint" selector set-at ] when* ]
+ [ query>> "query" selector set-at ]
+ } cleave
+ selector ;
PRIVATE>
<PRIVATE
:: (euler073) ( counter limit lo hi -- counter' )
- [let | m [ lo hi mediant ] |
- m denominator limit <= [
- counter 1 +
- limit lo m (euler073)
- limit m hi (euler073)
- ] [ counter ] if
- ] ;
+ lo hi mediant :> m
+ m denominator limit <= [
+ counter 1 +
+ limit lo m (euler073)
+ limit m hi (euler073)
+ ] [ counter ] if ;
PRIVATE>
0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
- [let | table [ sums-triangle ] |
- m [| x |
- x 1 + [| y |
- m x - [0,b) [| z |
- x z + table nth-unsafe
- [ y z + 1 + swap nth-unsafe ]
- [ y swap nth-unsafe ] bi -
- ] map partial-sum-infimum
- ] map-infimum
+ sums-triangle :> table
+ m [| x |
+ x 1 + [| y |
+ m x - [0,b) [| z |
+ x z + table nth-unsafe
+ [ y z + 1 + swap nth-unsafe ]
+ [ y swap nth-unsafe ] bi -
+ ] map partial-sum-infimum
] map-infimum
- ] ;
+ ] map-infimum ;
HINTS: (euler150) fixnum ;
: alert* ( str -- ) [ ] swap alert ;
:: ask-user ( string -- model' )
- [ [let | lbl [ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
- fldm [ <model-field*> ->% 1 ]
- btn [ "okay" <model-border-btn> ] |
- btn -> [ fldm swap updates ]
- [ [ drop lbl close-window ] $> , ] bi
- ] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
+ [
+ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , :> lbl
+ <model-field*> ->% 1 :> fldm
+ "okay" <model-border-btn> :> btn
+ btn -> [ fldm swap updates ]
+ [ [ drop lbl close-window ] $> , ] bi
+ ] <vbox> { 161 86 } >>pref-dim "" open-window ;
MACRO: ask-buttons ( buttons -- quot ) dup length [
[ swap
[ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
"" open-window
] dip firstn
- ] 2curry ;
\ No newline at end of file
+ ] 2curry ;
}
{ $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } }
- { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
"Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures"
<plist version="1.0">
<dict>
<key>content</key>
- <string>
- [let | $1 [ $2 ] $3|
- $0
- ]</string>
+ <string>[let $0 ]</string>
<key>name</key>
<string>let</string>
<key>scope</key>
projects / factor.git / commitdiff