steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

update existing code for [let change

db4
Joe Groff 2009-10-27 21:50:31 -05:00
parent 8a7acdf54f
commit 935c0797c3
56 changed files with 636 additions and 732 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
basis/channels/examples/examples.factor
View File

@ -25,12 +25,11 @@ IN: channels.examples
] 3keep filter ; ] 3keep filter ;
:: (sieve) ( prime c -- ) :: (sieve) ( prime c -- )
[let | p [ c from ] c from :> p
newc [ <channel> ] | <channel> :> newc
p prime to p prime to
[ newc p c filter ] "Filter" spawn drop [ newc p c filter ] "Filter" spawn drop
prime newc (sieve) prime newc (sieve) ;
] ;
: sieve ( prime -- ) : sieve ( prime -- )
#! Send prime numbers to 'prime' channel #! Send prime numbers to 'prime' channel

10
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -22,12 +22,10 @@ IN: compiler.cfg.intrinsics.alien
] [ emit-primitive ] if ; ] [ emit-primitive ] if ;
:: inline-alien ( node quot test -- ) :: inline-alien ( node quot test -- )
[let | infos [ node node-input-infos ] | node node-input-infos :> infos
infos test call infos test call
[ infos quot call ] [ infos quot call ]
[ node emit-primitive ] [ node emit-primitive ] if ;
if
] ; inline
: inline-alien-getter? ( infos -- ? ) : inline-alien-getter? ( infos -- ? )
[ first class>> c-ptr class<= ] [ first class>> c-ptr class<= ]

20
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -43,17 +43,15 @@ IN: compiler.cfg.intrinsics.allot
2 + cells array ^^allot ; 2 + cells array ^^allot ;
:: emit-<array> ( node -- ) :: emit-<array> ( node -- )
[let | len [ node node-input-infos first literal>> ] | node node-input-infos first literal>> :> len
len expand-<array>? [ len expand-<array>? [
[let | elt [ ds-pop ] ds-pop :> elt
reg [ len ^^allot-array ] | len ^^allot-array :> reg
ds-drop ds-drop
len reg array store-length len reg array store-length
len reg elt array store-initial-element len reg elt array store-initial-element
reg ds-push reg ds-push
] ] [ node emit-primitive ] if ;
] [ node emit-primitive ] if
] ;
: expand-(byte-array)? ( obj -- ? ) : expand-(byte-array)? ( obj -- ? )
dup integer? [ 0 1024 between? ] [ drop f ] if ; dup integer? [ 0 1024 between? ] [ drop f ] if ;

13
basis/compiler/cfg/ssa/liveness/liveness.factor
View File

@ -121,10 +121,9 @@ PRIVATE>
PRIVATE> PRIVATE>
:: live-out? ( vreg node -- ? ) :: live-out? ( vreg node -- ? )
[let | def [ vreg def-of ] | vreg def-of :> def
{ {
{ [ node def eq? ] [ vreg uses-of def only? not ] } { [ node def eq? ] [ vreg uses-of def only? not ] }
{ [ def node strictly-dominates? ] [ vreg node (live-out?) ] } { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
[ f ] [ f ]
} cond } cond ;
] ;

41
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -39,14 +39,13 @@ M: #enter-recursive remove-dead-code*
2bi ; 2bi ;
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle ) :: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
[let* | new-live-outputs [ inputs outputs filter-corresponding make-values ] inputs outputs filter-corresponding make-values :> new-live-outputs
live-outputs [ outputs filter-live ] | outputs filter-live :> live-outputs
new-live-outputs new-live-outputs
live-outputs live-outputs
live-outputs live-outputs
new-live-outputs new-live-outputs
drop-values drop-values ;
] ;
: drop-call-recursive-outputs ( node -- #shuffle ) : drop-call-recursive-outputs ( node -- #shuffle )
dup [ label>> return>> in-d>> ] [ out-d>> ] bi dup [ label>> return>> in-d>> ] [ out-d>> ] bi
@ -60,22 +59,20 @@ M: #call-recursive remove-dead-code*
tri 3array ; tri 3array ;
:: drop-recursive-inputs ( node -- shuffle ) :: drop-recursive-inputs ( node -- shuffle )
[let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ] node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs :> shuffle
new-outputs [ shuffle out-d>> ] | shuffle out-d>> :> new-outputs
node new-outputs node new-outputs
[ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
shuffle shuffle ;
] ;
:: drop-recursive-outputs ( node -- shuffle ) :: drop-recursive-outputs ( node -- shuffle )
[let* | return [ node label>> return>> ] node label>> return>> :> return
new-inputs [ return in-d>> filter-live ] return in-d>> filter-live :> new-inputs
new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] | return [ in-d>> ] [ out-d>> ] bi filter-corresponding :> new-outputs
return return
[ new-inputs >>in-d new-outputs >>out-d drop ] [ new-inputs >>in-d new-outputs >>out-d drop ]
[ drop-dead-outputs ] [ drop-dead-outputs ]
bi bi ;
] ;
M: #recursive remove-dead-code* ( node -- nodes ) M: #recursive remove-dead-code* ( node -- nodes )
[ drop-recursive-inputs ] [ drop-recursive-inputs ]

15
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -71,14 +71,13 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
filter-corresponding zip #data-shuffle ; inline filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle ) :: drop-dead-values ( outputs -- #shuffle )
[let* | new-outputs [ outputs make-values ] outputs make-values :> new-outputs
live-outputs [ outputs filter-live ] | outputs filter-live :> live-outputs
new-outputs new-outputs
live-outputs live-outputs
outputs outputs
new-outputs new-outputs
drop-values drop-values ;
] ;
: drop-dead-outputs ( node -- #shuffle ) : drop-dead-outputs ( node -- #shuffle )
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ; dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;

11
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -159,12 +159,11 @@ IN: compiler.tree.propagation.known-words
\ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
:: (comparison-constraints) ( in1 in2 op -- constraint ) :: (comparison-constraints) ( in1 in2 op -- constraint )
[let | i1 [ in1 value-info interval>> ] in1 value-info interval>> :> i1
i2 [ in2 value-info interval>> ] | in2 value-info interval>> :> i2
in1 i1 i2 op assumption is-in-interval in1 i1 i2 op assumption is-in-interval
in2 i2 i1 op swap-comparison assumption is-in-interval in2 i2 i1 op swap-comparison assumption is-in-interval
/\ /\ ;
] ;
:: comparison-constraints ( in1 in2 out op -- constraint ) :: comparison-constraints ( in1 in2 out op -- constraint )
in1 in2 op (comparison-constraints) out t--> in1 in2 op (comparison-constraints) out t-->

18
basis/compiler/utilities/utilities.factor
View File

@ -36,13 +36,11 @@ yield-hook [ [ ] ] initialize
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ; : penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
:: compress-path ( source assoc -- destination ) :: compress-path ( source assoc -- destination )
[let | destination [ source assoc at ] | source assoc at :> destination
source destination = [ source ] [ source destination = [ source ] [
[let | destination' [ destination assoc compress-path ] | destination assoc compress-path :> destination'
destination' destination = [ destination' destination = [
destination' source assoc set-at destination' source assoc set-at
] unless ] unless
destination' destination'
] ] if ;
] if
] ;

