Merge commit 'origin/master'

db4
Chris Double 2008-03-31 15:01:22 +13:00
commit 8a800361df
136 changed files with 690 additions and 342 deletions

View File

@ -42,6 +42,7 @@
#include <sys/socket.h> #include <sys/socket.h>
#include <sys/errno.h> #include <sys/errno.h>
#include <sys/mman.h> #include <sys/mman.h>
#include <sys/syslimits.h>
#include <fcntl.h> #include <fcntl.h>
#include <unistd.h> #include <unistd.h>
#endif #endif
@ -146,6 +147,7 @@ void unix_constants()
constant(PROT_WRITE); constant(PROT_WRITE);
constant(MAP_FILE); constant(MAP_FILE);
constant(MAP_SHARED); constant(MAP_SHARED);
constant(PATH_MAX);
grovel(pid_t); grovel(pid_t);
} }

View File

@ -39,7 +39,7 @@ M: alien equal?
2dup [ expired? ] either? [ 2dup [ expired? ] either? [
[ expired? ] both? [ expired? ] both?
] [ ] [
[ alien-address ] 2apply = [ alien-address ] bi@ =
] if ] if
] [ ] [
2drop f 2drop f

View File

@ -115,7 +115,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
swap [ swapd set-at ] curry assoc-each ; swap [ swapd set-at ] curry assoc-each ;
: union ( assoc1 assoc2 -- union ) : union ( assoc1 assoc2 -- union )
2dup [ assoc-size ] 2apply + pick new-assoc 2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ; [ rot update ] keep [ swap update ] keep ;
: diff ( assoc1 assoc2 -- diff ) : diff ( assoc1 assoc2 -- diff )

View File

@ -21,7 +21,7 @@ IN: bit-arrays.tests
{ t f t } { f t f } { t f t } { f t f }
] [ ] [
{ t f t } >bit-array dup clone dup [ not ] change-each { t f t } >bit-array dup clone dup [ not ] change-each
[ >array ] 2apply [ >array ] bi@
] unit-test ] unit-test
[ [

View File

@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
: load-components ( -- ) : load-components ( -- )
"exclude" "include" "exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply [ get-global " " split [ empty? not ] subset ] bi@
seq-diff seq-diff
[ "bootstrap." prepend require ] each ; [ "bootstrap." prepend require ] each ;

View File

@ -67,7 +67,7 @@ C: <anonymous-complement> anonymous-complement
members>> [ class< ] with all? ; members>> [ class< ] with all? ;
: anonymous-complement< ( first second -- ? ) : anonymous-complement< ( first second -- ? )
[ class>> ] 2apply swap class< ; [ class>> ] bi@ swap class< ;
: (class<) ( first second -- -1/0/1 ) : (class<) ( first second -- -1/0/1 )
{ {

View File

@ -47,8 +47,8 @@ TUPLE: mixin-instance loc class mixin ;
M: mixin-instance equal? M: mixin-instance equal?
{ {
{ [ over mixin-instance? not ] [ f ] } { [ over mixin-instance? not ] [ f ] }
{ [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] } { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
{ [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] } { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
{ [ t ] [ t ] } { [ t ] [ t ] }
} cond 2nip ; } cond 2nip ;

View File

@ -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." } ; { $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 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." } ; { $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
HELP: removed-slots HELP: removed-slots
@ -170,7 +170,7 @@ HELP: removed-slots
{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ; { $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
HELP: forget-slots 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" } "." } ; { $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
HELP: tuple HELP: tuple

View File

@ -10,18 +10,54 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
{ $subsection alist>quot } ; { $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators" 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 cond }
{ $subsection case } { $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* } ":" "A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode } { $subsection recursive-hashcode }
"An oddball combinator:" "An oddball combinator:"
{ $subsection with-datastack } { $subsection with-datastack }
{ $subsection "combinators-quot" } { $subsection "combinators-quot" }
{ $see-also "quotations" "basic-combinators" } ; { $see-also "quotations" "dataflow" } ;
ABOUT: "combinators" 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 HELP: alist>quot
{ $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } } { $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." } { $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." }

View File

@ -5,13 +5,13 @@ USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors kernel kernel.private math assocs quotations vectors
hashtables sorting ; hashtables sorting ;
: cleave ( obj seq -- ) : cleave ( x seq -- )
[ call ] with each ; [ call ] with each ;
: cleave>quot ( seq -- quot ) : cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append ; [ [ keep ] curry ] map concat [ drop ] append ;
: 2cleave ( obj seq -- ) : 2cleave ( x seq -- )
[ [ call ] 3keep drop ] each 2drop ; [ [ call ] 3keep drop ] each 2drop ;
: 2cleave>quot ( seq -- quot ) : 2cleave>quot ( seq -- quot )
@ -22,7 +22,7 @@ hashtables sorting ;
[ [ [ r> ] prepend ] map concat ] bi [ [ [ r> ] prepend ] map concat ] bi
append ; append ;
: spread ( seq -- ) : spread ( objs... seq -- )
spread>quot call ; spread>quot call ;
ERROR: no-cond ; ERROR: no-cond ;

View File

@ -10,7 +10,7 @@ IN: compiler.tests
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test [ 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 [ 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
[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test [ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test

View File

@ -72,13 +72,13 @@ unit-test
] unit-test ] unit-test
[ 12 13 ] [ [ 12 13 ] [
-12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
] unit-test ] unit-test
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test [ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
[ 12 13 ] [ [ 12 13 ] [
-12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
] unit-test ] unit-test
[ 1 ] [ [ 1 ] [

View File

@ -63,7 +63,7 @@ M: arm-backend load-indirect ( obj reg -- )
M: immediate load-literal M: immediate load-literal
over v>operand small-enough? [ over v>operand small-enough? [
[ v>operand ] 2apply swap MOV [ v>operand ] bi@ swap MOV
] [ ] [
v>operand load-indirect v>operand load-indirect
] if ; ] if ;
@ -322,10 +322,10 @@ M: arm-backend fp-shadows-int? ( -- ? ) f ;
! Alien intrinsics ! Alien intrinsics
M: arm-backend %unbox-byte-array ( dst src -- ) 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 -- ) 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 -- ) M: arm-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ; drop v>operand 0 MOV ;

View File

@ -33,7 +33,7 @@ IN: cpu.ppc.allot
f fresh-object ; f fresh-object ;
M: ppc-backend %box-float ( dst src -- ) M: ppc-backend %box-float ( dst src -- )
[ v>operand ] 2apply %allot-float 12 MR ; [ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- ) : %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits #! 1 cell header, 1 cell length, 1 cell sign, + digits

View File

@ -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: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
M: immediate load-literal M: immediate load-literal
[ v>operand ] 2apply LOAD ; [ v>operand ] bi@ LOAD ;
M: ppc-backend load-indirect ( obj reg -- ) M: ppc-backend load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep [ 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 ; >r v>operand r> loc>operand STW ;
M: ppc-backend %unbox-float ( dst src -- ) 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 ; M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
@ -291,10 +291,10 @@ M: ppc-backend %unbox-small-struct
! Alien intrinsics ! Alien intrinsics
M: ppc-backend %unbox-byte-array ( dst src -- ) 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 -- ) 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 -- ) M: ppc-backend %unbox-f ( dst src -- )
drop 0 swap v>operand LI ; drop 0 swap v>operand LI ;

View File

@ -101,6 +101,6 @@ M: x86-backend %box-alien ( dst src -- )
] %allot ] %allot
"end" get JMP "end" get JMP
"f" resolve-label "f" resolve-label
f [ v>operand ] 2apply MOV f [ v>operand ] bi@ MOV
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;

View File

@ -109,9 +109,9 @@ M: x86-backend %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ; 0 cell, rc-absolute-cell rel-word ;
M: x86-backend %unbox-float ( dst src -- ) 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 ; M: x86-backend %replace swap %peek ;
@ -162,10 +162,10 @@ M: x86-backend %return ( -- ) 0 %unwind ;
! Alien intrinsics ! Alien intrinsics
M: x86-backend %unbox-byte-array ( dst src -- ) 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 -- ) 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 -- ) M: x86-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ; drop v>operand 0 MOV ;

View File

@ -82,7 +82,7 @@ ERROR: assert got expect ;
: depth ( -- n ) datastack length ; : depth ( -- n ) datastack length ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' ) : 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 ; ERROR: relative-underflow stack ;

View File

@ -63,7 +63,7 @@ IN: dlists.tests
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test [ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
: assert-same-elements : assert-same-elements
[ prune natural-sort ] 2apply assert= ; [ prune natural-sort ] bi@ assert= ;
: dlist-push-all [ push-front ] curry each ; : dlist-push-all [ push-front ] curry each ;

View File

@ -18,8 +18,8 @@ TUPLE: effect in out terminated? ;
{ [ dup not ] [ t ] } { [ dup not ] [ t ] }
{ [ over effect-terminated? ] [ t ] } { [ over effect-terminated? ] [ t ] }
{ [ dup effect-terminated? ] [ f ] } { [ dup effect-terminated? ] [ f ] }
{ [ 2dup [ effect-in length ] 2apply > ] [ f ] } { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] 2apply = not ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
{ [ t ] [ t ] } { [ t ] [ t ] }
} cond 2nip ; } cond 2nip ;

View File

@ -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 operand-class* ds-loc-class ;
M: ds-loc set-operand-class set-ds-loc-class ; M: ds-loc set-operand-class set-ds-loc-class ;
M: ds-loc live-loc? 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. ! A retain stack location.
TUPLE: rs-loc n class ; 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 operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ; M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc? 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 ; UNION: loc ds-loc rs-loc ;
@ -206,7 +206,7 @@ INSTANCE: constant value
%move ; %move ;
: %move ( dst src -- ) : %move ( dst src -- )
2dup [ move-spec ] 2apply 2array { 2dup [ move-spec ] bi@ 2array {
{ { f f } [ %move-bug ] } { { f f } [ %move-bug ] }
{ { f unboxed-c-ptr } [ %move-bug ] } { { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %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 ; : 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 ; : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
@ -442,7 +442,7 @@ M: loc lazy-store
: fast-shuffle? ( live-locs -- ? ) : fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all #! Test if we have enough free registers to load all
#! shuffle inputs at once. #! shuffle inputs at once.
T{ int-regs } free-vregs [ length ] 2apply <= ; T{ int-regs } free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- ) : finalize-locs ( -- )
#! Perform any deferred stack shuffling. #! Perform any deferred stack shuffling.
@ -488,7 +488,7 @@ M: loc lazy-store
: phantom&spec ( phantom spec -- phantom' spec' ) : phantom&spec ( phantom spec -- phantom' spec' )
[ length f pad-left ] keep [ length f pad-left ] keep
[ <reversed> ] 2apply ; inline [ <reversed> ] bi@ ; inline
: phantom&spec-agree? ( phantom spec quot -- ? ) : phantom&spec-agree? ( phantom spec quot -- ? )
>r phantom&spec r> 2all? ; inline >r phantom&spec r> 2all? ; inline
@ -520,7 +520,7 @@ M: loc lazy-store
swap lazy-load ; swap lazy-load ;
: output-vregs ( -- seq seq ) : output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] 2apply ; +output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? ) : clash? ( seq -- ? )
phantoms append [ phantoms append [

View File

@ -32,14 +32,28 @@ $nl
{ $code "H{ } clone" } { $code "H{ } clone" }
"To convert an assoc to a hashtable:" "To convert an assoc to a hashtable:"
{ $subsection >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:" "Utility words to create a new hashtable from a single key/value pair:"
{ $subsection associate } { $subsection associate }
{ $subsection ?set-at } { $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:" "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 } { $subsection prune }
"Test if a sequence contains duplicates in linear time:" "Test if a sequence contains duplicates in linear time:"
{ $subsection all-unique? } { $subsection all-unique? } ;
{ $subsection "hashtables.private" } ;
ABOUT: "hashtables" ABOUT: "hashtables"

View File

@ -18,14 +18,9 @@ IN: hashtables
: (key@) ( key keys i -- array n ? ) : (key@) ( key keys i -- array n ? )
3dup swap array-nth 3dup swap array-nth
dup ((empty)) eq? dup ((empty)) eq?
[ 3drop nip f f ] [ 3drop nip f f ] [
[ = [ rot drop t ] [ probe (key@) ] if
= ] if ; inline
[ rot drop t ]
[ probe (key@) ]
if
]
if ; inline
: key@ ( key hash -- array n ? ) : key@ ( key hash -- array n ? )
hash-array 2dup hash@ (key@) ; inline hash-array 2dup hash@ (key@) ; inline
@ -89,7 +84,8 @@ IN: hashtables
] if ] if
] if ; inline ] 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 -- ) : (rehash) ( hash array -- )
[ swap pick (set-hash) drop f ] find-pair 2drop 2drop ; [ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
@ -99,8 +95,7 @@ IN: hashtables
[ hash-array array-capacity ] bi > ; [ hash-array array-capacity ] bi > ;
: hash-stale? ( hash -- ? ) : hash-stale? ( hash -- ? )
[ hash-deleted 10 fixnum*fast ] [ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
[ hash-count ] bi fixnum> ;
: grow-hash ( hash -- ) : grow-hash ( hash -- )
[ dup hash-array swap assoc-size 1+ ] keep [ dup hash-array swap assoc-size 1+ ] keep
@ -161,7 +156,7 @@ M: hashtable clone
M: hashtable equal? M: hashtable equal?
over hashtable? [ over hashtable? [
2dup [ assoc-size ] 2apply number= 2dup [ assoc-size ] bi@ number=
[ assoc= ] [ 2drop f ] if [ assoc= ] [ 2drop f ] if
] [ 2drop f ] if ; ] [ 2drop f ] if ;
@ -185,12 +180,12 @@ M: hashtable assoc-like
: prune ( seq -- newseq ) : prune ( seq -- newseq )
[ length <hashtable> ] [ length <hashtable> ]
[ length <vector> ] [ length <vector> ]
[ ] tri [ ] tri
[ >r 2dup r> (prune) ] each nip ; [ >r 2dup r> (prune) ] each nip ;
: all-unique? ( seq -- ? ) : all-unique? ( seq -- ? )
[ length ] [ length ]
[ prune length ] bi = ; [ prune length ] bi = ;
INSTANCE: hashtable assoc INSTANCE: hashtable assoc

View File

@ -66,8 +66,8 @@ IN: heaps.tests
dup heap-data clone swap dup heap-data clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
heap-data heap-data
[ [ entry-key ] map ] 2apply [ [ entry-key ] map ] bi@
[ natural-sort ] 2apply ; [ natural-sort ] bi@ ;
11 [ 11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test [ t ] swap [ 2^ delete-test sequence= ] curry unit-test

View File

@ -26,8 +26,8 @@ C: <literal-constraint> literal-constraint
M: literal-constraint equal? M: literal-constraint equal?
over literal-constraint? [ over literal-constraint? [
2dup 2dup
[ literal-constraint-literal ] 2apply eql? >r [ literal-constraint-literal ] bi@ eql? >r
[ literal-constraint-value ] 2apply = r> and [ literal-constraint-value ] bi@ = r> and
] [ ] [
2drop f 2drop f
] if ; ] if ;

View File

@ -224,7 +224,7 @@ DEFER: do-crap*
MATH: xyz MATH: xyz
M: fixnum xyz 2array ; M: fixnum xyz 2array ;
M: float xyz 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 [ [ xyz ] infer ] [ inference-error? ] must-fail-with

View File

@ -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" 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 [ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test [ ] [ "quux-test.txt" temp-file delete-file ] unit-test

View File

@ -3,7 +3,7 @@
USING: io.backend io.files.private io hashtables kernel math USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings system combinators splitting sbufs continuations io.encodings
io.encodings.binary init ; io.encodings.binary init accessors ;
IN: io.files IN: io.files
HOOK: (file-reader) io-backend ( path -- stream ) HOOK: (file-reader) io-backend ( path -- stream )
@ -145,8 +145,17 @@ PRIVATE>
TUPLE: file-info type size permissions modified ; TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info ) HOOK: file-info io-backend ( path -- info )
! Symlinks
HOOK: link-info io-backend ( path -- info ) 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: +regular-file+
SYMBOL: +directory+ SYMBOL: +directory+
SYMBOL: +character-device+ SYMBOL: +character-device+
@ -218,14 +227,14 @@ HOOK: delete-file io-backend ( path -- )
HOOK: delete-directory 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 -- ) : 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 ; : to-directory over file-name append-path ;
@ -258,13 +267,16 @@ M: object copy-file
DEFER: copy-tree-into DEFER: copy-tree-into
: copy-tree ( from to -- ) : copy-tree ( from to -- )
over directory? [ over link-info type>>
>r dup directory swap r> [ {
>r swap first append-path r> copy-tree-into { +symbolic-link+ [ copy-link ] }
] 2curry each { +directory+ [
] [ >r dup directory r> rot [
copy-file [ >r first r> copy-tree-into ] curry each
] if ; ] with-directory
] }
[ drop copy-file ]
} case ;
: copy-tree-into ( from to -- ) : copy-tree-into ( from to -- )
to-directory copy-tree ; to-directory copy-tree ;

View File

@ -43,29 +43,86 @@ $nl
"An alternative to using " { $link >r } " and " { $link r> } " is the following:" "An alternative to using " { $link >r } " and " { $link r> } " is the following:"
{ $subsection dip } ; { $subsection dip } ;
ARTICLE: "basic-combinators" "Basic combinators" ARTICLE: "cleave-combinators" "Cleave combinators"
"The following pair of words invoke words and quotations reflectively:" "The cleave combinators apply multiple quotations to a single value."
{ $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" } "."
$nl $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 slip }
{ $subsection 2slip } { $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 keep }
{ $subsection 2keep } { $subsection 2keep }
{ $subsection 3keep } { $subsection 3keep } ;
{ $subsection 2apply }
"A pair of utility words built from " { $link 2apply } ":" ARTICLE: "compositional-combinators" "Compositional combinators"
{ $subsection both? }
{ $subsection either? }
"A looping combinator:"
{ $subsection while }
"Quotations can be composed using efficient quotation-specific operations:" "Quotations can be composed using efficient quotation-specific operations:"
{ $subsection curry } { $subsection curry }
{ $subsection 2curry } { $subsection 2curry }
@ -73,8 +130,21 @@ $nl
{ $subsection with } { $subsection with }
{ $subsection compose } { $subsection compose }
{ $subsection 3compose } { $subsection 3compose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." "Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
{ $see-also "combinators" } ;
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" 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." "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 } { $subsection ?if }
"Sometimes instead of branching, you just need to pick one of two values:" "Sometimes instead of branching, you just need to pick one of two values:"
{ $subsection ? } { $subsection ? }
"Forms which abstract away common patterns involving multiple nested branches:"
{ $subsection cond }
{ $subsection case }
"There are some logical operations on booleans:" "There are some logical operations on booleans:"
{ $subsection >boolean } { $subsection >boolean }
{ $subsection not } { $subsection not }
{ $subsection and } { $subsection and }
{ $subsection or } { $subsection or }
{ $subsection xor } { $subsection xor }
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ; { $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "equality" "Equality and comparison testing" ARTICLE: "equality" "Equality and comparison testing"
@ -146,7 +214,23 @@ $nl
"An object can be cloned; the clone has distinct identity but equal value:" "An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ; { $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" ABOUT: "dataflow"
HELP: eq? ( obj1 obj2 -- ? ) HELP: eq? ( obj1 obj2 -- ? )
@ -211,12 +295,12 @@ HELP: hashcode*
{ $values { "depth" integer } { "obj" object } { "code" fixnum } } { $values { "depth" integer } { "obj" object } { "code" fixnum } }
{ $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:" { $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:"
{ $list { $list
{ "if two objects are equal under " { $link = } ", they must have equal hashcodes" } { "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" } { "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 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" } { "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 HELP: hashcode
{ $values { "obj" object } { "code" fixnum } } { $values { "obj" object } { "code" fixnum } }
@ -242,6 +326,8 @@ HELP: equal?
{ { $snippet "a = b" } " implies " { $snippet "b = a" } } { { $snippet "a = b" } " implies " { $snippet "b = a" } }
{ { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } } { { $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 { $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:" "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 } } { $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." } ; { $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: 2apply HELP: bi
{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } { "x" object } { "y" object } } { $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ; { $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 -- ) HELP: if ( cond true false -- )
{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } } { $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } }

View File

@ -66,46 +66,46 @@ DEFER: if
>r 3dup r> -roll 3slip ; inline >r 3dup r> -roll 3slip ; inline
! Cleavers ! Cleavers
: bi ( x p q -- p[x] q[x] ) : bi ( x p q -- )
>r keep r> call ; inline >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 >r pick >r bi r> r> call ; inline
! Double cleavers ! Double cleavers
: 2bi ( x y p q -- p[x,y] q[x,y] ) : 2bi ( x y p q -- )
>r 2keep r> call ; inline >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 >r >r 2keep r> 2keep r> call ; inline
! Triple cleavers ! 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 >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 >r >r 3keep r> 3keep r> call ; inline
! Spreaders ! Spreaders
: bi* ( x y p q -- p[x] q[y] ) : bi* ( x y p q -- )
>r swap slip r> call ; inline >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 >r rot >r bi* r> r> call ; inline
! Double spreaders ! 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 >r -rot 2slip r> call ; inline
! Appliers ! Appliers
: bi@ ( x y p -- p[x] p[y] ) : bi@ ( x y quot -- )
tuck 2slip call ; inline 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 tuck >r bi@ r> call ; inline
! Double appliers ! 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 dup -roll 3slip call ; inline
: while ( pred body tail -- ) : while ( pred body tail -- )
@ -199,6 +199,3 @@ GENERIC: construct-boa ( ... class -- tuple )
: do-primitive ( number -- ) "Improper primitive call" throw ; : do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE> PRIVATE>
! Deprecated
: 2apply bi@ ; inline

View File

@ -169,7 +169,7 @@ IN: math.intervals.tests
: random-interval ( -- interval ) : random-interval ( -- interval )
1000 random dup 2 1000 random + + 1000 random dup 2 1000 random + +
1 random zero? [ [ neg ] 2apply swap ] when 1 random zero? [ [ neg ] bi@ swap ] when
4 random { 4 random {
{ 0 [ [a,b] ] } { 0 [ [a,b] ] }
{ 1 [ [a,b) ] } { 1 [ [a,b) ] }
@ -197,7 +197,7 @@ IN: math.intervals.tests
0 pick interval-contains? over first { / /i } member? and [ 0 pick interval-contains? over first { / /i } member? and [
3drop t 3drop t
] [ ] [
[ >r [ random-element ] 2apply ! 2dup . . [ >r [ random-element ] bi@ ! 2dup . .
r> first execute ] 3keep r> first execute ] 3keep
second execute interval-contains? second execute interval-contains?
] if ; ] if ;
@ -214,7 +214,7 @@ IN: math.intervals.tests
: comparison-test : comparison-test
random-interval random-interval random-comparison 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? [ second execute dup incomparable eq? [
2drop t 2drop t
] [ ] [

View File

@ -67,7 +67,7 @@ C: <interval> interval
: (interval-op) ( p1 p2 quot -- p3 ) : (interval-op) ( p1 p2 quot -- p3 )
2over >r >r 2over >r >r
>r [ first ] 2apply r> call >r [ first ] bi@ r> call
r> r> [ second ] both? 2array ; inline r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 ) : interval-op ( i1 i2 quot -- i3 )
@ -108,7 +108,7 @@ C: <interval> interval
: interval-intersect ( i1 i2 -- i3 ) : interval-intersect ( i1 i2 -- i3 )
2dup and [ 2dup and [
[ interval>points ] 2apply swapd [ interval>points ] bi@ swapd
[ swap endpoint> ] most [ swap endpoint> ] most
>r [ swap endpoint< ] most r> >r [ swap endpoint< ] most r>
make-interval make-interval
@ -118,7 +118,7 @@ C: <interval> interval
: interval-union ( i1 i2 -- i3 ) : interval-union ( i1 i2 -- i3 )
2dup and [ 2dup and [
[ interval>points 2array ] 2apply append points>interval [ interval>points 2array ] bi@ append points>interval
] [ ] [
2drop f 2drop f
] if ; ] if ;
@ -131,17 +131,17 @@ C: <interval> interval
: interval-singleton? ( int -- ? ) : interval-singleton? ( int -- ? )
interval>points interval>points
2dup [ second ] 2apply and 2dup [ second ] bi@ and
[ [ first ] 2apply = ] [ [ first ] bi@ = ]
[ 2drop f ] if ; [ 2drop f ] if ;
: interval-length ( int -- n ) : interval-length ( int -- n )
dup dup
[ interval>points [ first ] 2apply swap - ] [ interval>points [ first ] bi@ swap - ]
[ drop 0 ] if ; [ drop 0 ] if ;
: interval-closure ( i1 -- i2 ) : 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 ) : interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter #! Inaccurate; could be tighter
@ -163,7 +163,7 @@ C: <interval> interval
[ min ] interval-op interval-closure ; [ min ] interval-op interval-closure ;
: interval-interior ( i1 -- i2 ) : interval-interior ( i1 -- i2 )
interval>points [ first ] 2apply (a,b) ; interval>points [ first ] bi@ (a,b) ;
: interval-division-op ( i1 i2 quot -- i3 ) : interval-division-op ( i1 i2 quot -- i3 )
>r 0 over interval-closure interval-contains? >r 0 over interval-closure interval-contains?
@ -186,13 +186,13 @@ SYMBOL: incomparable
: left-endpoint-< ( i1 i2 -- ? ) : left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ] 2keep [ swap interval-subset? ] 2keep
[ nip interval-singleton? ] 2keep [ nip interval-singleton? ] 2keep
[ interval-from ] 2apply = [ interval-from ] bi@ =
and and ; and and ;
: right-endpoint-< ( i1 i2 -- ? ) : right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ] 2keep [ interval-subset? ] 2keep
[ drop interval-singleton? ] 2keep [ drop interval-singleton? ] 2keep
[ interval-to ] 2apply = [ interval-to ] bi@ =
and and ; and and ;
: (interval<) over interval-from over interval-from endpoint< ; : (interval<) over interval-from over interval-from endpoint< ;

View File

@ -99,7 +99,7 @@ namespaces assocs kernel sequences math tools.test words ;
] unit-test ] unit-test
: regression-2 ( x y -- x.y ) : regression-2 ( x y -- x.y )
[ p1 ] 2apply [ [ p1 ] bi@ [
[ [
rot rot
[ 2swap [ swapd * -rot p2 +@ ] 2keep ] [ 2swap [ swapd * -rot p2 +@ ] 2keep ]

View File

@ -113,7 +113,7 @@ generic.standard system ;
: post-process ( class interval node -- classes intervals ) : post-process ( class interval node -- classes intervals )
dupd won't-overflow? dupd won't-overflow?
[ >r dup { f integer } member? [ drop fixnum ] when r> ] when [ >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 ) : math-output-interval-1 ( node word -- interval )
dup [ dup [
@ -147,7 +147,7 @@ generic.standard system ;
] each ] each
: intervals ( node -- i1 i2 ) : 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 ) : math-output-interval-2 ( node word -- interval )
dup [ dup [

View File

@ -475,7 +475,7 @@ SYMBOL: interactive-vocabs
: removed-definitions ( -- definitions ) : removed-definitions ( -- definitions )
new-definitions old-definitions new-definitions old-definitions
[ get first2 union ] 2apply diff ; [ get first2 union ] bi@ diff ;
: smudged-usage ( -- usages referenced removed ) : smudged-usage ( -- usages referenced removed )
removed-definitions filter-moved keys [ removed-definitions filter-moved keys [

View File

@ -114,7 +114,7 @@ SYMBOL: ->
: remove-breakpoints ( quot pos -- quot' ) : remove-breakpoints ( quot pos -- quot' )
over quotation? [ over quotation? [
1+ cut [ (remove-breakpoints) ] 2apply 1+ cut [ (remove-breakpoints) ] bi@
[ -> ] swap 3append [ -> ] swap 3append
] [ ] [
drop drop

View File

@ -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: compose call dup 3 slot swap 4 slot slip call ;
M: wrapper equal? M: wrapper equal?
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ; over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ;
UNION: callable quotation curry compose ; UNION: callable quotation curry compose ;

View File

@ -169,13 +169,13 @@ unit-test
[ f ] [ { "a" "b" "c" } { "a" "b" "c" } mismatch ] 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" <slice> ] must-fail [ -1 1 "abc" <slice> ] 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 ] [ "ab" "abc" <=> ] unit-test
[ 1 ] [ "abc" "ab" <=> ] unit-test [ 1 ] [ "abc" "ab" <=> ] unit-test

View File

@ -300,9 +300,9 @@ M: immutable-sequence clone-like like ;
: change-nth ( i seq quot -- ) : change-nth ( i seq quot -- )
[ >r nth r> call ] 3keep drop set-nth ; inline [ >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
<PRIVATE <PRIVATE
@ -369,7 +369,7 @@ PRIVATE>
(2each) each-integer ; inline (2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- ) : 2reverse-each ( seq1 seq2 quot -- )
>r [ <reversed> ] 2apply r> 2each ; inline >r [ <reversed> ] bi@ r> 2each ; inline
: 2reduce ( seq1 seq2 identity quot -- result ) : 2reduce ( seq1 seq2 identity quot -- result )
>r -rot r> 2each ; inline >r -rot r> 2each ; inline
@ -460,7 +460,7 @@ M: sequence <=>
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ; [ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
: sequence= ( seq1 seq2 -- ? ) : sequence= ( seq1 seq2 -- ? )
2dup [ length ] 2apply number= 2dup [ length ] bi@ number=
[ mismatch not ] [ 2drop f ] if ; inline [ mismatch not ] [ 2drop f ] if ; inline
: move ( to from seq -- ) : move ( to from seq -- )
@ -620,12 +620,12 @@ M: sequence <=>
[ drop nip ] [ drop nip ]
[ 2drop first ] [ 2drop first ]
[ >r drop first2 r> call ] [ >r drop first2 r> call ]
[ >r drop first3 r> 2apply ] [ >r drop first3 r> bi@ ]
} dispatch } dispatch
] [ ] [
drop drop
>r >r halves r> r> >r >r halves r> r>
[ [ binary-reduce ] 2curry 2apply ] keep [ [ binary-reduce ] 2curry bi@ ] keep
call call
] if ; inline ] if ; inline

View File

@ -32,7 +32,7 @@ DEFER: sort
] if ; inline ] if ; inline
: merge ( sorted1 sorted2 quot -- result ) : merge ( sorted1 sorted2 quot -- result )
>r [ [ <iterator> ] 2apply ] 2keep r> >r [ [ <iterator> ] bi@ ] 2keep r>
rot length rot length + <vector> rot length rot length + <vector>
[ (merge) ] keep underlying ; inline [ (merge) ] keep underlying ; inline

View File

@ -56,7 +56,7 @@ INSTANCE: groups sequence
] if ; ] if ;
: last-split1 ( seq subseq -- before after ) : last-split1 ( seq subseq -- before after )
[ <reversed> ] 2apply split1 [ reverse ] 2apply [ <reversed> ] bi@ split1 [ reverse ] bi@
dup [ swap ] when ; dup [ swap ] when ;
: (split) ( separators n seq -- ) : (split) ( separators n seq -- )

View File

@ -77,7 +77,7 @@ IN: vectors.tests
[ f ] [ [ f ] [
V{ 1 2 3 4 } dup clone V{ 1 2 3 4 } dup clone
[ underlying ] 2apply eq? [ underlying ] bi@ eq?
] unit-test ] unit-test
[ 0 ] [ [ 0 ] [

View File

@ -94,7 +94,7 @@ TUPLE: vocab-link name ;
M: vocab-link equal? M: vocab-link equal?
over vocab-link? over vocab-link?
[ [ vocab-link-name ] 2apply = ] [ 2drop f ] if ; [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
M: vocab-link hashcode* M: vocab-link hashcode*
vocab-link-name hashcode* ; vocab-link-name hashcode* ;

View File

@ -133,7 +133,7 @@ DEFER: create ( level c r -- scene )
pick 1 = [ <sphere> nip ] [ create-group ] if ; pick 1 = [ <sphere> nip ] [ create-group ] if ;
: ss-point ( dx dy -- point ) : ss-point ( dx dy -- point )
[ oversampling /f ] 2apply 0.0 3float-array ; [ oversampling /f ] bi@ 0.0 3float-array ;
: ss-grid ( -- ss-grid ) : ss-grid ( -- ss-grid )
oversampling [ oversampling [ ss-point ] with map ] map ; oversampling [ oversampling [ ss-point ] with map ] map ;
@ -150,7 +150,7 @@ DEFER: create ( level c r -- scene )
: pixel-grid ( -- grid ) : pixel-grid ( -- grid )
size reverse [ size reverse [
size [ size [
[ size 0.5 * - ] 2apply swap size [ size 0.5 * - ] bi@ swap size
3float-array 3float-array
] with map ] with map
] map ; ] map ;

View File

@ -5,7 +5,7 @@ io.files kernel ;
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [ [ "c071aa7e007a9770b2fb4304f55a17e5" ] [
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt" "extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt" "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
[ resource-path ] 2apply [ resource-path ] bi@
reverse-complement reverse-complement
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt" "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"

View File

@ -7,7 +7,7 @@ IN: benchmark.spectral-norm
: fast-truncate >fixnum >float ; inline : fast-truncate >fixnum >float ; inline
: eval-A ( i j -- n ) : eval-A ( i j -- n )
[ >float ] 2apply [ >float ] bi@
dupd + dup 1+ * 2 /f fast-truncate + 1+ dupd + dup 1+ * 2 /f fast-truncate + 1+
recip ; inline recip ; inline

View File

@ -3,7 +3,7 @@ IN: benchmark.typecheck2
TUPLE: hello n ; 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 ; : foo 0 100000000 [ over hello-n* + ] times ;

View File

@ -3,7 +3,7 @@ IN: benchmark.typecheck3
TUPLE: hello n ; 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 ; : foo 0 100000000 [ over hello-n* + ] times ;

View File

@ -3,7 +3,7 @@ IN: benchmark.typecheck4
TUPLE: hello n ; TUPLE: hello n ;
: hello-n* 4 slot ; : hello-n* 3 slot ;
: foo 0 100000000 [ over hello-n* + ] times ; : foo 0 100000000 [ over hello-n* + ] times ;

View File

@ -63,7 +63,7 @@ M: check< summary drop "Number exceeds upper bound" ;
[ range>accessor ] map ; [ range>accessor ] map ;
: clear-range ( range -- num ) : clear-range ( range -- num )
first2 dupd + [ 2^ 1- ] 2apply bitnot bitor ; first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ;
: range>setter ( range -- quot ) : range>setter ( range -- quot )
[ [

View File

@ -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 ) : relative-angle ( self other -- angle )
over boid-vel -rot relative-position angle-between ; over boid-vel -rot relative-position angle-between ;

View File

@ -19,11 +19,11 @@ IN: builder.benchmark
2array ; 2array ;
: compare-tables ( old new -- table ) : compare-tables ( old new -- table )
[ passing-benchmarks ] 2apply [ passing-benchmarks ] bi@
[ benchmark-difference ] with map ; [ benchmark-difference ] with map ;
: benchmark-deltas ( -- table ) : benchmark-deltas ( -- table )
"../benchmarks" "benchmarks" [ eval-file ] 2apply "../benchmarks" "benchmarks" [ eval-file ] bi@
compare-tables compare-tables
sort-values ; sort-values ;

View File

@ -48,15 +48,31 @@ IN: builder
: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; : 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 )
! <process>
! { "make" } >>command
! "../compile-log" >>stdout
! +stdout+ >>stderr ;
: make-vm ( -- desc ) : make-vm ( -- desc )
<process> <process>
{ "make" } >>command { gnu-make } to-strings >>command
"../compile-log" >>stdout "../compile-log" >>stdout
+stdout+ >>stderr ; +stdout+ >>stderr ;
: do-make-vm ( -- ) : do-make-vm ( -- )
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;

View File

@ -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 ) : maybe-tail* ( seq n -- seq )
2dup longer? 2dup longer?

View File

@ -185,7 +185,7 @@ M: number +second ( timestamp n -- timestamp )
[ month>> +month ] keep [ month>> +month ] keep
[ year>> +year ] keep ; inline [ year>> +year ] keep ; inline
: +slots [ 2apply + ] curry 2keep ; inline : +slots [ bi@ + ] curry 2keep ; inline
PRIVATE> PRIVATE>
@ -244,9 +244,9 @@ M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ; [ >gmt tuple-slots ] compare ;
: (time-) ( timestamp timestamp -- n ) : (time-) ( timestamp timestamp -- n )
[ >gmt ] 2apply [ >gmt ] bi@
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
M: timestamp time- M: timestamp time-
#! Exact calendar-time difference #! Exact calendar-time difference

View File

@ -182,7 +182,7 @@ M: timestamp year. ( timestamp -- )
[ [
[ month>> month-abbreviations nth write ] keep bl [ month>> month-abbreviations nth write ] keep bl
[ day>> number>string 2 32 pad-left 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 [ hour>> write-00 ] keep ":" write
minute>> write-00 minute>> write-00
] [ ] [

View File

@ -26,7 +26,7 @@ IN: cocoa.dialogs
[ -> filenames CF>string-array ] [ drop f ] if ; [ -> filenames CF>string-array ] [ drop f ] if ;
: split-path ( path -- dir file ) : split-path ( path -- dir file )
"/" last-split1 [ <NSString> ] 2apply ; "/" last-split1 [ <NSString> ] bi@ ;
: save-panel ( path -- paths ) : save-panel ( path -- paths )
<NSSavePanel> dup <NSSavePanel> dup

View File

@ -1,7 +1,7 @@
IN: concurrency.distributed.tests IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files USING: tools.test concurrency.distributed kernel io.files
arrays io.sockets system combinators threads math sequences arrays io.sockets system combinators threads math sequences
concurrency.messaging ; concurrency.messaging continuations ;
: test-node : test-node
{ {
@ -9,6 +9,8 @@ concurrency.messaging ;
{ [ windows? ] [ "127.0.0.1" 1238 <inet4> ] } { [ windows? ] [ "127.0.0.1" 1238 <inet4> ] }
} cond ; } cond ;
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
[ ] [ test-node dup 1array swap (start-node) ] unit-test [ ] [ test-node dup 1array swap (start-node) ] unit-test
[ ] [ yield ] unit-test [ ] [ yield ] unit-test

View File

@ -24,7 +24,7 @@ C: <rsa> rsa
: modulus-phi ( numbits -- n phi ) : modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key. #! Loop until phi is not divisible by the public key.
dup rsa-primes [ * ] 2keep dup rsa-primes [ * ] 2keep
[ 1- ] 2apply * [ 1- ] bi@ *
dup public-key gcd nip 1 = [ dup public-key gcd nip 1 = [
rot drop rot drop
] [ ] [

View File

@ -124,5 +124,5 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
: byte-array>sha1-interleave ( string -- seq ) : byte-array>sha1-interleave ( string -- seq )
[ zero? ] left-trim [ zero? ] left-trim
dup length odd? [ 1 tail ] when dup length odd? [ 1 tail ] when
seq>2seq [ byte-array>sha1 ] 2apply seq>2seq [ byte-array>sha1 ] bi@
swap 2seq>seq ; swap 2seq>seq ;

View File

@ -12,7 +12,7 @@ IN: documents
: =line ( n loc -- newloc ) second 2array ; : =line ( n loc -- newloc ) second 2array ;
: lines-equal? ( loc1 loc2 -- ? ) [ first ] 2apply number= ; : lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
TUPLE: document locs ; TUPLE: document locs ;
@ -46,7 +46,7 @@ TUPLE: document locs ;
2over = [ 2over = [
3drop 3drop
] [ ] [
>r [ first ] 2apply 1+ dup <slice> r> each >r [ first ] bi@ 1+ dup <slice> r> each
] if ; inline ] if ; inline
: start/end-on-line ( from to line# -- n1 n2 ) : start/end-on-line ( from to line# -- n1 n2 )
@ -85,7 +85,7 @@ TUPLE: document locs ;
: (set-doc-range) ( newlines from to lines -- ) : (set-doc-range) ( newlines from to lines -- )
[ prepare-insert ] 3keep [ prepare-insert ] 3keep
>r [ first ] 2apply 1+ r> >r [ first ] bi@ 1+ r>
replace-slice ; replace-slice ;
: set-doc-range ( string from to document -- ) : set-doc-range ( string from to document -- )

View File

@ -91,7 +91,7 @@ C: <faq> faq
: faq-sections, ( question-lists -- ) : faq-sections, ( question-lists -- )
unclip question-list-seq length 1+ dupd unclip question-list-seq length 1+ dupd
[ question-list-seq length + ] accumulate nip [ 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 ) : faq>html ( faq -- div )
"div" [ "div" [

View File

@ -69,7 +69,7 @@ $nl
{ { $link curry } { $snippet ": curry '[ , @ ] ;" } } { { $link curry } { $snippet ": curry '[ , @ ] ;" } }
{ { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } } { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
{ { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } } { { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } }
} ; } ;
ARTICLE: "fry.philosophy" "Fried quotation philosophy" ARTICLE: "fry.philosophy" "Fried quotation philosophy"

View File

@ -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." "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" } ; { $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 USING: concurrency.combinators
concurrency.messaging concurrency.messaging
concurrency.promises concurrency.promises

View File

@ -59,7 +59,7 @@ IN: help.lint
: check-see-also ( word element -- ) : check-see-also ( word element -- )
nip \ $see-also swap elements [ nip \ $see-also swap elements [
1 tail dup prune [ length ] 2apply assert= 1 tail dup prune [ length ] bi@ assert=
] each ; ] each ;
: vocab-exists? ( name -- ? ) : vocab-exists? ( name -- ? )

View File

@ -106,7 +106,7 @@ IN: http
: query>assoc ( query -- assoc ) : query>assoc ( query -- assoc )
dup [ dup [
"&" split [ "&" split [
"=" split1 [ dup [ url-decode ] when ] 2apply "=" split1 [ dup [ url-decode ] when ] bi@
] H{ } map>assoc ] H{ } map>assoc
] when ; ] when ;

View File

@ -51,14 +51,14 @@ SYMBOL: open-arrays
: binary-op ( quot -- ? ) : binary-op ( quot -- ? )
>r get-cba r> >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 set-reg f ; inline
: op1 ( opcode -- ? ) : op1 ( opcode -- ? )
[ swap arr-val ] binary-op ; [ swap arr-val ] binary-op ;
: op2 ( opcode -- ? ) : 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 -- ? ) : op3 ( opcode -- ? )
[ + >32bit ] binary-op ; [ + >32bit ] binary-op ;

View File

@ -151,10 +151,10 @@ MACRO: undo ( quot -- ) [undo] ;
\ - [ + ] [ - ] define-math-inverse \ - [ + ] [ - ] define-math-inverse
\ * [ / ] [ / ] define-math-inverse \ * [ / ] [ / ] define-math-inverse
\ / [ * ] [ / ] define-math-inverse \ / [ * ] [ / ] define-math-inverse
\ ^ [ recip ^ ] [ [ log ] 2apply / ] define-math-inverse \ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
\ ? 2 [ \ ? 2 [
[ assert-literal ] 2apply [ assert-literal ] bi@
[ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ] [ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
2curry 2curry
] define-pop-inverse ] define-pop-inverse

View File

@ -78,7 +78,7 @@ M: utf16le decode-char
swap BIN: 11111111 bitand ; swap BIN: 11111111 bitand ;
: stream-write2 ( stream char1 char2 -- ) : stream-write2 ( stream char1 char2 -- )
rot [ stream-write1 ] curry 2apply ; rot [ stream-write1 ] curry bi@ ;
: char>utf16be ( stream char -- ) : char>utf16be ( stream char -- )
dup HEX: FFFF > [ dup HEX: FFFF > [

View File

@ -161,5 +161,5 @@ TUPLE: datagram-port addr packet packet-addr ;
: check-datagram-send ( packet addrspec port -- ) : check-datagram-send ( packet addrspec port -- )
dup check-datagram-port dup check-datagram-port
datagram-port-addr [ class ] 2apply assert= datagram-port-addr [ class ] bi@ assert=
class byte-array assert= ; class byte-array assert= ;

View File

@ -64,8 +64,8 @@ M: inet6 inet-ntop ( data addrspec -- str )
M: inet6 inet-pton ( str addrspec -- data ) M: inet6 inet-pton ( str addrspec -- data )
drop "::" split1 drop "::" split1
[ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] 2apply [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@
2dup [ length ] 2apply + 8 swap - 0 <array> swap 3append 2dup [ length ] bi@ + 8 swap - 0 <array> swap 3append
[ 2 >be ] map concat >byte-array ; [ 2 >be ] map concat >byte-array ;
M: inet6 address-size drop 16 ; M: inet6 address-size drop 16 ;

View File

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

View File

@ -3,7 +3,7 @@
USING: io.backend io.nonblocking io.unix.backend io.files io USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar math.bitfields byte-arrays alien combinators calendar
io.encodings.binary ; io.encodings.binary accessors sequences strings ;
IN: io.unix.files IN: io.unix.files
@ -49,7 +49,7 @@ M: unix-io touch-file ( path -- )
close ; close ;
M: unix-io move-file ( from to -- ) 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 -- ) M: unix-io delete-file ( path -- )
normalize-pathname unlink io-error ; normalize-pathname unlink io-error ;
@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ; ] with-disposal ;
M: unix-io copy-file ( from to -- ) M: unix-io copy-file ( from to -- )
[ normalize-pathname ] 2apply [ normalize-pathname ] bi@
[ (copy-file) ] [ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ] [ swap file-info file-info-permissions chmod io-error ]
2bi ; 2bi ;
@ -84,7 +84,7 @@ M: unix-io copy-file ( from to -- )
{ [ dup S_ISLNK ] [ +symbolic-link+ ] } { [ dup S_ISLNK ] [ +symbolic-link+ ] }
{ [ dup S_ISSOCK ] [ +socket+ ] } { [ dup S_ISSOCK ] [ +socket+ ] }
{ [ t ] [ +unknown+ ] } { [ t ] [ +unknown+ ] }
} cond nip ; } cond nip ;
: stat>file-info ( stat -- info ) : stat>file-info ( stat -- info )
{ {
@ -100,3 +100,11 @@ M: unix-io file-info ( path -- info )
M: unix-io link-info ( path -- info ) M: unix-io link-info ( path -- info )
normalize-pathname lstat* stat>file-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 [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;

View File

@ -46,5 +46,5 @@ M: windows-ce-io (init-stdio) ( -- )
1 _getstdfilex _fileno 1 _getstdfilex _fileno
2 _getstdfilex _fileno 2 _getstdfilex _fileno
] if [ f <win32-file> ] 3apply ] if [ f <win32-file> ] 3apply
rot <reader> -rot [ <writer> ] 2apply rot <reader> -rot [ <writer> ] bi@
] with-variable ; ] with-variable ;

View File

@ -135,14 +135,14 @@ M: windows-io (file-appender) ( path -- stream )
open-append <win32-file> <writer> ; open-append <win32-file> <writer> ;
M: windows-io move-file ( from to -- ) 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 -- ) M: windows-io delete-file ( path -- )
normalize-pathname DeleteFile win32-error=0/f ; normalize-pathname DeleteFile win32-error=0/f ;
M: windows-io copy-file ( from to -- ) M: windows-io copy-file ( from to -- )
dup parent-directory make-directories 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 -- ) M: windows-io make-directory ( path -- )
normalize-pathname normalize-pathname

View File

@ -72,7 +72,7 @@ TUPLE: segment number color radius ;
: sub-tunnel ( from to sements -- segments ) : sub-tunnel ( from to sements -- segments )
#! return segments between from and to, after clamping from and to to #! return segments between from and to, after clamping from and to to
#! valid values #! valid values
[ sequence-index-range [ clamp-to-range ] curry 2apply ] keep <slice> ; [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
: nearer-segment ( segment segment oint -- segment ) : nearer-segment ( segment segment oint -- segment )
#! return whichever of the two segments is nearer to the oint #! return whichever of the two segments is nearer to the oint

View File

@ -1,8 +1,8 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.streams.string io strings splitting sequences math USING: kernel io.streams.string io strings splitting sequences math
math.parser assocs classes.tuple classes words namespaces math.parser assocs classes words namespaces prettyprint
hashtables ; hashtables mirrors ;
IN: json.writer IN: json.writer
#! Writes the object out to a stream in JSON format #! Writes the object out to a stream in JSON format
@ -39,21 +39,13 @@ M: sequence json-print ( array -- string )
#! javascript variable names. #! javascript variable names.
[ (jsvar-encode) ] map ; [ (jsvar-encode) ] map ;
: slots ( object -- values names ) : tuple>fields ( object -- string )
#! Given an object return an array of slots names and a sequence of slot values <mirror> [
#! the slot name and the slot value. [ swap jsvar-encode >json % " : " % >json % ] "" make
[ tuple-slots ] keep class slot-names ; ] { } assoc>map ;
: slots>fields ( values names -- array ) M: tuple json-print ( tuple -- string )
#! Convert the arrays containing the slot names and values CHAR: { write1 tuple>fields "," join write CHAR: } write1 ;
#! 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: hashtable json-print ( hashtable -- string ) M: hashtable json-print ( hashtable -- string )
CHAR: { write1 CHAR: { write1
@ -61,3 +53,5 @@ M: hashtable json-print ( hashtable -- string )
{ } assoc>map "," join write { } assoc>map "," join write
CHAR: } write1 ; CHAR: } write1 ;
M: object json-print ( object -- string )
unparse json-print ;

View File

@ -57,7 +57,7 @@ SYMBOL: terms
terms get [ [ swap +@ ] assoc-each ] bind ; terms get [ [ swap +@ ] assoc-each ] bind ;
: alt+ ( x y -- x+y ) : alt+ ( x y -- x+y )
[ >alt ] 2apply [ (alt+) (alt+) ] with-terms ; [ >alt ] bi@ [ (alt+) (alt+) ] with-terms ;
! Multiplication ! Multiplication
: alt*n ( vec n -- vec ) : alt*n ( vec n -- vec )
@ -79,7 +79,7 @@ SYMBOL: terms
] curry each ; ] curry each ;
: duplicates? ( seq -- ? ) : duplicates? ( seq -- ? )
dup prune [ length ] 2apply > ; dup prune [ length ] bi@ > ;
: (wedge) ( n basis1 basis2 -- n basis ) : (wedge) ( n basis1 basis2 -- n basis )
append dup duplicates? [ append dup duplicates? [
@ -90,7 +90,7 @@ SYMBOL: terms
] if ; ] if ;
: wedge ( x y -- x.y ) : wedge ( x y -- x.y )
[ >alt ] 2apply [ [ >alt ] bi@ [
swap [ swap [
[ [
2swap [ 2swap [
@ -200,7 +200,7 @@ DEFER: (d)
] with map ; ] with map ;
: bigraded-betti ( u-generators z-generators -- seq ) : 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 [ [ [ first ] map ] map ] keep
[ [ second ] map 2 head* { 0 0 } prepend ] map [ [ second ] map 2 head* { 0 0 } prepend ] map
1 tail dup first length 0 <array> add 1 tail dup first length 0 <array> add
@ -278,7 +278,7 @@ DEFER: (d)
] with map ; ] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq ) : 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 [ [ first3 ] swap compose map ] curry map ; inline
: bigraded-laplacian-betti ( u-generators z-generators -- seq ) : bigraded-laplacian-betti ( u-generators z-generators -- seq )

View File

@ -52,7 +52,7 @@ M: cons nil? ( cons -- bool )
TUPLE: lazy-cons car cdr ; TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise ) : lazy-cons ( car cdr -- promise )
[ promise ] 2apply \ lazy-cons construct-boa [ promise ] bi@ \ lazy-cons construct-boa
T{ promise f f t f } clone T{ promise f f t f } clone
[ set-promise-value ] keep ; [ set-promise-value ] keep ;

View File

@ -17,7 +17,7 @@ SYMBOL: d
SYMBOL: costs SYMBOL: costs
: init-d ( str1 str2 -- ) : init-d ( str1 str2 -- )
[ length 1+ ] 2apply 2dup <matrix> d set [ length 1+ ] bi@ 2dup <matrix> d set
[ 0 over ->d ] each [ 0 over ->d ] each
[ dup 0 ->d ] each ; inline [ dup 0 ->d ] each ; inline
@ -39,7 +39,7 @@ SYMBOL: costs
[ [
2dup init-d 2dup init-d
2dup compute-costs 2dup compute-costs
[ length ] 2apply [ [ length ] bi@ [
[ levenshtein-step ] curry each [ levenshtein-step ] curry each
] with each ] with each
levenshtein-result levenshtein-result

View File

@ -71,7 +71,7 @@ def-hash get-global [
! Remove set-alien-cell, etc. ! 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 ] assoc-subset
! Remove trivial defs ! Remove trivial defs
@ -148,7 +148,7 @@ GENERIC: run-lint ( obj -- obj )
: filter-symbols ( alist -- alist ) : filter-symbols ( alist -- alist )
[ [
nip first dup def-hash get at nip first dup def-hash get at
[ first ] 2apply literalize = not [ first ] bi@ literalize = not
] assoc-subset ; ] assoc-subset ;
M: sequence run-lint ( seq -- seq ) M: sequence run-lint ( seq -- seq )

View File

@ -32,10 +32,10 @@ SYMBOL: _
{ [ 2dup = ] [ 2drop t ] } { [ 2dup = ] [ 2drop t ] }
{ [ 2dup [ _ eq? ] either? ] [ 2drop t ] } { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
{ [ 2dup [ sequence? ] both? ] [ { [ 2dup [ sequence? ] both? ] [
2dup [ length ] 2apply = 2dup [ length ] bi@ =
[ [ (match) ] 2all? ] [ 2drop f ] if ] } [ [ (match) ] 2all? ] [ 2drop f ] if ] }
{ [ 2dup [ tuple? ] both? ] { [ 2dup [ tuple? ] both? ]
[ [ tuple>array ] 2apply [ (match) ] 2all? ] } [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
{ [ t ] [ 2drop f ] } { [ t ] [ 2drop f ] }
} cond ; } cond ;

View File

@ -8,11 +8,11 @@ math.functions.private sequences parser ;
M: real real-part ; M: real real-part ;
M: real imaginary-part drop 0 ; 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 ) : 2>rect ( x y -- xr yr xi yi )
[ [ real-part ] 2apply ] 2keep [ [ real-part ] bi@ ] 2keep
[ imaginary-part ] 2apply ; inline [ imaginary-part ] bi@ ; inline
M: complex number= M: complex number=
2>rect number= [ number= ] [ 2drop f ] if ; 2>rect number= [ number= ] [ 2drop f ] if ;

View File

@ -101,7 +101,7 @@ M: real absq sq ;
>r - abs r> < ; >r - abs r> < ;
: ~rel ( x y epsilon -- ? ) : ~rel ( x y epsilon -- ? )
>r [ - abs ] 2keep [ abs ] 2apply + r> * < ; >r [ - abs ] 2keep [ abs ] bi@ + r> * < ;
: ~ ( x y epsilon -- ? ) : ~ ( x y epsilon -- ? )
{ {
@ -124,7 +124,7 @@ M: real absq sq ;
: arg ( z -- arg ) >float-rect swap fatan2 ; inline : arg ( z -- arg ) >float-rect swap fatan2 ; inline
: >polar ( z -- abs arg ) : >polar ( z -- abs arg )
>float-rect [ [ sq ] 2apply + fsqrt ] 2keep swap fatan2 ; >float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ;
inline inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline : cis ( arg -- z ) dup fcos swap fsin rect> ; inline

View File

@ -13,10 +13,10 @@ IN: math.polynomials
<PRIVATE <PRIVATE
: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ; : 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ;
: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ; : 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ;
: pextend ( p p -- p p ) 2dup [ length ] 2apply max 2pad-right ; : pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
: pextend-left ( p p -- p p ) 2dup [ length ] 2apply max 2pad-left ; : pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
: unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ; : unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] 2apply ; : 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE> PRIVATE>
: p= ( p p -- ? ) pextend = ; : p= ( p p -- ? ) pextend = ;
@ -24,7 +24,7 @@ PRIVATE>
: ptrim ( p -- p ) : ptrim ( p -- p )
dup singleton? [ [ zero? ] right-trim ] unless ; 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+ ;
: p- ( p p -- p ) pextend v- ; : p- ( p p -- p ) pextend v- ;
: n*p ( n p -- n*p ) n*v ; : n*p ( n p -- n*p ) n*v ;
@ -32,7 +32,7 @@ PRIVATE>
! convolution ! convolution
: pextend-conv ( p p -- p p ) : pextend-conv ( p p -- p p )
#! extend to: p_m + p_n - 1 #! 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 ) : p* ( p p -- p )
#! Multiply two polynomials. #! Multiply two polynomials.
@ -46,13 +46,13 @@ PRIVATE>
: p/mod-setup ( p p -- p p n ) : p/mod-setup ( p p -- p p n )
2ptrim 2ptrim
2dup [ length ] 2apply - 2dup [ length ] bi@ -
dup 1 < [ drop 1 ] when dup 1 < [ drop 1 ] when
[ over length + 0 pad-left pextend ] keep 1+ ; [ over length + 0 pad-left pextend ] keep 1+ ;
: /-last ( seq seq -- a ) : /-last ( seq seq -- a )
#! divide the last two numbers in the sequences #! divide the last two numbers in the sequences
[ peek ] 2apply / ; [ peek ] bi@ / ;
: (p/mod) : (p/mod)
2dup /-last 2dup /-last
@ -74,7 +74,7 @@ PRIVATE>
] if ; ] if ;
: pgcd ( p p -- p q ) : 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' ) : pdiff ( p -- p' )
#! Polynomial derivative. #! Polynomial derivative.

View File

@ -14,7 +14,7 @@ IN: math.quaternions
: ** conjugate * ; inline : ** 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 : q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline

View File

@ -7,7 +7,7 @@ USING: kernel kernel.private math math.functions math.private ;
dup numerator swap denominator ; inline dup numerator swap denominator ; inline
: 2>fraction ( a/b c/d -- a c b d ) : 2>fraction ( a/b c/d -- a c b d )
[ >fraction ] 2apply swapd ; inline [ >fraction ] bi@ swapd ; inline
<PRIVATE <PRIVATE
@ -26,7 +26,7 @@ M: integer /
dup zero? [ dup zero? [
"Division by zero" throw "Division by zero" throw
] [ ] [
dup 0 < [ [ neg ] 2apply ] when dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip tuck /i >r /i r> fraction> 2dup gcd nip tuck /i >r /i r> fraction>
] if ; ] if ;

View File

@ -46,13 +46,13 @@ IN: math.statistics
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) : ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y)) ! 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 ) : (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
* recip >r [ ((r)) ] keep length 1- / r> * ; * recip >r [ ((r)) ] keep length 1- / r> * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) : [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 ( {{x,y}...} -- r )
[r] (r) ; [r] (r) ;

View File

@ -22,7 +22,7 @@ SYMBOL: visited
: random-neighbour ( cell -- newcell ) choices random ; : random-neighbour ( cell -- newcell ) choices random ;
: vertex ( pair -- ) : vertex ( pair -- )
first2 [ 0.5 + line-width * ] 2apply glVertex2d ; first2 [ 0.5 + line-width * ] bi@ glVertex2d ;
: (draw-maze) ( cell -- ) : (draw-maze) ( cell -- )
dup vertex dup vertex

View File

@ -23,9 +23,9 @@ TUPLE: not-a-decimal ;
: parse-decimal ( str -- ratio ) : parse-decimal ( str -- ratio )
"." split1 "." split1
>r dup "-" head? [ drop t "0" ] [ f swap ] if r> >r dup "-" head? [ drop t "0" ] [ f swap ] if r>
[ dup empty? [ drop "0" ] when ] 2apply [ dup empty? [ drop "0" ] when ] bi@
dup length 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 ; 10 swap ^ / + swap [ neg ] when ;
: DECIMAL: : DECIMAL:

View File

@ -113,7 +113,7 @@ TUPLE: no-method arguments generic ;
] curry assoc-map ; ] curry assoc-map ;
: sorted-methods ( alist -- alist' ) : sorted-methods ( alist -- alist' )
[ [ first ] 2apply classes< ] topological-sort ; [ [ first ] bi@ classes< ] topological-sort ;
: niceify-method [ dup \ f eq? [ drop f ] when ] map ; : niceify-method [ dup \ f eq? [ drop f ] when ] map ;

View File

@ -38,7 +38,7 @@ M: demo-gadget pref-dim* ( gadget -- dim )
: demo-gadget-frustum ( -- -x x -y y near far ) : demo-gadget-frustum ( -- -x x -y y near far )
FOV-RATIO NEAR-PLANE FOV / v*n FOV-RATIO NEAR-PLANE FOV / v*n
first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ; first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ;
: demo-gadget-set-matrices ( gadget -- ) : demo-gadget-set-matrices ( gadget -- )
GL_PROJECTION glMatrixMode GL_PROJECTION glMatrixMode

View File

@ -8,9 +8,9 @@ math.parser opengl.gl opengl.glu combinators arrays sequences
splitting words byte-arrays assocs combinators.lib ; splitting words byte-arrays assocs combinators.lib ;
IN: opengl 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 : 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 ; : 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 ; : scale-points 2array flip [ v* ] with map [ v+ ] with map ;

View File

@ -35,7 +35,7 @@ C: <parse-result> parse-result
] if ; ] if ;
: string= ( str1 str2 ignore-case -- ? ) : string= ( str1 str2 ignore-case -- ? )
[ [ >upper ] 2apply ] when sequence= ; [ [ >upper ] bi@ ] when sequence= ;
: string-head? ( str head ignore-case -- ? ) : string-head? ( str head ignore-case -- ? )
2over shorter? [ 2over shorter? [
@ -327,7 +327,7 @@ LAZY: <(+)> ( parser -- parser )
nonempty-list-of { } succeed <|> ; nonempty-list-of { } succeed <|> ;
LAZY: surrounded-by ( parser start end -- parser' ) LAZY: surrounded-by ( parser start end -- parser' )
[ token ] 2apply swapd pack ; [ token ] bi@ swapd pack ;
: exactly-n ( parser n -- parser' ) : exactly-n ( parser n -- parser' )
swap <repetition> <and-parser> [ flatten ] <@ ; swap <repetition> <and-parser> [ flatten ] <@ ;

View File

@ -70,7 +70,7 @@ MEMO: pack ( begin body end -- parser )
>r >r hide r> r> hide 3seq [ first ] action ; >r >r hide r> r> hide 3seq [ first ] action ;
: surrounded-by ( parser begin end -- parser' ) : surrounded-by ( parser begin end -- parser' )
[ token ] 2apply swapd pack ; [ token ] bi@ swapd pack ;
: 'digit' ( -- parser ) : 'digit' ( -- parser )
[ digit? ] satisfy [ digit> ] action ; [ digit? ] satisfy [ digit> ] action ;

View File

@ -11,9 +11,11 @@ USE: prettyprint
TUPLE: parse-result remaining ast ; TUPLE: parse-result remaining ast ;
TUPLE: parser id compiled ; TUPLE: parser id compiled ;
M: parser equal? [ id>> ] 2apply = ;
M: parser hashcode* ( depth obj -- code ) M: parser equal? [ id>> ] bi@ = ;
id>> hashcode* ;
M: parser hashcode* id>> hashcode* ;
C: <parser> parser C: <parser> parser
SYMBOL: ignore SYMBOL: ignore

View File

@ -31,7 +31,7 @@ IN: project-euler.009
: abc ( p q -- triplet ) : abc ( p q -- triplet )
[ [
2dup * , ! a = p * q 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 + 2 / , ! c = (p² + q²) / 2
] { } make natural-sort ; ] { } make natural-sort ;

View File

@ -39,7 +39,7 @@ IN: project-euler.014
dup even? [ 2 / ] [ 3 * 1+ ] if ; dup even? [ 2 / ] [ 3 * 1+ ] if ;
: longest ( seq seq -- seq ) : longest ( seq seq -- seq )
2dup [ length ] 2apply > [ drop ] [ nip ] if ; 2dup [ length ] bi@ > [ drop ] [ nip ] if ;
PRIVATE> PRIVATE>

View File

@ -58,7 +58,7 @@ PRIVATE>
: max-period ( seq -- elt n ) : max-period ( seq -- elt n )
dup [ period-length ] map dup supremum dup [ period-length ] map dup supremum
over index [ swap nth ] curry 2apply ; over index [ swap nth ] curry bi@ ;
PRIVATE> PRIVATE>

View File

@ -60,7 +60,7 @@ IN: project-euler.027
: max-consecutive ( seq -- elt n ) : max-consecutive ( seq -- elt n )
dup [ first2 consecutive-primes ] map dup supremum dup [ first2 consecutive-primes ] map dup supremum
over index [ swap nth ] curry 2apply ; over index [ swap nth ] curry bi@ ;
PRIVATE> PRIVATE>

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