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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-10-28 17:26:23 -05:00
parent e376a0ece2 c5c31b4300
commit 17f0a5d41a
104 changed files with 842 additions and 1086 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/fortran/fortran.factor
View File

@ -330,7 +330,7 @@ M: character-type (<fortran-result>)
] if-empty ;
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
return parameters fortran-sig>c-sig :> c-parameters :> c-return
return parameters fortran-sig>c-sig :> ( c-return c-parameters )
function fortran-name>symbol-name :> c-function
[args>args]
c-return library c-function c-parameters \ alien-invoke

2
basis/alien/parser/parser.factor
View File

@ -98,7 +98,7 @@ IN: alien.parser
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
parameters return parse-arglist :> callback-effect :> types
parameters return parse-arglist :> ( types callback-effect )
type-word callback-effect "callback-effect" set-word-prop
type-word lib "callback-library" set-word-prop
type-word return types lib library-abi callback-quot (( quot -- alien )) ;

4
basis/bitstreams/bitstreams.factor
View File

@ -113,7 +113,7 @@ PRIVATE>
M:: lsb0-bit-writer poke ( value n bs -- )
value n <widthed> :> widthed
widthed
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder )
byte bs widthed>> |widthed :> new-byte
new-byte #bits>> 8 = [
new-byte bits>> bs bytes>> push
@ -143,7 +143,7 @@ ERROR: not-enough-bits n bit-reader ;
neg shift n bits ;
:: adjust-bits ( n bs -- )
n 8 /mod :> #bits :> #bytes
n 8 /mod :> ( #bytes #bits )
bs [ #bytes + ] change-byte-pos
bit-pos>> #bits + dup 8 >= [
8 - bs (>>bit-pos)

8
basis/calendar/calendar.factor
View File

@ -119,16 +119,16 @@ GENERIC: easter ( obj -- obj' )
:: easter-month-day ( year -- month day )
year 19 mod :> a
year 100 /mod :> c :> b
b 4 /mod :> e :> d
year 100 /mod :> ( b c )
b 4 /mod :> ( d e )
b 8 + 25 /i :> f
b f - 1 + 3 /i :> g
19 a * b + d - g - 15 + 30 mod :> h
c 4 /mod :> k :> i
c 4 /mod :> ( i k )
32 2 e * + 2 i * + h - k - 7 mod :> l
a 11 h * + 22 l * + 451 /i :> m
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
h l + 7 m * - 114 + 31 /mod 1 + :> ( month day )
month day ;
M: integer easter ( year -- timestamp )

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

@ -25,12 +25,11 @@ IN: channels.examples
] 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

2
basis/checksums/hmac/hmac.factor
View File

@ -24,7 +24,7 @@ PRIVATE>
:: hmac-stream ( stream key checksum -- value )
checksum initialize-checksum-state :> checksum-state
checksum key checksum-state init-key :> Ki :> Ko
checksum key checksum-state init-key :> ( Ko Ki )
checksum-state Ki add-checksum-bytes
stream add-checksum-stream get-checksum
checksum initialize-checksum-state

2
basis/classes/struct/bit-accessors/bit-accessors.factor
View File

@ -10,7 +10,7 @@ IN: classes.struct.bit-accessors
[ 2^ 1 - ] bi@ swap bitnot bitand ;
:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
offset 8 /mod :> start-bit :> i
offset 8 /mod :> ( i start-bit )
start-bit bits + 8 min :> end-bit
start-bit end-bit ones-between :> mask
end-bit start-bit - :> used-bits

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

@ -22,12 +22,10 @@ IN: compiler.cfg.intrinsics.alien
] [ 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
: inline-alien-getter? ( infos -- ? )
[ 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 ;
:: 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 ;

6
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -156,18 +156,18 @@ MACRO: if-literals-match ( quots -- )
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
{cc,swap} first2 :> swap? :> cc
{cc,swap} first2 :> ( cc swap? )
swap?
[ src2 src1 rep cc ^^compare-vector ]
[ src1 src2 rep cc ^^compare-vector ] if ;
:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
rep orig-cc %compare-vector-ccs :> not? :> ccs
rep orig-cc %compare-vector-ccs :> ( ccs not? )
ccs empty?
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
ccs unclip :> first-cc :> rest-ccs
ccs unclip :> ( rest-ccs first-cc )
src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
rest-ccs first-dst

4
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -42,7 +42,7 @@ IN: compiler.cfg.intrinsics.slots
first class>> immediate class<= not ;
:: (emit-set-slot) ( infos -- )
3inputs :> slot :> obj :> src
3inputs :> ( src obj slot )
slot infos second value-tag ^^tag-offset>slot :> slot
@ -54,7 +54,7 @@ IN: compiler.cfg.intrinsics.slots
:: (emit-set-slot-imm) ( infos -- )
ds-drop
2inputs :> obj :> src
2inputs :> ( src obj )
infos third literal>> :> slot
infos second value-tag :> tag

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

@ -121,10 +121,9 @@ PRIVATE>
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 ;

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

@ -39,14 +39,13 @@ M: #enter-recursive remove-dead-code*
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
@ -60,22 +59,20 @@ M: #call-recursive remove-dead-code*
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 ]

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
:: 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 ;

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
:: (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-->

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

@ -36,13 +36,11 @@ yield-hook [ [ ] ] initialize
: 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 ;

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

@ -5,27 +5,25 @@ FROM: sequences => 3append ;
IN: concurrency.exchangers.tests
:: exchanger-test ( -- string )
[let |
ex [ <exchanger> ]
c [ 2 <count-down> ]
v1! [ f ]
v2! [ f ]
pr [ <promise> ] |
<exchanger> :> ex
2 <count-down> :> c
f :> v1!
f :> v2!
<promise> :> pr
[
c await
v1 ", " v2 3append pr fulfill
] "Awaiter" spawn drop
[
c await
v1 ", " v2 3append pr fulfill
] "Awaiter" spawn drop
[
"Goodbye world" ex exchange v1! c count-down
] "Exchanger 1" spawn drop
[
"Goodbye world" ex exchange v1! c count-down
] "Exchanger 1" spawn drop
[
"Hello world" ex exchange v2! c count-down
] "Exchanger 2" spawn drop
[
"Hello world" ex exchange v2! c count-down
] "Exchanger 2" spawn drop
pr ?promise
] ;
pr ?promise ;
[ "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
:: flag-test-1 ( -- val )
[let | f [ <flag> ] |
[ f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>>
] ;
<flag> :> f
[ f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>> ;
[ f ] [ flag-test-1 ] unit-test
:: flag-test-2 ( -- ? )
[let | f [ <flag> ] |
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>>
] ;
<flag> :> f
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag
f value>> ;
[ f ] [ flag-test-2 ] unit-test
:: flag-test-3 ( -- val )
[let | f [ <flag> ] |
f raise-flag
f value>>
] ;
<flag> :> f
f raise-flag
f value>> ;
[ t ] [ flag-test-3 ] unit-test
:: flag-test-4 ( -- val )
[let | f [ <flag> ] |
[ f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>>
] ;
<flag> :> f
[ f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>> ;
[ t ] [ flag-test-4 ] unit-test
:: flag-test-5 ( -- val )
[let | f [ <flag> ] |
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>>
] ;
<flag> :> f
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f value>> ;
[ 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
:: lock-test-0 ( -- v )
[let | v [ V{ } clone ]
c [ 2 <count-down> ] |
V{ } clone :> v
2 <count-down> :> c
[
yield
1 v push
yield
2 v push
c count-down
] "Lock test 1" spawn drop
[
yield
1 v push
yield
2 v push
c count-down
] "Lock test 1" spawn drop
[
yield
3 v push
yield
4 v push
c count-down
] "Lock test 2" spawn drop
[
yield
3 v push
yield
4 v push
c count-down
] "Lock test 2" spawn drop
c await
v
] ;
c await
v ;
:: lock-test-1 ( -- v )
[let | v [ V{ } clone ]
l [ <lock> ]
c [ 2 <count-down> ] |
V{ } clone :> v
<lock> :> l
2 <count-down> :> c
[
l [
yield
1 v push
yield
2 v push
] with-lock
c count-down
] "Lock test 1" spawn drop
[
l [
yield
1 v push
yield
2 v push
] with-lock
c count-down
] "Lock test 1" spawn drop
[
l [
yield
3 v push
yield
4 v push
] with-lock
c count-down
] "Lock test 2" spawn drop
[
l [
yield
3 v push
yield
4 v push
] with-lock
c count-down
] "Lock test 2" spawn drop
c await
v
] ;
c await
v ;
[ V{ 1 3 2 4 } ] [ lock-test-0 ] 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-test-1 ( -- v )
[let | l [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 1 <count-down> ]
c'' [ 4 <count-down> ]
v [ V{ } clone ] |
<rw-lock> :> l
1 <count-down> :> c
1 <count-down> :> c'
4 <count-down> :> c''
V{ } clone :> v
[
l [
1 v push
c count-down
yield
3 v push
] with-read-lock
c'' count-down
] "R/W lock test 1" spawn drop
[
l [
1 v push
c count-down
yield
3 v push
] with-read-lock
c'' count-down
] "R/W lock test 1" spawn drop
[
c await
l [
4 v push
1 seconds sleep
5 v push
] with-write-lock
c'' count-down
] "R/W lock test 2" spawn drop
[
c await
l [
4 v push
1 seconds sleep
5 v push
] with-write-lock
c'' count-down
] "R/W lock test 2" spawn drop
[
c await
l [
2 v push
c' count-down
] with-read-lock
c'' count-down
] "R/W lock test 4" spawn drop
[
c await
l [
2 v push
c' count-down
] with-read-lock
c'' count-down
] "R/W lock test 4" spawn drop
[
c' await
l [
6 v push
] with-write-lock
c'' count-down
] "R/W lock test 5" spawn drop
[
c' await
l [
6 v push
] with-write-lock
c'' count-down
] "R/W lock test 5" spawn drop
c'' await
v
] ;
c'' await
v ;
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
:: rw-lock-test-2 ( -- v )
[let | l [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 2 <count-down> ]
v [ V{ } clone ] |
<rw-lock> :> l
1 <count-down> :> c
2 <count-down> :> c'
V{ } clone :> v
[
l [
1 v push
c count-down
1 seconds sleep
2 v push
] with-write-lock
c' count-down
] "R/W lock test 1" spawn drop
[
l [
1 v push
c count-down
1 seconds sleep
2 v push
] with-write-lock
c' count-down
] "R/W lock test 1" spawn drop
[
c await
l [
3 v push
] with-read-lock
c' count-down
] "R/W lock test 2" spawn drop
[
c await
l [
3 v push
] with-read-lock
c' count-down
] "R/W lock test 2" spawn drop
c' await
v
] ;
c' await
v ;
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
! Test lock timeouts
:: lock-timeout-test ( -- v )
[let | l [ <lock> ] |
[
l [ 1 seconds sleep ] with-lock
] "Lock holder" spawn drop
<lock> :> l
[
l 1/10 seconds [ ] with-lock-timeout
] "Lock timeout-er" spawn-linked drop
[
l [ 1 seconds sleep ] with-lock
] "Lock holder" spawn drop
receive
] ;
[
l 1/10 seconds [ ] with-lock-timeout
] "Lock timeout-er" spawn-linked drop
receive ;
[ lock-timeout-test ] [
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
[let* | open-font [ font cache-font ]
line [ string open-font font foreground>> <CTLine> |CFRelease ]
font cache-font :> open-font
string open-font font foreground>> <CTLine> |CFRelease :> line
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-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
line >>line
metrics >>metrics
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
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 loc dim line-loc >>loc
metrics metrics>dim >>dim
]
metrics metrics>dim >>dim
] with-destructors ;
M: line dispose* line>> CFRelease ;

8
basis/cpu/ppc/ppc.factor
View File

@ -504,11 +504,11 @@ M: ppc %compare [ (%compare) ] 2dip %boolean ;
M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
dst temp branch1 branch2 (%boolean) ;
M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
dst temp branch1 branch2 (%boolean) ;
:: %branch ( label cc -- )
@ -534,11 +534,11 @@ M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
branch2 [ label branch2 execute( label -- ) ] when ; inline
M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ;
M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ;
: load-from-frame ( dst n rep -- )

4
basis/farkup/farkup.factor
View File

@ -114,8 +114,8 @@ DEFER: (parse-paragraph)
:: (take-until) ( state delimiter accum -- string/f state' )
state empty? [ accum "\n" join f ] [
state unclip-slice :> first :> rest
first delimiter split1 :> after :> before
state unclip-slice :> ( rest first )
first delimiter split1 :> ( before after )
before accum push
after [
accum "\n" join

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

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

27
basis/functors/functors.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.mixin classes.parser
USING: accessors arrays assocs classes.mixin classes.parser
classes.singleton classes.tuple classes.tuple.parser
combinators effects.parser fry functors.backend generic
generic.parser interpolate io.streams.string kernel lexer
@ -144,10 +144,31 @@ DEFER: ;FUNCTOR delimiter
: pop-functor-words ( -- )
functor-words unuse-words ;
: (parse-bindings) ( end -- )
dup parse-binding dup [
first2 [ make-local ] dip 2array ,
(parse-bindings)
] [ 2drop ] if ;
: with-bindings ( quot -- words assoc )
'[
in-lambda? on
_ H{ } make-assoc
] { } make swap ; inline
: parse-bindings ( end -- words assoc )
[
namespace use-words
(parse-bindings)
namespace unuse-words
] with-bindings ;
: parse-functor-body ( -- form )
push-functor-words
"WHERE" parse-bindings*
[ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
"WHERE" parse-bindings
[ [ swap <def> suffix ] { } assoc>map concat ]
[ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi*
[ ] append-as
pop-functor-words ;
: (FUNCTOR:) ( -- word def effect )

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

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

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

@ -16,7 +16,8 @@ IN: interpolate.tests
] 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

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

@ -48,7 +48,8 @@ TUPLE: range ufirst ulast bfirst blast ;
] 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>> {
@ -57,7 +58,7 @@ TUPLE: range ufirst ulast bfirst blast ;
[ 2drop ]
} case
] [ drop ] if
] each-element mapping ranges
] each-element mapping ranges
] ;
: 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
[ f ] [
[let | p [ <promise> ]
s [ <promise> ] |
[
"sleep 1000" run-detached
[ p fulfill ] [ wait-for-process s fulfill ] bi
] in-thread
[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 =
p ?promise handle>> 9 kill drop
s ?promise 0 =
]
] 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 ;
:: 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 ;

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

@ -11,11 +11,10 @@ TUPLE: macosx-monitor < monitor handle ;
'[ 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 ;

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! |
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 )

2
basis/io/sockets/unix/unix.factor
View File

@ -120,7 +120,7 @@ CONSTANT: packet-size 65536
[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
:: do-receive ( port -- packet sockaddr )
port addr>> empty-sockaddr/size :> len :> sockaddr
port addr>> empty-sockaddr/size :> ( sockaddr len )
port handle>> handle-fd ! s
receive-buffer get-global ! buf
packet-size ! nbytes

10
basis/lcs/lcs.factor
View File

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

8
basis/locals/errors/errors.factor
View File

@ -9,10 +9,10 @@ M: >r/r>-in-lambda-error summary
drop
"Explicit retain stack manipulation is not permitted in lambda bodies" ;
ERROR: binding-form-in-literal-error ;
ERROR: let-form-in-literal-error ;
M: binding-form-in-literal-error summary
drop "[let, [let* and [wlet not permitted inside literals" ;
M: let-form-in-literal-error summary
drop "[let not permitted inside literals" ;
ERROR: local-writer-in-literal-error ;
@ -27,7 +27,7 @@ M: local-word-in-literal-error summary
ERROR: :>-outside-lambda-error ;
M: :>-outside-lambda-error summary
drop ":> cannot be used outside of lambda expressions" ;
drop ":> cannot be used outside of [let, [|, or :: forms" ;
ERROR: bad-local args obj ;

4
basis/locals/fry/fry.factor
View File

@ -6,7 +6,7 @@ IN: locals.fry
! Support for mixing locals with fry
M: binding-form count-inputs body>> count-inputs ;
M: let count-inputs body>> count-inputs ;
M: lambda count-inputs body>> count-inputs ;
@ -14,5 +14,5 @@ M: lambda deep-fry
clone [ shallow-fry swap ] change-body
[ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
M: binding-form deep-fry
M: let deep-fry
clone [ fry '[ @ call ] ] change-body , ;

80
basis/locals/locals-docs.factor
View File

@ -8,45 +8,30 @@ HELP: [|
{ $examples "See " { $link "locals-examples" } "." } ;
HELP: [let
{ $syntax "[let | var-1 [ value-1... ]\n var-2 [ value-2... ]\n ... |\n body... ]" }
{ $description "Evaluates each " { $snippet "value-n" } " form and binds its result to a new local variable named " { $snippet "var-n" } " lexically scoped to the " { $snippet "body" } ", then evaluates " { $snippet "body" } ". The " { $snippet "value-n" } " forms are evaluated in parallel, so a " { $snippet "value-n" } " form may not refer to previous " { $snippet "var-n" } " definitions inside the same " { $link POSTPONE: [let } " form, unlike " { $link POSTPONE: [let* } "." }
{ $syntax "[let code :> var code :> var code... ]" }
{ $description "Establishes a new lexical scope for local variable bindings. Variables bound with " { $link POSTPONE: :> } " within the body of the " { $snippet "[let" } " will be lexically scoped to the body of the " { $snippet "[let" } " form." }
{ $examples "See " { $link "locals-examples" } "." } ;
HELP: [let*
{ $syntax "[let* | var-1 [ value-1... ]\n var-2 [ value-2... ]\n ... |\n body... ]" }
{ $description "Evaluates each " { $snippet "value-n" } " form and binds its result to a new local variable named " { $snippet "var-n" } " lexically scoped to the " { $snippet "body" } ", then evaluates " { $snippet "body" } ". The " { $snippet "value-n" } " forms are evaluated sequentially, so a " { $snippet "value-n" } " form may refer to previous " { $snippet "var-n" } " definitions inside the same " { $link POSTPONE: [let* } " form." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: [let POSTPONE: [let* } related-words
HELP: [wlet
{ $syntax "[wlet | binding1 [ body1... ]\n binding2 [ body2... ]\n ... |\n body... ]" }
{ $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form." }
{ $examples
{ $example
"USING: locals math prettyprint sequences ;"
"IN: scratchpad"
":: quuxify ( n seq -- newseq )"
" [wlet | add-n [| m | m n + ] |"
" seq [ add-n ] map ] ;"
"2 { 1 2 3 } quuxify ."
"{ 3 4 5 }"
}
} ;
HELP: :>
{ $syntax ":> var" ":> var!" }
{ $description "Binds the value on the top of the datastack to a new local variable named " { $snippet "var" } ", lexically scoped to the enclosing quotation or definition."
{ $syntax ":> var" ":> var!" ":> ( var-1 var-2 ... )" }
{ $description "Binds one or more new local variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack to a new local variable named " { $snippet "var" } ", lexically scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition."
$nl
"If the " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the new variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
"The " { $snippet ":> ( var-1 ... )" } " form binds multiple local variables from the top of the datastack in left to right order. These two snippets would have the same effect:"
{ $code ":> c :> b :> a" }
{ $code ":> ( a b c )" }
$nl
"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
{ $notes
"This syntax can only be used inside a " { $link POSTPONE: :: } " word, " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } ", or " { $link POSTPONE: [wlet } " form, or inside a quotation literal inside one of those forms."
}
"This syntax can only be used inside a lexical scope established by a " { $link POSTPONE: :: } " definition, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: [| } " quotation. Definition forms such as " { $link POSTPONE: : } " do not establish a lexical scope by themselves, nor is there a lexical scope available at the top level of source files or in the listener. To use local variable bindings in these situations, use " { $link POSTPONE: [let } " to provide a scope for them." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: [let POSTPONE: :> } related-words
HELP: ::
{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope." }
{ $syntax ":: word ( vars... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope."
$nl
"If any of the " { $snippet "vars" } "' names is followed by an exclamation point (" { $snippet "!" } "), that variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: : } " definitions." }
{ $examples "See " { $link "locals-examples" } "." } ;
@ -54,21 +39,27 @@ HELP: ::
HELP: MACRO::
{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a macro with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope." }
{ $description "Defines a macro with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope."
$nl
"If any of the " { $snippet "vars" } "' names is followed by an exclamation point (" { $snippet "!" } "), that variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
HELP: MEMO::
{ $syntax "MEMO:: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a macro with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope." }
{ $description "Defines a memoized word with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope."
$nl
"If any of the " { $snippet "vars" } "' names is followed by an exclamation point (" { $snippet "!" } "), that variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
HELP: M::
{ $syntax "M:: class generic ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a macro with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope." }
{ $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs; it reads datastack values into local variable bindings from left to right, then executes the body with those bindings in lexical scope."
$nl
"If any of the " { $snippet "vars" } "' names is followed by an exclamation point (" { $snippet "!" } "), that variable will be mutable. See " { $link "locals-mutable" } " for more information on mutable local bindings." }
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: M: } " definitions." }
{ $examples "See " { $link "locals-examples" } "." } ;
@ -86,14 +77,13 @@ IN: scratchpad
"""2.0
-3.0"""
}
{ $snippet "quadratic-roots" } " can also be expressed with " { $link POSTPONE: [let } ":"
"If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link POSTPONE: [let } " to provide a scope for the local variables:"
{ $example """USING: locals math math.functions kernel ;
IN: scratchpad
:: quadratic-roots ( a b c -- x y )
[let | disc [ b sq 4 a c * * - sqrt ] |
b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@
] ;
1.0 1.0 -6.0 quadratic-roots [ . ] bi@"""
[let 1.0 :> a 1.0 :> b -6.0 :> c
b sq 4 a c * * - sqrt :> disc
b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@
] [ . ] bi@"""
"""2.0
-3.0"""
}
@ -216,11 +206,11 @@ $nl
"One exception to the above rule is that array instances containing free local variables (that is, immutable local variables not referenced in a closure) do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile time." ;
ARTICLE: "locals-mutable" "Mutable locals"
"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
"Whenever a local variable is bound using " { $link POSTPONE: :> } ", " { $link POSTPONE: :: } ", or " { $link POSTPONE: [| } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } ") when it is bound. The variable's value can be read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix."
$nl
"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array."
$nl
"Writing to mutable locals in outer scopes is fully supported and has the expected semantics. See " { $link "locals-examples" } " for examples of mutable local variables in action." ;
"Writing to mutable locals in outer scopes is fully supported and has full closure semantics. See " { $link "locals-examples" } " for examples of mutable local variables in action." ;
ARTICLE: "locals-fry" "Locals and fry"
"Locals integrate with " { $link "fry" } " so that mixing locals with fried quotations gives intuitive results."
@ -296,12 +286,10 @@ ARTICLE: "locals" "Lexical variables and closures"
POSTPONE: MEMO::
POSTPONE: MACRO::
}
"Lexical binding forms:"
"Lexical scoping and binding forms:"
{ $subsections
POSTPONE: :>
POSTPONE: [let
POSTPONE: [let*
POSTPONE: [wlet
POSTPONE: :>
}
"Quotation literals where the inputs are named local variables:"
{ $subsections POSTPONE: [| }

155
basis/locals/locals-tests.factor
View File

@ -26,58 +26,35 @@ IN: locals.tests
[ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
:: let-test ( c -- d )
[let | a [ 1 ] b [ 2 ] | a b + c + ] ;
[let 1 :> a 2 :> b a b + c + ] ;
[ 7 ] [ 4 let-test ] unit-test
:: let-test-2 ( a -- a )
a [let | a [ ] | [let | b [ a ] | a ] ] ;
a [let :> a [let a :> b a ] ] ;
[ 3 ] [ 3 let-test-2 ] unit-test
:: let-test-3 ( a -- a )
a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
a [let :> a [let [ a ] :> b [let 3 :> a b ] ] ] ;
:: let-test-4 ( a -- b )
a [let | a [ 1 ] b [ ] | a b 2array ] ;
a [let 1 :> a :> b a b 2array ] ;
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
:: let-test-5 ( a b -- b )
a b [let | a [ ] b [ ] | a b 2array ] ;
a b [let :> a :> b a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
:: let-test-6 ( a -- b )
a [let | a [ ] b [ 1 ] | a b 2array ] ;
a [let :> a 1 :> b a b 2array ] ;
[ { 2 1 } ] [ 2 let-test-6 ] unit-test
[ -1 ] [ -1 let-test-3 call ] unit-test
[ 5 ] [
[let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
] unit-test
:: wlet-test-2 ( a b -- seq )
[wlet | add-b [ b + ] |
a [ add-b ] map ] ;
[ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
:: wlet-test-3 ( a -- b )
[wlet | add-a [ a + ] | [ add-a ] ]
[let | a [ 3 ] | a swap call ] ;
[ 5 ] [ 2 wlet-test-3 ] unit-test
:: wlet-test-4 ( a -- b )
[wlet | sub-a [| b | b a - ] |
3 sub-a ] ;
[ -7 ] [ 10 wlet-test-4 ] unit-test
:: write-test-1 ( n! -- q )
[| i | n i + dup n! ] ;
@ -94,8 +71,7 @@ IN: locals.tests
[ 5 ] [ 2 "q" get call ] unit-test
:: write-test-2 ( -- q )
[let | n! [ 0 ] |
[| i | n i + dup n! ] ] ;
[let 0 :> n! [| i | n i + dup n! ] ] ;
write-test-2 "q" set
@ -116,17 +92,11 @@ write-test-2 "q" set
[ ] [ 1 2 write-test-3 call ] unit-test
:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
:: write-test-4 ( x! -- q ) [ [let 0 :> y! f x! ] ] ;
[ ] [ 5 write-test-4 drop ] unit-test
! Not really a write test; just enforcing consistency
:: write-test-5 ( x -- y )
[wlet | fun! [ x + ] | 5 fun! ] ;
[ 9 ] [ 4 write-test-5 ] unit-test
:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
:: let-let-test ( n -- n ) [let n 3 + :> n n ] ;
[ 13 ] [ 10 let-let-test ] unit-test
@ -164,18 +134,12 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
[ ] [ \ lambda-generic see ] unit-test
:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ;
:: unparse-test-1 ( a -- ) [let 3 :> a! 4 :> b ] ;
[ "[let | a! [ 3 ] | ]" ] [
[ "[let 3 :> a! 4 :> b ]" ] [
\ unparse-test-1 "lambda" word-prop body>> first unparse
] unit-test
:: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
[ "[wlet | a! [ ] | ]" ] [
\ unparse-test-2 "lambda" word-prop body>> first unparse
] unit-test
:: unparse-test-3 ( -- b ) [| a! | ] ;
[ "[| a! | ]" ] [
@ -198,38 +162,6 @@ DEFER: xyzzy
[ 5 ] [ 10 xyzzy ] unit-test
:: let*-test-1 ( a -- b )
[let* | b [ a 1 + ]
c [ b 1 + ] |
a b c 3array ] ;
[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
:: let*-test-2 ( a -- b )
[let* | b [ a 1 + ]
c! [ b 1 + ] |
a b c 3array ] ;
[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
:: let*-test-3 ( a -- b )
[let* | b [ a 1 + ]
c! [ b 1 + ] |
c 1 + c! a b c 3array ] ;
[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
:: let*-test-4 ( a b -- c d )
[let | a [ b ]
b [ a ] |
[let* | a' [ a ]
a'' [ a' ]
b' [ b ]
b'' [ b' ] |
a'' b'' ] ] ;
[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
GENERIC: next-method-test ( a -- b )
M: integer next-method-test 3 + ;
@ -244,11 +176,11 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
{ 3 0 } [| a b c | ] must-infer-as
[ ] [ 1 [let | a [ ] | ] ] unit-test
[ ] [ 1 [let :> a ] ] unit-test
[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
[ 3 ] [ 1 [let :> a 3 ] ] unit-test
[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
[ ] [ 1 2 [let :> a :> b ] ] unit-test
:: a-word-with-locals ( a b -- ) ;
@ -306,10 +238,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ t ] [ 12 &&-test ] unit-test
:: let-and-cond-test-1 ( -- a )
[let | a [ 10 ] |
[let | a [ 20 ] |
[let 10 :> a
[let 20 :> a
{
{ [ t ] [ [let | c [ 30 ] | a ] ] }
{ [ t ] [ [let 30 :> c a ] ] }
} cond
]
] ;
@ -319,8 +251,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ 20 ] [ let-and-cond-test-1 ] unit-test
:: let-and-cond-test-2 ( -- pair )
[let | A [ 10 ] |
[let | B [ 20 ] |
[let 10 :> A
[let 20 :> B
{ { [ t ] [ { A B } ] } } cond
]
] ;
@ -333,7 +265,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
[ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
[ { 10 20 30 } ] [ [let 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test
[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
@ -453,7 +385,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
[
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
"USING: locals fry math ; 1 '[ [let 10 :> A A _ + ] ]"
eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
@ -465,10 +397,7 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
[ t ] [ 3 funny-macro-test ] unit-test
[ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases
[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
@ -484,15 +413,9 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [let 0 :> a a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | [let 0 :> a! { a! } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
@ -504,27 +427,14 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
[ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
is-even? [ a even? ]
>10? [ a 10 > ] |
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
] ;
\ wlet-&&-test def>> must-infer
[ f ] [ 1.5 wlet-&&-test ] unit-test
[ f ] [ 3 wlet-&&-test ] unit-test
[ f ] [ 8 wlet-&&-test ] unit-test
[ t ] [ 12 wlet-&&-test ] unit-test
: fry-locals-test-1 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
[let 6 '[ [let 4 :> A A _ + ] ] call ] ;
\ fry-locals-test-1 def>> must-infer
[ 10 ] [ fry-locals-test-1 ] unit-test
:: fry-locals-test-2 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
[let 6 '[ [let 4 :> A A _ + ] ] call ] ;
\ fry-locals-test-2 def>> must-infer
[ 10 ] [ fry-locals-test-2 ] unit-test
@ -542,18 +452,18 @@ M:: integer lambda-method-forget-test ( a -- b ) a ;
] unit-test
[ 10 ] [
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
[| | 0 '[ [let 10 :> A A _ + ] ] call ] call
] unit-test
! littledan found this problem
[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
[ "bar" ] [ [let [let "bar" :> foo foo ] :> a a ] ] unit-test
[ 10 ] [ [let 10 :> a [let a :> b b ] ] ] unit-test
[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test
[ { \ + } ] [ [let \ + :> x { \ x } ] ] unit-test
[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test
[ { \ + 3 } ] [ [let 3 :> a { \ + a } ] ] unit-test
[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
[ 3 ] [ [let \ + :> a 1 2 [ \ a execute ] ] call ] unit-test
! erg found this problem
:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
@ -578,3 +488,6 @@ M: integer ed's-bug neg ;
{ [ a ed's-bug ] } && ;
[ t ] [ \ ed's-test-case optimized? ] unit-test
! multiple bind
[ 3 1 2 ] [ [let 1 2 3 :> ( a b c ) c a b ] ] unit-test

6
basis/locals/locals.factor
View File

@ -7,16 +7,12 @@ IN: locals
SYNTAX: :>
scan locals get [ :>-outside-lambda-error ] unless*
[ make-local ] bind <def> suffix! ;
parse-def suffix! ;
SYNTAX: [| parse-lambda append! ;
SYNTAX: [let parse-let append! ;
SYNTAX: [let* parse-let* append! ;
SYNTAX: [wlet parse-wlet append! ;
SYNTAX: :: (::) define-declared ;
SYNTAX: M:: (M::) define ;

10
basis/locals/macros/macros.factor
View File

@ -7,13 +7,11 @@ M: lambda expand-macros clone [ expand-macros ] change-body ;
M: lambda expand-macros* expand-macros literal ;
M: binding-form expand-macros
clone
[ [ expand-macros ] assoc-map ] change-bindings
[ expand-macros ] change-body ;
M: let expand-macros
clone [ expand-macros ] change-body ;
M: binding-form expand-macros* expand-macros literal ;
M: let expand-macros* expand-macros literal ;
M: lambda condomize? drop t ;
M: lambda condomize '[ @ ] ;
M: lambda condomize '[ @ ] ;

50
basis/locals/parser/parser.factor
View File

@ -46,6 +46,12 @@ SYMBOL: locals
(parse-lambda) <lambda>
?rewrite-closures ;
: parse-multi-def ( locals -- multi-def )
")" parse-tokens swap [ [ make-local ] map ] bind <multi-def> ;
: parse-def ( name/paren locals -- def )
over "(" = [ nip parse-multi-def ] [ [ make-local ] bind <def> ] if ;
M: lambda-parser parse-quotation ( -- quotation )
H{ } clone (parse-lambda) ;
@ -56,48 +62,8 @@ M: lambda-parser parse-quotation ( -- quotation )
[ nip scan-object 2array ]
} cond ;
: (parse-bindings) ( end -- )
dup parse-binding dup [
first2 [ make-local ] dip 2array ,
(parse-bindings)
] [ 2drop ] if ;
: with-bindings ( quot -- words assoc )
'[
in-lambda? on
_ H{ } make-assoc
] { } make swap ; inline
: parse-bindings ( end -- bindings vars )
[ (parse-bindings) ] with-bindings ;
: parse-let ( -- form )
"|" expect "|" parse-bindings
(parse-lambda) <let> ?rewrite-closures ;
: parse-bindings* ( end -- words assoc )
[
namespace use-words
(parse-bindings)
namespace unuse-words
] with-bindings ;
: parse-let* ( -- form )
"|" expect "|" parse-bindings*
(parse-lambda) <let*> ?rewrite-closures ;
: (parse-wbindings) ( end -- )
dup parse-binding dup [
first2 [ make-local-word ] keep 2array ,
(parse-wbindings)
] [ 2drop ] if ;
: parse-wbindings ( end -- bindings vars )
[ (parse-wbindings) ] with-bindings ;
: parse-wlet ( -- form )
"|" expect "|" parse-wbindings
(parse-lambda) <wlet> ?rewrite-closures ;
H{ } clone (parse-lambda) <let> ?rewrite-closures ;
: parse-locals ( -- effect vars assoc )
complete-effect
@ -121,4 +87,4 @@ M: lambda-parser parse-quotation ( -- quotation )
[
[ parse-definition ]
parse-locals-definition drop
] with-method-definition ;
] with-method-definition ;

23
basis/locals/prettyprint/prettyprint.factor
View File

@ -27,22 +27,17 @@ M: lambda pprint*
: pprint-let ( let word -- )
pprint-word
[ body>> ] [ bindings>> ] bi
\ | pprint-word
t <inset
<block
[ <block [ pprint-var ] dip pprint* block> ] assoc-each
block>
\ | pprint-word
<block pprint-elements block>
block>
<block body>> pprint-elements block>
\ ] pprint-word ;
M: let pprint* \ [let pprint-let ;
M: wlet pprint* \ [wlet pprint-let ;
M: let* pprint* \ [let* pprint-let ;
M: def pprint*
<block \ :> pprint-word local>> pprint-word block> ;
dup local>> word?
[ <block \ :> pprint-word local>> pprint-var block> ]
[ pprint-tuple ] if ;
M: multi-def pprint*
dup locals>> [ word? ] all?
[ <block \ :> pprint-word "(" text locals>> [ pprint-var ] each ")" text block> ]
[ pprint-tuple ] if ;

20
basis/locals/rewrite/sugar/sugar.factor
View File

@ -6,7 +6,7 @@ locals.errors locals.types make quotations sequences vectors
words ;
IN: locals.rewrite.sugar
! Step 1: rewrite [| [let [let* [wlet into :> forms, turn
! Step 1: rewrite [| into :> forms, turn
! literals with locals in them into code which constructs
! the literal after pushing locals on the stack
@ -73,7 +73,7 @@ M: quotation rewrite-element rewrite-sugar* ;
M: lambda rewrite-element rewrite-sugar* ;
M: binding-form rewrite-element binding-form-in-literal-error ;
M: let rewrite-element let-form-in-literal-error ;
M: local rewrite-element , ;
@ -104,6 +104,8 @@ M: tuple rewrite-sugar* rewrite-element ;
M: def rewrite-sugar* , ;
M: multi-def rewrite-sugar* locals>> <reversed> [ <def> , ] each ;
M: hashtable rewrite-sugar* rewrite-element ;
M: wrapper rewrite-sugar*
@ -115,17 +117,5 @@ M: word rewrite-sugar*
M: object rewrite-sugar* , ;
: let-rewrite ( body bindings -- )
[ quotation-rewrite % <def> , ] assoc-each
quotation-rewrite % ;
M: let rewrite-sugar*
[ body>> ] [ bindings>> ] bi let-rewrite ;
M: let* rewrite-sugar*
[ body>> ] [ bindings>> ] bi let-rewrite ;
M: wlet rewrite-sugar*
[ body>> ] [ bindings>> ] bi
[ '[ _ ] ] assoc-map
let-rewrite ;
body>> quotation-rewrite % ;

16
basis/locals/types/types.factor
View File

@ -8,20 +8,10 @@ TUPLE: lambda vars body ;
C: <lambda> lambda
TUPLE: binding-form bindings body ;
TUPLE: let < binding-form ;
TUPLE: let body ;
C: <let> let
TUPLE: let* < binding-form ;
C: <let*> let*
TUPLE: wlet < binding-form ;
C: <wlet> wlet
TUPLE: quote local ;
C: <quote> quote
@ -32,6 +22,10 @@ TUPLE: def local ;
C: <def> def
TUPLE: multi-def locals ;
C: <multi-def> multi-def
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )

12
basis/math/matrices/matrices.factor
View File

@ -16,7 +16,7 @@ IN: math.matrices
:: rotation-matrix3 ( axis theta -- matrix )
theta cos :> c
theta sin :> s
axis first3 :> z :> y :> x
axis first3 :> ( x y z )
x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array
x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array
x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array
@ -25,14 +25,14 @@ IN: math.matrices
:: rotation-matrix4 ( axis theta -- matrix )
theta cos :> c
theta sin :> s
axis first3 :> z :> y :> x
axis first3 :> ( x y z )
x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array
x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array
x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array
{ 0.0 0.0 0.0 1.0 } 4array ;
:: translation-matrix4 ( offset -- matrix )
offset first3 :> z :> y :> x
offset first3 :> ( x y z )
{
{ 1.0 0.0 0.0 x }
{ 0.0 1.0 0.0 y }
@ -44,7 +44,7 @@ IN: math.matrices
dup number? [ dup dup ] [ first3 ] if ;
:: scale-matrix3 ( factors -- matrix )
factors >scale-factors :> z :> y :> x
factors >scale-factors :> ( x y z )
{
{ x 0.0 0.0 }
{ 0.0 y 0.0 }
@ -52,7 +52,7 @@ IN: math.matrices
} ;
:: scale-matrix4 ( factors -- matrix )
factors >scale-factors :> z :> y :> x
factors >scale-factors :> ( x y z )
{
{ x 0.0 0.0 0.0 }
{ 0.0 y 0.0 0.0 }
@ -64,7 +64,7 @@ IN: math.matrices
[ recip ] map scale-matrix4 ;
:: frustum-matrix4 ( xy-dim near far -- matrix )
xy-dim first2 :> y :> x
xy-dim first2 :> ( x y )
near x /f :> xf
near y /f :> yf
near far + near far - /f :> zf

2
basis/math/primes/miller-rabin/miller-rabin.factor
View File

@ -8,7 +8,7 @@ IN: math.primes.miller-rabin
:: (miller-rabin) ( n trials -- ? )
n 1 - :> n-1
n-1 factor-2s :> s :> r
n-1 factor-2s :> ( r s )
0 :> a!
trials [
drop

4
basis/math/vectors/conversion/conversion.factor
View File

@ -81,8 +81,8 @@ ERROR: bad-vconvert-input value expected-type ;
PRIVATE>
MACRO:: vconvert ( from-type to-type -- )
from-type new [ element-type ] [ byte-length ] bi :> from-length :> from-element
to-type new [ element-type ] [ byte-length ] bi :> to-length :> to-element
from-type new [ element-type ] [ byte-length ] bi :> ( from-element from-length )
to-type new [ element-type ] [ byte-length ] bi :> ( to-element to-length )
from-element heap-size :> from-size
to-element heap-size :> to-size

4
basis/math/vectors/simd/simd-tests.factor
View File

@ -391,8 +391,8 @@ TUPLE: inconsistent-vector-test bool branch ;
2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
:: test-vector-tests ( vector decl -- none? any? all? )
vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none
vector decl test-vector-tests-branch :> branch-all :> branch-any :> branch-none
vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all )
vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all )
bool-none branch-none ?inconsistent
bool-any branch-any ?inconsistent

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 ;
[ 1 0 ] [
[let* | m1 [ 1 <model> ]
m2 [ 2 <model> ]
c [ { m1 m2 } <product> ]
o1 [ an-observer new ]
o2 [ an-observer new ] |
[let
1 <model> :> m1
2 <model> :> m2
{ m1 m2 } <product> :> c
an-observer new :> o1
an-observer new :> o2
o1 m1 add-connection
o2 m2 add-connection

8
basis/opengl/opengl.factor
View File

@ -95,8 +95,8 @@ MACRO: all-enabled-client-state ( seq quot -- )
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
loc first2 :> y :> x
dim first2 :> h :> w
loc first2 :> ( x y )
dim first2 :> ( w h )
[
x 0.5 + y 0.5 +
x w + 0.3 - y 0.5 +
@ -115,8 +115,8 @@ MACRO: all-enabled-client-state ( seq quot -- )
rect-vertices (gl-rect) ;
:: (fill-rect-vertices) ( loc dim -- vertices )
loc first2 :> y :> x
dim first2 :> h :> w
loc first2 :> ( x y )
dim first2 :> ( w h )
[
x y
x w + y

2
basis/opengl/textures/textures.factor
View File

@ -278,7 +278,7 @@ TUPLE: single-texture < disposable image dim loc texture-coords texture display-
] unless ;
:: tex-image ( image bitmap -- )
image image-format :> type :> format :> internal-format
image image-format :> ( internal-format format type )
GL_TEXTURE_2D 0 internal-format
image dim>> adjust-texture-dim first2 0
format type bitmap glTexImage2D ;

16
basis/peg/ebnf/ebnf.factor
View File

@ -445,16 +445,16 @@ M: ebnf-sequence build-locals ( code ast -- code )
drop
] [
[
"FROM: locals => [let* ; FROM: sequences => nth ; [let* | " %
dup length swap [
dup ebnf-var? [
"FROM: locals => [let :> ; FROM: sequences => nth ; [let " %
dup length [
over ebnf-var? [
" " % # " over nth :> " %
name>> %
" [ " % # " over nth ] " %
] [
2drop
] if
] 2each
" | " %
" " %
%
" nip ]" %
] "" make
@ -463,9 +463,9 @@ M: ebnf-sequence build-locals ( code ast -- code )
M: ebnf-var build-locals ( code ast -- )
[
"FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " %
name>> % " [ dup ] " %
" | " %
"FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " %
" dup :> " % name>> %
" " %
%
" nip ]" %
] "" make ;

52
basis/peg/peg.factor
View File

@ -172,9 +172,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
l lrstack get (setup-lr) ;
:: lr-answer ( r p m -- ast )
[let* |
h [ m ans>> head>> ]
|
m ans>> head>> :> h
h rule-id>> r rule-id eq? [
m ans>> seed>> m (>>ans)
m ans>> failed? [
@ -184,14 +182,11 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] if
] [
m ans>> seed>>
] if
] ; inline
] if ; inline
:: recall ( r p -- memo-entry )
[let* |
m [ p r rule-id memo ]
h [ p heads at ]
|
p r rule-id memo :> m
p heads at :> h
h [
m r rule-id h involved-set>> h rule-id>> suffix member? not and [
fail p memo-entry boa
@ -207,15 +202,12 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] if
] [
m
] if
] ; inline
] if ; inline
:: apply-non-memo-rule ( r p -- ast )
[let* |
lr [ fail r rule-id f lrstack get left-recursion boa ]
m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ]
ans [ r eval-rule ]
|
fail r rule-id f lrstack get left-recursion boa :> lr
lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
r eval-rule :> ans
lrstack get next>> lrstack set
pos get m (>>pos)
lr head>> [
@ -226,8 +218,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] [
ans m (>>ans)
ans
] if
] ; inline
] if ; inline
: apply-memo-rule ( r m -- ast )
[ ans>> ] [ pos>> ] bi pos set
@ -622,20 +613,19 @@ PRIVATE>
ERROR: parse-failed input word ;
SYNTAX: PEG:
(:)
[let | effect [ ] def [ ] word [ ] |
[
[
[let | compiled-def [ def call compile ] |
[let
(:) :> ( word def effect )
[
[
dup compiled-def compiled-parse
[ ast>> ] [ word parse-failed ] ?if
]
word swap effect define-declared
]
] with-compilation-unit
] append!
] ;
def call compile :> compiled-def
[
dup compiled-def compiled-parse
[ ast>> ] [ word parse-failed ] ?if
]
word swap effect define-declared
] with-compilation-unit
] append!
] ;
USING: vocabs vocabs.loader ;

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

@ -10,77 +10,70 @@ IN: persistent.hashtables.nodes.bitmap
: 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
shift
<bitmap-node>
new-leaf
]
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) :> ( n' new-leaf )
n n' eq? [
bitmap-node
] [
[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
]
]
bitmap
n' idx nodes new-nth
shift
<bitmap-node>
] 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% ;

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 )
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 :> ( idx leaf-node )
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 ;

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

@ -8,39 +8,37 @@ persistent.hashtables.nodes ;
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) :> ( n' new-leaf )
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

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>> =
[ 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 ;

2
basis/regexp/nfa/nfa.factor
View File

@ -46,7 +46,7 @@ GENERIC: nfa-node ( node -- start-state end-state )
epsilon nfa-table get add-transition ;
M:: star nfa-node ( node -- start end )
node term>> nfa-node :> s1 :> s0
node term>> nfa-node :> ( s0 s1 )
next-state :> s2
next-state :> s3
s1 s0 epsilon-transition

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

@ -192,17 +192,17 @@ M: bad-executable summary
\ 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,
] ;
:: infer-get-local ( -- )
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

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

@ -32,13 +32,12 @@ yield
[ [ 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

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

@ -6,26 +6,25 @@ namespaces namespaces.private assocs accessors ;
IN: tools.walker.debug
:: 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
[
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>> ;

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

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

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

@ -56,13 +56,12 @@ M: array array-base-type first ;
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

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

@ -74,12 +74,12 @@ $nl
"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
f :> false
URL" http://factorcode.org/" :> url
"hello" :> string
\\ drop :> word
<XML
<x
number=<-number->

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

@ -54,8 +54,7 @@ XML-NS: foo http://blah.com
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

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

@ -7,25 +7,24 @@ IN: benchmark.beust2
:: (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 -- )
@ -33,9 +32,8 @@ IN: benchmark.beust2
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

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

@ -71,37 +71,35 @@ CONSTANT: homo-sapiens
[ 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 [ ] |
[let
:> alu
0 :> k!
[| 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 ] |
[let
:> ( n out IUB-chars IUB-floats homo-sapiens-chars homo-sapiens-floats )
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
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 ;

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

@ -17,20 +17,19 @@ STRUCT: yuv_buffer
{ 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

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

@ -61,37 +61,33 @@ CONSTANT: AES_BLOCK_SIZE 16
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>

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

@ -17,28 +17,29 @@ IN: crypto.passwd-md5
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 ;

4
extra/decimals/decimals.factor
View File

@ -75,8 +75,8 @@ M: decimal before?
:: D/ ( D1 D2 a -- D3 )
D1 D2 guard-decimals 2drop
D1 >decimal< :> e1 :> m1
D2 >decimal< :> e2 :> m2
D1 >decimal< :> ( m1 e1 )
D2 >decimal< :> ( m2 e2 )
m1 a 10^ *
m2 /i

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

@ -189,7 +189,7 @@ CONSTANT: galois-slides
}
{ $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"

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

@ -272,7 +272,7 @@ CONSTANT: google-slides
}
{ $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"

6
extra/gpu/render/render.factor
View File

@ -332,13 +332,13 @@ DEFER: [bind-uniform-tuple]
] [
{ [ ] }
name "." append 1array
] if* :> name-prefixes :> quot-prefixes
] if* :> ( quot-prefixes name-prefixes )
type all-uniform-tuple-slots :> uniforms
texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
uniforms name-prefix [bind-uniform-tuple]
quot-prefix prepend
] 2map :> value-cleave :> texture-unit'
] 2map :> ( texture-unit' value-cleave )
texture-unit'
value>>-quot { value-cleave 2cleave } append ;
@ -356,7 +356,7 @@ DEFER: [bind-uniform-tuple]
} cond ;
:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
texture-unit uniforms [ prefix [bind-uniform] ] map :> ( texture-unit' uniforms-cleave )
texture-unit'
{ uniforms-cleave 2cleave } >quotation ;

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

@ -26,11 +26,11 @@ CONSTANT: fill-value 255
] 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 ;

19
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"
"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:"
@ -76,8 +61,8 @@ $nl
$nl
"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] ."
"USING: arrays locals 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:"

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

@ -13,17 +13,6 @@ IN: infix.tests
-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
@ -42,4 +31,4 @@ IN: infix.tests
[ 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

11
extra/infix/infix.factor
View File

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

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

@ -101,11 +101,12 @@ CONSTANT: max-speed 30.0
] 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 ]

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

@ -107,13 +107,13 @@ CONSTANT: default-segment-radius 1
} 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 ;
@ -138,10 +138,10 @@ CONSTANT: distant 1000
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 )

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
:: 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

10
extra/math/matrices/simd/simd.factor
View File

@ -35,8 +35,8 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
:: 2map-columns ( a b quot -- c )
[
a columns :> a4 :> a3 :> a2 :> a1
b columns :> b4 :> b3 :> b2 :> b1
a columns :> ( a1 a2 a3 a4 )
b columns :> ( b1 b2 b3 b4 )
a1 b1 quot call
a2 b2 quot call
@ -61,8 +61,8 @@ TYPED: n/m4 ( a: float b: matrix4 -- c: matrix4 ) [ n/v ] with map-columns ;
TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
[
a columns :> a4 :> a3 :> a2 :> a1
b columns :> b4 :> b3 :> b2 :> b1
a columns :> ( a1 a2 a3 a4 )
b columns :> ( b1 b2 b3 b4 )
b1 first a1 n*v :> c1a
b2 first a1 n*v :> c2a
@ -86,7 +86,7 @@ TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
] make-matrix4 ;
TYPED:: m4.v ( m: matrix4 v: float-4 -- v': float-4 )
m columns :> m4 :> m3 :> m2 :> m1
m columns :> ( m1 m2 m3 m4 )
v first m1 n*v
v second m2 n*v v+

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

@ -123,15 +123,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
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 )
@ -143,4 +144,4 @@ PRIVATE>
[ dispose f ] change-handle drop ;
M: mdb-connection dispose
mdb-close ;
mdb-close ;

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

@ -151,14 +151,16 @@ M: mdb-collection create-collection
[ "$cmd" = ] [ "system" head? ] bi or ;
: check-collection ( collection -- fq-collection )
[let* | instance [ mdb-instance ]
instance-name [ instance name>> ] |
[let
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 ] ;
[ instance-name ] dip "." glue
] ;
: fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline

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

@ -105,15 +105,14 @@ USE: tools.walker
! [ dump-to-file ] keep
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
] ;
:: build-query-object ( query -- selector )
H{ } clone :> selector
query { [ 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>

2
extra/nurbs/nurbs.factor
View File

@ -60,7 +60,7 @@ TUPLE: nurbs-curve
:: (eval-bases) ( curve t interval values order -- values' )
order 2 - curve (knot-constants)>> nth :> all-knot-constants
interval order interval + all-knot-constants clip-range :> to :> from
interval order interval + all-knot-constants clip-range :> ( from to )
from to all-knot-constants subseq :> knot-constants
values { 0.0 } { 0.0 } surround 2 <clumps> :> bases

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

@ -33,13 +33,12 @@ IN: project-euler.073
<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>

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 ;
:: (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 ;

2
extra/reports/noise/noise.factor
View File

@ -81,8 +81,6 @@ M: wrapper noise wrapped>> noise ;
M: let noise body>> noise ;
M: wlet noise body>> noise ;
M: lambda noise body>> noise ;
M: object noise drop { 0 0 } ;

2
extra/sequences/product/product.factor
View File

@ -49,7 +49,7 @@ M: product-sequence nth
product@ nths ;
:: product-each ( sequences quot -- )
sequences start-product-iter :> lengths :> ns
sequences start-product-iter :> ( ns lengths )
lengths [ 0 = ] any? [
[ ns lengths end-product-iter? ]
[ ns sequences nths quot call ns lengths product-iter ] until

4
extra/spider/spider.factor
View File

@ -69,12 +69,12 @@ fetched-in parsed-html links processed-in fetched-at ;
:: fill-spidered-result ( spider spider-result -- )
f spider-result url>> spider spidered>> set-at
[ spider-result url>> http-get ] benchmark :> fetched-in :> html :> headers
[ spider-result url>> http-get ] benchmark :> ( headers html fetched-in )
[
html parse-html
spider currently-spidering>>
over find-all-links normalize-hrefs
] benchmark :> processed-in :> links :> parsed-html
] benchmark :> ( parsed-html links processed-in )
spider-result
headers >>headers
fetched-in >>fetched-in

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

@ -12,12 +12,13 @@ IN: ui.gadgets.alerts
: 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
@ -25,4 +26,4 @@ MACRO: ask-buttons ( buttons -- quot ) dup length [
[ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
"" open-window
] 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"
{ "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"

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

@ -3,10 +3,7 @@
<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>

2
misc/fuel/fuel-syntax.el
View File

@ -272,7 +272,7 @@
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
("\\(\\[\\)\\(let\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|"))
(" \\(|\\) " (1 "(|"))
(" \\(|\\)$" (1 ")"))

0
extra/dns/cache/nx/nx.factor → unmaintained/dns/cache/nx/nx.factor vendored
View File

0
extra/dns/cache/rr/rr.factor → unmaintained/dns/cache/rr/rr.factor vendored
View File

0
extra/dns/dns.factor → unmaintained/dns/dns.factor
View File

0
extra/dns/forwarding/forwarding.factor → unmaintained/dns/forwarding/forwarding.factor
View File

0
extra/dns/misc/misc.factor → unmaintained/dns/misc/misc.factor
View File

Some files were not shown because too many files have changed in this diff Show More