From: Doug Coleman Date: Fri, 28 Sep 2012 16:16:08 +0000 (-0700) Subject: kernel: Add 4dup, 4drop, and 4cleave. X-Git-Tag: 0.97~2227 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=3582a6c624db5d1f5e95ab419a61b94e8a44861f kernel: Add 4dup, 4drop, and 4cleave. --- diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 2e33a4d930..bf8d3465fd 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -377,6 +377,10 @@ big-endian off ds-reg 3 bootstrap-cells SUB ] \ 3drop define-sub-primitive +[ + ds-reg 4 bootstrap-cells SUB +] \ 4drop define-sub-primitive + [ temp0 ds-reg [] MOV ds-reg bootstrap-cell ADD @@ -401,6 +405,18 @@ big-endian off ds-reg -2 bootstrap-cells [+] temp3 MOV ] \ 3dup define-sub-primitive +[ + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp2 ds-reg -2 bootstrap-cells [+] MOV + temp3 ds-reg -3 bootstrap-cells [+] MOV + ds-reg 4 bootstrap-cells ADD + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp2 MOV + ds-reg -3 bootstrap-cells [+] temp3 MOV +] \ 4dup define-sub-primitive + [ temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 2659ed3280..92478812be 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -31,7 +31,3 @@ SYNTAX: shuffle( : -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline deprecated : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline - -: 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline - -: 4drop ( a b c d -- ) 3drop drop ; inline diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 34fee639e1..fba664d629 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -87,6 +87,10 @@ IN: stack-checker.transforms \ 3cleave t "no-compile" set-word-prop +\ 4cleave [ 4cleave>quot ] 1 define-transform + +\ 4cleave t "no-compile" set-word-prop + \ spread [ deep-spread>quot ] 1 define-transform \ spread t "no-compile" set-word-prop diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 111b7d9631..127ef7f6f0 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -329,9 +329,11 @@ tuple { "drop" "kernel" ( x -- ) } { "2drop" "kernel" ( x y -- ) } { "3drop" "kernel" ( x y z -- ) } + { "4drop" "kernel" ( w x y z -- ) } { "dup" "kernel" ( x -- x x ) } { "2dup" "kernel" ( x y -- x y x y ) } { "3dup" "kernel" ( x y z -- x y z x y z ) } + { "4dup" "kernel" ( w x y z -- w x y z w x y z ) } { "rot" "kernel" ( x y z -- y z x ) } { "-rot" "kernel" ( x y z -- z x y ) } { "dupd" "kernel" ( x y -- x x y ) } diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index cabeddbbc1..fca640d114 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -24,6 +24,7 @@ $nl cleave 2cleave 3cleave + 4cleave } "Cleave combinators provide a more readable alternative to repeated applications of the " { $link keep } " combinators. The following example using " { $link keep } ":" { $code diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 44b9147a88..1a76bcc70e 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -64,6 +64,13 @@ SLOT: terminated? : 3cleave>quot ( seq -- quot ) [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ; +! 4cleave +: 4cleave ( w x y z seq -- ) + [ 4keep ] each 4drop ; + +: 4cleave>quot ( seq -- quot ) + [ [ 4keep ] curry ] map concat [ 4drop ] append [ ] like ; + ! spread : shallow-spread>quot ( seq -- quot ) [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index b0b5ff7f7e..f88a8d5b86 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -90,7 +90,7 @@ M: decoder stream-read-unsafe (read-first) [ 0 (store-read) 1 (read-rest) - ] [ 2drop 2drop 0 ] if* + ] [ 4drop 0 ] if* ] if ; inline M: decoder stream-contents* diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 1a536bae85..541be95292 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -11,9 +11,11 @@ HELP: eq? HELP: drop $shuffle ; HELP: 2drop $shuffle ; HELP: 3drop $shuffle ; +HELP: 4drop $shuffle ; HELP: dup $shuffle ; HELP: 2dup $shuffle ; HELP: 3dup $shuffle ; +HELP: 4dup $shuffle ; HELP: nip $shuffle ; HELP: 2nip $shuffle ; HELP: over $shuffle ; diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 5aa690788e..4afbf9a837 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -117,7 +117,7 @@ os windows? [ ! Regression : (loop) ( a b c d -- ) [ pick ] dip swap [ pick ] dip swap - < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive + < [ [ 1 + ] 3dip (loop) ] [ 4drop ] if ; inline recursive : loop ( obj -- ) H{ } values swap [ dup length swap ] dip [ 0 ] 3dip (loop) ; @@ -187,3 +187,6 @@ os windows? [ ! Make sure memory protection faults work [ f 0 alien-unsigned-1 ] [ vm-error? ] must-fail-with [ 1 0 alien-unsigned-1 ] [ vm-error? ] must-fail-with + +{ 1 2 3 1 2 3 } [ 1 2 3 3dup ] unit-test +{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4dup ] unit-test diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 65ecbe8b31..710a899856 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -73,6 +73,9 @@ DEFER: if : 3keep ( ..a x y z quot: ( ..a x y z -- ..b ) -- ..b x y z ) [ 3dup ] dip 3dip ; inline +: 4keep ( ..a w x y z quot: ( ..a w x y z -- ..b ) -- ..b w x y z ) + [ 4dup ] dip 4dip ; inline + ! Cleavers : bi ( x p q -- ) [ keep ] dip call ; inline diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 54fb241582..f5b73f8794 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -99,7 +99,7 @@ TUPLE: float-parse dup ratio? [ + ] [ 2drop f ] if ; inline : @abort ( i number-parse n x -- f ) - 2drop 2drop f ; inline + 4drop f ; inline : @split ( i number-parse n -- n i number-parse n' ) -rot 0 ; inline @@ -295,7 +295,7 @@ PRIVATE> integer) ( valid? accum digit radix -- valid? accum ) - 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline + 2dup < [ swapd * + ] [ 4drop f 0 ] if ; inline : each-digit ( seq radix quot -- n/f ) [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 76b55928ee..201bffe111 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -717,7 +717,7 @@ PRIVATE> : move-backward ( shift from to seq -- ) 2over = [ - 2drop 2drop + 4drop ] [ [ [ 2over + pick ] dip move-unsafe [ 1 + ] dip ] keep move-backward @@ -725,7 +725,7 @@ PRIVATE> : move-forward ( shift from to seq -- ) 2over = [ - 2drop 2drop + 4drop ] [ [ [ pick [ dup dup ] dip + swap ] dip move-unsafe 1 - ] keep move-forward diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index 68ca6451a5..fb3e1c66e0 100644 --- a/extra/irc/client/internals/internals.factor +++ b/extra/irc/client/internals/internals.factor @@ -12,7 +12,7 @@ IN: irc.client.internals [ drop call( host port -- stream ) ] [ drop 15 sleep 1 - do-connect ] recover - ] [ 2drop 2drop f ] if ; + ] [ 4drop f ] if ; : /NICK ( nick -- ) "NICK " prepend irc-print ; : /PONG ( text -- ) "PONG " prepend irc-print ;