Merge branch 'master' of factorcode.org:/git/factor
Eduardo Cavazos
commit
5618025403
|
|
@ -71,7 +71,7 @@ M: object xyz ;
|
|||
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 -- )
|
||||
|
|
@ -87,10 +87,10 @@ M: object xyz ;
|
|||
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?
|
||||
|
|
@ -194,7 +194,7 @@ M: fixnum annotate-entry-test-1 drop ;
|
|||
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
|
||||
|
|
@ -448,7 +448,7 @@ cell-bits 32 = [
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ [ >r "A" throw r> ] [ "B" throw ] if ]
|
||||
[ [ [ "A" throw ] dip ] [ "B" throw ] if ]
|
||||
cleaned-up-tree drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -463,7 +463,7 @@ cell-bits 32 = [
|
|||
: buffalo-wings ( i seq -- )
|
||||
2dup < [
|
||||
2dup chicken-fingers
|
||||
>r 1+ r> buffalo-wings
|
||||
[ 1+ ] dip buffalo-wings
|
||||
] [
|
||||
2drop
|
||||
] if ; inline recursive
|
||||
|
|
@ -482,7 +482,7 @@ cell-bits 32 = [
|
|||
: ribs ( i seq -- )
|
||||
2dup < [
|
||||
steak
|
||||
>r 1+ r> ribs
|
||||
[ 1+ ] dip ribs
|
||||
] [
|
||||
2drop
|
||||
] if ; inline recursive
|
||||
|
|
|
|||
|
|
@ -75,9 +75,9 @@ IN: compiler.tree.dead-code.tests
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -34,8 +34,8 @@ sequences accessors tools.test kernel math ;
|
|||
[ ] [ [ [ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -435,7 +435,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
|||
] 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
|
||||
|
||||
|
|
|
|||
|
|
@ -561,7 +561,7 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
|
|||
|
||||
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 -- )
|
||||
|
|
@ -569,8 +569,8 @@ 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 -- )
|
||||
|
|
|
|||
|
|
@ -131,11 +131,11 @@ HELP: datastack-overflow.
|
|||
{ $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.
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@ ALIAS: $slot $snippet
|
|||
[
|
||||
snippet-style get [
|
||||
last-element off
|
||||
>r ($code-style) r> with-nesting
|
||||
[ ($code-style) ] dip with-nesting
|
||||
] with-style
|
||||
] ($block) ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -11,9 +11,10 @@ IN: help.syntax
|
|||
\ ; 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
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ SYMBOL: html
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ TUPLE: html-sub-stream < html-stream style parent ;
|
|||
"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
|
||||
|
|
@ -163,13 +163,13 @@ M: html-stream stream-flush
|
|||
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
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ TUPLE: interval-map array ;
|
|||
first2 between? ;
|
||||
|
||||
: all-intervals ( sequence -- intervals )
|
||||
[ >r dup number? [ dup 2array ] when r> ] { } assoc-map-as ;
|
||||
[ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
|
||||
|
||||
: disjoint? ( node1 node2 -- ? )
|
||||
[ second ] [ first ] bi* < ;
|
||||
|
|
|
|||
|
|
@ -38,8 +38,8 @@ SYMBOL: message-histogram
|
|||
|
||||
: histogram. ( assoc quot -- )
|
||||
standard-table-style [
|
||||
>r >alist sort-values <reversed> r> [
|
||||
[ >r swap r> with-cell pprint-cell ] with-row
|
||||
[ >alist sort-values <reversed> ] dip [
|
||||
[ swapd with-cell pprint-cell ] with-row
|
||||
] curry assoc-each
|
||||
] tabular-output ;
|
||||
|
||||
|
|
@ -69,7 +69,7 @@ SYMBOL: message-histogram
|
|||
errors. ;
|
||||
|
||||
: analyze-log ( lines word-names -- )
|
||||
>r parse-log r> analyze-entries analysis. ;
|
||||
[ parse-log ] dip analyze-entries analysis. ;
|
||||
|
||||
: analyze-log-file ( service word-names -- )
|
||||
>r parse-log-file r> analyze-entries analysis. ;
|
||||
[ parse-log-file ] dip analyze-entries analysis. ;
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ MACRO: match-cond ( assoc -- )
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ M: rect rect-dim dim>> ;
|
|||
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> ;
|
||||
|
|
@ -46,7 +46,7 @@ M: rect rect-dim dim>> ;
|
|||
(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> ;
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ TUPLE: history < model back forward ;
|
|||
|
||||
: go-back/forward ( history to from -- )
|
||||
[ 2drop ]
|
||||
[ >r dupd (add-history) r> pop swap set-model ] if-empty ;
|
||||
[ [ dupd (add-history) ] dip pop swap set-model ] if-empty ;
|
||||
|
||||
: go-back ( history -- )
|
||||
dup [ forward>> ] [ back>> ] bi go-back/forward ;
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@ M: model update-model drop ;
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ PRIVATE>
|
|||
: (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*
|
||||
|
|
|
|||
|
|
@ -234,13 +234,13 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ;
|
|||
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
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: just-parser (compile) ( parser -- quot )
|
|||
: 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 )
|
||||
|
|
@ -60,11 +60,11 @@ PRIVATE>
|
|||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -146,8 +146,8 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
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
|
||||
] [
|
||||
|
|
@ -156,8 +156,8 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
] 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
|
||||
|
|
@ -352,7 +352,7 @@ TUPLE: token-parser symbol ;
|
|||
[ ?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 )
|
||||
|
|
|
|||
|
|
@ -21,9 +21,6 @@ M: effect pprint* effect>string "(" swap ")" 3append text ;
|
|||
: ?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 [
|
||||
|
|
@ -93,7 +90,7 @@ M: f pprint* drop \ f pprint-word ;
|
|||
] 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 ;
|
||||
|
|
@ -156,13 +153,13 @@ M: tuple pprint*
|
|||
: 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 )
|
||||
|
||||
|
|
@ -206,10 +203,12 @@ M: tuple pprint-narrow? drop t ;
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -135,20 +135,6 @@ M: object method-layout ;
|
|||
[ \ 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 ;"
|
||||
|
|
@ -164,19 +150,6 @@ M: object method-layout ;
|
|||
"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
|
||||
|
|
@ -219,8 +192,7 @@ DEFER: parse-error-file
|
|||
"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 ;"
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ TUPLE: pprinter last-newline line-count indent ;
|
|||
|
||||
: 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
|
||||
|
|
@ -189,7 +189,7 @@ M: block short-section ( block -- )
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,20 +3,18 @@ IN: sequences.next
|
|||
|
||||
<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
|
||||
|
|
|
|||
|
|
@ -2,3 +2,4 @@ USING: shuffle tools.test ;
|
|||
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: kernel generalizations ;
|
|||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -115,7 +115,6 @@ ARTICLE: "inference-errors" "Inference warnings and errors"
|
|||
{ $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"
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ M: inference-error compiler-error-type type>> ;
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
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
|
||||
|
|
@ -101,7 +101,7 @@ DEFER: stop
|
|||
<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 -- ? )
|
||||
|
|
@ -164,10 +164,8 @@ PRIVATE>
|
|||
|
||||
: 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
|
||||
|
||||
|
|
@ -176,7 +174,7 @@ PRIVATE>
|
|||
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 ;
|
||||
|
|
@ -200,11 +198,11 @@ M: real sleep
|
|||
<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 -- )
|
||||
|
|
|
|||
|
|
@ -33,8 +33,8 @@ IN: tools.completion
|
|||
{
|
||||
{ [ 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 ;
|
||||
|
||||
|
|
@ -67,7 +67,7 @@ IN: tools.completion
|
|||
over empty? [
|
||||
nip [ first ] map
|
||||
] [
|
||||
>r >lower r> [ completion ] with map
|
||||
[ >lower ] dip [ completion ] with map
|
||||
rank-completions
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ SYMBOL: deploy-image
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -7,13 +7,12 @@ urls math.parser ;
|
|||
: shake-and-bake ( vocab -- )
|
||||
[ "test.image" temp-file delete-file ] ignore-errors
|
||||
"resource:" [
|
||||
>r vm
|
||||
"test.image" temp-file
|
||||
r> dup deploy-config make-deploy-image
|
||||
[ vm "test.image" temp-file ] dip
|
||||
dup deploy-config make-deploy-image
|
||||
] with-directory ;
|
||||
|
||||
: small-enough? ( n -- ? )
|
||||
>r "test.image" temp-file file-info size>> r> cell 4 / * <= ;
|
||||
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
|
||||
|
||||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
|
|
@ -51,9 +51,10 @@ IN: tools.memory
|
|||
[ "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>
|
||||
|
||||
|
|
@ -71,7 +72,7 @@ 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 [
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ M: method-body (profile.)
|
|||
|
||||
: counter. ( obj n -- )
|
||||
[
|
||||
>r [ (profile.) ] with-cell r>
|
||||
[ [ (profile.) ] with-cell ] dip
|
||||
[ number>string write ] with-cell
|
||||
] with-row ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
|
|
@ -26,24 +26,22 @@ SYMBOL: this-test
|
|||
] 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 ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ namespaces system sequences splitting grouping assocs strings ;
|
|||
IN: tools.time
|
||||
|
||||
: benchmark ( quot -- runtime )
|
||||
micros >r call micros r> - ; inline
|
||||
micros [ call micros ] dip - ; inline
|
||||
|
||||
: time. ( data -- )
|
||||
unclip
|
||||
|
|
@ -37,4 +37,4 @@ IN: tools.time
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -250,9 +250,9 @@ C: <vocab-author> vocab-author
|
|||
|
||||
: 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 )
|
||||
|
|
|
|||
|
|
@ -203,7 +203,7 @@ M: vocab summary
|
|||
M: vocab-link summary vocab-summary ;
|
||||
|
||||
: set-vocab-summary ( string vocab -- )
|
||||
>r 1array r>
|
||||
[ 1array ] dip
|
||||
dup vocab-summary-path
|
||||
set-vocab-file-contents ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ unicode.normalize math unicode.categories combinators
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ VALUE: properties
|
|||
: (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 ;
|
||||
|
|
|
|||
|
|
@ -27,14 +27,17 @@ IN: unicode.normalize
|
|||
|
||||
: 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
|
||||
|
||||
|
|
@ -45,7 +48,7 @@ IN: unicode.normalize
|
|||
: 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 -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue