pick pick -> 2over

minor cleanups
db4
Doug Coleman 2008-01-11 12:02:44 -10:00
parent 824c696e96
commit 84891e2591
14 changed files with 30 additions and 28 deletions

View File

@ -93,4 +93,4 @@ TUPLE: alien-invoke library function return parameters ;
TUPLE: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
pick pick \ alien-invoke-error construct-boa throw ;
2over \ alien-invoke-error construct-boa throw ;

View File

@ -43,7 +43,7 @@ M: assoc assoc-find
inline
: assoc-push-if ( key value quot accum -- )
>r pick pick 2slip r> roll
>r 2over 2slip r> roll
[ >r 2array r> push ] [ 3drop ] if ; inline
: assoc-pusher ( quot -- quot' accum )
@ -122,7 +122,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
: cache ( key assoc quot -- value )
pick pick at [
2over at [
>r 3drop r>
] [
pick rot >r >r call dup r> r> set-at

View File

@ -232,14 +232,14 @@ UNION: operand register indirect ;
: rex-prefix ( reg r/m rex.w -- )
#! Compile an AMD64 REX prefix.
pick pick rex.w? BIN: 01001000 BIN: 01000000 ?
2over rex.w? BIN: 01001000 BIN: 01000000 ?
swap rex.r swap rex.b
dup BIN: 01000000 = [ drop ] [ , ] if ;
: 16-prefix ( reg r/m -- )
[ register-16? ] either? [ HEX: 66 , ] when ;
: prefix ( reg r/m rex.w -- ) pick pick 16-prefix rex-prefix ;
: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
: prefix-1 ( reg rex.w -- ) f swap prefix ;
@ -290,7 +290,7 @@ UNION: operand register indirect ;
: 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand.
pick pick 16-prefix
2over 16-prefix
direction-bit
operand-size-bit
(2-operand) ;

View File

@ -50,7 +50,7 @@ M: object xyz ;
] unit-test
: (fx-repeat) ( i n quot -- )
pick pick fixnum>= [
2over fixnum>= [
3drop
] [
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
@ -66,7 +66,7 @@ M: object xyz ;
] unit-test
: (i-repeat) ( i n quot -- )
pick pick dup xyz drop >= [
2over dup xyz drop >= [
3drop
] [
[ swap >r call 1+ r> ] keep (i-repeat)
@ -214,7 +214,7 @@ GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ;
: (annotate-entry-test-2) ( from to quot -- )
pick pick >= [
2over >= [
3drop
] [
[ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)

View File

@ -19,6 +19,7 @@ $nl
{ $subsection 3dup }
{ $subsection dupd }
{ $subsection over }
{ $subsection 2over }
{ $subsection pick }
{ $subsection tuck }
"Permuting stack elements:"
@ -160,6 +161,7 @@ HELP: nip ( x y -- y ) $shuffle ;
HELP: 2nip ( x y z -- z ) $shuffle ;
HELP: tuck ( x y -- y x y ) $shuffle ;
HELP: over ( x y -- x y x ) $shuffle ;
HELP: 2over $shuffle ;
HELP: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $shuffle ;
HELP: spin $shuffle ;

View File

@ -12,6 +12,8 @@ IN: kernel
: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
: 2over ( x y z -- x y z x y ) pick pick ; inline
: clear ( -- ) { } set-datastack ;
! Combinators
@ -55,7 +57,7 @@ DEFER: if
: keep ( x quot -- x ) over slip ; inline
: 2keep ( x y quot -- x y ) pick pick 2slip ; inline
: 2keep ( x y quot -- x y ) 2over 2slip ; inline
: 3keep ( x y z quot -- x y z )
>r 3dup r> -roll 3slip ; inline

View File

@ -66,9 +66,9 @@ C: <interval> interval
[ endpoint-max ] reduce <interval> ;
: (interval-op) ( p1 p2 quot -- p3 )
pick pick >r >r
>r >r first r> first r> call
r> second r> second and 2array ; inline
2over >r >r
>r [ first ] 2apply r> call
r> r> [ second ] 2apply and 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
pick interval-from pick interval-from pick (interval-op) >r

View File

@ -119,7 +119,7 @@ M: float fp-nan?
: iterate-prep 0 -rot ; inline
: if-iterate? >r >r pick pick < r> r> if ; inline
: if-iterate? >r >r 2over < r> r> if ; inline
: iterate-step ( i n quot -- i n quot )
#! Apply quot to i, keep i and quot, hide n.

View File

@ -225,7 +225,7 @@ M: #dispatch optimize-node*
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
{ [ pick pick swap node-history member? ] [ 3drop t ] }
{ [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;

View File

@ -194,7 +194,7 @@ TUPLE: slice-error reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when
dup length pick < [ "end > sequence" slice-error ] when
pick pick > [ "start > end" slice-error ] when ; inline
2over > [ "start > end" slice-error ] when ; inline
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
@ -445,7 +445,7 @@ PRIVATE>
[ = not ] with subset ;
: cache-nth ( i seq quot -- elt )
pick pick ?nth dup [
2over ?nth dup [
>r 3drop r>
] [
drop swap >r over >r call dup r> r> set-nth
@ -465,7 +465,7 @@ M: sequence <=>
[ mismatch not ] [ 2drop f ] if ; inline
: move ( to from seq -- )
pick pick number=
2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
: (delete) ( elt store scan seq -- elt store scan seq )
@ -499,15 +499,15 @@ M: sequence <=>
: pop* ( seq -- ) dup length 1- swap set-length ;
: move-backward ( shift from to seq -- )
pick pick number= [
2over number= [
2drop 2drop
] [
[ >r pick pick + pick r> move >r 1+ r> ] keep
[ >r 2over + pick r> move >r 1+ r> ] keep
move-backward
] if ;
: move-forward ( shift from to seq -- )
pick pick number= [
2over number= [
2drop 2drop
] [
[ >r pick >r dup dup r> + swap r> move 1- ] keep

View File

@ -89,8 +89,8 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ;
: simple-slot ( class name # -- spec )
>r object bootstrap-word over r> f f <slot-spec>
pick pick simple-reader-word over set-slot-spec-reader
rot rot simple-writer-word over set-slot-spec-writer ;
2over simple-reader-word over set-slot-spec-reader
-rot simple-writer-word over set-slot-spec-writer ;
: simple-slots ( class slots base -- specs )
over length [ + ] with map

View File

@ -113,7 +113,7 @@ M: input-port stream-read
] if ;
: read-until-loop ( seps port sbuf -- separator/f )
pick pick read-until-step over [
2over read-until-step over [
>r over push-all r> dup [
>r 3drop r>
] [

View File

@ -21,8 +21,6 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
: 2over ( a b c -- a b c a b ) pick pick ; inline
: nipd ( a b c -- b c ) rot drop ; inline
: 3nip ( a b c d -- d ) 3 nnip ; inline

View File

@ -105,7 +105,7 @@ C: <pane-stream> pane-stream
: pane-format ( style pane seq -- )
[ dup pane-nl ]
[ pick pick pane-current stream-format ]
[ 2over pane-current stream-format ]
interleave 2drop ;
GENERIC: write-gadget ( gadget stream -- )
@ -327,7 +327,7 @@ M: paragraph stream-format
] [
rot " " split
[ 2dup gadget-bl ]
[ pick pick gadget-format ] interleave
[ 2over gadget-format ] interleave
2drop
] if ;