Remove >r/r>

db4
Slava Pestov 2008-12-17 19:17:37 -06:00
parent 92141af349
commit 34792a9f23
46 changed files with 115 additions and 129 deletions

View File

@ -14,7 +14,7 @@ kernel.private math ;
[ ]
[ dup ]
[ swap ]
[ >r r> ]
[ [ ] dip ]
[ fixnum+ ]
[ fixnum+fast ]
[ 3 fixnum+fast ]

View File

@ -249,7 +249,7 @@ SYMBOL: max-uses
] with-scope ;
: random-test ( num-intervals max-uses max-registers max-insns -- )
over >r random-live-intervals r> int-regs associate check-linear-scan ;
over [ random-live-intervals ] dip int-regs associate check-linear-scan ;
[ ] [ 30 2 1 60 random-test ] unit-test
[ ] [ 60 2 2 60 random-test ] unit-test

View File

@ -75,7 +75,7 @@ unit-test
-12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
] unit-test
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
[ -1 2 ] [ 1 2 [ [ 0 swap fixnum- ] dip ] compile-call ] unit-test
[ 12 13 ] [
-12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
@ -88,13 +88,13 @@ unit-test
! Test slow shuffles
[ 3 1 2 3 4 5 6 7 8 9 ] [
1 2 3 4 5 6 7 8 9
[ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ]
[ [ [ [ [ [ [ [ [ [ 3 ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ]
compile-call
] unit-test
[ 2 2 2 2 2 2 2 2 2 2 1 ] [
1 2
[ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-call
[ swap [ dup dup dup dup dup dup dup dup dup ] dip ] compile-call
] unit-test
[ ] [ [ 9 [ ] times ] compile-call ] unit-test
@ -110,7 +110,7 @@ unit-test
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
: try-breaking-dispatch-2 ( -- ? )
1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
[ t ] [
10000000 [ drop try-breaking-dispatch-2 ] all?
@ -131,10 +131,10 @@ unit-test
2dup 1 slot eq? [ 2drop ] [
2dup array-nth tombstone? [
[
[ array-nth ] 2keep >r 1 fixnum+fast r> array-nth
[ array-nth ] 2keep [ 1 fixnum+fast ] dip array-nth
pick 2dup hellish-bug-1 3drop
] 2keep
] unless >r 2 fixnum+fast r> hellish-bug-2
] unless [ 2 fixnum+fast ] dip hellish-bug-2
] if ; inline recursive
: hellish-bug-3 ( hash array -- )
@ -159,9 +159,9 @@ TUPLE: my-tuple ;
[ 5 ] [ "hi" foox ] unit-test
! Making sure we don't needlessly unbox/rebox
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-call ] unit-test
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ [ eq? ] dip ] compile-call ] unit-test
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call >r eq? r> ] unit-test
[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call [ eq? ] dip ] unit-test
[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
@ -188,7 +188,7 @@ TUPLE: my-tuple ;
[ 2 1 ] [
2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-call
[ 2dup fixnum< [ [ die ] dip ] when ] compile-call
] unit-test
! Regression

View File

@ -8,7 +8,7 @@ IN: compiler.tests
[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry [ 9 ] dip call /i ] compile-call ] unit-test
[ -10 -20 ] [ 10 20 -1 [ [ * ] curry bi@ ] compile-call ] unit-test
@ -21,14 +21,14 @@ IN: compiler.tests
[ [ 6 2 + ] ]
[
2 5
[ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry ]
[ [ [ + ] curry ] dip 0 < [ -2 ] [ 6 ] if swap curry ]
compile-call >quotation
] unit-test
[ 8 ]
[
2 5
[ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry call ]
[ [ [ + ] curry ] dip 0 < [ -2 ] [ 6 ] if swap curry call ]
compile-call
] unit-test

View File

@ -248,12 +248,12 @@ USE: binary-search.private
: lift-loop-tail-test-1 ( a quot -- )
over even? [
[ >r 3 - r> call ] keep lift-loop-tail-test-1
[ [ 3 - ] dip call ] keep lift-loop-tail-test-1
] [
over 0 < [
2drop
] [
[ >r 2 - r> call ] keep lift-loop-tail-test-1
[ [ 2 - ] dip call ] keep lift-loop-tail-test-1
] if
] if ; inline
@ -290,7 +290,7 @@ HINTS: recursive-inline-hang-3 array ;
! Wow
: counter-example ( a b c d -- a' b' c' d' )
dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline
: counter-example' ( -- a' b' c' d' )
1 2 3.0 3 counter-example ;
@ -330,7 +330,7 @@ PREDICATE: list < improper-list
[ 0 5 ] [ 0 interval-inference-bug ] unit-test
: aggressive-flush-regression ( a -- b )
f over >r <array> drop r> 1 + ;
f over [ <array> drop ] dip 1 + ;
[ 1.0 aggressive-flush-regression drop ] must-fail

View File

@ -79,7 +79,7 @@ IN: compiler.tree.dead-code.tests
[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
[ [ over [ + ] dip ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
[ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test

View File

@ -80,10 +80,12 @@ M: shuffle-node pprint* effect>> effect>string text ;
[ out-d>> length 1 = ]
} 1&& ;
SYMBOLS: >R R> ;
M: #shuffle node>quot
{
{ [ dup #>r? ] [ drop \ >r , ] }
{ [ dup #r>? ] [ drop \ r> , ] }
{ [ dup #>r? ] [ drop \ >R , ] }
{ [ dup #r>? ] [ drop \ R> , ] }
{
[ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
[

View File

@ -8,13 +8,13 @@ compiler.tree.debugger ;
: test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>quot ;
[ [ >r >fixnum r> >fixnum fixnum+fast ] ]
[ [ [ >fixnum ] dip >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
[ [ +-integer-integer dup >fixnum ] ]
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ]
[ [ [ >fixnum ] dip >fixnum fixnum+fast 4 fixnum*fast ] ]
[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
TUPLE: declared-fixnum { x fixnum } ;

View File

@ -18,7 +18,7 @@ IN: compiler.tree.propagation.tests
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 >r r> ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 [ ] dip ] final-classes ] unit-test
[ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
@ -198,7 +198,7 @@ IN: compiler.tree.propagation.tests
[
{ fixnum byte-array } declare
[ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
>r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
[ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
255 min 0 max
] final-classes
] unit-test

View File

@ -302,9 +302,7 @@ big-endian on
4 ds-reg 0 STW
] f f f \ -rot define-sub-primitive
[ jit->r ] f f f \ >r define-sub-primitive
[ jit-r> ] f f f \ r> define-sub-primitive
[ jit->r ] f f f \ load-local define-sub-primitive
! Comparisons
: jit-compare ( insn -- )

View File

@ -50,8 +50,8 @@ M: x86.64 %prologue ( n -- )
M: stack-params %load-param-reg
drop
>r R11 swap param@ MOV
r> param@ R11 MOV ;
[ R11 swap param@ MOV ] dip
param@ R11 MOV ;
M: stack-params %save-param-reg
drop

View File

@ -319,9 +319,7 @@ big-endian off
ds-reg [] temp1 MOV
] f f f \ -rot define-sub-primitive
[ jit->r ] f f f \ >r define-sub-primitive
[ jit-r> ] f f f \ r> define-sub-primitive
[ jit->r ] f f f \ load-local define-sub-primitive
! Comparisons
: jit-compare ( insn -- )

View File

@ -42,7 +42,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
sqlite3_bind_parameter_index ;
: parameter-index ( handle name text -- handle name text )
>r dupd sqlite-bind-parameter-index r> ;
[ dupd sqlite-bind-parameter-index ] dip ;
: sqlite-bind-text ( handle index text -- )
utf8 encode dup length SQLITE_TRANSIENT

View File

@ -20,7 +20,7 @@ PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
CONSULT: baz goodbye these>> ;
M: hello foo this>> ;
M: hello bar hello-test ;
M: hello whoa >r this>> r> + ;
M: hello whoa [ this>> ] dip + ;
GENERIC: bing ( c -- d )
PROTOCOL: bee bing ;

View File

@ -20,7 +20,7 @@ HELP: '[
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: >r/r>-in-fry-error
{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ;
{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to retain stack manipulation primitives." } ;
ARTICLE: "fry.examples" "Examples of fried quotations"
"The easiest way to understand fried quotations is to look at some examples."

View File

@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
[ "USING: fry kernel ; f '[ load-local _ ]" eval ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [

View File

@ -25,7 +25,7 @@ M: >r/r>-in-fry-error summary
"Explicit retain stack manipulation is not permitted in fried quotations" ;
: check-fry ( quot -- quot )
dup { >r r> load-locals get-local drop-locals } intersect
dup { load-local load-locals get-local drop-locals } intersect
empty? [ >r/r>-in-fry-error ] unless ;
PREDICATE: fry-specifier < word { _ @ } memq? ;

View File

@ -32,7 +32,7 @@ IN: furnace.chloe-tags
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( href rest query value-name -- url )
dup [ >r 3drop r> value ] [
dup [ [ 3drop ] dip value ] [
drop
<url>
swap parse-query-attr >>query

View File

@ -20,7 +20,7 @@ ARTICLE: "grouping" "Groups and clumps"
{ $unchecked-example "dup n groups concat sequence= ." "t" }
}
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
{ $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
{ $unchecked-example "dup n clumps unclip-last [ [ first ] map ] dip append sequence= ." "t" }
}
} ;

View File

@ -61,7 +61,7 @@ IN: heaps.tests
random-alist
<min-heap> [ heap-push-all ] keep
dup data>> clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
] keep 3 /i [ 2dup [ delete-random ] dip heap-delete ] times
data>>
[ [ key>> ] map ] bi@
[ natural-sort ] bi@ ;

View File

@ -5,7 +5,7 @@ IN: lcs
<PRIVATE
: levenshtein-step ( insert delete change same? -- next )
0 1 ? + >r [ 1+ ] bi@ r> min min ;
0 1 ? + [ [ 1+ ] bi@ ] dip min min ;
: lcs-step ( insert delete change same? -- next )
1 -1./0. ? + max max ; ! -1./0. is -inf (float)

View File

@ -30,7 +30,10 @@ M: local-writer localize
read-local-quot [ set-local-value ] append ;
M: def localize
local>> [ prefix ] [ local-reader? [ 1array >r ] [ >r ] ? ] bi ;
local>>
[ prefix ]
[ local-reader? [ 1array load-local ] [ load-local ] ? ]
bi ;
M: object localize 1quotation ;

View File

@ -101,7 +101,7 @@ M: hashtable rewrite-sugar* rewrite-element ;
M: wrapper rewrite-sugar* rewrite-element ;
M: word rewrite-sugar*
dup { >r r> load-locals get-local drop-locals } memq?
dup { load-locals get-local drop-locals } memq?
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
M: object rewrite-sugar* , ;

View File

@ -47,7 +47,7 @@ MACRO: match-cond ( assoc -- )
[ "Fall-through in match-cond" throw ]
[
first2
>r [ dupd match ] curry r>
[ [ dupd match ] curry ] dip
[ bind ] curry rot
[ ?if ] 2curry append
] reduce ;

View File

@ -97,7 +97,7 @@ IN: math.functions.tests
: verify-gcd ( a b -- ? )
2dup gcd
>r rot * swap rem r> = ;
[ rot * swap rem ] dip = ;
[ t ] [ 123 124 verify-gcd ] unit-test
[ t ] [ 50 120 verify-gcd ] unit-test

View File

@ -255,8 +255,7 @@ IN: math.intervals.tests
0 pick interval-contains? over first \ recip eq? and [
2drop t
] [
[ >r random-element ! dup .
r> first execute ] 2keep
[ [ random-element ] dip first execute ] 2keep
second execute interval-contains?
] if ;
@ -287,8 +286,7 @@ IN: math.intervals.tests
0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t
] [
[ >r [ random-element ] bi@ ! 2dup . .
r> first execute ] 3keep
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
second execute interval-contains?
] if ;
@ -304,7 +302,7 @@ IN: math.intervals.tests
: comparison-test ( -- ? )
random-interval random-interval random-comparison
[ >r [ random-element ] bi@ r> first execute ] 3keep
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test

View File

@ -115,7 +115,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
PREDICATE: gl-program < integer (gl-program?) ;
: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
>r <vertex-shader> check-gl-shader
r> <fragment-shader> check-gl-shader
[ <vertex-shader> check-gl-shader ]
[ <fragment-shader> check-gl-shader ] bi*
2array <gl-program> check-gl-program ;

View File

@ -14,7 +14,7 @@ C: <cons> cons
: each ( list quot: ( elt -- ) -- )
over
[ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ]
[ [ [ car>> ] dip call ] [ [ cdr>> ] dip ] 2bi each ]
[ 2drop ] if ; inline recursive
: reduce ( list start quot -- end )
@ -27,7 +27,7 @@ C: <cons> cons
0 [ drop 1+ ] reduce ;
: cut ( list index -- back front-reversed )
f swap [ >r [ cdr>> ] [ car>> ] bi r> <cons> ] times ;
f swap [ [ [ cdr>> ] [ car>> ] bi ] dip <cons> ] times ;
: split-reverse ( list -- back-reversed front )
dup length 2/ cut [ reverse ] bi@ ;
@ -41,7 +41,7 @@ TUPLE: deque { front read-only } { back read-only } ;
[ back>> ] [ front>> ] bi deque boa ;
: flipped ( deque quot -- newdeque )
>r flip r> call flip ;
[ flip ] dip call flip ;
PRIVATE>
: deque-empty? ( deque -- ? )

View File

@ -32,7 +32,7 @@ PRIVATE>
[ >branch< swap remove-left -rot [ <branch> ] 2dip rot ] if ;
: both-with? ( obj a b quot -- ? )
swap >r with r> swap both? ; inline
swap [ with ] dip swap both? ; inline
GENERIC: sift-down ( value prio left right -- heap )

View File

@ -70,9 +70,10 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
} cond ;
: serialize-shared ( obj quot -- )
>r dup object-id
[ CHAR: o write1 serialize-cell drop ]
r> if* ; inline
[
dup object-id
[ CHAR: o write1 serialize-cell drop ]
] dip if* ; inline
M: f (serialize) ( obj -- )
drop CHAR: n write1 ;
@ -256,7 +257,7 @@ SYMBOL: deserialized
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
>r dup length r> [ set-array-nth ] curry 2each ;
[ dup length ] dip [ set-array-nth ] curry 2each ;
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading

View File

@ -28,22 +28,10 @@ $nl
} ;
HELP: too-many->r
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
{ $examples
{ $code
": too-many->r-example ( a b -- )"
" >r 3 + >r ;"
}
} ;
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." } ;
HELP: too-many-r>
{ $error-description "Thrown if inference notices a quotation popping elements from the return stack it did not place there." }
{ $examples
{ $code
": too-many-r>-example ( a b -- )"
" r> 3 + >r ;"
}
} ;
{ $error-description "Thrown if inference notices a quotation popping elements from the return stack it did not place there." } ;
HELP: missing-effect
{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." }

View File

@ -174,8 +174,6 @@ M: object infer-call*
: infer-special ( word -- )
{
{ \ >r [ 1 infer->r ] }
{ \ r> [ 1 infer-r> ] }
{ \ declare [ infer-declare ] }
{ \ call [ infer-call ] }
{ \ (call) [ infer-call ] }
@ -213,7 +211,7 @@ M: object infer-call*
"local-word-def" word-prop infer-quot-here ;
{
>r r> declare call (call) slip 2slip 3slip dip 2dip 3dip
declare call (call) slip 2slip 3slip dip 2dip 3dip
curry compose execute (execute) if dispatch <tuple-boa>
(throw) load-locals get-local drop-locals do-primitive
alien-invoke alien-indirect alien-callback

View File

@ -218,7 +218,7 @@ DEFER: do-crap*
MATH: xyz ( a b -- c )
M: fixnum xyz 2array ;
M: float xyz
[ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
[ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ;
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
@ -480,7 +480,7 @@ DEFER: an-inline-word
dup [ normal-word-2 ] when ;
: an-inline-word ( obj quot -- )
>r normal-word r> call ; inline
[ normal-word ] dip call ; inline
{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
@ -503,7 +503,7 @@ ERROR: custom-error ;
] unit-test
[ T{ effect f 1 1 t } ] [
[ dup >r 3 throw r> ] infer
[ dup [ 3 throw ] dip ] infer
] unit-test
! This was a false trigger of the undecidable quotation
@ -511,7 +511,7 @@ ERROR: custom-error ;
{ 2 1 } [ find-last-sep ] must-infer-as
! Regression
: missing->r-check >r ;
: missing->r-check 1 load-locals ;
[ [ missing->r-check ] infer ] must-fail
@ -548,7 +548,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
[ [ inference-invalidation-d ] infer ] must-fail
: bad-recursion-3 ( -- ) dup [ >r bad-recursion-3 r> ] when ; inline
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline
[ [ bad-recursion-3 ] infer ] must-fail
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline
@ -572,7 +572,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
DEFER: eee'
: ddd' ( ? -- ) [ f eee' ] when ; inline recursive
: eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
: eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
[ [ eee' ] infer ] [ inference-error? ] must-fail-with

View File

@ -16,7 +16,7 @@ M: tuple-array nth
[ seq>> nth ] [ class>> ] bi prefix >tuple ;
M: tuple-array set-nth ( elt n seq -- )
>r >r tuple>array 1 tail r> r> seq>> set-nth ;
[ tuple>array 1 tail ] 2dip seq>> set-nth ;
M: tuple-array new-sequence
class>> <tuple-array> ;

View File

@ -51,7 +51,7 @@ IN: validators
] if ;
: v-regexp ( str what regexp -- str )
>r over r> matches?
[ over ] dip matches?
[ drop ] [ "invalid " prepend throw ] if ;
: v-email ( str -- str )

View File

@ -36,26 +36,30 @@ SYMBOL: +listener-dragdrop-wrapper+
{
{ "IDropTarget" {
[ ! DragEnter
>r 2drop
filenames-from-data-object
length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if
dup 0 r> set-ulong-nth
[
2drop
filenames-from-data-object
length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if
dup 0
] dip set-ulong-nth
>>last-drop-effect drop
S_OK
] [ ! DragOver
>r 2drop last-drop-effect>> 0 r> set-ulong-nth
[ 2drop last-drop-effect>> 0 ] dip set-ulong-nth
S_OK
] [ ! DragLeave
drop S_OK
] [ ! Drop
>r 2drop nip
filenames-from-data-object
dup length 1 = [
first unparse [ "USE: parser " % % " run-file" % ] "" make
eval-listener
DROPEFFECT_COPY
] [ 2drop DROPEFFECT_NONE ] if
0 r> set-ulong-nth
[
2drop nip
filenames-from-data-object
dup length 1 = [
first unparse [ "USE: parser " % % " run-file" % ] "" make
eval-listener
DROPEFFECT_COPY
] [ 2drop DROPEFFECT_NONE ] if
0
] dip set-ulong-nth
S_OK
]
} }

View File

@ -987,8 +987,6 @@ FUNCTION: DWORD GetFileType ( HANDLE hFile ) ;
FUNCTION: DWORD GetFullPathNameW ( LPCTSTR lpFileName, DWORD nBufferLength, LPTSTR lpBuffer, LPTSTR* lpFilePart ) ;
ALIAS: GetFullPathName GetFullPathNameW
! clear "license.txt" 32768 "char[32768]" <c-object> f over >r GetFullPathName r> swap 2 * head >string .
! FUNCTION: GetGeoInfoA
! FUNCTION: GetGeoInfoW
! FUNCTION: GetHandleContext

View File

@ -10,7 +10,7 @@ USING: kernel hashtables xml-rpc xml calendar sequences
{ "divide" [ / ] } } ;
: apply-function ( name args -- {number} )
>r functions hash r> first2 rot call 1array ;
[ functions hash ] dip first2 rot call 1array ;
: problem>solution ( xml-doc -- xml-doc )
receive-rpc dup rpc-method-name swap rpc-method-params

View File

@ -55,7 +55,7 @@ M: base64 item>xml
"params" build-tag* ;
: method-call ( name seq -- xml )
params >r "methodName" build-tag r>
params [ "methodName" build-tag ] dip
2array "methodCall" build-tag* build-xml ;
: return-params ( seq -- xml )
@ -117,7 +117,7 @@ TAG: boolean xml>item
: unstruct-member ( tag -- )
children-tags first2
first-child-tag xml>item
>r children>string r> swap set ;
[ children>string ] dip swap set ;
TAG: struct xml>item
[
@ -158,10 +158,10 @@ TAG: array xml>item
: post-rpc ( rpc url -- rpc )
! This needs to do something in the event of an error
>r send-rpc r> http-post nip string>xml receive-rpc ;
[ send-rpc ] dip http-post nip string>xml receive-rpc ;
: invoke-method ( params method url -- )
>r swap <rpc-method> r> post-rpc ;
[ swap <rpc-method> ] dip post-rpc ;
: put-http-response ( string -- )
"HTTP/1.1 200 OK\nConnection: close\nContent-Length: " write

View File

@ -8,12 +8,13 @@ TUPLE: mode file file-name-glob first-line-glob ;
<TAGS: parse-mode-tag ( modes tag -- )
TAG: MODE
"NAME" over at >r
mode new {
{ "FILE" f (>>file) }
{ "FILE_NAME_GLOB" f (>>file-name-glob) }
{ "FIRST_LINE_GLOB" f (>>first-line-glob) }
} init-from-tag r>
"NAME" over at [
mode new {
{ "FILE" f (>>file) }
{ "FILE_NAME_GLOB" f (>>file-name-glob) }
{ "FIRST_LINE_GLOB" f (>>first-line-glob) }
} init-from-tag
] dip
rot set-at ;
TAGS>
@ -56,7 +57,7 @@ SYMBOL: rule-sets
[ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ;
: each-rule ( rule-set quot -- )
>r rules>> values concat r> each ; inline
[ rules>> values concat ] dip each ; inline
: resolve-delegates ( ruleset -- )
[ resolve-delegate ] each-rule ;
@ -65,8 +66,7 @@ SYMBOL: rule-sets
over [ dupd update ] [ nip clone ] if ;
: import-keywords ( parent child -- )
over >r [ keywords>> ] bi@ ?update
r> (>>keywords) ;
over [ [ keywords>> ] bi@ ?update ] dip (>>keywords) ;
: import-rules ( parent child -- )
swap [ add-rule ] curry each-rule ;
@ -115,5 +115,5 @@ ERROR: mutually-recursive-rulesets ruleset ;
: find-mode ( file-name first-line -- mode )
modes
[ nip >r 2dup r> suitable-mode? ] assoc-find
2drop >r 2drop r> [ "text" ] unless* ;
[ nip [ 2dup ] dip suitable-mode? ] assoc-find
2drop [ 2drop ] dip [ "text" ] unless* ;

View File

@ -101,4 +101,4 @@ TAGS>
: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
: parse-keyword-tag ( tag keyword-map -- )
>r dup main>> string>token swap children>string r> set-at ;
[ dup main>> string>token swap children>string ] dip set-at ;

View File

@ -69,7 +69,7 @@ M: string-matcher text-matches?
] keep string>> length and ;
M: regexp text-matches?
>r >string r> match-head ;
[ >string ] dip match-head ;
: rule-start-matches? ( rule -- match-count/f )
dup start>> tuck swap can-match-here? [
@ -97,7 +97,7 @@ DEFER: get-rules
f swap rules>> at ?push-all ;
: get-char-rules ( vector/f char ruleset -- vector/f )
>r ch>upper r> rules>> at ?push-all ;
[ ch>upper ] dip rules>> at ?push-all ;
: get-rules ( char ruleset -- seq )
f -rot [ get-char-rules ] keep get-always-rules ;

View File

@ -20,14 +20,14 @@ SYMBOLS: line last-offset position context
current-rule-set keywords>> ;
: token, ( from to id -- )
2over = [ 3drop ] [ >r line get subseq r> <token> , ] if ;
2over = [ 3drop ] [ [ line get subseq ] dip <token> , ] if ;
: prev-token, ( id -- )
>r last-offset get position get r> token,
[ last-offset get position get ] dip token,
position get last-offset set ;
: next-token, ( len id -- )
>r position get 2dup + r> token,
[ position get 2dup + ] dip token,
position get + dup 1- position set last-offset set ;
: push-context ( rules -- )

View File

@ -41,7 +41,7 @@ MEMO: standard-rule-set ( id -- ruleset )
: ?push-all ( seq1 seq2 -- seq1+seq2 )
[
over [ >r V{ } like r> over push-all ] [ nip ] if
over [ [ V{ } like ] dip over push-all ] [ nip ] if
] when* ;
: rule-set-no-word-sep* ( ruleset -- str )
@ -107,8 +107,7 @@ M: regexp text-hash-char drop f ;
text-hash-char [ suffix ] when* ;
: add-rule ( rule ruleset -- )
>r dup rule-chars* >upper swap
r> rules>> inverted-index ;
[ dup rule-chars* >upper swap ] dip rules>> inverted-index ;
: add-escape-rule ( string ruleset -- )
over [

View File

@ -53,5 +53,5 @@ SYMBOL: tag-handler-word
: TAGS>
tag-handler-word get
tag-handlers get >alist [ >r dup main>> r> case ] curry
tag-handlers get >alist [ [ dup main>> ] dip case ] curry
define ; parsing

View File

@ -380,12 +380,11 @@ tuple
{ "over" "kernel" }
{ "pick" "kernel" }
{ "swap" "kernel" }
{ ">r" "kernel" }
{ "r>" "kernel" }
{ "eq?" "kernel" }
{ "tag" "kernel.private" }
{ "slot" "slots.private" }
{ "get-local" "locals.backend" }
{ "load-local" "locals.backend" }
{ "drop-locals" "locals.backend" }
} [ make-sub-primitive ] assoc-each