[ ]
[ dup ]
[ swap ]
- [ >r r> ]
+ [ [ ] dip ]
[ fixnum+ ]
[ fixnum+fast ]
[ 3 fixnum+fast ]
] 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
-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
! 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
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?
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 -- )
[ 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
[ 2 1 ] [
2 1
- [ 2dup fixnum< [ >r die r> ] when ] compile-call
+ [ 2dup fixnum< [ [ die ] dip ] when ] compile-call
] unit-test
! Regression
[ 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
[ [ 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
: 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
! 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 ;
[ 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
[ [ 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
[ 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 ]
[
: 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 } ;
[ 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
[
{ 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
4 ds-reg 0 STW\r
] f f f \ -rot define-sub-primitive\r
\r
-[ jit->r ] f f f \ >r define-sub-primitive\r
-\r
-[ jit-r> ] f f f \ r> define-sub-primitive\r
+[ jit->r ] f f f \ load-local define-sub-primitive\r
\r
! Comparisons\r
: jit-compare ( insn -- )\r
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
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 -- )
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
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 ;
{ $examples "See " { $link "fry.examples" } "." } ;\r
\r
HELP: >r/r>-in-fry-error\r
-{ $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." } ;\r
+{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to retain stack manipulation primitives." } ;\r
\r
ARTICLE: "fry.examples" "Examples of fried quotations"\r
"The easiest way to understand fried quotations is to look at some examples."\r
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 } } ] [
"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? ;
[ [ "/" ?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
{ $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" }
}
} ;
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@ ;
\r
<PRIVATE\r
: levenshtein-step ( insert delete change same? -- next )\r
- 0 1 ? + >r [ 1+ ] bi@ r> min min ;\r
+ 0 1 ? + [ [ 1+ ] bi@ ] dip min min ;\r
\r
: lcs-step ( insert delete change same? -- next )\r
1 -1./0. ? + max max ; ! -1./0. is -inf (float)\r
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 ;
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* , ;
[ "Fall-through in match-cond" throw ]
[
first2
- >r [ dupd match ] curry r>
+ [ [ dupd match ] curry ] dip
[ bind ] curry rot
[ ?if ] 2curry append
] reduce ;
: 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
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 ;
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 ;
: 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
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 ;
: 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 )
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@ ;
[ back>> ] [ front>> ] bi deque boa ;
: flipped ( deque quot -- newdeque )
- >r flip r> call flip ;
+ [ flip ] dip call flip ;
PRIVATE>
: deque-empty? ( deque -- ? )
[ >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 )
} 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 ;
[ ] 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
} ;
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." }
: infer-special ( word -- )
{
- { \ >r [ 1 infer->r ] }
- { \ r> [ 1 infer-r> ] }
{ \ declare [ infer-declare ] }
{ \ call [ infer-call ] }
{ \ (call) [ 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
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
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
] 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
{ 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
[ [ 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
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
[ 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> ;
] if ;
: v-regexp ( str what regexp -- str )
- >r over r> matches?
+ [ over ] dip matches?
[ drop ] [ "invalid " prepend throw ] if ;
: v-email ( str -- str )
{\r
{ "IDropTarget" {\r
[ ! DragEnter\r
- >r 2drop\r
- filenames-from-data-object\r
- length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if\r
- dup 0 r> set-ulong-nth\r
+ [\r
+ 2drop\r
+ filenames-from-data-object\r
+ length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if\r
+ dup 0\r
+ ] dip set-ulong-nth\r
>>last-drop-effect drop\r
S_OK\r
] [ ! DragOver\r
- >r 2drop last-drop-effect>> 0 r> set-ulong-nth\r
+ [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth\r
S_OK\r
] [ ! DragLeave\r
drop S_OK\r
] [ ! Drop\r
- >r 2drop nip\r
- filenames-from-data-object\r
- dup length 1 = [\r
- first unparse [ "USE: parser " % % " run-file" % ] "" make\r
- eval-listener\r
- DROPEFFECT_COPY\r
- ] [ 2drop DROPEFFECT_NONE ] if\r
- 0 r> set-ulong-nth\r
+ [\r
+ 2drop nip\r
+ filenames-from-data-object\r
+ dup length 1 = [\r
+ first unparse [ "USE: parser " % % " run-file" % ] "" make\r
+ eval-listener\r
+ DROPEFFECT_COPY\r
+ ] [ 2drop DROPEFFECT_NONE ] if\r
+ 0\r
+ ] dip set-ulong-nth\r
S_OK\r
]\r
} }\r
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
{ "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
"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 )
: 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
[
: 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
<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>
[ 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 ;
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 ;
: 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* ;
: 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 ;
] 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? [
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 ;
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 -- )
: ?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 )
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 [
: 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
{ "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
projects / factor.git / commitdiff