34
basis/concurrency/exchangers/exchangers-tests.factor
View File

@ -5,27 +5,25 @@ FROM: sequences => 3append ;
IN: concurrency.exchangers.tests IN: concurrency.exchangers.tests
:: exchanger-test ( -- string ) :: exchanger-test ( -- string )
[let | <exchanger> :> ex
ex [ <exchanger> ] 2 <count-down> :> c
c [ 2 <count-down> ] f :> v1!
v1! [ f ] f :> v2!
v2! [ f ] <promise> :> pr
pr [ <promise> ] |
[ [
c await c await
v1 ", " v2 3append pr fulfill v1 ", " v2 3append pr fulfill
] "Awaiter" spawn drop ] "Awaiter" spawn drop
[ [
"Goodbye world" ex exchange v1! c count-down "Goodbye world" ex exchange v1! c count-down
] "Exchanger 1" spawn drop ] "Exchanger 1" spawn drop
[ [
"Hello world" ex exchange v2! c count-down "Hello world" ex exchange v2! c count-down
] "Exchanger 2" spawn drop ] "Exchanger 2" spawn drop
pr ?promise pr ?promise ;
] ;
[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test [ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test

43
basis/concurrency/flags/flags-tests.factor
View File

@ -3,46 +3,41 @@ kernel threads locals accessors calendar ;
IN: concurrency.flags.tests IN: concurrency.flags.tests
:: flag-test-1 ( -- val ) :: flag-test-1 ( -- val )
[let | f [ <flag> ] | <flag> :> f
[ f raise-flag ] "Flag test" spawn drop [ f raise-flag ] "Flag test" spawn drop
f lower-flag f lower-flag
f value>> f value>> ;
] ;
[ f ] [ flag-test-1 ] unit-test [ f ] [ flag-test-1 ] unit-test
:: flag-test-2 ( -- ? ) :: flag-test-2 ( -- ? )
[let | f [ <flag> ] | <flag> :> f
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag f lower-flag
f value>> f value>> ;
] ;
[ f ] [ flag-test-2 ] unit-test [ f ] [ flag-test-2 ] unit-test
:: flag-test-3 ( -- val ) :: flag-test-3 ( -- val )
[let | f [ <flag> ] | <flag> :> f
f raise-flag f raise-flag
f value>> f value>> ;
] ;
[ t ] [ flag-test-3 ] unit-test [ t ] [ flag-test-3 ] unit-test
:: flag-test-4 ( -- val ) :: flag-test-4 ( -- val )
[let | f [ <flag> ] | <flag> :> f
[ f raise-flag ] "Flag test" spawn drop [ f raise-flag ] "Flag test" spawn drop
f wait-for-flag f wait-for-flag
f value>> f value>> ;
] ;
[ t ] [ flag-test-4 ] unit-test [ t ] [ flag-test-4 ] unit-test
:: flag-test-5 ( -- val ) :: flag-test-5 ( -- val )
[let | f [ <flag> ] | <flag> :> f
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag f wait-for-flag
f value>> f value>> ;
] ;
[ t ] [ flag-test-5 ] unit-test [ t ] [ flag-test-5 ] unit-test

228
basis/concurrency/locks/locks-tests.factor
View File

@ -4,57 +4,55 @@ threads sequences calendar accessors ;
IN: concurrency.locks.tests IN: concurrency.locks.tests
:: lock-test-0 ( -- v ) :: lock-test-0 ( -- v )
[let | v [ V{ } clone ] V{ } clone :> v
c [ 2 <count-down> ] | 2 <count-down> :> c
[ [
yield yield
1 v push 1 v push
yield yield
2 v push 2 v push
c count-down c count-down
] "Lock test 1" spawn drop ] "Lock test 1" spawn drop
[ [
yield yield
3 v push 3 v push
yield yield
4 v push 4 v push
c count-down c count-down
] "Lock test 2" spawn drop ] "Lock test 2" spawn drop
c await c await
v v ;
] ;
:: lock-test-1 ( -- v ) :: lock-test-1 ( -- v )
[let | v [ V{ } clone ] V{ } clone :> v
l [ <lock> ] <lock> :> l
c [ 2 <count-down> ] | 2 <count-down> :> c
[ [
l [ l [
yield yield
1 v push 1 v push
yield yield
2 v push 2 v push
] with-lock ] with-lock
c count-down c count-down
] "Lock test 1" spawn drop ] "Lock test 1" spawn drop
[ [
l [ l [
yield yield
3 v push 3 v push
yield yield
4 v push 4 v push
] with-lock ] with-lock
c count-down c count-down
] "Lock test 2" spawn drop ] "Lock test 2" spawn drop
c await c await
v v ;
] ;
[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test [ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test [ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
@ -80,98 +78,96 @@ IN: concurrency.locks.tests
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
:: rw-lock-test-1 ( -- v ) :: rw-lock-test-1 ( -- v )
[let | l [ <rw-lock> ] <rw-lock> :> l
c [ 1 <count-down> ] 1 <count-down> :> c
c' [ 1 <count-down> ] 1 <count-down> :> c'
c'' [ 4 <count-down> ] 4 <count-down> :> c''
v [ V{ } clone ] | V{ } clone :> v
[ [
l [ l [
1 v push 1 v push
c count-down c count-down
yield yield
3 v push 3 v push
] with-read-lock ] with-read-lock
c'' count-down c'' count-down
] "R/W lock test 1" spawn drop ] "R/W lock test 1" spawn drop
[ [
c await c await
l [ l [
4 v push 4 v push
1 seconds sleep 1 seconds sleep
5 v push 5 v push
] with-write-lock ] with-write-lock
c'' count-down c'' count-down
] "R/W lock test 2" spawn drop ] "R/W lock test 2" spawn drop
[ [
c await c await
l [ l [
2 v push 2 v push
c' count-down c' count-down
] with-read-lock ] with-read-lock
c'' count-down c'' count-down
] "R/W lock test 4" spawn drop ] "R/W lock test 4" spawn drop
[ [
c' await c' await
l [ l [
6 v push 6 v push
] with-write-lock ] with-write-lock
c'' count-down c'' count-down
] "R/W lock test 5" spawn drop ] "R/W lock test 5" spawn drop
c'' await c'' await
v v ;
] ;
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
:: rw-lock-test-2 ( -- v ) :: rw-lock-test-2 ( -- v )
[let | l [ <rw-lock> ] <rw-lock> :> l
c [ 1 <count-down> ] 1 <count-down> :> c
c' [ 2 <count-down> ] 2 <count-down> :> c'
v [ V{ } clone ] | V{ } clone :> v
[ [
l [ l [
1 v push 1 v push
c count-down c count-down
1 seconds sleep 1 seconds sleep
2 v push 2 v push
] with-write-lock ] with-write-lock
c' count-down c' count-down
] "R/W lock test 1" spawn drop ] "R/W lock test 1" spawn drop
[ [
c await c await
l [ l [
3 v push 3 v push
] with-read-lock ] with-read-lock
c' count-down c' count-down
] "R/W lock test 2" spawn drop ] "R/W lock test 2" spawn drop
c' await c' await
v v ;
] ;
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
! Test lock timeouts ! Test lock timeouts
:: lock-timeout-test ( -- v ) :: lock-timeout-test ( -- v )
[let | l [ <lock> ] | <lock> :> l
[
l [ 1 seconds sleep ] with-lock
] "Lock holder" spawn drop
[ [
l 1/10 seconds [ ] with-lock-timeout l [ 1 seconds sleep ] with-lock
] "Lock timeout-er" spawn-linked drop ] "Lock holder" spawn drop
receive [
] ; l 1/10 seconds [ ] with-lock-timeout
] "Lock timeout-er" spawn-linked drop
receive ;
[ lock-timeout-test ] [ [ lock-timeout-test ] [
thread>> name>> "Lock timeout-er" = thread>> name>> "Lock timeout-er" =

45
basis/core-text/core-text.factor
View File

@ -112,35 +112,34 @@ TUPLE: line < disposable line metrics image loc dim ;
[ [
line new-disposable line new-disposable
[let* | open-font [ font cache-font ] font cache-font :> open-font
line [ string open-font font foreground>> <CTLine> |CFRelease ] string open-font font foreground>> <CTLine> |CFRelease :> line
rect [ line line-rect ] line line-rect :> rect
(loc) [ rect origin>> CGPoint>loc ] rect origin>> CGPoint>loc :> (loc)
(dim) [ rect size>> CGSize>dim ] rect size>> CGSize>dim :> (dim)
(ext) [ (loc) (dim) v+ ] (loc) (dim) v+ :> (ext)
loc [ (loc) [ floor ] map ] (loc) [ floor ] map :> loc
ext [ (loc) (dim) [ + ceiling ] 2map ] (loc) (dim) [ + ceiling ] 2map :> ext
dim [ ext loc [ - >integer 1 max ] 2map ] ext loc [ - >integer 1 max ] 2map :> dim
metrics [ open-font line compute-line-metrics ] | open-font line compute-line-metrics :> metrics
line >>line line >>line
metrics >>metrics metrics >>metrics
dim [ dim [
{ {
[ font dim fill-background ] [ font dim fill-background ]
[ loc dim line string fill-selection-background ] [ loc dim line string fill-selection-background ]
[ loc set-text-position ] [ loc set-text-position ]
[ [ line ] dip CTLineDraw ] [ [ line ] dip CTLineDraw ]
} cleave } cleave
] make-bitmap-image >>image ] make-bitmap-image >>image
metrics loc dim line-loc >>loc metrics loc dim line-loc >>loc
metrics metrics>dim >>dim metrics metrics>dim >>dim
]
] with-destructors ; ] with-destructors ;
M: line dispose* line>> CFRelease ; M: line dispose* line>> CFRelease ;

4
basis/fry/fry-docs.factor
View File

@ -68,10 +68,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"'[ [ _ key? ] all? ] filter" "'[ [ _ key? ] all? ] filter"
"[ [ key? ] curry all? ] curry filter" "[ [ key? ] curry all? ] curry filter"
} }
"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:" "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:"
{ $code { $code
"'[ 3 _ + 4 _ / ]" "'[ 3 _ + 4 _ / ]"
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]" "[| a b | 3 a + 4 b / ]"
} ; } ;
ARTICLE: "fry" "Fried quotations" ARTICLE: "fry" "Fried quotations"

28
basis/furnace/auth/providers/providers.factor
View File

@ -23,26 +23,24 @@ GENERIC: new-user ( user provider -- user/f )
! Password recovery support ! Password recovery support
:: issue-ticket ( email username provider -- user/f ) :: issue-ticket ( email username provider -- user/f )
[let | user [ username provider get-user ] | username provider get-user :> user
user [ user [
user email>> length 0 > [ user email>> length 0 > [
user email>> email = [ user email>> email = [
user user
256 random-bits >hex >>ticket 256 random-bits >hex >>ticket
dup provider update-user dup provider update-user
] [ f ] if
] [ f ] if ] [ f ] if
] [ f ] if ] [ f ] if
] ; ] [ f ] if ;
:: claim-ticket ( ticket username provider -- user/f ) :: claim-ticket ( ticket username provider -- user/f )
[let | user [ username provider get-user ] | username provider get-user :> user
user [ user [
user ticket>> ticket = [ user ticket>> ticket = [
user f >>ticket dup provider update-user user f >>ticket dup provider update-user
] [ f ] if
] [ f ] if ] [ f ] if
] ; ] [ f ] if ;
! For configuration ! For configuration

3
basis/interpolate/interpolate-tests.factor
View File

@ -16,7 +16,8 @@ IN: interpolate.tests
] unit-test ] unit-test
[ "Oops, I accidentally the whole economy..." ] [ [ "Oops, I accidentally the whole economy..." ] [
[let | noun [ "economy" ] | [let
"economy" :> noun
[ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer [ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer
] ]
] unit-test ] unit-test

5
basis/io/encodings/gb18030/gb18030.factor
View File

@ -48,7 +48,8 @@ TUPLE: range ufirst ulast bfirst blast ;
] dip set-at ; ] dip set-at ;
: xml>gb-data ( stream -- mapping ranges ) : xml>gb-data ( stream -- mapping ranges )
[let | mapping [ H{ } clone ] ranges [ V{ } clone ] | [let
H{ } clone :> mapping V{ } clone :> ranges
[ [
dup contained? [ dup contained? [
dup name>> main>> { dup name>> main>> {
@ -57,7 +58,7 @@ TUPLE: range ufirst ulast bfirst blast ;
[ 2drop ] [ 2drop ]
} case } case
] [ drop ] if ] [ drop ] if
] each-element mapping ranges ] each-element mapping ranges
] ; ] ;
: unlinear ( num -- bytes ) : unlinear ( num -- bytes )

17
basis/io/launcher/unix/unix-tests.factor
View File

@ -125,14 +125,15 @@ concurrency.promises threads unix.process ;
! Killed processes were exiting with code 0 on FreeBSD ! Killed processes were exiting with code 0 on FreeBSD
[ f ] [ [ f ] [
[let | p [ <promise> ] [let
s [ <promise> ] | <promise> :> p
[ <promise> :> s
"sleep 1000" run-detached [
[ p fulfill ] [ wait-for-process s fulfill ] bi "sleep 1000" run-detached
] in-thread [ p fulfill ] [ wait-for-process s fulfill ] bi
] in-thread
p ?promise handle>> 9 kill drop p ?promise handle>> 9 kill drop
s ?promise 0 = s ?promise 0 =
] ]
] unit-test ] unit-test

15
basis/io/mmap/windows/windows.factor
View File

@ -12,14 +12,13 @@ IN: io.mmap.windows
MapViewOfFile [ win32-error=0/f ] keep ; MapViewOfFile [ win32-error=0/f ] keep ;
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) :: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
[let | lo [ length 32 bits ] length 32 bits :> lo
hi [ length -32 shift 32 bits ] | length -32 shift 32 bits :> hi
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
path access-mode create-mode 0 open-file |dispose path access-mode create-mode 0 open-file |dispose
dup handle>> f protect hi lo f create-file-mapping |dispose dup handle>> f protect hi lo f create-file-mapping |dispose
dup handle>> access 0 0 0 map-view-of-file dup handle>> access 0 0 0 map-view-of-file
] with-privileges ] with-privileges ;
] ;
TUPLE: win32-mapped-file file mapping ; TUPLE: win32-mapped-file file mapping ;

9
basis/io/monitors/macosx/macosx.factor
View File

@ -11,11 +11,10 @@ TUPLE: macosx-monitor < monitor handle ;
'[ first { +modify-file+ } _ queue-change ] each ; '[ first { +modify-file+ } _ queue-change ] each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor ) M:: macosx (monitor) ( path recursive? mailbox -- monitor )
[let | path [ path normalize-path ] | path normalize-path :> path
path mailbox macosx-monitor new-monitor path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry dup [ enqueue-notifications ] curry
path 1array 0 0 <event-stream> >>handle path 1array 0 0 <event-stream> >>handle ;
] ;
M: macosx-monitor dispose* handle>> dispose ; M: macosx-monitor dispose* handle>> dispose ;

7
basis/io/sockets/secure/openssl/openssl.factor
View File

@ -35,10 +35,9 @@ TUPLE: openssl-context < secure-context aliens sessions ;
[| buf size rwflag password! | [| buf size rwflag password! |
password [ B{ 0 } password! ] unless password [ B{ 0 } password! ] unless
[let | len [ password strlen ] | password strlen :> len
buf password len 1 + size min memcpy buf password len 1 + size min memcpy
len len
]
] alien-callback ; ] alien-callback ;
: default-pasword ( ctx -- alien ) : default-pasword ( ctx -- alien )

10
basis/lcs/lcs.factor
View File

@ -25,11 +25,11 @@ IN: lcs
[ [ + ] curry map ] with map ; [ [ + ] curry map ] with map ;
:: run-lcs ( old new init step -- matrix ) :: run-lcs ( old new init step -- matrix )
[let | matrix [ old length 1 + new length 1 + init call ] | old length 1 + new length 1 + init call :> matrix
old length [| i | old length [| i |
new length new length
[| j | i j matrix old new step loop-step ] each [| j | i j matrix old new step loop-step ] each
] each matrix ] ; inline ] each matrix ; inline
PRIVATE> PRIVATE>
: levenshtein ( old new -- n ) : levenshtein ( old new -- n )

11
basis/models/product/product-tests.factor
View File

@ -27,11 +27,12 @@ TUPLE: an-observer { i integer } ;
M: an-observer model-changed nip [ 1 + ] change-i drop ; M: an-observer model-changed nip [ 1 + ] change-i drop ;
[ 1 0 ] [ [ 1 0 ] [
[let* | m1 [ 1 <model> ] [let
m2 [ 2 <model> ] 1 <model> :> m1
c [ { m1 m2 } <product> ] 2 <model> :> m2
o1 [ an-observer new ] { m1 m2 } <product> :> c
o2 [ an-observer new ] | an-observer new :> o1
an-observer new :> o2
o1 m1 add-connection o1 m1 add-connection
o2 m2 add-connection o2 m2 add-connection

122
basis/persistent/hashtables/nodes/bitmap/bitmap.factor
View File

@ -10,77 +10,71 @@ IN: persistent.hashtables.nodes.bitmap
: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline : index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline
M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry ) M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
[let* | shift [ bitmap-node shift>> ] bitmap-node shift>> :> shift
bit [ hashcode shift bitpos ] hashcode shift bitpos :> bit
bitmap [ bitmap-node bitmap>> ] bitmap-node bitmap>> :> bitmap
nodes [ bitmap-node nodes>> ] | bitmap-node nodes>> :> nodes
bitmap bit bitand 0 eq? [ f ] [ bitmap bit bitand 0 eq? [ f ] [
key hashcode key hashcode
bit bitmap index nodes nth-unsafe bit bitmap index nodes nth-unsafe
(entry-at) (entry-at)
] if ] if ;
] ;
M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf ) M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf )
[let* | shift [ bitmap-node shift>> ] bitmap-node shift>> :> shift
bit [ hashcode shift bitpos ] hashcode shift bitpos :> bit
bitmap [ bitmap-node bitmap>> ] bitmap-node bitmap>> :> bitmap
idx [ bit bitmap index ] bit bitmap index :> idx
nodes [ bitmap-node nodes>> ] | bitmap-node nodes>> :> nodes
bitmap bit bitand 0 eq? [
[let | new-leaf [ value key hashcode <leaf-node> ] | bitmap bit bitand 0 eq? [
bitmap bit bitor value key hashcode <leaf-node> :> new-leaf
new-leaf idx nodes insert-nth 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 shift
<bitmap-node> <bitmap-node>
new-leaf ] if
] new-leaf
] [ ]
[let | n [ idx nodes nth ] | ] if ;
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
] ;
M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' ) M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
[let | bit [ hashcode bitmap-node shift>> bitpos ] hashcode bitmap-node shift>> bitpos :> bit
bitmap [ bitmap-node bitmap>> ] bitmap-node bitmap>> :> bitmap
nodes [ bitmap-node nodes>> ] bitmap-node nodes>> :> nodes
shift [ bitmap-node shift>> ] | bitmap-node shift>> :> shift
bit bitmap bitand 0 eq? [ bitmap-node ] [ bit bitmap bitand 0 eq? [ bitmap-node ] [
[let* | idx [ bit bitmap index ] bit bitmap index :> idx
n [ idx nodes nth-unsafe ] idx nodes nth-unsafe :> n
n' [ key hashcode n (pluck-at) ] | key hashcode n (pluck-at) :> n'
n n' eq? [ n n' eq? [
bitmap-node bitmap-node
] [ ] [
n' [ n' [
bitmap bitmap
n' idx nodes new-nth n' idx nodes new-nth
shift shift
<bitmap-node> <bitmap-node>
] [ ] [
bitmap bit eq? [ f ] [ bitmap bit eq? [ f ] [
bitmap bit bitnot bitand bitmap bit bitnot bitand
idx nodes remove-nth idx nodes remove-nth
shift shift
<bitmap-node> <bitmap-node>
] if
] if
] if ] if
] ] if
] if ] if
] ; ] if ;
M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ; M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ;

58
basis/persistent/hashtables/nodes/collision/collision.factor
View File

@ -15,43 +15,39 @@ M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node )
M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node ) M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node )
hashcode collision-node hashcode>> eq? [ hashcode collision-node hashcode>> eq? [
[let | idx [ key hashcode collision-node find-index drop ] | key hashcode collision-node find-index drop :> idx
idx [ idx [
idx collision-node leaves>> smash [ idx collision-node leaves>> smash [
collision-node hashcode>> collision-node hashcode>>
<collision-node> <collision-node>
] when ] when
] [ collision-node ] if ] [ collision-node ] if
]
] [ collision-node ] if ; ] [ collision-node ] if ;
M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf ) M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf )
hashcode collision-node hashcode>> eq? [ hashcode collision-node hashcode>> eq? [
key hashcode collision-node find-index key hashcode collision-node find-index :> leaf-node :> idx
[let | leaf-node [ ] idx [ ] | idx [
idx [ value leaf-node value>> = [
value leaf-node value>> = [ collision-node f
collision-node f
] [
hashcode
value key hashcode <leaf-node>
idx
collision-node leaves>>
new-nth
<collision-node>
f
] if
] [ ] [
[let | new-leaf-node [ value key hashcode <leaf-node> ] | hashcode
hashcode value key hashcode <leaf-node>
collision-node leaves>> idx
new-leaf-node collision-node leaves>>
suffix new-nth
<collision-node> <collision-node>
new-leaf-node f
]
] if ] 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 shift collision-node value key hashcode make-bitmap-node
] if ; ] if ;

56
basis/persistent/hashtables/nodes/full/full.factor
View File

@ -8,39 +8,37 @@ persistent.hashtables.nodes ;
IN: persistent.hashtables.nodes.full IN: persistent.hashtables.nodes.full
M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf ) M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf )
[let* | nodes [ full-node nodes>> ] full-node nodes>> :> nodes
idx [ hashcode full-node shift>> mask ] hashcode full-node shift>> mask :> idx
n [ idx nodes nth-unsafe ] | idx nodes nth-unsafe :> n
shift radix-bits + value key hashcode n (new-at)
[let | new-leaf [ ] n' [ ] | shift radix-bits + value key hashcode n (new-at) :> new-leaf :> n'
n n' eq? [ n n' eq? [
full-node full-node
] [ ] [
n' idx nodes new-nth shift <full-node> n' idx nodes new-nth shift <full-node>
] if ] if
new-leaf new-leaf ;
]
] ;
M:: full-node (pluck-at) ( key hashcode full-node -- node' ) M:: full-node (pluck-at) ( key hashcode full-node -- node' )
[let* | idx [ hashcode full-node shift>> mask ] hashcode full-node shift>> mask :> idx
n [ idx full-node nodes>> nth ] idx full-node nodes>> nth :> n
n' [ key hashcode n (pluck-at) ] | key hashcode n (pluck-at) :> n'
n n' eq? [
full-node n n' eq? [
full-node
] [
n' [
n' idx full-node nodes>> new-nth
full-node shift>>
<full-node>
] [ ] [
n' [ hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
n' idx full-node nodes>> new-nth idx full-node nodes>> remove-nth
full-node shift>> full-node shift>>
<full-node> <bitmap-node>
] [
hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
idx full-node nodes>> remove-nth
full-node shift>>
<bitmap-node>
] if
] if ] if
] ; ] if ;
M:: full-node (entry-at) ( key hashcode full-node -- node' ) M:: full-node (entry-at) ( key hashcode full-node -- node' )
key hashcode key hashcode

7
basis/persistent/hashtables/nodes/leaf/leaf.factor
View File

@ -19,10 +19,9 @@ M:: leaf-node (new-at) ( shift value key hashcode leaf-node -- node' added-leaf
value leaf-node value>> = value leaf-node value>> =
[ leaf-node f ] [ value key hashcode <leaf-node> f ] if [ leaf-node f ] [ value key hashcode <leaf-node> f ] if
] [ ] [
[let | new-leaf [ value key hashcode <leaf-node> ] | value key hashcode <leaf-node> :> new-leaf
hashcode leaf-node new-leaf 2array <collision-node> hashcode leaf-node new-leaf 2array <collision-node>
new-leaf new-leaf
]
] if ] if
] [ shift leaf-node value key hashcode make-bitmap-node ] if ; ] [ shift leaf-node value key hashcode make-bitmap-node ] if ;

20
basis/stack-checker/known-words/known-words.factor
View File

@ -193,16 +193,16 @@ M: bad-executable summary
\ load-local [ infer-load-local ] "special" set-word-prop \ load-local [ infer-load-local ] "special" set-word-prop
: infer-get-local ( -- ) : infer-get-local ( -- )
[let* | n [ pop-literal nip 1 swap - ] pop-literal nip 1 swap - :> n
in-r [ n consume-r ] n consume-r :> in-r
out-d [ in-r first copy-value 1array ] in-r first copy-value 1array :> out-d
out-r [ in-r copy-values ] | in-r copy-values :> out-r
out-d output-d
out-r output-r out-d output-d
f out-d in-r out-r out-r output-r
out-r in-r zip out-d first in-r first 2array suffix f out-d in-r out-r
#shuffle, out-r in-r zip out-d first in-r first 2array suffix
] ; #shuffle, ;
\ get-local [ infer-get-local ] "special" set-word-prop \ get-local [ infer-get-local ] "special" set-word-prop

13
basis/threads/threads-tests.factor
View File

@ -32,13 +32,12 @@ yield
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with [ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
:: spawn-namespace-test ( -- ? ) :: spawn-namespace-test ( -- ? )
[let | p [ <promise> ] g [ gensym ] | <promise> :> p gensym :> g
[ [
g "x" set g "x" set
[ "x" get p fulfill ] "B" spawn drop [ "x" get p fulfill ] "B" spawn drop
] with-scope ] with-scope
p ?promise g eq? p ?promise g eq? ;
] ;
[ t ] [ spawn-namespace-test ] unit-test [ t ] [ spawn-namespace-test ] unit-test

35
basis/tools/walker/debug/debug.factor
View File

@ -6,26 +6,25 @@ namespaces namespaces.private assocs accessors ;
IN: tools.walker.debug IN: tools.walker.debug
:: test-walker ( quot -- data ) :: test-walker ( quot -- data )
[let | p [ <promise> ] | <promise> :> p
[
H{ } clone >n
[ [
H{ } clone >n p promise-fulfilled?
[ drop ] [ p fulfill ] if
2drop
] show-walker-hook set
[ break
p promise-fulfilled?
[ drop ] [ p fulfill ] if
2drop
] show-walker-hook set
break quot call
] "Walker test" spawn drop
quot call step-into-all
] "Walker test" spawn drop p ?promise
send-synchronous drop
step-into-all p ?promise
p ?promise variables>> walker-continuation swap at
send-synchronous drop value>> data>> ;
p ?promise
variables>> walker-continuation swap at
value>> data>>
] ;

7
basis/unicode/collation/collation.factor
View File

@ -76,10 +76,9 @@ ducet insert-helpers
drop [ 0 ] unless* tail-slice ; drop [ 0 ] unless* tail-slice ;
:: ?combine ( char slice i -- ? ) :: ?combine ( char slice i -- ? )
[let | str [ i slice nth char suffix ] | i slice nth char suffix :> str
str ducet key? dup str ducet key? dup
[ str i slice set-nth ] when [ str i slice set-nth ] when ;
] ;
: add ( char -- ) : add ( char -- )
dup blocked? [ 1string , ] [ dup blocked? [ 1string , ] [

23
basis/unix/unix.factor
View File

@ -48,18 +48,17 @@ ERROR: unix-error errno message ;
ERROR: unix-system-call-error args errno message word ; ERROR: unix-system-call-error args errno message word ;
MACRO:: unix-system-call ( quot -- ) MACRO:: unix-system-call ( quot -- )
[let | n [ quot infer in>> ] quot infer in>> :> n
word [ quot first ] | quot first :> word
[ [
n ndup quot call dup 0 < [ n ndup quot call dup 0 < [
drop drop
n narray n narray
errno dup strerror errno dup strerror
word unix-system-call-error word unix-system-call-error
] [ ] [
n nnip n nnip
] if ] if
]
] ; ] ;
HOOK: open-file os ( path flags mode -- fd ) HOOK: open-file os ( path flags mode -- fd )

13
basis/windows/dinput/constants/constants.factor
View File

@ -56,13 +56,12 @@ M: array array-base-type first ;
DIOBJECTDATAFORMAT <struct-boa> ; DIOBJECTDATAFORMAT <struct-boa> ;
:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien ) :: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
[let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] | array length malloc-DIOBJECTDATAFORMAT-array :> alien
array [| args i | array [| args i |
struct args <DIOBJECTDATAFORMAT> struct args <DIOBJECTDATAFORMAT>
i alien set-nth i alien set-nth
] each-index ] each-index
alien alien ;
] ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien ) : <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip

12
basis/xml/syntax/syntax-docs.factor
View File

@ -74,12 +74,12 @@ $nl
"Here is an example of the locals version:" "Here is an example of the locals version:"
{ $example { $example
"""USING: locals urls xml.syntax xml.writer ; """USING: locals urls xml.syntax xml.writer ;
[let | [let
number [ 3 ] 3 :> number [ 3 ]
false [ f ] f :> false [ f ]
url [ URL" http://factorcode.org/" ] URL" http://factorcode.org/" :> url
string [ "hello" ] "hello" :> string
word [ \\ drop ] | \\ drop :> world
<XML <XML
<x <x
number=<-number-> number=<-number->

3
basis/xml/syntax/syntax-tests.factor
View File

@ -54,8 +54,7 @@ XML-NS: foo http://blah.com
y y
<foo/> <foo/>
</x>""" ] [ </x>""" ] [
[let* | a [ "one" ] c [ "two" ] x [ "y" ] [let "one" :> a "two" :> c "y" :> x [XML <-x-> <foo/> XML] :> d
d [ [XML <-x-> <foo/> XML] ] |
<XML <XML
<x> <-a-> <b val=<-c->/> <-d-> </x> <x> <-a-> <b val=<-c->/> <-d-> </x>
XML> pprint-xml>string XML> pprint-xml>string

42
extra/benchmark/beust2/beust2.factor
View File

@ -7,25 +7,24 @@ IN: benchmark.beust2
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? ) :: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
10 first - iota [| i | 10 first - iota [| i |
[let* | digit [ i first + ] i first + :> digit
mask [ digit 2^ ] digit 2^ :> mask
value' [ i value + ] | i value + :> value'
used mask bitand zero? [ used mask bitand zero? [
value max > [ t ] [ value max > [ t ] [
remaining 1 <= [ remaining 1 <= [
listener call f listener call f
] [ ] [
remaining 1 - remaining 1 -
0 0
value' 10 * value' 10 *
used mask bitor used mask bitor
max max
listener listener
(count-numbers) (count-numbers)
] if
] if ] if
] [ f ] if ] if
] ] [ f ] if
] any? ; inline recursive ] any? ; inline recursive
:: count-numbers ( max listener -- ) :: count-numbers ( max listener -- )
@ -33,9 +32,8 @@ IN: benchmark.beust2
inline inline
:: beust ( -- ) :: beust ( -- )
[let | i! [ 0 ] | 0 :> i!
5000000000 [ i 1 + i! ] count-numbers 5000000000 [ i 1 + i! ] count-numbers
i number>string " unique numbers." append print i number>string " unique numbers." append print ;
] ;
MAIN: beust MAIN: beust

42
extra/benchmark/fasta/fasta.factor
View File

@ -71,38 +71,34 @@ CONSTANT: homo-sapiens
[ make-random-fasta ] 2curry split-lines ; inline [ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta ( k len alu -- k' ) :: make-repeat-fasta ( k len alu -- k' )
[let | kn [ alu length ] | alu length :> kn
len [ k + kn mod alu nth-unsafe ] "" map-as print len [ k + kn mod alu nth-unsafe ] "" map-as print
k len + k len + ; inline
] ; inline
: write-repeat-fasta ( n alu desc id -- ) : write-repeat-fasta ( n alu desc id -- )
write-description write-description
[let | k! [ 0 ] alu [ ] | 0 :> k! :> alu
[| len | k len alu make-repeat-fasta k! ] split-lines [| len | k len alu make-repeat-fasta k! ] split-lines ; inline
] ; inline
: fasta ( n out -- ) : fasta ( n out -- )
homo-sapiens make-cumulative homo-sapiens make-cumulative
IUB make-cumulative IUB make-cumulative
[let | homo-sapiens-floats [ ] :> homo-sapiens-floats
homo-sapiens-chars [ ] :> homo-sapiens-chars
IUB-floats [ ] :> IUB-floats
IUB-chars [ ] :> IUB-chars
out [ ] :> out
n [ ] :> n
seed [ initial-seed ] | initial-seed :> seed
out ascii [ out ascii [
n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
initial-seed initial-seed
n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta 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 n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
drop drop
] with-file-writer ] with-file-writer ;
] ;
: run-fasta ( -- ) 2500000 reverse-complement-in fasta ; : run-fasta ( -- ) 2500000 reverse-complement-in fasta ;

27
extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
View File

@ -17,20 +17,19 @@ STRUCT: yuv_buffer
{ v void* } ; { v void* } ;
:: fake-data ( -- rgb yuv ) :: fake-data ( -- rgb yuv )
[let* | w [ 1600 ] 1600 :> w
h [ 1200 ] 1200 :> h
buffer [ yuv_buffer <struct> ] yuv_buffer <struct> :> buffer
rgb [ w h * 3 * <byte-array> ] | w h * 3 * <byte-array> :> rgb
rgb buffer rgb buffer
w >>y_width w >>y_width
h >>y_height h >>y_height
h >>uv_height h >>uv_height
w >>y_stride w >>y_stride
w >>uv_stride w >>uv_stride
w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y 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 >>u
w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ;
] ;
: clamp ( n -- n ) : clamp ( n -- n )
255 min 0 max ; inline 255 min 0 max ; inline

44
extra/crypto/aes/aes.factor
View File

@ -61,37 +61,33 @@ CONSTANT: AES_BLOCK_SIZE 16
bitor bitor bitor 32 bits ; bitor bitor bitor 32 bits ;
:: set-t ( T i -- ) :: set-t ( T i -- )
[let* | i sbox nth :> a1
a1 [ i sbox nth ] a1 xtime :> a2
a2 [ a1 xtime ] a1 a2 bitxor :> a3
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
] ;
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 ) MEMO:: t-table ( -- array )
1024 0 <array> 1024 0 <array>
dup 256 [ set-t ] with each ; dup 256 [ set-t ] with each ;
:: set-d ( D i -- ) :: set-d ( D i -- )
[let* | i inv-sbox nth :> a1
a1 [ i inv-sbox nth ] a1 xtime :> a2
a2 [ a1 xtime ] a2 xtime :> a4
a4 [ a2 xtime ] a4 xtime :> a8
a8 [ a4 xtime ] a8 a1 bitxor :> a9
a9 [ a8 a1 bitxor ] a9 a2 bitxor :> ab
ab [ a9 a2 bitxor ] a9 a4 bitxor :> ad
ad [ a9 a4 bitxor ] a8 a4 a2 bitxor bitxor :> ae
ae [ a8 a4 a2 bitxor bitxor ]
| ae a9 ad ab ui32 i D set-nth
ae a9 ad ab ui32 i D set-nth ab ae a9 ad ui32 i HEX: 100 + 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
ad ab ae a9 ui32 i HEX: 200 + D set-nth a9 ad ab ae ui32 i HEX: 300 + D set-nth ;
a9 ad ab ae ui32 i HEX: 300 + D set-nth
] ;
MEMO:: d-table ( -- array ) MEMO:: d-table ( -- array )
1024 0 <array> 1024 0 <array>

43
extra/crypto/passwd-md5/passwd-md5.factor
View File

@ -17,28 +17,29 @@ IN: crypto.passwd-md5
PRIVATE> PRIVATE>
:: passwd-md5 ( magic salt password -- bytes ) :: passwd-md5 ( magic salt password -- bytes )
[let* | final! [ password magic salt 3append password magic salt 3append
salt password tuck 3append md5 checksum-bytes salt password tuck 3append md5 checksum-bytes
password length password length
[ 16 / ceiling swap <repetition> concat ] keep [ 16 / ceiling swap <repetition> concat ] keep
head-slice append head-slice append
password [ length make-bits ] [ first ] bi password [ length make-bits ] [ first ] bi
'[ CHAR: \0 _ ? ] "" map-as append '[ CHAR: \0 _ ? ] "" map-as append
md5 checksum-bytes ] | md5 checksum-bytes :> final!
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
magic salt "$" 3append 1000 iota [
{ 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group "" swap
[ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat {
11 final nth 2 to64 3append ] ; [ 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 ) : parse-shadow-password ( string -- magic salt password )
"$" split harvest first3 [ "$" tuck 3append ] 2dip ; "$" split harvest first3 [ "$" tuck 3append ] 2dip ;

2
extra/galois-talk/galois-talk.factor
View File

@ -189,7 +189,7 @@ CONSTANT: galois-slides
} }
{ $slide "Locals and lexical scope" { $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } } { "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" "Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } } { "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures" "Full closures"

2
extra/google-tech-talk/google-tech-talk.factor
View File

@ -272,7 +272,7 @@ CONSTANT: google-slides
} }
{ $slide "Locals and lexical scope" { $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } } { "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" "Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } } { "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures" "Full closures"

10
extra/images/normalization/normalization.factor
View File

@ -26,11 +26,11 @@ CONSTANT: fill-value 255
] B{ } map-as ; ] B{ } map-as ;
:: permute ( bytes src-order dst-order -- new-bytes ) :: permute ( bytes src-order dst-order -- new-bytes )
[let | src [ src-order name>> ] src-order name>> :> src
dst [ dst-order name>> ] | dst-order name>> :> dst
bytes src length group bytes src length group
[ pad4 src dst permutation shuffle dst length head ] [ pad4 src dst permutation shuffle dst length head ]
map concat ] ; map concat ;
: (reorder-components) ( image src-order dest-order -- image ) : (reorder-components) ( image src-order dest-order -- image )
[ permute ] 2curry change-bitmap ; [ permute ] 2curry change-bitmap ;

17
extra/infix/infix-docs.factor
View File

@ -25,25 +25,10 @@ HELP: [infix
} }
} ; } ;
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" ARTICLE: "infix" "Infix notation"
"The " { $vocab-link "infix" } " vocabulary implements support for infix notation in Factor source code." "The " { $vocab-link "infix" } " vocabulary implements support for infix notation in Factor source code."
{ $subsections { $subsections
POSTPONE: [infix POSTPONE: [infix
POSTPONE: [infix|
} }
$nl $nl
"The usual infix math operators are supported:" "The usual infix math operators are supported:"
@ -77,7 +62,7 @@ $nl
"You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation." "You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation."
{ $example { $example
"USING: arrays infix ;" "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" "9"
} }
"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:" "Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"

13
extra/infix/infix-tests.factor
View File

@ -13,17 +13,6 @@ IN: infix.tests
-5* -5*
0 infix] ] unit-test 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 [ 0.0 ] [ [infix sin(0) infix] ] unit-test
[ 10 ] [ [infix lcm(2,5) infix] ] unit-test [ 10 ] [ [infix lcm(2,5) infix] ] unit-test
[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test [ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test
@ -42,4 +31,4 @@ IN: infix.tests
[ t ] [ 5 \ stupid_function check-word ] unit-test [ t ] [ 5 \ stupid_function check-word ] unit-test
[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] 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

11
extra/infix/infix.factor
View File

@ -83,14 +83,3 @@ PRIVATE>
SYNTAX: [infix SYNTAX: [infix
"infix]" [infix-parse parsed \ call parsed ; "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 ;

11
extra/jamshred/player/player.factor
View File

@ -101,11 +101,12 @@ CONSTANT: max-speed 30.0
] if ; ] if ;
:: move-player-on-heading ( d-left player distance heading -- d-left' player ) :: move-player-on-heading ( d-left player distance heading -- d-left' player )
[let* | d-to-move [ d-left distance min ] d-left distance min :> d-to-move
move-v [ d-to-move heading n*v ] | d-to-move heading n*v :> move-v
move-v player location+
heading player update-nearest-segment2 move-v player location+
d-left d-to-move - player ] ; heading player update-nearest-segment2
d-left d-to-move - player ;
: distance-to-move-freely ( player -- distance ) : distance-to-move-freely ( player -- distance )
[ almost-to-collision ] [ almost-to-collision ]

18
extra/jamshred/tunnel/tunnel.factor
View File

@ -107,13 +107,13 @@ CONSTANT: default-segment-radius 1
} case ; } case ;
:: distance-to-next-segment ( current next location heading -- distance ) :: distance-to-next-segment ( current next location heading -- distance )
[let | cf [ current forward>> ] | current forward>> :> cf
cf next location>> v. cf location v. - cf heading v. / ] ; cf next location>> v. cf location v. - cf heading v. / ;
:: distance-to-next-segment-area ( current next location heading -- distance ) :: distance-to-next-segment-area ( current next location heading -- distance )
[let | cf [ current forward>> ] current forward>> :> cf
h [ next current half-way-between-oints ] | next current half-way-between-oints :> h
cf h v. cf location v. - cf heading v. / ] ; cf h v. cf location v. - cf heading v. / ;
: vector-to-centre ( seg loc -- v ) : vector-to-centre ( seg loc -- v )
over location>> swap v- swap forward>> proj-perp ; over location>> swap v- swap forward>> proj-perp ;
@ -138,10 +138,10 @@ CONSTANT: distant 1000
v norm 0 = [ v norm 0 = [
distant distant
] [ ] [
[let* | a [ v dup v. ] v dup v. :> a
b [ v w v. 2 * ] v w v. 2 * :> b
c [ w dup v. r sq - ] | w dup v. r sq - :> c
c b a quadratic max-real ] c b a quadratic max-real
] if ; ] if ;
: sideways-heading ( oint segment -- v ) : sideways-heading ( oint segment -- v )

13
extra/mason/common/common.factor
View File

@ -33,13 +33,12 @@ M: unix really-delete-tree delete-tree ;
'[ drop @ f ] attempt-all drop ; inline '[ drop @ f ] attempt-all drop ; inline
:: upload-safely ( local username host remote -- ) :: upload-safely ( local username host remote -- )
[let* | temp [ remote ".incomplete" append ] remote ".incomplete" append :> temp
scp-remote [ { username "@" host ":" temp } concat ] { username "@" host ":" temp } concat :> scp-remote
scp [ scp-command get ] scp-command get :> scp
ssh [ ssh-command get ] | ssh-command get :> ssh
5 [ { scp local scp-remote } short-running-process ] retry 5 [ { scp local scp-remote } short-running-process ] retry
5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ;
] ;
: eval-file ( file -- obj ) : eval-file ( file -- obj )
dup utf8 file-lines parse-fresh dup utf8 file-lines parse-fresh

21
extra/mongodb/connection/connection.factor
View File

@ -123,15 +123,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
PRIVATE> PRIVATE>
:: verify-nodes ( mdb -- ) :: verify-nodes ( mdb -- )
[ [let* | acc [ V{ } clone ] [
node1 [ mdb dup master-node [ check-node ] keep ] V{ } clone :> acc
node2 [ mdb node1 remote>> mdb dup master-node [ check-node ] keep :> node1
[ [ check-node ] keep ] mdb node1 remote>>
[ drop f ] if* ] [ [ check-node ] keep ]
| node1 [ acc push ] when* [ drop f ] if* :> node2
node2 [ acc push ] when*
mdb acc nodelist>table >>nodes drop node1 [ acc push ] when*
] node2 [ acc push ] when*
mdb acc nodelist>table >>nodes drop
] with-destructors ; ] with-destructors ;
: mdb-open ( mdb -- mdb-connection ) : mdb-open ( mdb -- mdb-connection )
@ -143,4 +144,4 @@ PRIVATE>
[ dispose f ] change-handle drop ; [ dispose f ] change-handle drop ;
M: mdb-connection dispose M: mdb-connection dispose
mdb-close ; mdb-close ;

16
extra/mongodb/driver/driver.factor
View File

@ -151,14 +151,14 @@ M: mdb-collection create-collection
[ "$cmd" = ] [ "system" head? ] bi or ; [ "$cmd" = ] [ "system" head? ] bi or ;
: check-collection ( collection -- fq-collection ) : check-collection ( collection -- fq-collection )
[let* | instance [ mdb-instance ] mdb-instance :> instance
instance-name [ instance name>> ] | instance name>> :> instance-name
dup mdb-collection? [ name>> ] when dup mdb-collection? [ name>> ] when
"." split1 over instance-name = "." split1 over instance-name =
[ nip ] [ drop ] if [ nip ] [ drop ] if
[ ] [ reserved-namespace? ] bi [ ] [ reserved-namespace? ] bi
[ instance (ensure-collection) ] unless [ instance (ensure-collection) ] unless
[ instance-name ] dip "." glue ] ; [ instance-name ] dip "." glue ;
: fix-query-collection ( mdb-query -- mdb-query ) : fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline [ check-collection ] change-collection ; inline

15
extra/mongodb/operations/operations.factor
View File

@ -106,14 +106,13 @@ USE: tools.walker
write flush ; inline write flush ; inline
: build-query-object ( query -- selector ) : build-query-object ( query -- selector )
[let | selector [ H{ } clone ] | H{ } clone :> selector
{ [ orderby>> [ "orderby" selector set-at ] when* ] { [ orderby>> [ "orderby" selector set-at ] when* ]
[ explain>> [ "$explain" selector set-at ] when* ] [ explain>> [ "$explain" selector set-at ] when* ]
[ hint>> [ "$hint" selector set-at ] when* ] [ hint>> [ "$hint" selector set-at ] when* ]
[ query>> "query" selector set-at ] [ query>> "query" selector set-at ]
} cleave } cleave
selector selector ;
] ;
PRIVATE> PRIVATE>

13
extra/project-euler/073/073.factor
View File

@ -33,13 +33,12 @@ IN: project-euler.073
<PRIVATE <PRIVATE
:: (euler073) ( counter limit lo hi -- counter' ) :: (euler073) ( counter limit lo hi -- counter' )
[let | m [ lo hi mediant ] | lo hi mediant :> m
m denominator limit <= [ m denominator limit <= [
counter 1 + counter 1 +
limit lo m (euler073) limit lo m (euler073)
limit m hi (euler073) limit m hi (euler073)
] [ counter ] if ] [ counter ] if ;
] ;
PRIVATE> PRIVATE>

19
extra/project-euler/150/150.factor
View File

@ -54,17 +54,16 @@ IN: project-euler.150
0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ; 0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n ) :: (euler150) ( m -- n )
[let | table [ sums-triangle ] | sums-triangle :> table
m [| x | m [| x |
x 1 + [| y | x 1 + [| y |
m x - [0,b) [| z | m x - [0,b) [| z |
x z + table nth-unsafe x z + table nth-unsafe
[ y z + 1 + swap nth-unsafe ] [ y z + 1 + swap nth-unsafe ]
[ y swap nth-unsafe ] bi - [ y swap nth-unsafe ] bi -
] map partial-sum-infimum ] map partial-sum-infimum
] map-infimum
] map-infimum ] map-infimum
] ; ] map-infimum ;
HINTS: (euler150) fixnum ; HINTS: (euler150) fixnum ;

15
extra/ui/gadgets/alerts/alerts.factor
View File

@ -12,12 +12,13 @@ IN: ui.gadgets.alerts
: alert* ( str -- ) [ ] swap alert ; : alert* ( str -- ) [ ] swap alert ;
:: ask-user ( string -- model' ) :: ask-user ( string -- model' )
[ [let | lbl [ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ] [
fldm [ <model-field*> ->% 1 ] string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , :> lbl
btn [ "okay" <model-border-btn> ] | <model-field*> ->% 1 :> fldm
btn -> [ fldm swap updates ] "okay" <model-border-btn> :> btn
[ [ drop lbl close-window ] $> , ] bi btn -> [ fldm swap updates ]
] ] <vbox> { 161 86 } >>pref-dim "" open-window ; [ [ drop lbl close-window ] $> , ] bi
] <vbox> { 161 86 } >>pref-dim "" open-window ;
MACRO: ask-buttons ( buttons -- quot ) dup length [ MACRO: ask-buttons ( buttons -- quot ) dup length [
[ swap [ swap
@ -25,4 +26,4 @@ MACRO: ask-buttons ( buttons -- quot ) dup length [
[ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox> [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
"" open-window "" open-window
] dip firstn ] dip firstn
] 2curry ; ] 2curry ;

2
extra/vpri-talk/vpri-talk.factor
View File

@ -209,7 +209,7 @@ CONSTANT: vpri-slides
} }
{ $slide "Locals and lexical scope" { $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } } { "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" "Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } } { "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures" "Full closures"

5
misc/Factor.tmbundle/Snippets/let.tmSnippet
View File

@ -3,10 +3,7 @@
<plist version="1.0"> <plist version="1.0">
<dict> <dict>
<key>content</key> <key>content</key>
<string> <string>[let $0 ]</string>
[let | $1 [ $2 ] $3|
$0
]</string>
<key>name</key> <key>name</key>
<string>let</string> <string>let</string>
<key>scope</key> <key>scope</key>