kernel: Add 4dup, 4drop, and 4cleave.

diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 2e33a4d93066d1dcfb519298949c27501b6190c7..bf8d3465fd1a5010e9cdcf7638b2faacf93b4908 100644 (file)
--- 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 2659ed3280ddf9e7549a1e034cb3634b41237bfa..92478812beb565699cb06804d68aeb6d83b9325a 100644 (file)
--- 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 34fee639e100b1d9916b562591ec8230becf3553..fba664d629c85fc4c99232998596b32056d55b0e 100644 (file)
--- 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 111b7d9631effb19259c02a6c8bbed9b7a57d780..127ef7f6f0489666022435d19e951b06e7ed4e68 100755 (executable)
--- 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 cabeddbbc1e71f8be99f5803d602812621d65f28..fca640d114cd324a7bdb9aa5a018a03cad8bd6e7 100644 (file)
--- 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 44b9147a88d44b3aa68e2a34418e8241bb29f32d..1a76bcc70ece7b34d8640394942bb7bd9cc3d279 100644 (file)
--- 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 b0b5ff7f7e4d94306d56b345226d3ea6b7c71b57..f88a8d5b860fcf8ccea90110c16cef16fe5375aa 100644 (file)
--- 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 1a536bae85e842e99b6cdaad052e6e84013963aa..541be9529208eced0e51428ebba1100831ac121d 100644 (file)
--- 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 5aa690788eb229d7431562eaafb4d3eaa342a35e..4afbf9a837e37b2bd698a256f0ed6206d692d38b 100644 (file)
--- 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 <alien> 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 65ecbe8b312612025830e1d7f2b78d05a3a795fe..710a89985641e53137548783ed519fda968af3e1 100644 (file)
--- 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 54fb24158224f98e62bb419a07cee59c7a4a22bd..f5b73f8794d012371349572561174017136b3a1c 100644 (file)
--- 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>
 <PRIVATE
 
 : (digits>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 76b55928ee8f4baf6f3f17c086daf4fc61c3d406..201bffe111ced8b1e968e907e2f634aafe59aefc 100644 (file)
--- 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 68ca6451a571751951ef953327bd577dc1efce5b..fb3e1c66e07a81d196bed806ed8513d4be481485 100644 (file)
--- 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 ;