parent
824c696e96
commit
84891e2591
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>
|
||||
] [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue