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

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

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

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

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

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

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 ;

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*

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 ;

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

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

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

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

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 ;