diff --git a/build-support/grovel.c b/build-support/grovel.c index 2eee054dab..db16aa9bca 100644 --- a/build-support/grovel.c +++ b/build-support/grovel.c @@ -42,6 +42,7 @@ #include #include #include + #include #include #include #endif @@ -146,6 +147,7 @@ void unix_constants() constant(PROT_WRITE); constant(MAP_FILE); constant(MAP_SHARED); + constant(PATH_MAX); grovel(pid_t); } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index d0adec1fcf..cfa9fb2e16 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -39,7 +39,7 @@ M: alien equal? 2dup [ expired? ] either? [ [ expired? ] both? ] [ - [ alien-address ] 2apply = + [ alien-address ] bi@ = ] if ] [ 2drop f diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 196ec614b7..b911faf672 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -115,7 +115,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) swap [ swapd set-at ] curry assoc-each ; : union ( assoc1 assoc2 -- union ) - 2dup [ assoc-size ] 2apply + pick new-assoc + 2dup [ assoc-size ] bi@ + pick new-assoc [ rot update ] keep [ swap update ] keep ; : diff ( assoc1 assoc2 -- diff ) diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 5774b86e45..e28c16c3c2 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -21,7 +21,7 @@ IN: bit-arrays.tests { t f t } { f t f } ] [ { t f t } >bit-array dup clone dup [ not ] change-each - [ >array ] 2apply + [ >array ] bi@ ] unit-test [ diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f472e0158f..bbb2e44843 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -23,7 +23,7 @@ SYMBOL: bootstrap-time : load-components ( -- ) "exclude" "include" - [ get-global " " split [ empty? not ] subset ] 2apply + [ get-global " " split [ empty? not ] subset ] bi@ seq-diff [ "bootstrap." prepend require ] each ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index e2206213a6..2945bd2546 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -67,7 +67,7 @@ C: anonymous-complement members>> [ class< ] with all? ; : anonymous-complement< ( first second -- ? ) - [ class>> ] 2apply swap class< ; + [ class>> ] bi@ swap class< ; : (class<) ( first second -- -1/0/1 ) { diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 85a6fb241d..eb6b3bd6e2 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -47,8 +47,8 @@ TUPLE: mixin-instance loc class mixin ; M: mixin-instance equal? { { [ over mixin-instance? not ] [ f ] } - { [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] } - { [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] } + { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } + { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } { [ t ] [ t ] } } cond 2nip ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index a747008fa2..7123d5c7c8 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -162,7 +162,7 @@ HELP: reshape-tuple { $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ; HELP: reshape-tuples -{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } } +{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } } { $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ; HELP: removed-slots @@ -170,7 +170,7 @@ HELP: removed-slots { $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ; HELP: forget-slots -{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } } +{ $values { "class" tuple-class } { "slots" "a sequence of strings" } } { $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ; HELP: tuple diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index f5d4470bde..f497fd20e5 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -10,18 +10,54 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $subsection alist>quot } ; ARTICLE: "combinators" "Additional combinators" -"The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":" +"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary." +$nl +"Generalization of " { $link bi } " and " { $link tri } ":" +{ $subsection cleave } +"Generalization of " { $link bi* } " and " { $link tri* } ":" +{ $subsection spread } +"Two combinators which abstract out nested chains of " { $link if } ":" { $subsection cond } { $subsection case } +"The " { $vocab-link "combinators" } " also provides some less frequently-used features." +$nl "A combinator which can help with implementing methods on " { $link hashcode* } ":" { $subsection recursive-hashcode } "An oddball combinator:" { $subsection with-datastack } { $subsection "combinators-quot" } -{ $see-also "quotations" "basic-combinators" } ; +{ $see-also "quotations" "dataflow" } ; ABOUT: "combinators" +HELP: cleave +{ $values { "x" object } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } } +{ $description "Applies each quotation to the object in turn." } +{ $examples + "The " { $link bi } " combinator takes one value and two quotations; the " { $link tri } " combinator takes one value and three quotations. The " { $link cleave } " combinator takes one value and any number of quotations, and is essentially equivalent to a chain of " { $link keep } " forms:" + { $code + "! Equivalent" + "{ [ p ] [ q ] [ r ] [ s ] } cleave" + "[ p ] keep [ q ] keep [ r ] keep s" + } +} ; + +{ bi tri cleave } related-words + +HELP: spread +{ $values { "objs..." "objects" } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } } +{ $description "Applies each quotation to the object in turn." } +{ $examples + "The " { $link bi* } " combinator takes two values and two quotations; the " { $link tri* } " combinator takes three values and three quotations. The " { $link spread } " combinator takes " { $snippet "n" } " values and " { $snippet "n" } " quotations, where " { $snippet "n" } " is the length of the input sequence, and is essentially equivalent to series of retain stack manipulations:" + { $code + "! Equivalent" + "{ [ p ] [ q ] [ r ] [ s ] } spread" + ">r >r >r p r> q r> r r> s" + } +} ; + +{ bi* tri* spread } related-words + HELP: alist>quot { $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } } { $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." } diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index cc03955fd8..e19847dbd4 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -5,13 +5,13 @@ USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting ; -: cleave ( obj seq -- ) +: cleave ( x seq -- ) [ call ] with each ; : cleave>quot ( seq -- quot ) [ [ keep ] curry ] map concat [ drop ] append ; -: 2cleave ( obj seq -- ) +: 2cleave ( x seq -- ) [ [ call ] 3keep drop ] each 2drop ; : 2cleave>quot ( seq -- quot ) @@ -22,7 +22,7 @@ hashtables sorting ; [ [ [ r> ] prepend ] map concat ] bi append ; -: spread ( seq -- ) +: spread ( objs... seq -- ) spread>quot call ; ERROR: no-cond ; diff --git a/core/compiler/tests/curry.factor b/core/compiler/tests/curry.factor index d2e7115f8f..61d20fd8ab 100755 --- a/core/compiler/tests/curry.factor +++ b/core/compiler/tests/curry.factor @@ -10,7 +10,7 @@ IN: compiler.tests [ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test [ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test -[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-call ] unit-test +[ -10 -20 ] [ 10 20 -1 [ [ * ] curry bi@ ] compile-call ] unit-test [ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test [ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 8a33d57fe7..081a8fd47c 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -72,13 +72,13 @@ unit-test ] unit-test [ 12 13 ] [ - -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call + -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call ] unit-test [ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test [ 12 13 ] [ - -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call + -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call ] unit-test [ 1 ] [ diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 8742a693cb..563dd10bc4 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -63,7 +63,7 @@ M: arm-backend load-indirect ( obj reg -- ) M: immediate load-literal over v>operand small-enough? [ - [ v>operand ] 2apply swap MOV + [ v>operand ] bi@ swap MOV ] [ v>operand load-indirect ] if ; @@ -322,10 +322,10 @@ M: arm-backend fp-shadows-int? ( -- ? ) f ; ! Alien intrinsics M: arm-backend %unbox-byte-array ( dst src -- ) - [ v>operand ] 2apply byte-array-offset ADD ; + [ v>operand ] bi@ byte-array-offset ADD ; M: arm-backend %unbox-alien ( dst src -- ) - [ v>operand ] 2apply alien-offset <+> LDR ; + [ v>operand ] bi@ alien-offset <+> LDR ; M: arm-backend %unbox-f ( dst src -- ) drop v>operand 0 MOV ; diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index df0a08a86d..6c37fce4f1 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -33,7 +33,7 @@ IN: cpu.ppc.allot f fresh-object ; M: ppc-backend %box-float ( dst src -- ) - [ v>operand ] 2apply %allot-float 12 MR ; + [ v>operand ] bi@ %allot-float 12 MR ; : %allot-bignum ( #digits -- ) #! 1 cell header, 1 cell length, 1 cell sign, + digits diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 1daf3ac622..903ac32df9 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -71,7 +71,7 @@ M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ; M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ; M: immediate load-literal - [ v>operand ] 2apply LOAD ; + [ v>operand ] bi@ LOAD ; M: ppc-backend load-indirect ( obj reg -- ) [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep @@ -138,7 +138,7 @@ M: ppc-backend %replace >r v>operand r> loc>operand STW ; M: ppc-backend %unbox-float ( dst src -- ) - [ v>operand ] 2apply float-offset LFD ; + [ v>operand ] bi@ float-offset LFD ; M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ; @@ -291,10 +291,10 @@ M: ppc-backend %unbox-small-struct ! Alien intrinsics M: ppc-backend %unbox-byte-array ( dst src -- ) - [ v>operand ] 2apply byte-array-offset ADDI ; + [ v>operand ] bi@ byte-array-offset ADDI ; M: ppc-backend %unbox-alien ( dst src -- ) - [ v>operand ] 2apply alien-offset LWZ ; + [ v>operand ] bi@ alien-offset LWZ ; M: ppc-backend %unbox-f ( dst src -- ) drop 0 swap v>operand LI ; diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index f837a92504..5519a9a8d5 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -101,6 +101,6 @@ M: x86-backend %box-alien ( dst src -- ) ] %allot "end" get JMP "f" resolve-label - f [ v>operand ] 2apply MOV + f [ v>operand ] bi@ MOV "end" resolve-label ] with-scope ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index f993639c05..31fa4c8e4b 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -109,9 +109,9 @@ M: x86-backend %dispatch-label ( word -- ) 0 cell, rc-absolute-cell rel-word ; M: x86-backend %unbox-float ( dst src -- ) - [ v>operand ] 2apply float-offset [+] MOVSD ; + [ v>operand ] bi@ float-offset [+] MOVSD ; -M: x86-backend %peek [ v>operand ] 2apply MOV ; +M: x86-backend %peek [ v>operand ] bi@ MOV ; M: x86-backend %replace swap %peek ; @@ -162,10 +162,10 @@ M: x86-backend %return ( -- ) 0 %unwind ; ! Alien intrinsics M: x86-backend %unbox-byte-array ( dst src -- ) - [ v>operand ] 2apply byte-array-offset [+] LEA ; + [ v>operand ] bi@ byte-array-offset [+] LEA ; M: x86-backend %unbox-alien ( dst src -- ) - [ v>operand ] 2apply alien-offset [+] MOV ; + [ v>operand ] bi@ alien-offset [+] MOV ; M: x86-backend %unbox-f ( dst src -- ) drop v>operand 0 MOV ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index a7937cdb9d..033ae0680c 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -82,7 +82,7 @@ ERROR: assert got expect ; : depth ( -- n ) datastack length ; : trim-datastacks ( seq1 seq2 -- seq1' seq2' ) - 2dup [ length ] 2apply min tuck tail >r tail r> ; + 2dup [ length ] bi@ min tuck tail >r tail r> ; ERROR: relative-underflow stack ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 2bc0e6a3fb..28db6e1cbd 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -63,7 +63,7 @@ IN: dlists.tests [ 0 ] [ 1 over push-front dup pop-front* dlist-length ] unit-test : assert-same-elements - [ prune natural-sort ] 2apply assert= ; + [ prune natural-sort ] bi@ assert= ; : dlist-push-all [ push-front ] curry each ; diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 23e8daf122..aed4a64c6c 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -18,8 +18,8 @@ TUPLE: effect in out terminated? ; { [ dup not ] [ t ] } { [ over effect-terminated? ] [ t ] } { [ dup effect-terminated? ] [ f ] } - { [ 2dup [ effect-in length ] 2apply > ] [ f ] } - { [ 2dup [ effect-height ] 2apply = not ] [ f ] } + { [ 2dup [ effect-in length ] bi@ > ] [ f ] } + { [ 2dup [ effect-height ] bi@ = not ] [ f ] } { [ t ] [ t ] } } cond 2nip ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index e03923e860..aac1b2cdc6 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -79,7 +79,7 @@ M: ds-loc minimal-ds-loc* ds-loc-n min ; M: ds-loc operand-class* ds-loc-class ; M: ds-loc set-operand-class set-ds-loc-class ; M: ds-loc live-loc? - over ds-loc? [ [ ds-loc-n ] 2apply = not ] [ 2drop t ] if ; + over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ; ! A retain stack location. TUPLE: rs-loc n class ; @@ -89,7 +89,7 @@ TUPLE: rs-loc n class ; M: rs-loc operand-class* rs-loc-class ; M: rs-loc set-operand-class set-rs-loc-class ; M: rs-loc live-loc? - over rs-loc? [ [ rs-loc-n ] 2apply = not ] [ 2drop t ] if ; + over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ; UNION: loc ds-loc rs-loc ; @@ -206,7 +206,7 @@ INSTANCE: constant value %move ; : %move ( dst src -- ) - 2dup [ move-spec ] 2apply 2array { + 2dup [ move-spec ] bi@ 2array { { { f f } [ %move-bug ] } { { f unboxed-c-ptr } [ %move-bug ] } { { f unboxed-byte-array } [ %move-bug ] } @@ -318,7 +318,7 @@ M: phantom-stack cut-phantom : phantoms ( -- phantom phantom ) phantom-d get phantom-r get ; -: each-phantom ( quot -- ) phantoms rot 2apply ; inline +: each-phantom ( quot -- ) phantoms rot bi@ ; inline : finalize-heights ( -- ) [ finalize-height ] each-phantom ; @@ -442,7 +442,7 @@ M: loc lazy-store : fast-shuffle? ( live-locs -- ? ) #! Test if we have enough free registers to load all #! shuffle inputs at once. - T{ int-regs } free-vregs [ length ] 2apply <= ; + T{ int-regs } free-vregs [ length ] bi@ <= ; : finalize-locs ( -- ) #! Perform any deferred stack shuffling. @@ -488,7 +488,7 @@ M: loc lazy-store : phantom&spec ( phantom spec -- phantom' spec' ) [ length f pad-left ] keep - [ ] 2apply ; inline + [ ] bi@ ; inline : phantom&spec-agree? ( phantom spec quot -- ? ) >r phantom&spec r> 2all? ; inline @@ -520,7 +520,7 @@ M: loc lazy-store swap lazy-load ; : output-vregs ( -- seq seq ) - +output+ +clobber+ [ get [ get ] map ] 2apply ; + +output+ +clobber+ [ get [ get ] map ] bi@ ; : clash? ( seq -- ? ) phantoms append [ diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index d62afdffb5..2a4be9c570 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -32,14 +32,28 @@ $nl { $code "H{ } clone" } "To convert an assoc to a hashtable:" { $subsection >hashtable } +"Further topics:" +{ $subsection "hashtables.keys" } +{ $subsection "hashtables.utilities" } +{ $subsection "hashtables.private" } ; + +ARTICLE: "hashtables.keys" "Hashtable keys" +"Hashtables rely on the " { $link hashcode } " word to rapidly locate values associated with keys. The objects used as keys in a hashtable must obey certain restrictions." +$nl +"The " { $link hashcode } " of a key is a function of the its slot values, and if the hashcode changes then the hashtable will be left in an inconsistent state. The easiest way to avoid this problem is to never mutate objects used as hashtable keys." +$nl +"In certain advanced applications, this cannot be avoided and the best design involves mutating hashtable keys. In this case, a custom " { $link hashcode* } " method must be defined which only depends on immutable slots." +$nl +"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words." ; + +ARTICLE: "hashtables.utilities" "Hashtable utilities" "Utility words to create a new hashtable from a single key/value pair:" { $subsection associate } { $subsection ?set-at } "The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:" { $subsection prune } "Test if a sequence contains duplicates in linear time:" -{ $subsection all-unique? } -{ $subsection "hashtables.private" } ; +{ $subsection all-unique? } ; ABOUT: "hashtables" diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 1fabc1aab7..5ac49ffa2f 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -18,14 +18,9 @@ IN: hashtables : (key@) ( key keys i -- array n ? ) 3dup swap array-nth dup ((empty)) eq? - [ 3drop nip f f ] - [ - = - [ rot drop t ] - [ probe (key@) ] - if - ] - if ; inline + [ 3drop nip f f ] [ + = [ rot drop t ] [ probe (key@) ] if + ] if ; inline : key@ ( key hash -- array n ? ) hash-array 2dup hash@ (key@) ; inline @@ -89,7 +84,8 @@ IN: hashtables ] if ] if ; inline -: find-pair ( array quot -- key value ? ) 0 rot (find-pair) ; inline +: find-pair ( array quot -- key value ? ) + 0 rot (find-pair) ; inline : (rehash) ( hash array -- ) [ swap pick (set-hash) drop f ] find-pair 2drop 2drop ; @@ -99,8 +95,7 @@ IN: hashtables [ hash-array array-capacity ] bi > ; : hash-stale? ( hash -- ? ) - [ hash-deleted 10 fixnum*fast ] - [ hash-count ] bi fixnum> ; + [ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ; : grow-hash ( hash -- ) [ dup hash-array swap assoc-size 1+ ] keep @@ -161,7 +156,7 @@ M: hashtable clone M: hashtable equal? over hashtable? [ - 2dup [ assoc-size ] 2apply number= + 2dup [ assoc-size ] bi@ number= [ assoc= ] [ 2drop f ] if ] [ 2drop f ] if ; @@ -185,12 +180,12 @@ M: hashtable assoc-like : prune ( seq -- newseq ) [ length ] - [ length ] - [ ] tri + [ length ] + [ ] tri [ >r 2dup r> (prune) ] each nip ; : all-unique? ( seq -- ? ) - [ length ] + [ length ] [ prune length ] bi = ; INSTANCE: hashtable assoc diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 0b3123c87b..77560c7444 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -66,8 +66,8 @@ IN: heaps.tests dup heap-data clone swap ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times heap-data - [ [ entry-key ] map ] 2apply - [ natural-sort ] 2apply ; + [ [ entry-key ] map ] bi@ + [ natural-sort ] bi@ ; 11 [ [ t ] swap [ 2^ delete-test sequence= ] curry unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 7764fd4fd1..ed36ca4890 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -26,8 +26,8 @@ C: literal-constraint M: literal-constraint equal? over literal-constraint? [ 2dup - [ literal-constraint-literal ] 2apply eql? >r - [ literal-constraint-value ] 2apply = r> and + [ literal-constraint-literal ] bi@ eql? >r + [ literal-constraint-value ] bi@ = r> and ] [ 2drop f ] if ; diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 1cc1548a3d..84014512aa 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -224,7 +224,7 @@ DEFER: do-crap* MATH: xyz M: fixnum xyz 2array ; M: float xyz - [ 3 ] 2apply swapd >r 2array swap r> 2array swap ; + [ 3 ] bi@ swapd >r 2array swap r> 2array swap ; [ [ xyz ] infer ] [ inference-error? ] must-fail-with diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index b78f7667a6..9920d8d25c 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -117,7 +117,7 @@ io.encodings.utf8 ; [ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test -[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test +[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] bi@ move-file ] unit-test [ t ] [ "quux-test.txt" temp-file exists? ] unit-test [ ] [ "quux-test.txt" temp-file delete-file ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 48098e612d..458a9145a6 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs continuations io.encodings -io.encodings.binary init ; +io.encodings.binary init accessors ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -145,8 +145,17 @@ PRIVATE> TUPLE: file-info type size permissions modified ; HOOK: file-info io-backend ( path -- info ) + +! Symlinks HOOK: link-info io-backend ( path -- info ) +HOOK: make-link io-backend ( path1 path2 -- ) + +HOOK: read-link io-backend ( path -- info ) + +: copy-link ( path1 path2 -- ) + >r read-link r> make-link ; + SYMBOL: +regular-file+ SYMBOL: +directory+ SYMBOL: +character-device+ @@ -218,14 +227,14 @@ HOOK: delete-file io-backend ( path -- ) HOOK: delete-directory io-backend ( path -- ) -: (delete-tree) ( path dir? -- ) - [ - dup directory* [ (delete-tree) ] assoc-each - delete-directory - ] [ delete-file ] if ; - : delete-tree ( path -- ) - dup directory? (delete-tree) ; + dup link-info type>> +directory+ = [ + dup directory over [ + [ first delete-tree ] each + ] with-directory delete-directory + ] [ + delete-file + ] if ; : to-directory over file-name append-path ; @@ -258,13 +267,16 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) - over directory? [ - >r dup directory swap r> [ - >r swap first append-path r> copy-tree-into - ] 2curry each - ] [ - copy-file - ] if ; + over link-info type>> + { + { +symbolic-link+ [ copy-link ] } + { +directory+ [ + >r dup directory r> rot [ + [ >r first r> copy-tree-into ] curry each + ] with-directory + ] } + [ drop copy-file ] + } case ; : copy-tree-into ( from to -- ) to-directory copy-tree ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 0babb14fa7..a446869096 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -43,29 +43,86 @@ $nl "An alternative to using " { $link >r } " and " { $link r> } " is the following:" { $subsection dip } ; -ARTICLE: "basic-combinators" "Basic combinators" -"The following pair of words invoke words and quotations reflectively:" -{ $subsection call } -{ $subsection execute } -"These words are used to implement " { $emphasis "combinators" } ", which are words that take code from the stack. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:" -{ $code - ": keep ( x quot -- x )" - " over >r call r> ; inline" -} -"Word inlining is documented in " { $link "declarations" } "." +ARTICLE: "cleave-combinators" "Cleave combinators" +"The cleave combinators apply multiple quotations to a single value." $nl -"There are some words that combine shuffle words with " { $link call } ". They are useful for implementing higher-level combinators." +"Two quotations:" +{ $subsection bi } +{ $subsection 2bi } +"Three quotations:" +{ $subsection tri } +{ $subsection 2tri } +"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" +{ $code + "! First alternative; uses keep" + "[ 1 + ] keep" + "[ 1 - ] keep" + "2 *" + "! Second alternative: uses tri" + "[ 1 + ]" + "[ 1 - ]" + "[ 2 * ] tri" +} +"The latter is more aesthetically pleasing than the former." +$nl +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +$nl +"From the Merriam-Webster Dictionary: " +$nl +{ $strong "cleave" } +{ $list + { $emphasis "To divide by or as if by a cutting blow" } + { $emphasis "To separate into distinct parts and especially into groups having divergent views" } +} ; + +ARTICLE: "spread-combinators" "Spread combinators" +"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading." +$nl +"Two quotations:" +{ $subsection bi* } +{ $subsection 2bi* } +"Three quotations:" +{ $subsection tri* } +"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" +{ $code + "! First alternative; uses retain stack explicitly" + ">r >r 1 +" + "r> 1 -" + "r> 2 *" + "! Second alternative: uses tri*" + "[ 1 + ]" + "[ 1 - ]" + "[ 2 * ] tri*" +} + +$nl +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ; + +ARTICLE: "apply-combinators" "Apply combinators" +"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application." +$nl +"Two quotations:" +{ $subsection bi@ } +{ $subsection 2bi@ } +"Three quotations:" +{ $subsection tri@ } +"A pair of utility words built from " { $link bi@ } ":" +{ $subsection both? } +{ $subsection either? } ; + +ARTICLE: "slip-keep-combinators" "The slip and keep combinators" +"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" { $subsection slip } { $subsection 2slip } +{ $subsection 3slip } +"The dip combinator invokes the quotation at the top of the stack, hiding the value underneath:" +{ $subsection dip } +"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" { $subsection keep } { $subsection 2keep } -{ $subsection 3keep } -{ $subsection 2apply } -"A pair of utility words built from " { $link 2apply } ":" -{ $subsection both? } -{ $subsection either? } -"A looping combinator:" -{ $subsection while } +{ $subsection 3keep } ; + +ARTICLE: "compositional-combinators" "Compositional combinators" "Quotations can be composed using efficient quotation-specific operations:" { $subsection curry } { $subsection 2curry } @@ -73,8 +130,21 @@ $nl { $subsection with } { $subsection compose } { $subsection 3compose } -"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." -{ $see-also "combinators" } ; +"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ; + +ARTICLE: "implementing-combinators" "Implementing combinators" +"The following pair of words invoke words and quotations reflectively:" +{ $subsection call } +{ $subsection execute } +"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:" +{ $code + ": keep ( x quot -- x )" + " over >r call r> ; inline" +} +"Word inlining is documented in " { $link "declarations" } "." +$nl +"A looping combinator:" +{ $subsection while } ; ARTICLE: "booleans" "Booleans" "In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." @@ -115,15 +185,13 @@ ARTICLE: "conditionals" "Conditionals and logic" { $subsection ?if } "Sometimes instead of branching, you just need to pick one of two values:" { $subsection ? } -"Forms which abstract away common patterns involving multiple nested branches:" -{ $subsection cond } -{ $subsection case } "There are some logical operations on booleans:" { $subsection >boolean } { $subsection not } { $subsection and } { $subsection or } { $subsection xor } +"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." { $see-also "booleans" "bitwise-arithmetic" both? either? } ; ARTICLE: "equality" "Equality and comparison testing" @@ -146,7 +214,23 @@ $nl "An object can be cloned; the clone has distinct identity but equal value:" { $subsection clone } ; -! Defined in handbook.factor +ARTICLE: "dataflow" "Data and control flow" +{ $subsection "evaluator" } +{ $subsection "words" } +{ $subsection "effects" } +{ $subsection "booleans" } +{ $subsection "shuffle-words" } +"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." +{ $subsection "cleave-combinators" } +{ $subsection "spread-combinators" } +{ $subsection "apply-combinators" } +{ $subsection "slip-keep-combinators" } +{ $subsection "conditionals" } +{ $subsection "combinators" } +"Advanced topics:" +{ $subsection "implementing-combinators" } +{ $subsection "continuations" } ; + ABOUT: "dataflow" HELP: eq? ( obj1 obj2 -- ? ) @@ -211,12 +295,12 @@ HELP: hashcode* { $values { "depth" integer } { "obj" object } { "code" fixnum } } { $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:" { $list - { "if two objects are equal under " { $link = } ", they must have equal hashcodes" } - { "if the hashcode of an object depends on the values of its slots, the hashcode of the slots must be computed recursively by calling " { $link hashcode* } " with a " { $snippet "level" } " parameter decremented by one. This avoids excessive work while still computing well-distributed hashcodes. The " { $link recursive-hashcode } " combinator can help with implementing this logic" } - { "the hashcode should be a " { $link fixnum } ", however returning a " { $link bignum } " will not cause any problems other than potential performance degradation." - "the hashcode is only permitted to change between two invocations if the object was mutated in some way" } + { "If two objects are equal under " { $link = } ", they must have equal hashcodes." } + { "If the hashcode of an object depends on the values of its slots, the hashcode of the slots must be computed recursively by calling " { $link hashcode* } " with a " { $snippet "level" } " parameter decremented by one. This avoids excessive work while still computing well-distributed hashcodes. The " { $link recursive-hashcode } " combinator can help with implementing this logic," } + { "The hashcode should be a " { $link fixnum } ", however returning a " { $link bignum } " will not cause any problems other than potential performance degradation." } + { "The hashcode is only permitted to change between two invocations if the object or one of its slot values was mutated." } } -"If mutable objects are used as hashtable keys, they must not be mutated in such a way that their hashcode changes. Doing so will violate bucket sorting invariants and result in undefined behavior." } ; +"If mutable objects are used as hashtable keys, they must not be mutated in such a way that their hashcode changes. Doing so will violate bucket sorting invariants and result in undefined behavior. See " { $link "hashtables.keys" } " for details." } ; HELP: hashcode { $values { "obj" object } { "code" fixnum } } @@ -242,6 +326,8 @@ HELP: equal? { { $snippet "a = b" } " implies " { $snippet "b = a" } } { { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } } } + $nl + "If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word." } { $examples "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" @@ -376,9 +462,152 @@ HELP: 3keep { $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } } { $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ; -HELP: 2apply -{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } { "x" object } { "y" object } } -{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ; +HELP: bi +{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } "." } +{ $examples + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] bi" + "dup p q" + } + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- y )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] bi" + "dup p swap q" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] bi" + "[ p ] keep q" + } + +} ; + +HELP: 2bi +{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." } +{ $examples + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] 2bi" + "2dup p q" + } + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] 2bi" + "2dup p swap q" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] 2bi" + "[ p ] 2keep q" + } +} ; + +HELP: tri +{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." } +{ $examples + "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] tri" + "dup p dup q r" + } + "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x -- y )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] tri" + "dup p over q rot r" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] tri" + "[ p ] keep [ q ] keep r" + } +} ; + +HELP: 2tri +{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values, and finally applies " { $snippet "r" } " to the two input values." } +{ $examples + "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 2tri" + "2dup p 2dup q r" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 2tri" + "[ p ] 2keep [ q ] 2keep r" + } +} ; + + +HELP: bi* +{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] [ q ] bi*" + ">r p r> q" + } +} ; + +HELP: 2bi* +{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( w x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to " { $snippet "w" } " and " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } " and " { $snippet "z" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] [ q ] 2bi*" + ">r >r q r> r> q" + } +} ; + +HELP: tri* +{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] tri*" + ">r >r q r> q r> r" + } +} ; + +HELP: bi@ +{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } +{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] bi@" + ">r p r> p" + } +} ; + +HELP: 2bi@ +{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- )" } } } +{ $description "Applies the quotation to " { $snippet "w" } " and " { $snippet "x" } ", then to " { $snippet "y" } " and " { $snippet "z" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] 2bi@" + ">r >r p r> r> p" + } +} ; + +HELP: tri@ +{ $values { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } +{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } ", and finally to " { $snippet "z" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] tri@" + ">r >r p r> p r> p" + } +} ; HELP: if ( cond true false -- ) { $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index cbabeb6bfa..ab42a1b903 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -66,46 +66,46 @@ DEFER: if >r 3dup r> -roll 3slip ; inline ! Cleavers -: bi ( x p q -- p[x] q[x] ) +: bi ( x p q -- ) >r keep r> call ; inline -: tri ( x p q r -- p[x] q[x] r[x] ) +: tri ( x p q r -- ) >r pick >r bi r> r> call ; inline ! Double cleavers -: 2bi ( x y p q -- p[x,y] q[x,y] ) +: 2bi ( x y p q -- ) >r 2keep r> call ; inline -: 2tri ( x y p q r -- p[x,y] q[x,y] r[x,y] ) +: 2tri ( x y p q r -- ) >r >r 2keep r> 2keep r> call ; inline ! Triple cleavers -: 3bi ( x y z p q -- p[x,y,z] q[x,y,z] ) +: 3bi ( x y z p q -- ) >r 3keep r> call ; inline -: 3tri ( x y z p q r -- p[x,y,z] q[x,y,z] r[x,y,z] ) +: 3tri ( x y z p q r -- ) >r >r 3keep r> 3keep r> call ; inline ! Spreaders -: bi* ( x y p q -- p[x] q[y] ) +: bi* ( x y p q -- ) >r swap slip r> call ; inline -: tri* ( x y z p q r -- p[x] q[y] r[z] ) +: tri* ( x y z p q r -- ) >r rot >r bi* r> r> call ; inline ! Double spreaders -: 2bi* ( w x y z p q -- p[w,x] q[y,z] ) +: 2bi* ( w x y z p q -- ) >r -rot 2slip r> call ; inline ! Appliers -: bi@ ( x y p -- p[x] p[y] ) +: bi@ ( x y quot -- ) tuck 2slip call ; inline -: tri@ ( x y z p -- p[x] p[y] p[z] ) +: tri@ ( x y z quot -- ) tuck >r bi@ r> call ; inline ! Double appliers -: 2bi@ ( w x y z p -- p[w,x] p[y,z] ) +: 2bi@ ( w x y z quot -- ) dup -roll 3slip call ; inline : while ( pred body tail -- ) @@ -199,6 +199,3 @@ GENERIC: construct-boa ( ... class -- tuple ) : do-primitive ( number -- ) "Improper primitive call" throw ; PRIVATE> - -! Deprecated -: 2apply bi@ ; inline diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 5a3fe777b6..f6317e7475 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -169,7 +169,7 @@ IN: math.intervals.tests : random-interval ( -- interval ) 1000 random dup 2 1000 random + + - 1 random zero? [ [ neg ] 2apply swap ] when + 1 random zero? [ [ neg ] bi@ swap ] when 4 random { { 0 [ [a,b] ] } { 1 [ [a,b) ] } @@ -197,7 +197,7 @@ IN: math.intervals.tests 0 pick interval-contains? over first { / /i } member? and [ 3drop t ] [ - [ >r [ random-element ] 2apply ! 2dup . . + [ >r [ random-element ] bi@ ! 2dup . . r> first execute ] 3keep second execute interval-contains? ] if ; @@ -214,7 +214,7 @@ IN: math.intervals.tests : comparison-test random-interval random-interval random-comparison - [ >r [ random-element ] 2apply r> first execute ] 3keep + [ >r [ random-element ] bi@ r> first execute ] 3keep second execute dup incomparable eq? [ 2drop t ] [ diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index d1c458065f..cc51060f63 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -67,7 +67,7 @@ C: interval : (interval-op) ( p1 p2 quot -- p3 ) 2over >r >r - >r [ first ] 2apply r> call + >r [ first ] bi@ r> call r> r> [ second ] both? 2array ; inline : interval-op ( i1 i2 quot -- i3 ) @@ -108,7 +108,7 @@ C: interval : interval-intersect ( i1 i2 -- i3 ) 2dup and [ - [ interval>points ] 2apply swapd + [ interval>points ] bi@ swapd [ swap endpoint> ] most >r [ swap endpoint< ] most r> make-interval @@ -118,7 +118,7 @@ C: interval : interval-union ( i1 i2 -- i3 ) 2dup and [ - [ interval>points 2array ] 2apply append points>interval + [ interval>points 2array ] bi@ append points>interval ] [ 2drop f ] if ; @@ -131,17 +131,17 @@ C: interval : interval-singleton? ( int -- ? ) interval>points - 2dup [ second ] 2apply and - [ [ first ] 2apply = ] + 2dup [ second ] bi@ and + [ [ first ] bi@ = ] [ 2drop f ] if ; : interval-length ( int -- n ) dup - [ interval>points [ first ] 2apply swap - ] + [ interval>points [ first ] bi@ swap - ] [ drop 0 ] if ; : interval-closure ( i1 -- i2 ) - dup [ interval>points [ first ] 2apply [a,b] ] when ; + dup [ interval>points [ first ] bi@ [a,b] ] when ; : interval-shift ( i1 i2 -- i3 ) #! Inaccurate; could be tighter @@ -163,7 +163,7 @@ C: interval [ min ] interval-op interval-closure ; : interval-interior ( i1 -- i2 ) - interval>points [ first ] 2apply (a,b) ; + interval>points [ first ] bi@ (a,b) ; : interval-division-op ( i1 i2 quot -- i3 ) >r 0 over interval-closure interval-contains? @@ -186,13 +186,13 @@ SYMBOL: incomparable : left-endpoint-< ( i1 i2 -- ? ) [ swap interval-subset? ] 2keep [ nip interval-singleton? ] 2keep - [ interval-from ] 2apply = + [ interval-from ] bi@ = and and ; : right-endpoint-< ( i1 i2 -- ? ) [ interval-subset? ] 2keep [ drop interval-singleton? ] 2keep - [ interval-to ] 2apply = + [ interval-to ] bi@ = and and ; : (interval<) over interval-from over interval-from endpoint< ; diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index d5e8e2d75d..f22cce9fa8 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -99,7 +99,7 @@ namespaces assocs kernel sequences math tools.test words ; ] unit-test : regression-2 ( x y -- x.y ) - [ p1 ] 2apply [ + [ p1 ] bi@ [ [ rot [ 2swap [ swapd * -rot p2 +@ ] 2keep ] diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 349cf88f17..abe48ec272 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -113,7 +113,7 @@ generic.standard system ; : post-process ( class interval node -- classes intervals ) dupd won't-overflow? [ >r dup { f integer } member? [ drop fixnum ] when r> ] when - [ dup [ 1array ] when ] 2apply ; + [ dup [ 1array ] when ] bi@ ; : math-output-interval-1 ( node word -- interval ) dup [ @@ -147,7 +147,7 @@ generic.standard system ; ] each : intervals ( node -- i1 i2 ) - node-in-d first2 [ value-interval* ] 2apply ; + node-in-d first2 [ value-interval* ] bi@ ; : math-output-interval-2 ( node word -- interval ) dup [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index f8836217b5..36e5decd05 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -475,7 +475,7 @@ SYMBOL: interactive-vocabs : removed-definitions ( -- definitions ) new-definitions old-definitions - [ get first2 union ] 2apply diff ; + [ get first2 union ] bi@ diff ; : smudged-usage ( -- usages referenced removed ) removed-definitions filter-moved keys [ diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 6c557d873d..d294f95be6 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -114,7 +114,7 @@ SYMBOL: -> : remove-breakpoints ( quot pos -- quot' ) over quotation? [ - 1+ cut [ (remove-breakpoints) ] 2apply + 1+ cut [ (remove-breakpoints) ] bi@ [ -> ] swap 3append ] [ drop diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 693e337959..c0f15a9388 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -12,7 +12,7 @@ M: curry call dup 3 slot swap 4 slot call ; M: compose call dup 3 slot swap 4 slot slip call ; M: wrapper equal? - over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ; + over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ; UNION: callable quotation curry compose ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index c545a9baee..3a30824084 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -169,13 +169,13 @@ unit-test [ f ] [ { "a" "b" "c" } { "a" "b" "c" } mismatch ] unit-test -[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] 2apply ] unit-test +[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] bi@ ] unit-test -[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test +[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] bi@ ] unit-test [ -1 1 "abc" ] must-fail -[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test +[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test [ -1 ] [ "ab" "abc" <=> ] unit-test [ 1 ] [ "abc" "ab" <=> ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 111cf74ea2..1f2a6c5501 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -300,9 +300,9 @@ M: immutable-sequence clone-like like ; : change-nth ( i seq quot -- ) [ >r nth r> call ] 3keep drop set-nth ; inline -: min-length ( seq1 seq2 -- n ) [ length ] 2apply min ; inline +: min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline -: max-length ( seq1 seq2 -- n ) [ length ] 2apply max ; inline +: max-length ( seq1 seq2 -- n ) [ length ] bi@ max ; inline (2each) each-integer ; inline : 2reverse-each ( seq1 seq2 quot -- ) - >r [ ] 2apply r> 2each ; inline + >r [ ] bi@ r> 2each ; inline : 2reduce ( seq1 seq2 identity quot -- result ) >r -rot r> 2each ; inline @@ -460,7 +460,7 @@ M: sequence <=> [ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ; : sequence= ( seq1 seq2 -- ? ) - 2dup [ length ] 2apply number= + 2dup [ length ] bi@ number= [ mismatch not ] [ 2drop f ] if ; inline : move ( to from seq -- ) @@ -620,12 +620,12 @@ M: sequence <=> [ drop nip ] [ 2drop first ] [ >r drop first2 r> call ] - [ >r drop first3 r> 2apply ] + [ >r drop first3 r> bi@ ] } dispatch ] [ drop >r >r halves r> r> - [ [ binary-reduce ] 2curry 2apply ] keep + [ [ binary-reduce ] 2curry bi@ ] keep call ] if ; inline diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index ab2ce21010..5f81b17187 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -32,7 +32,7 @@ DEFER: sort ] if ; inline : merge ( sorted1 sorted2 quot -- result ) - >r [ [ ] 2apply ] 2keep r> + >r [ [ ] bi@ ] 2keep r> rot length rot length + [ (merge) ] keep underlying ; inline diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 419a30dda4..9be1d5fc64 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -56,7 +56,7 @@ INSTANCE: groups sequence ] if ; : last-split1 ( seq subseq -- before after ) - [ ] 2apply split1 [ reverse ] 2apply + [ ] bi@ split1 [ reverse ] bi@ dup [ swap ] when ; : (split) ( separators n seq -- ) diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index d990f5f31c..18aa0f3fa7 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -77,7 +77,7 @@ IN: vectors.tests [ f ] [ V{ 1 2 3 4 } dup clone - [ underlying ] 2apply eq? + [ underlying ] bi@ eq? ] unit-test [ 0 ] [ diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index f111b5bc74..886417b715 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -94,7 +94,7 @@ TUPLE: vocab-link name ; M: vocab-link equal? over vocab-link? - [ [ vocab-link-name ] 2apply = ] [ 2drop f ] if ; + [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ; M: vocab-link hashcode* vocab-link-name hashcode* ; diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index dbd1f5131b..3ec8cb4245 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -133,7 +133,7 @@ DEFER: create ( level c r -- scene ) pick 1 = [ nip ] [ create-group ] if ; : ss-point ( dx dy -- point ) - [ oversampling /f ] 2apply 0.0 3float-array ; + [ oversampling /f ] bi@ 0.0 3float-array ; : ss-grid ( -- ss-grid ) oversampling [ oversampling [ ss-point ] with map ] map ; @@ -150,7 +150,7 @@ DEFER: create ( level c r -- scene ) : pixel-grid ( -- grid ) size reverse [ size [ - [ size 0.5 * - ] 2apply swap size + [ size 0.5 * - ] bi@ swap size 3float-array ] with map ] map ; diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor index c8d4714802..c66de87cb5 100755 --- a/extra/benchmark/reverse-complement/reverse-complement-tests.factor +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -5,7 +5,7 @@ io.files kernel ; [ "c071aa7e007a9770b2fb4304f55a17e5" ] [ "extra/benchmark/reverse-complement/reverse-complement-test-in.txt" "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" - [ resource-path ] 2apply + [ resource-path ] bi@ reverse-complement "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 42bae7d0d1..7eddeefc1b 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -7,7 +7,7 @@ IN: benchmark.spectral-norm : fast-truncate >fixnum >float ; inline : eval-A ( i j -- n ) - [ >float ] 2apply + [ >float ] bi@ dupd + dup 1+ * 2 /f fast-truncate + 1+ recip ; inline diff --git a/extra/benchmark/typecheck2/typecheck2.factor b/extra/benchmark/typecheck2/typecheck2.factor index d7977063ee..0fc1debb67 100644 --- a/extra/benchmark/typecheck2/typecheck2.factor +++ b/extra/benchmark/typecheck2/typecheck2.factor @@ -3,7 +3,7 @@ IN: benchmark.typecheck2 TUPLE: hello n ; -: hello-n* dup tuple? [ 4 slot ] [ 3 throw ] if ; +: hello-n* dup tuple? [ 3 slot ] [ 3 throw ] if ; : foo 0 100000000 [ over hello-n* + ] times ; diff --git a/extra/benchmark/typecheck3/typecheck3.factor b/extra/benchmark/typecheck3/typecheck3.factor index e85fb2850c..9a58e0a795 100644 --- a/extra/benchmark/typecheck3/typecheck3.factor +++ b/extra/benchmark/typecheck3/typecheck3.factor @@ -3,7 +3,7 @@ IN: benchmark.typecheck3 TUPLE: hello n ; -: hello-n* dup tag 2 eq? [ 4 slot ] [ 3 throw ] if ; +: hello-n* dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ; : foo 0 100000000 [ over hello-n* + ] times ; diff --git a/extra/benchmark/typecheck4/typecheck4.factor b/extra/benchmark/typecheck4/typecheck4.factor index a1362a68ab..eb211e97e7 100644 --- a/extra/benchmark/typecheck4/typecheck4.factor +++ b/extra/benchmark/typecheck4/typecheck4.factor @@ -3,7 +3,7 @@ IN: benchmark.typecheck4 TUPLE: hello n ; -: hello-n* 4 slot ; +: hello-n* 3 slot ; : foo 0 100000000 [ over hello-n* + ] times ; diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 175f66f4a6..114809377b 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -63,7 +63,7 @@ M: check< summary drop "Number exceeds upper bound" ; [ range>accessor ] map ; : clear-range ( range -- num ) - first2 dupd + [ 2^ 1- ] 2apply bitnot bitor ; + first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ; : range>setter ( range -- quot ) [ diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index efa7216699..4ea20629c1 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -80,7 +80,7 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: relative-position ( self other -- v ) swap [ boid-pos ] 2apply v- ; +: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ; : relative-angle ( self other -- angle ) over boid-vel -rot relative-position angle-between ; diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor index 2f38462976..9e5e932831 100644 --- a/extra/builder/benchmark/benchmark.factor +++ b/extra/builder/benchmark/benchmark.factor @@ -19,11 +19,11 @@ IN: builder.benchmark 2array ; : compare-tables ( old new -- table ) - [ passing-benchmarks ] 2apply + [ passing-benchmarks ] bi@ [ benchmark-difference ] with map ; : benchmark-deltas ( -- table ) - "../benchmarks" "benchmarks" [ eval-file ] 2apply + "../benchmarks" "benchmarks" [ eval-file ] bi@ compare-tables sort-values ; diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 461d951209..75664ce5e5 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -48,15 +48,31 @@ IN: builder : record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; -: do-make-clean ( -- ) { "make" "clean" } try-process ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gnu-make ( -- string ) + os { "freebsd" "openbsd" "netbsd" } member? + [ "gmake" ] + [ "make" ] + if ; + +! : do-make-clean ( -- ) { "make" "clean" } try-process ; + +: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! : make-vm ( -- desc ) +! +! { "make" } >>command +! "../compile-log" >>stdout +! +stdout+ >>stderr ; + : make-vm ( -- desc ) - { "make" } >>command - "../compile-log" >>stdout - +stdout+ >>stderr ; + { gnu-make } to-strings >>command + "../compile-log" >>stdout + +stdout+ >>stderr ; : do-make-vm ( -- ) make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 55ff38d408..92b9af41ef 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -88,7 +88,7 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: longer? ( seq seq -- ? ) [ length ] 2apply > ; +: longer? ( seq seq -- ? ) [ length ] bi@ > ; : maybe-tail* ( seq n -- seq ) 2dup longer? diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 0a808f53bd..6c29c0d1ac 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -185,7 +185,7 @@ M: number +second ( timestamp n -- timestamp ) [ month>> +month ] keep [ year>> +year ] keep ; inline -: +slots [ 2apply + ] curry 2keep ; inline +: +slots [ bi@ + ] curry 2keep ; inline PRIVATE> @@ -244,9 +244,9 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; : (time-) ( timestamp timestamp -- n ) - [ >gmt ] 2apply - [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep - [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; + [ >gmt ] bi@ + [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep + [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ; M: timestamp time- #! Exact calendar-time difference diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index b0bd7c464f..26ed873fd3 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -182,7 +182,7 @@ M: timestamp year. ( timestamp -- ) [ [ month>> month-abbreviations nth write ] keep bl [ day>> number>string 2 32 pad-left write ] keep bl - dup now [ year>> ] 2apply = [ + dup now [ year>> ] bi@ = [ [ hour>> write-00 ] keep ":" write minute>> write-00 ] [ diff --git a/extra/cocoa/dialogs/dialogs.factor b/extra/cocoa/dialogs/dialogs.factor index ea77c496a2..606526a240 100644 --- a/extra/cocoa/dialogs/dialogs.factor +++ b/extra/cocoa/dialogs/dialogs.factor @@ -26,7 +26,7 @@ IN: cocoa.dialogs [ -> filenames CF>string-array ] [ drop f ] if ; : split-path ( path -- dir file ) - "/" last-split1 [ ] 2apply ; + "/" last-split1 [ ] bi@ ; : save-panel ( path -- paths ) dup diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index 0941eb4251..856c37a6bc 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -1,7 +1,7 @@ IN: concurrency.distributed.tests USING: tools.test concurrency.distributed kernel io.files arrays io.sockets system combinators threads math sequences -concurrency.messaging ; +concurrency.messaging continuations ; : test-node { @@ -9,6 +9,8 @@ concurrency.messaging ; { [ windows? ] [ "127.0.0.1" 1238 ] } } cond ; +[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test + [ ] [ test-node dup 1array swap (start-node) ] unit-test [ ] [ yield ] unit-test diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index ffb2a64b76..ccf17da4e8 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -24,7 +24,7 @@ C: rsa : modulus-phi ( numbits -- n phi ) #! Loop until phi is not divisible by the public key. dup rsa-primes [ * ] 2keep - [ 1- ] 2apply * + [ 1- ] bi@ * dup public-key gcd nip 1 = [ rot drop ] [ diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index af3671e7d9..8f3d3e6ecc 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -124,5 +124,5 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; : byte-array>sha1-interleave ( string -- seq ) [ zero? ] left-trim dup length odd? [ 1 tail ] when - seq>2seq [ byte-array>sha1 ] 2apply + seq>2seq [ byte-array>sha1 ] bi@ swap 2seq>seq ; diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 60ae592d4c..14f0dc41ac 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -12,7 +12,7 @@ IN: documents : =line ( n loc -- newloc ) second 2array ; -: lines-equal? ( loc1 loc2 -- ? ) [ first ] 2apply number= ; +: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ; TUPLE: document locs ; @@ -46,7 +46,7 @@ TUPLE: document locs ; 2over = [ 3drop ] [ - >r [ first ] 2apply 1+ dup r> each + >r [ first ] bi@ 1+ dup r> each ] if ; inline : start/end-on-line ( from to line# -- n1 n2 ) @@ -85,7 +85,7 @@ TUPLE: document locs ; : (set-doc-range) ( newlines from to lines -- ) [ prepare-insert ] 3keep - >r [ first ] 2apply 1+ r> + >r [ first ] bi@ 1+ r> replace-slice ; : set-doc-range ( string from to document -- ) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index d7624466f7..c6d9cd04d2 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -91,7 +91,7 @@ C: faq : faq-sections, ( question-lists -- ) unclip question-list-seq length 1+ dupd [ question-list-seq length + ] accumulate nip - 0 -rot [ pick question-list>html [ , nl, ] 2apply 1+ ] 2each drop ; + 0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ; : faq>html ( faq -- div ) "div" [ diff --git a/extra/fry/fry-docs.factor b/extra/fry/fry-docs.factor index 739e7d012c..84d02d529d 100755 --- a/extra/fry/fry-docs.factor +++ b/extra/fry/fry-docs.factor @@ -69,7 +69,7 @@ $nl { { $link curry } { $snippet ": curry '[ , @ ] ;" } } { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } - { { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } } + { { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } } } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 8963c2b1ad..912c3c35f3 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -68,17 +68,6 @@ ARTICLE: "evaluator" "Evaluation semantics" "If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage." { $see-also "compiler" } ; -ARTICLE: "dataflow" "Data and control flow" -{ $subsection "evaluator" } -{ $subsection "words" } -{ $subsection "effects" } -{ $subsection "shuffle-words" } -{ $subsection "booleans" } -{ $subsection "conditionals" } -{ $subsection "basic-combinators" } -{ $subsection "combinators" } -{ $subsection "continuations" } ; - USING: concurrency.combinators concurrency.messaging concurrency.promises diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index b65e44fda4..01e08473c6 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -59,7 +59,7 @@ IN: help.lint : check-see-also ( word element -- ) nip \ $see-also swap elements [ - 1 tail dup prune [ length ] 2apply assert= + 1 tail dup prune [ length ] bi@ assert= ] each ; : vocab-exists? ( name -- ? ) diff --git a/extra/http/http.factor b/extra/http/http.factor index 69c0ba2c9f..6ff4829b48 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -106,7 +106,7 @@ IN: http : query>assoc ( query -- assoc ) dup [ "&" split [ - "=" split1 [ dup [ url-decode ] when ] 2apply + "=" split1 [ dup [ url-decode ] when ] bi@ ] H{ } map>assoc ] when ; diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index 1740e8a523..e88301c7f8 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -51,14 +51,14 @@ SYMBOL: open-arrays : binary-op ( quot -- ? ) >r get-cba r> - swap >r >r [ reg-val ] 2apply swap r> call r> + swap >r >r [ reg-val ] bi@ swap r> call r> set-reg f ; inline : op1 ( opcode -- ? ) [ swap arr-val ] binary-op ; : op2 ( opcode -- ? ) - get-cba >r [ reg-val ] 2apply r> reg-val set-arr f ; + get-cba >r [ reg-val ] bi@ r> reg-val set-arr f ; : op3 ( opcode -- ? ) [ + >32bit ] binary-op ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index d524180471..1b7badd94a 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -151,10 +151,10 @@ MACRO: undo ( quot -- ) [undo] ; \ - [ + ] [ - ] define-math-inverse \ * [ / ] [ / ] define-math-inverse \ / [ * ] [ / ] define-math-inverse -\ ^ [ recip ^ ] [ [ log ] 2apply / ] define-math-inverse +\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse \ ? 2 [ - [ assert-literal ] 2apply + [ assert-literal ] bi@ [ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ] 2curry ] define-pop-inverse diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index e8ca04af35..fbc296e57c 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -78,7 +78,7 @@ M: utf16le decode-char swap BIN: 11111111 bitand ; : stream-write2 ( stream char1 char2 -- ) - rot [ stream-write1 ] curry 2apply ; + rot [ stream-write1 ] curry bi@ ; : char>utf16be ( stream char -- ) dup HEX: FFFF > [ diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index b345a98e88..85319ad8ef 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -161,5 +161,5 @@ TUPLE: datagram-port addr packet packet-addr ; : check-datagram-send ( packet addrspec port -- ) dup check-datagram-port - datagram-port-addr [ class ] 2apply assert= + datagram-port-addr [ class ] bi@ assert= class byte-array assert= ; diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index 77e8e098b1..8480fcd856 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -64,8 +64,8 @@ M: inet6 inet-ntop ( data addrspec -- str ) M: inet6 inet-pton ( str addrspec -- data ) drop "::" split1 - [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] 2apply - 2dup [ length ] 2apply + 8 swap - 0 swap 3append + [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@ + 2dup [ length ] bi@ + 8 swap - 0 swap 3append [ 2 >be ] map concat >byte-array ; M: inet6 address-size drop 16 ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor new file mode 100644 index 0000000000..1810b8587b --- /dev/null +++ b/extra/io/sockets/sockets-tests.factor @@ -0,0 +1,4 @@ +IN: io.sockets.tests +USING: io.sockets sequences math tools.test ; + +[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3b493d2fe4..c4e506d37f 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -3,7 +3,7 @@ USING: io.backend io.nonblocking io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitfields byte-arrays alien combinators calendar -io.encodings.binary ; +io.encodings.binary accessors sequences strings ; IN: io.unix.files @@ -49,7 +49,7 @@ M: unix-io touch-file ( path -- ) close ; M: unix-io move-file ( from to -- ) - [ normalize-pathname ] 2apply rename io-error ; + [ normalize-pathname ] bi@ rename io-error ; M: unix-io delete-file ( path -- ) normalize-pathname unlink io-error ; @@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - [ normalize-pathname ] 2apply + [ normalize-pathname ] bi@ [ (copy-file) ] [ swap file-info file-info-permissions chmod io-error ] 2bi ; @@ -84,7 +84,7 @@ M: unix-io copy-file ( from to -- ) { [ dup S_ISLNK ] [ +symbolic-link+ ] } { [ dup S_ISSOCK ] [ +socket+ ] } { [ t ] [ +unknown+ ] } - } cond nip ; + } cond nip ; : stat>file-info ( stat -- info ) { @@ -100,3 +100,11 @@ M: unix-io file-info ( path -- info ) M: unix-io link-info ( path -- info ) normalize-pathname lstat* stat>file-info ; + +M: unix-io make-link ( path1 path2 -- ) + normalize-pathname symlink io-error ; + +M: unix-io read-link ( path -- path' ) + normalize-pathname + PATH_MAX [ tuck ] [ ] bi readlink + dup io-error head-slice >string ; diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index f51521dfcc..152e76a6c7 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -46,5 +46,5 @@ M: windows-ce-io (init-stdio) ( -- ) 1 _getstdfilex _fileno 2 _getstdfilex _fileno ] if [ f ] 3apply - rot -rot [ ] 2apply + rot -rot [ ] bi@ ] with-variable ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 64c4684e15..27917cedfa 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -135,14 +135,14 @@ M: windows-io (file-appender) ( path -- stream ) open-append ; M: windows-io move-file ( from to -- ) - [ normalize-pathname ] 2apply MoveFile win32-error=0/f ; + [ normalize-pathname ] bi@ MoveFile win32-error=0/f ; M: windows-io delete-file ( path -- ) normalize-pathname DeleteFile win32-error=0/f ; M: windows-io copy-file ( from to -- ) dup parent-directory make-directories - [ normalize-pathname ] 2apply 0 CopyFile win32-error=0/f ; + [ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ; M: windows-io make-directory ( path -- ) normalize-pathname diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 61fef7959c..7be406d37a 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -72,7 +72,7 @@ TUPLE: segment number color radius ; : sub-tunnel ( from to sements -- segments ) #! return segments between from and to, after clamping from and to to #! valid values - [ sequence-index-range [ clamp-to-range ] curry 2apply ] keep ; + [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; : nearer-segment ( segment segment oint -- segment ) #! return whichever of the two segments is nearer to the oint diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor index f847bbff68..1741b96e75 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.streams.string io strings splitting sequences math - math.parser assocs classes.tuple classes words namespaces - hashtables ; + math.parser assocs classes words namespaces prettyprint + hashtables mirrors ; IN: json.writer #! Writes the object out to a stream in JSON format @@ -39,25 +39,19 @@ M: sequence json-print ( array -- string ) #! javascript variable names. [ (jsvar-encode) ] map ; -: slots ( object -- values names ) - #! Given an object return an array of slots names and a sequence of slot values - #! the slot name and the slot value. - [ tuple-slots ] keep class slot-names ; +: tuple>fields ( object -- string ) + [ + [ swap jsvar-encode >json % " : " % >json % ] "" make + ] { } assoc>map ; -: slots>fields ( values names -- array ) - #! Convert the arrays containing the slot names and values - #! to an array of strings suitable for describing that slot - #! as a field in a javascript object. - [ - [ jsvar-encode >json % " : " % >json % ] "" make - ] 2map ; - -M: object json-print ( object -- string ) - CHAR: { write1 slots slots>fields "," join write CHAR: } write1 ; +M: tuple json-print ( tuple -- string ) + CHAR: { write1 tuple>fields "," join write CHAR: } write1 ; M: hashtable json-print ( hashtable -- string ) CHAR: { write1 [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ] { } assoc>map "," join write CHAR: } write1 ; - + +M: object json-print ( object -- string ) + unparse json-print ; diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 71cbb1d951..f286690d37 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -57,7 +57,7 @@ SYMBOL: terms terms get [ [ swap +@ ] assoc-each ] bind ; : alt+ ( x y -- x+y ) - [ >alt ] 2apply [ (alt+) (alt+) ] with-terms ; + [ >alt ] bi@ [ (alt+) (alt+) ] with-terms ; ! Multiplication : alt*n ( vec n -- vec ) @@ -79,7 +79,7 @@ SYMBOL: terms ] curry each ; : duplicates? ( seq -- ? ) - dup prune [ length ] 2apply > ; + dup prune [ length ] bi@ > ; : (wedge) ( n basis1 basis2 -- n basis ) append dup duplicates? [ @@ -90,7 +90,7 @@ SYMBOL: terms ] if ; : wedge ( x y -- x.y ) - [ >alt ] 2apply [ + [ >alt ] bi@ [ swap [ [ 2swap [ @@ -200,7 +200,7 @@ DEFER: (d) ] with map ; : bigraded-betti ( u-generators z-generators -- seq ) - [ basis graded ] 2apply tensor bigraded-ker/im-d + [ basis graded ] bi@ tensor bigraded-ker/im-d [ [ [ first ] map ] map ] keep [ [ second ] map 2 head* { 0 0 } prepend ] map 1 tail dup first length 0 add @@ -278,7 +278,7 @@ DEFER: (d) ] with map ; : bigraded-laplacian ( u-generators z-generators quot -- seq ) - >r [ basis graded ] 2apply tensor bigraded-triples r> + >r [ basis graded ] bi@ tensor bigraded-triples r> [ [ first3 ] swap compose map ] curry map ; inline : bigraded-laplacian-betti ( u-generators z-generators -- seq ) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 07cd34b4df..52cca64b2f 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -52,7 +52,7 @@ M: cons nil? ( cons -- bool ) TUPLE: lazy-cons car cdr ; : lazy-cons ( car cdr -- promise ) - [ promise ] 2apply \ lazy-cons construct-boa + [ promise ] bi@ \ lazy-cons construct-boa T{ promise f f t f } clone [ set-promise-value ] keep ; diff --git a/extra/levenshtein/levenshtein.factor b/extra/levenshtein/levenshtein.factor index 07e16fb862..98b376593c 100644 --- a/extra/levenshtein/levenshtein.factor +++ b/extra/levenshtein/levenshtein.factor @@ -17,7 +17,7 @@ SYMBOL: d SYMBOL: costs : init-d ( str1 str2 -- ) - [ length 1+ ] 2apply 2dup d set + [ length 1+ ] bi@ 2dup d set [ 0 over ->d ] each [ dup 0 ->d ] each ; inline @@ -39,7 +39,7 @@ SYMBOL: costs [ 2dup init-d 2dup compute-costs - [ length ] 2apply [ + [ length ] bi@ [ [ levenshtein-step ] curry each ] with each levenshtein-result diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index a220eece01..dcf52f723a 100644 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -71,7 +71,7 @@ def-hash get-global [ ! Remove set-alien-cell, etc. [ - drop [ accessor-words swap seq-diff ] keep [ length ] 2apply = + drop [ accessor-words swap seq-diff ] keep [ length ] bi@ = ] assoc-subset ! Remove trivial defs @@ -148,7 +148,7 @@ GENERIC: run-lint ( obj -- obj ) : filter-symbols ( alist -- alist ) [ nip first dup def-hash get at - [ first ] 2apply literalize = not + [ first ] bi@ literalize = not ] assoc-subset ; M: sequence run-lint ( seq -- seq ) diff --git a/extra/match/match.factor b/extra/match/match.factor index fef925431d..2c6923a6ba 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -32,10 +32,10 @@ SYMBOL: _ { [ 2dup = ] [ 2drop t ] } { [ 2dup [ _ eq? ] either? ] [ 2drop t ] } { [ 2dup [ sequence? ] both? ] [ - 2dup [ length ] 2apply = + 2dup [ length ] bi@ = [ [ (match) ] 2all? ] [ 2drop f ] if ] } { [ 2dup [ tuple? ] both? ] - [ [ tuple>array ] 2apply [ (match) ] 2all? ] } + [ [ tuple>array ] bi@ [ (match) ] 2all? ] } { [ t ] [ 2drop f ] } } cond ; diff --git a/extra/math/complex/complex.factor b/extra/math/complex/complex.factor index 236d9df7a0..588f34d3fc 100755 --- a/extra/math/complex/complex.factor +++ b/extra/math/complex/complex.factor @@ -8,11 +8,11 @@ math.functions.private sequences parser ; M: real real-part ; M: real imaginary-part drop 0 ; -M: complex absq >rect [ sq ] 2apply + ; +M: complex absq >rect [ sq ] bi@ + ; : 2>rect ( x y -- xr yr xi yi ) - [ [ real-part ] 2apply ] 2keep - [ imaginary-part ] 2apply ; inline + [ [ real-part ] bi@ ] 2keep + [ imaginary-part ] bi@ ; inline M: complex number= 2>rect number= [ number= ] [ 2drop f ] if ; diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 85e07fe73f..dcbccb4316 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -101,7 +101,7 @@ M: real absq sq ; >r - abs r> < ; : ~rel ( x y epsilon -- ? ) - >r [ - abs ] 2keep [ abs ] 2apply + r> * < ; + >r [ - abs ] 2keep [ abs ] bi@ + r> * < ; : ~ ( x y epsilon -- ? ) { @@ -124,7 +124,7 @@ M: real absq sq ; : arg ( z -- arg ) >float-rect swap fatan2 ; inline : >polar ( z -- abs arg ) - >float-rect [ [ sq ] 2apply + fsqrt ] 2keep swap fatan2 ; + >float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ; inline : cis ( arg -- z ) dup fcos swap fsin rect> ; inline diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index 000d97f2a6..d6ac71e629 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -13,10 +13,10 @@ IN: math.polynomials : p= ( p p -- ? ) pextend = ; @@ -24,7 +24,7 @@ PRIVATE> : ptrim ( p -- p ) dup singleton? [ [ zero? ] right-trim ] unless ; -: 2ptrim ( p p -- p p ) [ ptrim ] 2apply ; +: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ; : p+ ( p p -- p ) pextend v+ ; : p- ( p p -- p ) pextend v- ; : n*p ( n p -- n*p ) n*v ; @@ -32,7 +32,7 @@ PRIVATE> ! convolution : pextend-conv ( p p -- p p ) #! extend to: p_m + p_n - 1 - 2dup [ length ] 2apply + 1- 2pad-right [ >vector ] 2apply ; + 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ; : p* ( p p -- p ) #! Multiply two polynomials. @@ -46,13 +46,13 @@ PRIVATE> : p/mod-setup ( p p -- p p n ) 2ptrim - 2dup [ length ] 2apply - + 2dup [ length ] bi@ - dup 1 < [ drop 1 ] when [ over length + 0 pad-left pextend ] keep 1+ ; : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences - [ peek ] 2apply / ; + [ peek ] bi@ / ; : (p/mod) 2dup /-last @@ -74,7 +74,7 @@ PRIVATE> ] if ; : pgcd ( p p -- p q ) - swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] 2apply ; + swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ; : pdiff ( p -- p' ) #! Polynomial derivative. diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor index d61afd17c3..f121e4a0d1 100755 --- a/extra/math/quaternions/quaternions.factor +++ b/extra/math/quaternions/quaternions.factor @@ -14,7 +14,7 @@ IN: math.quaternions : ** conjugate * ; inline -: 2q ( u v -- u' u'' v' v'' ) [ first2 ] 2apply ; inline +: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline : q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor index 5d07bd046f..3c430111ff 100755 --- a/extra/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -7,7 +7,7 @@ USING: kernel kernel.private math math.functions math.private ; dup numerator swap denominator ; inline : 2>fraction ( a/b c/d -- a c b d ) - [ >fraction ] 2apply swapd ; inline + [ >fraction ] bi@ swapd ; inline r /i r> fraction> ] if ; diff --git a/extra/math/statistics/statistics.factor b/extra/math/statistics/statistics.factor index 4c60363be0..f7295604cd 100644 --- a/extra/math/statistics/statistics.factor +++ b/extra/math/statistics/statistics.factor @@ -46,13 +46,13 @@ IN: math.statistics : ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) ! finds sigma((xi-mean(x))(yi-mean(y)) - 0 [ [ >r pick r> swap - ] 2apply * + ] 2reduce 2nip ; + 0 [ [ >r pick r> swap - ] bi@ * + ] 2reduce 2nip ; : (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) * recip >r [ ((r)) ] keep length 1- / r> * ; : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) - first2 [ [ [ mean ] 2apply ] 2keep ] 2keep [ std ] 2apply ; + first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ; : r ( {{x,y}...} -- r ) [r] (r) ; diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index 14a493cec5..5d7bb9a1a2 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -22,7 +22,7 @@ SYMBOL: visited : random-neighbour ( cell -- newcell ) choices random ; : vertex ( pair -- ) - first2 [ 0.5 + line-width * ] 2apply glVertex2d ; + first2 [ 0.5 + line-width * ] bi@ glVertex2d ; : (draw-maze) ( cell -- ) dup vertex diff --git a/extra/money/money.factor b/extra/money/money.factor index 4058ee9e6a..4584daf592 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -23,9 +23,9 @@ TUPLE: not-a-decimal ; : parse-decimal ( str -- ratio ) "." split1 >r dup "-" head? [ drop t "0" ] [ f swap ] if r> - [ dup empty? [ drop "0" ] when ] 2apply + [ dup empty? [ drop "0" ] when ] bi@ dup length - >r [ string>number dup [ not-a-decimal ] unless ] 2apply r> + >r [ string>number dup [ not-a-decimal ] unless ] bi@ r> 10 swap ^ / + swap [ neg ] when ; : DECIMAL: diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index ed82d2478e..ac62fb08f9 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -113,7 +113,7 @@ TUPLE: no-method arguments generic ; ] curry assoc-map ; : sorted-methods ( alist -- alist' ) - [ [ first ] 2apply classes< ] topological-sort ; + [ [ first ] bi@ classes< ] topological-sort ; : niceify-method [ dup \ f eq? [ drop f ] when ] map ; diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 61d3be0e15..84515305c8 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -38,7 +38,7 @@ M: demo-gadget pref-dim* ( gadget -- dim ) : demo-gadget-frustum ( -- -x x -y y near far ) FOV-RATIO NEAR-PLANE FOV / v*n - first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ; + first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ; : demo-gadget-set-matrices ( gadget -- ) GL_PROJECTION glMatrixMode diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 08e3cb204b..36d24e1300 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -8,9 +8,9 @@ math.parser opengl.gl opengl.glu combinators arrays sequences splitting words byte-arrays assocs combinators.lib ; IN: opengl -: coordinates [ first2 ] 2apply ; +: coordinates [ first2 ] bi@ ; -: fix-coordinates [ first2 [ >fixnum ] 2apply ] 2apply ; +: fix-coordinates [ first2 [ >fixnum ] bi@ ] bi@ ; : gl-color ( color -- ) first4 glColor4d ; inline @@ -85,7 +85,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) : unit-circle dup [ sin ] map swap [ cos ] map ; -: adjust-points [ [ 1 + 0.5 * ] map ] 2apply ; +: adjust-points [ [ 1 + 0.5 * ] map ] bi@ ; : scale-points 2array flip [ v* ] with map [ v+ ] with map ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index bf06708e09..d6aacf9645 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -35,7 +35,7 @@ C: parse-result ] if ; : string= ( str1 str2 ignore-case -- ? ) - [ [ >upper ] 2apply ] when sequence= ; + [ [ >upper ] bi@ ] when sequence= ; : string-head? ( str head ignore-case -- ? ) 2over shorter? [ @@ -327,7 +327,7 @@ LAZY: <(+)> ( parser -- parser ) nonempty-list-of { } succeed <|> ; LAZY: surrounded-by ( parser start end -- parser' ) - [ token ] 2apply swapd pack ; + [ token ] bi@ swapd pack ; : exactly-n ( parser n -- parser' ) swap [ flatten ] <@ ; diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 7a82418c27..49035ea43c 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -70,7 +70,7 @@ MEMO: pack ( begin body end -- parser ) >r >r hide r> r> hide 3seq [ first ] action ; : surrounded-by ( parser begin end -- parser' ) - [ token ] 2apply swapd pack ; + [ token ] bi@ swapd pack ; : 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] action ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index e07942a3cd..43eb9e8d9e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -11,9 +11,11 @@ USE: prettyprint TUPLE: parse-result remaining ast ; TUPLE: parser id compiled ; -M: parser equal? [ id>> ] 2apply = ; -M: parser hashcode* ( depth obj -- code ) - id>> hashcode* ; + +M: parser equal? [ id>> ] bi@ = ; + +M: parser hashcode* id>> hashcode* ; + C: parser SYMBOL: ignore diff --git a/extra/project-euler/009/009.factor b/extra/project-euler/009/009.factor index f09643d290..690fed9012 100644 --- a/extra/project-euler/009/009.factor +++ b/extra/project-euler/009/009.factor @@ -31,7 +31,7 @@ IN: project-euler.009 : abc ( p q -- triplet ) [ 2dup * , ! a = p * q - [ sq ] 2apply 2dup - 2 / , ! b = (p² - q²) / 2 + [ sq ] bi@ 2dup - 2 / , ! b = (p² - q²) / 2 + 2 / , ! c = (p² + q²) / 2 ] { } make natural-sort ; diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index 02c5dbb9d3..32b1aa5549 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -39,7 +39,7 @@ IN: project-euler.014 dup even? [ 2 / ] [ 3 * 1+ ] if ; : longest ( seq seq -- seq ) - 2dup [ length ] 2apply > [ drop ] [ nip ] if ; + 2dup [ length ] bi@ > [ drop ] [ nip ] if ; PRIVATE> diff --git a/extra/project-euler/026/026.factor b/extra/project-euler/026/026.factor index 3ad1908aa6..f1f546ec1c 100644 --- a/extra/project-euler/026/026.factor +++ b/extra/project-euler/026/026.factor @@ -58,7 +58,7 @@ PRIVATE> : max-period ( seq -- elt n ) dup [ period-length ] map dup supremum - over index [ swap nth ] curry 2apply ; + over index [ swap nth ] curry bi@ ; PRIVATE> diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor index 2bc7894684..2d99204bf3 100644 --- a/extra/project-euler/027/027.factor +++ b/extra/project-euler/027/027.factor @@ -60,7 +60,7 @@ IN: project-euler.027 : max-consecutive ( seq -- elt n ) dup [ first2 consecutive-primes ] map dup supremum - over index [ swap nth ] curry 2apply ; + over index [ swap nth ] curry bi@ ; PRIVATE> diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor index 6f29c3519e..35b1c87e7a 100644 --- a/extra/project-euler/033/033.factor +++ b/extra/project-euler/033/033.factor @@ -33,10 +33,10 @@ IN: project-euler.033 10 99 [a,b] dup cartesian-product [ first2 < ] subset ; : safe? ( ax xb -- ? ) - [ 10 /mod ] 2apply -roll = rot zero? not and nip ; + [ 10 /mod ] bi@ -roll = rot zero? not and nip ; : ax/xb ( ax xb -- z/f ) - 2dup safe? [ [ 10 /mod ] 2apply 2nip / ] [ 2drop f ] if ; + 2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ; : curious? ( m n -- ? ) 2dup / [ ax/xb ] dip = ; diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor index 62e516e4b0..bc8aec8bde 100644 --- a/extra/project-euler/044/044.factor +++ b/extra/project-euler/044/044.factor @@ -31,7 +31,7 @@ IN: project-euler.044 dup 3 * 1- * 2 / ; : sum-and-diff? ( m n -- ? ) - 2dup + -rot - [ pentagonal? ] 2apply and ; + 2dup + -rot - [ pentagonal? ] bi@ and ; PRIVATE> diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index 30c46de0a0..b4cbd6dbcb 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -35,7 +35,7 @@ IN: project-euler.079 ] { } make ; : find-source ( seq -- elt ) - dup values swap keys [ prune ] 2apply seq-diff + dup values swap keys [ prune ] bi@ seq-diff dup empty? [ "Topological sort failed" throw ] [ first ] if ; : remove-source ( seq elt -- seq ) diff --git a/extra/random-tester/random/random.factor b/extra/random-tester/random/random.factor index 163de69a59..11f2e60d1a 100755 --- a/extra/random-tester/random/random.factor +++ b/extra/random-tester/random/random.factor @@ -54,7 +54,7 @@ IN: random-tester ] if ; : random-ratio ( -- ratio ) - 1000000000 dup [ random ] 2apply 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ; + 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ; : random-float ( -- float ) 50% [ random-ratio ] [ special-floats get random ] if diff --git a/extra/random/random-docs.factor b/extra/random/random-docs.factor index 905f81b53d..a8a214dcc7 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/random-docs.factor @@ -17,7 +17,7 @@ HELP: random-32* { $description "Generates a random 32-bit unsigned integer." } ; HELP: random-bytes* -{ $values { "n" "an integer" } { "tuple" "a random number generator" } { "bytes" "a sequence of random bytes" } } +{ $values { "n" "an integer" } { "tuple" "a random number generator" } { "byte-array" "a sequence of random bytes" } } { $description "Generates a byte-array of random bytes." } ; HELP: random @@ -26,7 +26,7 @@ HELP: random { $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ; HELP: random-bytes -{ $values { "n" "an integer" } { "bytes" "a random integer" } } +{ $values { "n" "an integer" } { "byte-array" "a random integer" } } { $description "Outputs an integer with n bytes worth of bits." } ; HELP: random-bits diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 51574887e3..f3f55007f0 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,6 +1,6 @@ USING: alien.c-types io io.files io.nonblocking kernel namespaces random io.encodings.binary singleton init -accessors ; +accessors system ; IN: random.unix TUPLE: unix-random path ; @@ -15,7 +15,14 @@ C: unix-random M: unix-random random-bytes* ( n tuple -- byte-array ) path>> file-read-unbuffered ; -[ - "/dev/random" secure-random-generator set-global - "/dev/urandom" insecure-random-generator set-global -] "random.unix" add-init-hook +os "openbsd" = [ + [ + "/dev/srandom" secure-random-generator set-global + "/dev/prandom" insecure-random-generator set-global + ] "random.unix" add-init-hook +] [ + [ + "/dev/random" secure-random-generator set-global + "/dev/urandom" insecure-random-generator set-global + ] "random.unix" add-init-hook +] if diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index cd69105e65..65426d4277 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -46,9 +46,9 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) MS_DEF_PROV PROV_RSA_FULL insecure-random-generator set-global - ! MS_STRONG_PROV - ! PROV_RSA_FULL secure-random-generator set-global + MS_STRONG_PROV + PROV_RSA_FULL secure-random-generator set-global - MS_ENH_RSA_AES_PROV - PROV_RSA_AES secure-random-generator set-global + ! MS_ENH_RSA_AES_PROV + ! PROV_RSA_AES secure-random-generator set-global ] "random.windows" add-init-hook diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index b57724d1db..fa36a7c6f8 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -16,7 +16,7 @@ SYMBOL: ignore-case? : char-between?-quot ( ch1 ch2 -- quot ) ignore-case? get - [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ] + [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ] [ [ between? ] ] if 2curry ; diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor index e62eb76cb1..1f2bbde171 100644 --- a/extra/regexp2/regexp2.factor +++ b/extra/regexp2/regexp2.factor @@ -16,7 +16,7 @@ SYMBOL: ignore-case? : char-between?-quot ( ch1 ch2 -- quot ) ignore-case? get - [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ] + [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ] [ [ between? ] ] if 2curry ; diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 2614a774dd..7e9496c90d 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -9,7 +9,7 @@ IN: reports.noise { -nrot 5 } { -roll 4 } { -rot 3 } - { 2apply 1 } + { bi@ 1 } { 2curry 1 } { 2drop 1 } { 2dup 1 } diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index 7466883c5f..a3e61dd889 100644 --- a/extra/roman/roman.factor +++ b/extra/roman/roman.factor @@ -23,7 +23,7 @@ TUPLE: roman-range-error n ; ] if ; : roman<= ( ch1 ch2 -- ? ) - [ 1string roman-digits index ] 2apply >= ; + [ 1string roman-digits index ] bi@ >= ; : roman>n ( ch -- n ) 1string roman-digits index roman-values nth ; @@ -57,7 +57,7 @@ PRIVATE> ( str1 str2 -- m n ) - [ roman> ] 2apply ; + [ roman> ] bi@ ; : binary-roman-op ( str1 str2 quot -- str3 ) >r 2roman> r> call >roman ; inline diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 257133c67f..c523053740 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -60,7 +60,7 @@ test-db [ "charlie" create-node* "charlie" set "gertrude" create-node* "gertrude" set [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test - { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each + { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] bi@ parent-child ] each [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 2865b1fd6c..ac247057f4 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -24,7 +24,7 @@ C: id M: id hashcode* obj>> hashcode* ; -M: id equal? over id? [ [ obj>> ] 2apply eq? ] [ 2drop f ] if ; +M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; : add-object ( obj -- ) #! Add an object to the sequence of already serialized diff --git a/extra/shufflers/shufflers.factor b/extra/shufflers/shufflers.factor index 172db1def1..b11668a53e 100644 --- a/extra/shufflers/shufflers.factor +++ b/extra/shufflers/shufflers.factor @@ -20,7 +20,7 @@ IN: shufflers : put-effect ( word -- ) dup word-name "-" split1 - [ >array [ 1string ] map ] 2apply + [ >array [ 1string ] map ] bi@ "declared-effect" set-word-prop ; : in-shuffle ( -- ) in get ".shuffle" append set-in ; diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor index db5fb75617..764c4d92f0 100644 --- a/extra/sudoku/sudoku.factor +++ b/extra/sudoku/sudoku.factor @@ -18,7 +18,7 @@ SYMBOL: board : cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ; : box-contains? ( n x y -- ? ) - [ 3 /i 3 * ] 2apply + [ 3 /i 3 * ] bi@ 9 [ >r 3dup r> cell-contains? ] contains? >r 3drop r> ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index d1c4b148a5..99af06b80f 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -35,7 +35,7 @@ linkname magic version uname gname devmajor devminor prefix ; : header-checksum ( seq -- x ) 148 cut-slice 8 tail-slice - [ sum ] 2apply + 256 + ; + [ sum ] bi@ + 256 + ; TUPLE: checksum-error ; TUPLE: malformed-block-error ; diff --git a/extra/tools/completion/completion.factor b/extra/tools/completion/completion.factor index e44c3c401e..16bde2100f 100755 --- a/extra/tools/completion/completion.factor +++ b/extra/tools/completion/completion.factor @@ -40,7 +40,7 @@ unicode.categories ; : score ( full fuzzy -- n ) dup [ - [ [ length ] 2apply - 15 swap [-] 3 /f ] 2keep + [ [ length ] bi@ - 15 swap [-] 3 /f ] 2keep runs [ [ 0 [ pick score-1 max ] reduce nip ] keep length * + @@ -57,7 +57,7 @@ unicode.categories ; : complete ( full short -- score ) [ dupd fuzzy score ] 2keep - [ ] 2apply + [ ] bi@ dupd fuzzy score max ; : completion ( short candidate -- result ) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 5030763a3d..f104fb0210 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,7 +1,7 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math sequences io.launcher arrays -namespaces continuations ; +namespaces continuations layouts ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors @@ -17,7 +17,7 @@ namespaces continuations ; [ ] [ "hello-world" shake-and-bake ] unit-test [ t ] [ - 500000 small-enough? + cell 8 = 8 5 ? 100000 * small-enough? ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor index b37e42f323..de8f8740f0 100755 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -14,7 +14,7 @@ global [ sent-messages get super-sent-messages get - [ keys [ objc-methods get at dup ] H{ } map>assoc ] 2apply + [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@ super-message-senders [ intersect ] change message-senders [ intersect ] change diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 479ae9c42c..927f7111fa 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -26,11 +26,14 @@ M: pair make-disassemble-cmd M: method-spec make-disassemble-cmd first2 method make-disassemble-cmd ; +: gdb-binary ( -- string ) + os "freebsd" = "gdb66" "gdb" ? ; + : run-gdb ( -- lines ) +closed+ >>stdin out-file >>stdout - [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command + [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command try-process out-file ascii file-lines ; diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index e58ba343c7..6b548aaf68 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -24,7 +24,7 @@ M: border pref-dim* ; : scale-rect ( rect vec -- loc dim ) - [ v* ] curry >r rect-bounds r> 2apply ; + [ v* ] curry >r rect-bounds r> bi@ ; : average-rects ( rect1 rect2 weight -- rect ) tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index def6b99b05..b3ecad6aed 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -135,7 +135,7 @@ M: editor ungraft* dup editor-caret-color gl-color dup caret-loc origin get v+ swap caret-dim over v+ - [ { 0.5 -0.5 } v+ ] 2apply gl-line + [ { 0.5 -0.5 } v+ ] bi@ gl-line ] when ; : line-translation ( n -- loc ) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 267f6f0f0f..ddcaa4b979 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -22,7 +22,7 @@ M: array rect-dim drop { 0 0 } ; : rect-extent ( rect -- loc ext ) rect-bounds over v+ ; : 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 ) - [ rect-extent ] 2apply swapd ; + [ rect-extent ] bi@ swapd ; : ( loc ext -- rect ) over [v-] ; diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/extra/ui/gadgets/grids/grids-tests.factor index 0792d55135..f20275ff25 100644 --- a/extra/ui/gadgets/grids/grids-tests.factor +++ b/extra/ui/gadgets/grids/grids-tests.factor @@ -25,13 +25,13 @@ IN: ui.gadgets.grids.tests [ { 100 200 } ] [ 100x100 100x100 - [ 1array ] 2apply 2array pref-dim + [ 1array ] bi@ 2array pref-dim ] unit-test [ ] [ 100x100 100x100 - [ 1array ] 2apply 2array layout + [ 1array ] bi@ 2array layout ] unit-test [ { 230 120 } { 100 100 } { 100 100 } ] [ diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index 99bd1be876..d4a1895894 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -57,7 +57,7 @@ scroller H{ 2dup control-value = [ 2drop ] [ set-control-value ] if ; : rect-min ( rect1 rect2 -- rect ) - >r [ rect-loc ] keep r> [ rect-dim ] 2apply vmin ; + >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin ; : (scroll>rect) ( rect scroller -- ) [ diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index dfc7bf2264..4c8c6491ca 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -26,7 +26,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; : process-other-extend ( lines -- set ) [ "#" split1 drop ";" split1 drop trim-blank ] map [ empty? not ] subset - [ ".." split1 [ dup ] unless* [ hex> ] 2apply [a,b] ] map + [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map concat >set ; : other-extend-lines ( -- lines ) @@ -83,7 +83,7 @@ VALUE: grapheme-table grapheme-table nth nth not ; : chars ( i str n -- str[i] str[i+n] ) - swap >r dupd + r> [ ?nth ] curry 2apply ; + swap >r dupd + r> [ ?nth ] curry bi@ ; : find-index ( seq quot -- i ) find drop ; inline : find-last-index ( seq quot -- i ) find-last drop ; inline diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index 8129ec17f8..092a247204 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -100,7 +100,7 @@ SYMBOL: locale ! Just casing locale, or overall? >upper >lower ; : insensitive= ( str1 str2 -- ? ) - [ >case-fold ] 2apply = ; + [ >case-fold ] bi@ = ; : lower? ( string -- ? ) dup >lower = ; diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 47637e8330..d62beb1a2c 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -38,7 +38,7 @@ IN: unicode.normalize : (insert) ( seq n quot -- ) over 0 = [ 3drop ] [ - [ >r dup 1- rot [ nth ] curry 2apply r> 2apply > ] 3keep + [ >r dup 1- rot [ nth ] curry bi@ r> bi@ > ] 3keep roll [ 3drop ] [ >r [ dup 1- rot exchange ] 2keep 1- r> (insert) ] if ] if ; inline diff --git a/extra/units/units.factor b/extra/units/units.factor index b92cbb659a..cf53ceaee3 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -16,7 +16,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; 1array split1 append ; : 2remove-one ( seq seq obj -- seq seq ) - [ remove-one ] curry 2apply ; + [ remove-one ] curry bi@ ; : symbolic-reduce ( seq seq -- seq seq ) 2dup seq-intersect dup empty? @@ -24,7 +24,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; : ( n top bot -- obj ) symbolic-reduce - [ natural-sort ] 2apply + [ natural-sort ] bi@ dimensioned construct-boa ; : >dimensioned< ( d -- n top bot ) @@ -37,10 +37,10 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; { dimensioned-top dimensioned-bot } get-slots ; : check-dimensions ( d d -- ) - [ dimensions 2array ] 2apply = + [ dimensions 2array ] bi@ = [ dimensions-not-equal ] unless ; -: 2values [ dimensioned-value ] 2apply ; +: 2values [ dimensioned-value ] bi@ ; : ; : d* ( d d -- d ) - [ dup number? [ scalar ] when ] 2apply - [ [ dimensioned-top ] 2apply append ] 2keep - [ [ dimensioned-bot ] 2apply append ] 2keep + [ dup number? [ scalar ] when ] bi@ + [ [ dimensioned-top ] bi@ append ] 2keep + [ [ dimensioned-bot ] bi@ append ] 2keep 2values * dimension-op> ; : d-neg ( d -- d ) -1 d* ; diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor index cb7b347c20..6cb5d6385b 100755 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -24,16 +24,6 @@ IN: unix : F_SETFL 4 ; inline : O_NONBLOCK 4 ; inline -C-STRUCT: addrinfo - { "int" "flags" } - { "int" "family" } - { "int" "socktype" } - { "int" "protocol" } - { "socklen_t" "addrlen" } - { "char*" "canonname" } - { "void*" "addr" } - { "addrinfo*" "next" } ; - C-STRUCT: sockaddr-in { "uchar" "len" } { "uchar" "family" } diff --git a/extra/unix/bsd/freebsd/freebsd.factor b/extra/unix/bsd/freebsd/freebsd.factor index 94bb708527..f25cbd1537 100644 --- a/extra/unix/bsd/freebsd/freebsd.factor +++ b/extra/unix/bsd/freebsd/freebsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/macosx/macosx.factor b/extra/unix/bsd/macosx/macosx.factor index 3c0617ad17..edef2aaa0c 100644 --- a/extra/unix/bsd/macosx/macosx.factor +++ b/extra/unix/bsd/macosx/macosx.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/netbsd/netbsd.factor b/extra/unix/bsd/netbsd/netbsd.factor index ac18749830..071daa682d 100644 --- a/extra/unix/bsd/netbsd/netbsd.factor +++ b/extra/unix/bsd/netbsd/netbsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 256 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/openbsd/openbsd.factor b/extra/unix/bsd/openbsd/openbsd.factor index 3c0617ad17..29b44f7da6 100644 --- a/extra/unix/bsd/openbsd/openbsd.factor +++ b/extra/unix/bsd/openbsd/openbsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "void*" "addr" } + { "char*" "canonname" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index bed87ebd0f..ffd102901c 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -77,6 +77,7 @@ FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; FUNCTION: void* popen ( char* command, char* type ) ; FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; +FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ; FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ; FUNCTION: int rename ( char* from, char* to ) ; @@ -93,6 +94,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_ FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; FUNCTION: char* strerror ( int errno ) ; +FUNCTION: int symlink ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; @@ -102,6 +104,8 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ; FUNCTION: int kill ( pid_t pid, int sig ) ; +: PATH_MAX 1024 ; inline + : PRIO_PROCESS 0 ; inline : PRIO_PGRP 1 ; inline : PRIO_USER 2 ; inline diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index c7eaafe887..822b290f88 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -63,7 +63,7 @@ SYMBOL: rule-sets over [ dupd update ] [ nip clone ] if ; : import-keywords ( parent child -- ) - over >r [ rule-set-keywords ] 2apply ?update + over >r [ rule-set-keywords ] bi@ ?update r> set-rule-set-keywords ; : import-rules ( parent child -- )