2over fixnum>= [
3drop
] [
- [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
+ [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
] if ; inline recursive
: fx-repeat ( n quot -- )
2over dup xyz drop >= [
3drop
] [
- [ swap >r call 1+ r> ] keep (i-repeat)
+ [ swap [ call 1+ ] dip ] keep (i-repeat)
] if ; inline recursive
-: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
+: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
[ t ] [
[ [ dup xyz drop ] i-repeat ] \ xyz inlined?
2dup >= [
2drop
] [
- >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
+ [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
] unit-test
[ ] [
- [ [ >r "A" throw r> ] [ "B" throw ] if ]
+ [ [ [ "A" throw ] dip ] [ "B" throw ] if ]
cleaned-up-tree drop
] unit-test
: buffalo-wings ( i seq -- )
2dup < [
2dup chicken-fingers
- >r 1+ r> buffalo-wings
+ [ 1+ ] dip buffalo-wings
] [
2drop
] if ; inline recursive
: ribs ( i seq -- )
2dup < [
steak
- >r 1+ r> ribs
+ [ 1+ ] dip ribs
] [
2drop
] if ; inline recursive
remove-dead-code
"no-check" get [ dup check-nodes ] unless nodes>quot ;
-[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
+[ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test
-[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
+[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb
-: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
-: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
+: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
+: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test
] unit-test
: recursive-test-4 ( i n -- )
- 2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive
+ 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
-M: int-regs %save-param-reg drop >r param@ r> MOV ;
+M: int-regs %save-param-reg drop [ param@ ] dip MOV ;
M: int-regs %load-param-reg drop swap param@ MOV ;
GENERIC: MOVSS/D ( dst src reg-class -- )
M: single-float-regs MOVSS/D drop MOVSS ;
M: double-float-regs MOVSS/D drop MOVSD ;
-M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ;
-M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ;
+M: float-regs %save-param-reg [ param@ ] 2dip MOVSS/D ;
+M: float-regs %load-param-reg [ swap param@ ] dip MOVSS/D ;
GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( n reg-class -- )
{ $notes "This error usually indicates a run-away recursion, however if you legitimately need a data stack larger than the default, see " { $link "runtime-cli-args" } "." } ;
HELP: retainstack-underflow.
-{ $error-description "Thrown by the Factor VM if " { $link r> } " is called while the retain stack is empty." }
+{ $error-description "Thrown by the Factor VM if an attempt is made to access the retain stack in an invalid manner. This bug should never come up in practice and indicates a bug in Factor." }
{ $notes "You can use the stack effect tool to statically check stack effects of quotations. See " { $link "inference" } "." } ;
HELP: retainstack-overflow.
-{ $error-description "Thrown by the Factor VM if " { $link >r } " is called when the retain stack is full." }
+{ $error-description "Thrown by the Factor VM if " { $link dip } " is called when the retain stack is full." }
{ $notes "This error usually indicates a run-away recursion, however if you legitimately need a retain stack larger than the default, see " { $link "runtime-cli-args" } "." } ;
HELP: memory-error.
[
snippet-style get [
last-element off
- >r ($code-style) r> with-nesting
+ [ ($code-style) ] dip with-nesting
] with-style
] ($block) ; inline
\ ; parse-until >array swap set-word-help ; parsing
: ARTICLE:
- location >r
- \ ; parse-until >array [ first2 ] keep 2 tail <article>
- over add-article >link r> remember-definition ; parsing
+ location [
+ \ ; parse-until >array [ first2 ] keep 2 tail <article>
+ over add-article >link
+ ] dip remember-definition ; parsing
: ABOUT:
in get vocab
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
- >r >r elements-vocab create r> r> define-declared ;
+ [ elements-vocab create ] 2dip define-declared ;
: <foo> ( str -- <str> ) "<" swap ">" 3append ;
"font-family: " % % "; " % ;
: apply-style ( style key quot -- style gadget )
- >r over at r> when* ; inline
+ [ over at ] dip when* ; inline
: make-css ( style quot -- str )
"" make nip ; inline
stream>> stream-flush ;
M: html-stream stream-write1
- >r 1string r> stream-write ;
+ [ 1string ] dip stream-write ;
M: html-stream stream-write
- not-a-div >r escape-string r> stream>> stream-write ;
+ not-a-div [ escape-string ] dip stream>> stream-write ;
M: html-stream stream-format
- >r html over at [ >r escape-string r> ] unless r>
+ [ html over at [ [ escape-string ] dip ] unless ] dip
format-html-span ;
M: html-stream stream-nl
first2 between? ;\r
\r
: all-intervals ( sequence -- intervals )\r
- [ >r dup number? [ dup 2array ] when r> ] { } assoc-map-as ;\r
+ [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;\r
\r
: disjoint? ( node1 node2 -- ? )\r
[ second ] [ first ] bi* < ;\r
\r
: histogram. ( assoc quot -- )\r
standard-table-style [\r
- >r >alist sort-values <reversed> r> [\r
- [ >r swap r> with-cell pprint-cell ] with-row\r
+ [ >alist sort-values <reversed> ] dip [\r
+ [ swapd with-cell pprint-cell ] with-row\r
] curry assoc-each\r
] tabular-output ;\r
\r
errors. ;\r
\r
: analyze-log ( lines word-names -- )\r
- >r parse-log r> analyze-entries analysis. ;\r
+ [ parse-log ] dip analyze-entries analysis. ;\r
\r
: analyze-log-file ( service word-names -- )\r
- >r parse-log-file r> analyze-entries analysis. ;\r
+ [ parse-log-file ] dip analyze-entries analysis. ;\r
2dup [ length ] bi@ < [ 2drop f f ]
[
2dup length head over match
- [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if*
+ [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if*
] if ;
: match-first ( seq pattern-seq -- bindings )
over rect-loc v+ swap rect-dim <rect> ;
: (rect-intersect) ( rect rect -- array array )
- 2rect-extent vmin >r vmax r> ;
+ 2rect-extent [ vmax ] [ vmin ] 2bi* ;
: rect-intersect ( rect1 rect2 -- newrect )
(rect-intersect) <extent-rect> ;
(rect-intersect) [v-] { 0 0 } = ;
: (rect-union) ( rect rect -- array array )
- 2rect-extent vmax >r vmin r> ;
+ 2rect-extent [ vmin ] [ vmax ] 2bi* ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
\r
: go-back/forward ( history to from -- )\r
[ 2drop ]\r
- [ >r dupd (add-history) r> pop swap set-model ] if-empty ;\r
+ [ [ dupd (add-history) ] dip pop swap set-model ] if-empty ;\r
\r
: go-back ( history -- )\r
dup [ forward>> ] [ back>> ] bi go-back/forward ;\r
] if ;
: ((change-model)) ( model quot -- newvalue model )
- over >r >r value>> r> call r> ; inline
+ over [ [ value>> ] dip call ] dip ; inline
: change-model ( model quot -- )
((change-model)) set-model ; inline
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text>> [
2dup start
- [ rot dupd >r >r swap subseq % r> r> length + ] [
+ [ rot dupd [ swap subseq % ] 2dip length + ] [
rot tail % "\n" % 0
lexer get next-line swap (parse-multiline-string)
] if*
FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_rsa ( ctx rsa -- n )
- >r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ;
+ [ SSL_CTRL_SET_TMP_RSA 0 ] dip SSL_CTX_ctrl ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
- >r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
+ [ SSL_CTRL_SET_TMP_DH 0 ] dip SSL_CTX_ctrl ;
: SSL_CTX_set_session_cache_mode ( ctx mode -- n )
- >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ;
+ [ SSL_CTRL_SET_SESS_CACHE_MODE ] dip f SSL_CTX_ctrl ;
: SSL_SESS_CACHE_OFF HEX: 0000 ; inline
: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline
: 1token ( ch -- parser ) 1string token ;
: (list-of) ( items separator repeat1? -- parser )
- >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
+ [ over 2seq ] dip [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
: list-of ( items separator -- parser )
[ flatten-vectors ] action ;
: from-m-to-n ( parser m n -- parser' )
- >r [ exactly-n ] 2keep r> swap - at-most-n 2seq
+ [ [ exactly-n ] 2keep ] dip swap - at-most-n 2seq
[ flatten-vectors ] action ;
: pack ( begin body end -- parser )
- >r >r hide r> r> hide 3seq [ first ] action ;
+ [ hide ] 2dip hide 3seq [ first ] action ;
: surrounded-by ( parser begin end -- parser' )
[ token ] bi@ swapd pack ;
pos set dup involved-set>> clone >>eval-set drop ;
: (grow-lr) ( h p r: ( -- result ) m -- )
- >r >r [ setup-growth ] 2keep r> r>
- >r dup eval-rule r> swap
+ [ [ setup-growth ] 2keep ] 2dip
+ [ dup eval-rule ] dip swap
dup pick stop-growth? [
5 ndrop
] [
] if ; inline recursive
: grow-lr ( h p r m -- ast )
- >r >r [ heads set-at ] 2keep r> r>
- pick over >r >r (grow-lr) r> r>
+ [ [ heads set-at ] 2keep ] 2dip
+ pick over [ (grow-lr) ] 2dip
swap heads delete-at
dup pos>> pos set ans>>
; inline
[ ?head-slice ] keep swap [
<parse-result> f f add-error
] [
- >r drop pos get "token '" r> append "'" append 1vector add-error f
+ [ drop pos get "token '" ] dip append "'" append 1vector add-error f
] if ;
M: token-parser (compile) ( peg -- quot )
: ?end-group ( word -- )
?effect-height 0 < [ end-group ] when ;
-\ >r hard "break-before" set-word-prop
-\ r> hard "break-after" set-word-prop
-
! Atoms
: word-style ( word -- style )
dup "word-style" word-prop >hashtable [
] H{ } make-assoc ;
: unparse-string ( str prefix suffix -- str )
- [ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ;
+ [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
: pprint-string ( obj str prefix suffix -- )
unparse-string swap string-style styled-text ;
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
- dup zero? [ 2drop f ] [ >r head r> ] if
+ dup zero? [ 2drop f ] [ [ head ] dip ] if
] when ;
: pprint-elements ( seq -- )
- do-length-limit >r
- [ pprint* ] each
- r> [ "~" swap number>string " more~" 3append text ] when* ;
+ do-length-limit
+ [ [ pprint* ] each ] dip
+ [ "~" swap number>string " more~" 3append text ] when* ;
GENERIC: pprint-delims ( obj -- start end )
: pprint-object ( obj -- )
[
<flow
- dup pprint-delims >r pprint-word
- dup pprint-narrow? <inset
- >pprint-sequence pprint-elements
- block> r> pprint-word block>
+ dup pprint-delims [
+ pprint-word
+ dup pprint-narrow? <inset
+ >pprint-sequence pprint-elements
+ block>
+ ] dip pprint-word block>
] check-recursion ;
M: object pprint* pprint-object ;
[ \ method-layout see-methods ] with-string-writer "\n" split
] unit-test
-: retain-stack-test
- {
- "USING: io kernel sequences words ;"
- "IN: prettyprint.tests"
- ": retain-stack-layout ( x -- )"
- " dup stream-readln stream-readln"
- " >r [ define ] map r>"
- " define ;"
- } ;
-
-[ t ] [
- "retain-stack-layout" retain-stack-test check-see
-] unit-test
-
: soft-break-test
{
"USING: kernel math sequences strings ;"
"soft-break-layout" soft-break-test check-see
] unit-test
-: another-retain-layout-test
- {
- "USING: kernel sequences ;"
- "IN: prettyprint.tests"
- ": another-retain-layout ( seq1 seq2 quot -- newseq )"
- " -rot 2dup dupd min-length [ each drop roll ] map"
- " >r 3drop r> ; inline"
- } ;
-
-[ t ] [
- "another-retain-layout" another-retain-layout-test check-see
-] unit-test
-
DEFER: parse-error-file
: another-soft-break-test
"USING: kernel sequences ;"
"IN: prettyprint.tests"
": final-soft-break-layout ( class dim -- view )"
- " >r \"alloc\" send 0 0 r>"
- " first2 <NSRect>"
+ " [ \"alloc\" send 0 0 ] dip first2 <NSRect>"
" <PixelFormat> \"initWithFrame:pixelFormat:\" send"
" dup 1 \"setPostsBoundsChangedNotifications:\" send"
" dup 1 \"setPostsFrameChangedNotifications:\" send ;"
: text-fits? ( len -- ? )
margin get dup zero?
- [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ;
+ [ 2drop t ] [ [ pprinter get indent>> + ] dip <= ] if ;
! break only if position margin 2 / >
SYMBOL: soft
: empty-block? ( block -- ? ) sections>> empty? ;
: if-nonempty ( block quot -- )
- >r dup empty-block? [ drop ] r> if ; inline
+ [ dup empty-block? [ drop ] ] dip if ; inline
: (<block) ( block -- ) pprinter-stack get push ;
<PRIVATE
-: iterate-seq >r dup length swap r> ; inline
+: iterate-seq [ dup length swap ] dip ; inline
: (map-next) ( i seq quot -- )
! this uses O(n) more bounds checks than is really necessary
- >r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline
+ [ [ [ 1+ ] dip ?nth ] 2keep nth-unsafe ] dip call ; inline
PRIVATE>
-: each-next ( seq quot -- )
- ! quot: next-elt elt --
+: each-next ( seq quot: ( next-elt elt -- ) -- )
iterate-seq [ (map-next) ] 2curry each-integer ; inline
-: map-next ( seq quot -- newseq )
- ! quot: next-elt elt -- newelt
- over dup length swap new-sequence >r
- iterate-seq [ (map-next) ] 2curry
- r> [ collect ] keep ; inline
+: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq )
+ over dup length swap new-sequence [
+ iterate-seq [ (map-next) ] 2curry
+ ] dip [ collect ] keep ; inline
[ 8 ] [ 5 6 7 8 3nip ] unit-test
[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
+[ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test
IN: shuffle
-: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
+: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
: nipd ( a b c -- b c ) rot drop ; inline
{ $subsection inconsistent-recursive-call-error }
"Retain stack usage errors:"
{ $subsection too-many->r }
-{ $subsection too-many-r> }
-"See " { $link "shuffle-words" } " for retain stack usage conventions. This error can only occur if your code calls " { $link >r } " and " { $link r> } " directly. The " { $link dip } " combinator is safer to use because there is no way to leave the retain stack in an unbalanced state." ;
+{ $subsection too-many-r> } ;
ABOUT: "inference-errors"
M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * )
- >r boa r>
+ [ boa ] dip
recursive-state get word>>
\ inference-error boa throw ; inline
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
dlists assocs system combinators init boxes accessors
-math.order deques strings quotations ;
+math.order deques strings quotations fry ;
IN: threads
SYMBOL: initial-thread
<PRIVATE
: schedule-sleep ( thread dt -- )
- >r check-registered dup r> sleep-queue heap-push*
+ [ check-registered dup ] dip sleep-queue heap-push*
>>sleep-entry drop ;
: expire-sleep? ( heap -- ? )
: suspend ( quot state -- obj )
[
- >r
- >r self swap call
- r> self (>>state)
- r> self continuation>> >box
+ [ [ self swap call ] dip self (>>state) ] dip
+ self continuation>> >box
next
] callcc1 2nip ; inline
GENERIC: sleep-until ( time/f -- )
M: integer sleep-until
- [ schedule-sleep ] curry "sleep" suspend drop ;
+ '[ _ schedule-sleep ] "sleep" suspend drop ;
M: f sleep-until
drop [ drop ] "interrupt" suspend drop ;
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
- >r [ loop ] curry r> spawn ;
+ [ '[ _ loop ] ] dip spawn ;
: in-thread ( quot -- )
- >r datastack r>
- [ >r set-datastack r> call ] 2curry
+ [ datastack ] dip
+ '[ _ set-datastack _ call ]
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
{
{ [ over zero? ] [ 2drop 10 ] }
{ [ 2dup length 1- number= ] [ 2drop 4 ] }
- { [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
- { [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
+ { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] }
+ { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] }
[ 2drop 1 ]
} cond ;
over empty? [
nip [ first ] map
] [
- >r >lower r> [ completion ] with map
+ [ >lower ] dip [ completion ] with map
rank-completions
] if ;
parse-fresh [ first assoc-union ] unless-empty ;
: set-deploy-config ( assoc vocab -- )
- >r unparse-use string-lines r>
+ [ unparse-use string-lines ] dip
dup deploy-config-path set-vocab-file-contents ;
: set-deploy-flag ( value key vocab -- )
: shake-and-bake ( vocab -- )\r
[ "test.image" temp-file delete-file ] ignore-errors\r
"resource:" [\r
- >r vm\r
- "test.image" temp-file\r
- r> dup deploy-config make-deploy-image\r
+ [ vm "test.image" temp-file ] dip\r
+ dup deploy-config make-deploy-image\r
] with-directory ;\r
\r
: small-enough? ( n -- ? )\r
- >r "test.image" temp-file file-info size>> r> cell 4 / * <= ;\r
+ [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;\r
\r
[ ] [ "hello-world" shake-and-bake ] unit-test\r
\r
USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words
system sorting splitting grouping math.parser classes memory
-combinators ;
+combinators fry ;
IN: tools.memory
<PRIVATE
[ "Largest free block:" write-labelled-size ]
} spread ;
-: heap-stat-step ( counts sizes obj -- )
- [ dup size swap class rot at+ ] keep
- 1 swap class rot at+ ;
+: heap-stat-step ( obj counts sizes -- )
+ [ over ] dip
+ [ [ [ drop 1 ] [ class ] bi ] dip at+ ]
+ [ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ;
PRIVATE>
: heap-stats ( -- counts sizes )
H{ } clone H{ } clone
- [ >r 2dup r> heap-stat-step ] each-object ;
+ 2dup '[ _ _ heap-stat-step ] each-object ;
: heap-stats. ( -- )
heap-stats dup keys natural-sort standard-table-style [
: counter. ( obj n -- )
[
- >r [ (profile.) ] with-cell r>
+ [ [ (profile.) ] with-cell ] dip
[ number>string write ] with-cell
] with-row ;
USING: accessors namespaces arrays prettyprint sequences kernel
vectors quotations words parser assocs combinators continuations
debugger io io.styles io.files vocabs vocabs.loader source-files
-compiler.units summary stack-checker effects tools.vocabs ;
+compiler.units summary stack-checker effects tools.vocabs fry ;
IN: tools.test
SYMBOL: failures
] if ;
: unit-test ( output input -- )
- [ 2array ] 2keep [
- { } swap with-datastack swap >array assert=
- ] 2curry (unit-test) ;
+ [ 2array ] 2keep '[
+ _ { } _ with-datastack swap >array assert=
+ ] (unit-test) ;
: short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ;
: must-infer-as ( effect quot -- )
- >r 1quotation r> [ infer short-effect ] curry unit-test ;
+ [ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
: must-infer ( word/quot -- )
dup word? [ 1quotation ] when
- [ infer drop ] curry [ ] swap unit-test ;
+ '[ _ infer drop ] [ ] swap unit-test ;
: must-fail-with ( quot pred -- )
- >r [ f ] compose r>
- [ recover ] 2curry
- [ t ] swap unit-test ;
+ [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
: must-fail ( quot -- )
[ drop t ] must-fail-with ;
IN: tools.time
: benchmark ( quot -- runtime )
- micros >r call micros r> - ; inline
+ micros [ call micros ] dip - ; inline
: time. ( data -- )
unclip
] bi* ;
: time ( quot -- )
- gc-reset micros >r call gc-stats micros r> - prefix time. ; inline
+ gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline
: keyed-vocabs ( str quot -- seq )
all-vocabs [
- swap >r
- [ >r 2dup r> swap call member? ] filter
- r> swap
+ swap [
+ [ [ 2dup ] dip swap call member? ] filter
+ ] dip swap
] assoc-map 2nip ; inline
: tagged ( tag -- assoc )
M: vocab-link summary vocab-summary ;\r
\r
: set-vocab-summary ( string vocab -- )\r
- >r 1array r>\r
+ [ 1array ] dip\r
dup vocab-summary-path\r
set-vocab-file-contents ;\r
\r
assocs strings splitting kernel accessors ;
IN: unicode.case
-: at-default ( key assoc -- value/key ) over >r at r> or ;
+: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
: ch>lower ( ch -- lower ) simple-lower at-default ;
: ch>upper ( ch -- upper ) simple-upper at-default ;
: (process-data) ( index data -- newdata )
filter-comments
[ [ nth ] keep first swap ] with { } map>assoc
- [ >r hex> r> ] assoc-map ;
+ [ [ hex> ] dip ] assoc-map ;
: process-data ( index data -- hash )
(process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;
: hangul>jamo ( hangul -- jamo-string )
hangul-base - final-count /mod final-base +
- >r medial-count /mod medial-base +
- >r initial-base + r> r>
+ [
+ medial-count /mod medial-base +
+ [ initial-base + ] dip
+ ] dip
dup final-base = [ drop 2array ] [ 3array ] if ;
: jamo>hangul ( initial medial final -- hangul )
- >r >r initial-base - medial-count *
- r> medial-base - + final-count *
- r> final-base - + hangul-base + ;
+ [
+ [ initial-base - medial-count * ] dip
+ medial-base - + final-count *
+ ] dip final-base - + hangul-base + ;
! Normalization -- Decomposition
: reorder-next ( string i -- new-i done? )
over [ non-starter? ] find-from drop [
reorder-slice
- >r dup [ combining-class ] insertion-sort to>> r>
+ [ dup [ combining-class ] insertion-sort to>> ] dip
] [ length t ] if* ;
: reorder-loop ( string start -- )
projects / factor.git / commitdiff