From ac2bf0b87dba920d500815ac39f66d66381108e9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 18 Jul 2008 19:22:59 -0500 Subject: [PATCH] Adding inline recursive declarations --- core/assocs/assocs.factor | 2 +- core/binary-search/binary-search.factor | 4 +-- core/bootstrap/syntax.factor | 1 + core/combinators/combinators.factor | 8 ++--- core/dequeues/dequeues.factor | 5 ++- core/dlists/dlists.factor | 4 +-- core/effects/effects.factor | 18 ++++++---- core/effects/parser/parser.factor | 34 ++++++++++++++----- core/generic/generic.factor | 3 ++ .../standard/engines/tuple/tuple.factor | 3 ++ core/graphs/graphs.factor | 4 +-- core/hashtables/hashtables.factor | 4 +-- core/inference/backend/backend.factor | 3 +- core/inference/class/class-tests.factor | 2 ++ core/inference/dataflow/dataflow.factor | 19 ++++++----- core/inference/transforms/transforms.factor | 21 +----------- core/io/encodings/encodings.factor | 5 ++- core/kernel/kernel.factor | 7 ++-- core/listener/listener.factor | 4 +-- core/math/bitfields/bitfields-tests.factor | 10 ++++++ core/math/bitfields/bitfields.factor | 21 +++++++++++- core/math/integers/integers.factor | 2 +- core/math/math.factor | 16 ++++----- core/memory/memory.factor | 5 ++- core/optimizer/control/control.factor | 2 -- core/sequences/sequences.factor | 7 ++-- core/sorting/sorting.factor | 11 +++--- core/splitting/splitting.factor | 2 +- core/syntax/syntax.factor | 1 + core/threads/threads.factor | 2 +- core/words/words.factor | 9 ++++- extra/cocoa/enumeration/enumeration.factor | 4 +-- extra/concurrency/mailboxes/mailboxes.factor | 10 ++---- .../messaging/messaging-tests.factor | 2 +- extra/io/monitors/monitors-tests.factor | 4 +-- extra/locals/locals.factor | 6 ++-- extra/math/functions/functions.factor | 4 +-- extra/sequences/deep/deep.factor | 20 +++++------ extra/sorting/insertion/insertion.factor | 4 +-- extra/ui/cocoa/cocoa.factor | 5 +-- extra/ui/freetype/freetype.factor | 2 +- 41 files changed, 169 insertions(+), 131 deletions(-) diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 6cb8958298..be796ca554 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -84,7 +84,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) ] [ 3dup nth-unsafe at* [ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if - ] if ; inline + ] if ; inline recursive : assoc-stack ( key seq -- value ) dup length 1- swap (assoc-stack) ; diff --git a/core/binary-search/binary-search.factor b/core/binary-search/binary-search.factor index 87a4e0f503..2863944c8b 100644 --- a/core/binary-search/binary-search.factor +++ b/core/binary-search/binary-search.factor @@ -16,7 +16,7 @@ IN: binary-search [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi [ drop ] [ dup ] [ ] tri* nth ; inline -: (search) ( quot seq -- i elt ) +: (search) ( quot: ( elt -- <=> ) seq -- i elt ) dup length 1 <= [ finish ] [ @@ -25,7 +25,7 @@ IN: binary-search { +lt+ [ dup midpoint@ head-slice (search) ] } { +gt+ [ dup midpoint@ tail-slice (search) ] } } case - ] if ; inline + ] if ; inline recursive PRIVATE> diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 940b8ba57d..e7dd333ed8 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -59,6 +59,7 @@ IN: bootstrap.syntax "flushable" "foldable" "inline" + "recursive" "parsing" "t" "{" diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 0e04042bea..10324224b6 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -90,10 +90,10 @@ ERROR: no-case ; : ( initial length -- array ) next-power-of-2 swap [ nip clone ] curry map ; -: distribute-buckets ( assoc initial quot -- buckets ) - spin [ length ] keep - [ >r 2dup r> dup first roll call (distribute-buckets) ] each - nip ; inline +: distribute-buckets ( alist initial quot -- buckets ) + swapd [ >r dup first r> call 2array ] curry map + [ length dup ] keep + [ first2 (distribute-buckets) ] with each ; inline : hash-case-table ( default assoc -- array ) V{ } [ 1array ] distribute-buckets diff --git a/core/dequeues/dequeues.factor b/core/dequeues/dequeues.factor index 67c87d79c3..ae55c57fe5 100644 --- a/core/dequeues/dequeues.factor +++ b/core/dequeues/dequeues.factor @@ -37,8 +37,7 @@ GENERIC: node-value ( node -- value ) [ peek-back ] [ pop-back* ] bi ; : slurp-dequeue ( dequeue quot -- ) - over dequeue-empty? [ 2drop ] [ - [ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi - ] if ; inline + [ drop [ dequeue-empty? not ] curry ] + [ [ pop-back ] prepose curry ] 2bi [ ] while ; inline MIXIN: dequeue diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 0095734e63..370ec4042f 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -48,11 +48,11 @@ M: dlist-node node-value obj>> ; : set-front-to-back ( dlist -- ) dup front>> [ dup back>> >>front ] unless drop ; -: (dlist-find-node) ( dlist-node quot -- node/f ? ) +: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? ) over [ [ call ] 2keep rot [ drop t ] [ >r next>> r> (dlist-find-node) ] if - ] [ 2drop f f ] if ; inline + ] [ 2drop f f ] if ; inline recursive : dlist-find-node ( dlist quot -- node/f ? ) >r front>> r> (dlist-find-node) ; inline diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 6aee6fbcb2..c221ad073b 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces sequences strings words assocs -combinators accessors ; +combinators accessors arrays ; IN: effects TUPLE: effect in out terminated? ; @@ -22,15 +22,16 @@ TUPLE: effect in out terminated? ; [ t ] } cond 2nip ; -GENERIC: (stack-picture) ( obj -- str ) -M: string (stack-picture) ; -M: word (stack-picture) name>> ; -M: integer (stack-picture) drop "object" ; +GENERIC: effect>string ( obj -- str ) +M: string effect>string ; +M: word effect>string name>> ; +M: integer effect>string drop "object" ; +M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; : stack-picture ( seq -- string ) - [ [ (stack-picture) % CHAR: \s , ] each ] "" make ; + [ [ effect>string % CHAR: \s , ] each ] "" make ; -: effect>string ( effect -- string ) +M: effect effect>string ( effect -- string ) [ "( " % [ in>> stack-picture % "-- " % ] @@ -51,6 +52,9 @@ M: word stack-effect M: effect clone [ in>> clone ] [ out>> clone ] bi ; +: stack-height ( word -- n ) + stack-effect effect-height ; + : split-shuffle ( stack shuffle -- stack1 stack2 ) in>> length cut* ; diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 8f28450de7..93401d321c 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -1,15 +1,31 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: lexer sets sequences kernel splitting effects ; +USING: lexer sets sequences kernel splitting effects summary +combinators debugger arrays parser ; IN: effects.parser -: parse-effect ( end -- effect ) - parse-tokens dup { "(" "((" } intersect empty? [ - { "--" } split1 dup [ - - ] [ - "Stack effect declaration must contain --" throw +DEFER: parse-effect + +ERROR: bad-effect ; + +M: bad-effect summary + drop "Bad stack effect declaration" ; + +: parse-effect-token ( end -- token/f ) + scan tuck = [ drop f ] [ + dup { f "(" "((" } member? [ bad-effect ] [ + ":" ?tail [ + scan-word { + { \ ( [ ")" parse-effect ] } + [ ] + } case 2array + ] when ] if - ] [ - "Stack effect declaration must not contain ( or ((" throw ] if ; + +: parse-effect-tokens ( end -- tokens ) + [ parse-effect-token dup ] curry [ ] [ drop ] produce ; + +: parse-effect ( end -- effect ) + parse-effect-tokens { "--" } split1 dup + [ ] [ "Stack effect declaration must contain --" throw ] if ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 3aecd4825e..a621c7fa91 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -77,6 +77,9 @@ TUPLE: check-method class generic ; PREDICATE: method-body < word "method-generic" word-prop >boolean ; +M: method-body inline? + "method-generic" word-prop inline? ; + M: method-body stack-effect "method-generic" word-prop stack-effect ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 6f1773a21f..325f2ebb39 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -64,6 +64,9 @@ M: engine-word stack-effect [ extra-values ] [ stack-effect ] bi dup [ clone [ length + ] change-in ] [ 2drop f ] if ; +M: engine-word inline? + "tuple-dispatch-generic" word-prop inline? ; + M: engine-word crossref? "forgotten" word-prop not ; M: engine-word irrelevant? drop t ; diff --git a/core/graphs/graphs.factor b/core/graphs/graphs.factor index 792b2ab340..f2003641de 100644 --- a/core/graphs/graphs.factor +++ b/core/graphs/graphs.factor @@ -37,14 +37,14 @@ SYMBOL: graph SYMBOL: previous -: (closure) ( obj quot -- ) +: (closure) ( obj quot: ( elt -- assoc ) -- ) over previous get key? [ 2drop ] [ over previous get conjoin dup slip [ nip (closure) ] curry assoc-each - ] if ; inline + ] if ; inline recursive : closure ( obj quot -- assoc ) H{ } clone [ diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 943071a9f8..32fda7d2fb 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -27,7 +27,7 @@ TUPLE: hashtable dup ((empty)) eq? [ 3drop no-key ] [ = [ rot drop t ] [ probe (key@) ] if - ] if ; inline + ] if ; inline recursive : key@ ( key hash -- array n ? ) array>> dup length>> 0 eq? @@ -51,7 +51,7 @@ TUPLE: hashtable ] [ probe (new-key@) ] if - ] if ; inline + ] if ; inline recursive : new-key@ ( key hash -- array n empty? ) array>> 2dup hash@ (new-key@) ; inline diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index b4a533597c..0543159903 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -365,7 +365,8 @@ TUPLE: unbalanced-branches-error quots in out ; [ unify-effects ] [ unify-dataflow ] bi ; inline : infer-branches ( last branches node -- ) - #! last is a quotation which provides a #return or a #values + #! last -> #return or #values + #! node -> #if or #dispatch 1 reify-curries call dup node, pop-d drop diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 7be70f1ad4..a133f008e4 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -620,6 +620,8 @@ TUPLE: declared-fixnum { x fixnum } ; [ { ascii } declare decode-char ] \ decode-char inlined? ] unit-test +[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test + ! Later ! [ t ] [ diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 734c1c551c..1438353893 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -144,7 +144,8 @@ TUPLE: #dispatch < #branch ; : #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ; -TUPLE: #merge < node ; +! Phi node: merging is a sequence of sequences of values +TUPLE: #merge < node merging ; : #merge ( -- node ) \ #merge all-out-node ; @@ -191,7 +192,7 @@ TUPLE: #declare < node ; : #drop ( n -- #shuffle ) d-tail flatten-curries \ #shuffle in-node ; -: node-exists? ( node quot -- ? ) +: node-exists? ( node quot: ( node -- ? ) -- ? ) over [ 2dup 2slip rot [ 2drop t @@ -201,7 +202,7 @@ TUPLE: #declare < node ; ] if ] [ 2drop f - ] if ; inline + ] if ; inline recursive GENERIC: calls-label* ( label node -- ? ) @@ -223,21 +224,21 @@ SYMBOL: node-stack : iterate-next ( -- node ) node@ successor>> ; -: iterate-nodes ( node quot -- ) +: iterate-nodes ( node quot: ( -- ) -- ) over [ [ swap >node call node> drop ] keep iterate-nodes ] [ 2drop - ] if ; inline + ] if ; inline recursive -: (each-node) ( quot -- next ) +: (each-node) ( quot: ( node -- ) -- next ) node@ [ swap call ] 2keep node-children [ [ [ (each-node) ] keep swap ] iterate-nodes ] each drop - iterate-next ; inline + iterate-next ; inline recursive : with-node-iterator ( quot -- ) >r V{ } clone node-stack r> with-variable ; inline @@ -260,14 +261,14 @@ SYMBOL: node-stack 2drop ] if ; inline -: (transform-nodes) ( prev node quot -- ) +: (transform-nodes) ( prev node quot: ( node -- newnode ) -- ) dup >r call dup [ >>successor successor>> dup successor>> r> (transform-nodes) ] [ r> 2drop f >>successor drop - ] if ; inline + ] if ; inline recursive : transform-nodes ( node quot -- new-node ) over [ diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index c56c8ed080..c757ff4e96 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel words sequences generic math -namespaces quotations assocs combinators math.bitfields +namespaces quotations assocs combinators inference.backend inference.dataflow inference.state classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private ; @@ -48,25 +48,6 @@ IN: inference.transforms \ spread [ spread>quot ] 1 define-transform -! Bitfields -GENERIC: (bitfield-quot) ( spec -- quot ) - -M: integer (bitfield-quot) ( spec -- quot ) - [ swapd shift bitor ] curry ; - -M: pair (bitfield-quot) ( spec -- quot ) - first2 over word? [ >r swapd execute r> ] [ ] ? - [ shift bitor ] append 2curry ; - -: bitfield-quot ( spec -- quot ) - [ (bitfield-quot) ] map [ 0 ] prefix concat ; - -\ bitfield [ bitfield-quot ] 1 define-transform - -\ flags [ - [ 0 , [ , \ bitor , ] each ] [ ] make -] 1 define-transform - ! Tuple operations : [get-slots] ( slots -- quot ) [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 0181f80af4..fc02d880f1 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -93,11 +93,10 @@ M: decoder stream-read-partial stream-read ; { CHAR: \n [ line-ends\n ] } } case ; inline -: ((read-until)) ( buf quot -- string/f sep/f ) - ! quot: -- char stop? +: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f ) dup call [ >r drop "" like r> ] - [ pick push ((read-until)) ] if ; inline + [ pick push ((read-until)) ] if ; inline recursive : (read-until) ( quot -- string/f sep/f ) 100 swap ((read-until)) ; inline diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6b785a61ba..2540ee39cd 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -109,10 +109,13 @@ DEFER: if : 2bi@ ( w x y z quot -- ) dup 2bi* ; inline -: while ( pred body tail -- ) +: loop ( pred: ( -- ? ) -- ) + dup slip swap [ loop ] [ drop ] if ; inline recursive + +: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) >r >r dup slip r> r> roll [ >r tuck 2slip r> while ] - [ 2nip call ] if ; inline + [ 2nip call ] if ; inline recursive ! Object protocol GENERIC: hashcode* ( depth obj -- code ) diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 4e2a8c768e..5ff5830e7a 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -59,9 +59,7 @@ SYMBOL: error-hook ] recover ; : until-quit ( -- ) - quit-flag get - [ quit-flag off ] - [ listen until-quit ] if ; inline + quit-flag get [ quit-flag off ] [ listen until-quit ] if ; : listener ( -- ) [ until-quit ] with-interactive-vocabs ; diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index 2480012773..8864b64532 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -15,3 +15,13 @@ IN: math.bitfields.tests [ 3 ] [ foo ] unit-test [ 3 ] [ { a b } flags ] unit-test \ foo must-infer + +[ 0 ] [ { } bitfield-quot call ] unit-test + +[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test + +[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test + +[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test + +[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test diff --git a/core/math/bitfields/bitfields.factor b/core/math/bitfields/bitfields.factor index a0fb17ef48..64ae60d5b3 100644 --- a/core/math/bitfields/bitfields.factor +++ b/core/math/bitfields/bitfields.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math sequences words ; +USING: arrays kernel math sequences words +namespaces inference.transforms ; IN: math.bitfields GENERIC: (bitfield) ( value accum shift -- newaccum ) @@ -16,3 +17,21 @@ M: pair (bitfield) ( value accum pair -- newaccum ) : flags ( values -- n ) 0 [ dup word? [ execute ] when bitor ] reduce ; + +GENERIC: (bitfield-quot) ( spec -- quot ) + +M: integer (bitfield-quot) ( spec -- quot ) + [ swapd shift bitor ] curry ; + +M: pair (bitfield-quot) ( spec -- quot ) + first2 over word? [ >r swapd execute r> ] [ ] ? + [ shift bitor ] append 2curry ; + +: bitfield-quot ( spec -- quot ) + [ (bitfield-quot) ] map [ 0 ] prefix concat ; + +\ bitfield [ bitfield-quot ] 1 define-transform + +\ flags [ + [ 0 , [ , \ bitor , ] each ] [ ] make +] 1 define-transform diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 6563a1cd11..1e27d5f16c 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -40,7 +40,7 @@ M: fixnum bit? neg shift 1 bitand 0 > ; : (fixnum-log2) ( accum n -- accum ) dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ; - inline + inline recursive M: fixnum (log2) 0 swap (fixnum-log2) ; diff --git a/core/math/math.factor b/core/math/math.factor index 859d0f6f29..457dddceeb 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -124,21 +124,21 @@ M: float fp-nan? PRIVATE> -: (each-integer) ( i n quot -- ) +: (each-integer) ( i n quot: ( i -- ) -- ) [ iterate-step iterate-next (each-integer) ] - [ 3drop ] if-iterate? ; inline + [ 3drop ] if-iterate? ; inline recursive -: (find-integer) ( i n quot -- i ) +: (find-integer) ( i n quot: ( i -- ? ) -- i ) [ iterate-step roll [ 2drop ] [ iterate-next (find-integer) ] if - ] [ 3drop f ] if-iterate? ; inline + ] [ 3drop f ] if-iterate? ; inline recursive -: (all-integers?) ( i n quot -- ? ) +: (all-integers?) ( i n quot: ( i -- ? ) -- ? ) [ iterate-step roll [ iterate-next (all-integers?) ] [ 3drop f ] if - ] [ 3drop t ] if-iterate? ; inline + ] [ 3drop t ] if-iterate? ; inline recursive : each-integer ( n quot -- ) iterate-prep (each-integer) ; inline @@ -152,7 +152,7 @@ PRIVATE> : all-integers? ( n quot -- ? ) iterate-prep (all-integers?) ; inline -: find-last-integer ( n quot -- i ) +: find-last-integer ( n quot: ( i -- ? ) -- i ) over 0 < [ 2drop f ] [ @@ -161,4 +161,4 @@ PRIVATE> ] [ >r 1- r> find-last-integer ] if - ] if ; inline + ] if ; inline recursive diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 0d684c3261..227aa1f9dc 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -5,9 +5,8 @@ USING: arrays kernel sequences vectors system hashtables kernel.private sbufs growable assocs namespaces quotations math strings combinators ; -: (each-object) ( quot -- ) - next-object dup - [ swap [ call ] keep (each-object) ] [ 2drop ] if ; inline +: (each-object) ( quot: ( obj -- ) -- ) + [ next-object dup ] swap [ drop ] while ; inline : each-object ( quot -- ) begin-scan (each-object) end-scan ; inline diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index f3f9f51991..feb5706d97 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -70,8 +70,6 @@ M: #label collect-label-info* [ V{ } clone node-stack get length 3array ] keep node-param label-info get set-at ; -USE: prettyprint - M: #call-label collect-label-info* node-param label-info get at node-stack get over third tail diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 07900a900d..349d68adc5 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -238,7 +238,8 @@ INSTANCE: repetition immutable-sequence ] 3keep ; inline : (copy) ( dst i src j n -- dst ) - dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline + dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; + inline recursive : prepare-subseq ( from to seq -- dst i src j n ) [ >r swap - r> new-sequence dup 0 ] 3keep @@ -650,7 +651,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : halves ( seq -- first second ) dup midpoint@ cut-slice ; -: binary-reduce ( seq start quot -- value ) +: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value ) #! We can't use case here since combinators depends on #! sequences pick length dup 0 3 between? [ @@ -665,7 +666,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; >r >r halves r> r> [ [ binary-reduce ] 2curry bi@ ] keep call - ] if ; inline + ] if ; inline recursive : cut ( seq n -- before after ) [ head ] [ tail ] 2bi ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 8b84ea8fe0..b7bb71f602 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -52,14 +52,14 @@ TUPLE: merge : r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline : decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline -: (merge) ( merge quot -- ) +: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- ) over r-done? [ drop dump-l ] [ over l-done? [ drop dump-r ] [ 2dup decide [ over r-next ] [ over l-next ] if (merge) ] if - ] if ; inline + ] if ; inline recursive : flip-accum ( merge -- ) dup [ accum>> ] [ accum1>> ] bi eq? [ @@ -111,10 +111,9 @@ TUPLE: merge [ merge ] 2curry each-chunk ; inline : sort-loop ( merge quot -- ) - 2 swap - [ pick seq>> length pick > ] - [ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ] - [ ] while 3drop ; inline + [ 2 [ over seq>> length over > ] ] dip + [ [ 1 shift 2dup ] dip sort-pass ] curry + [ ] while 2drop ; inline : each-pair ( seq quot -- ) [ [ length 1+ 2/ ] keep ] dip diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index c30ea462c1..38f5ae0891 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -30,7 +30,7 @@ IN: splitting : (split) ( separators n seq -- ) 3dup rot [ member? ] curry find-from drop [ [ swap subseq , ] 2keep 1+ swap (split) ] - [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline + [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive : split, ( seq separators -- ) 0 rot (split) ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index e8ee857877..54df692895 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -89,6 +89,7 @@ IN: bootstrap.syntax "POSTPONE:" [ scan-word parsed ] define-syntax "\\" [ scan-word literalize parsed ] define-syntax "inline" [ word make-inline ] define-syntax + "recursive" [ word make-recursive ] define-syntax "foldable" [ word make-foldable ] define-syntax "flushable" [ word make-flushable ] define-syntax "delimiter" [ word t "delimiter" set-word-prop ] define-syntax diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 552d64cfe7..4b32f4519d 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -195,7 +195,7 @@ M: real sleep [ (spawn) ] keep ; : spawn-server ( quot name -- thread ) - >r [ [ ] [ ] while ] curry r> spawn ; + >r [ loop ] curry r> spawn ; : in-thread ( quot -- ) >r datastack r> diff --git a/core/words/words.factor b/core/words/words.factor index 1d84acbc14..5cf15abfa4 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -164,6 +164,9 @@ M: object redefined drop ; : make-inline ( word -- ) t "inline" set-word-prop ; +: make-recursive ( word -- ) + t "recursive" set-word-prop ; + : make-flushable ( word -- ) t "flushable" set-word-prop ; @@ -181,7 +184,7 @@ GENERIC: reset-word ( word -- ) M: word reset-word { "unannotated-def" - "parsing" "inline" "foldable" "flushable" + "parsing" "inline" "recursive" "foldable" "flushable" "predicating" "reading" "writing" "constructing" @@ -222,6 +225,10 @@ ERROR: bad-create name vocab ; : constructor-word ( name vocab -- word ) >r "<" swap ">" 3append r> create ; +GENERIC: inline? ( word -- ? ) + +M: word inline? "inline" word-prop ; + PREDICATE: parsing-word < word "parsing" word-prop ; : delimiter? ( obj -- ? ) diff --git a/extra/cocoa/enumeration/enumeration.factor b/extra/cocoa/enumeration/enumeration.factor index 0cd8e90531..765fb65ef2 100644 --- a/extra/cocoa/enumeration/enumeration.factor +++ b/extra/cocoa/enumeration/enumeration.factor @@ -11,13 +11,13 @@ IN: cocoa.enumeration ] with-malloc ] with-malloc ; inline -:: (NSFastEnumeration-each) ( object quot state stackbuf count -- ) +:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) object state stackbuf count -> countByEnumeratingWithState:objects:count: dup zero? [ drop ] [ state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* '[ , void*-nth quot call ] each object quot state stackbuf count (NSFastEnumeration-each) - ] if ; inline + ] if ; inline recursive : NSFastEnumeration-each ( object quot -- ) [ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index d0d6afef3f..b7d9e46aa8 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -23,13 +23,13 @@ M: mailbox dispose* threads>> notify-all ; : wait-for-mailbox ( mailbox timeout -- ) >r threads>> r> "mailbox" wait ; -: block-unless-pred ( mailbox timeout pred -- ) +: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- ) pick check-disposed pick data>> over dlist-contains? [ 3drop ] [ >r 2dup wait-for-mailbox r> block-unless-pred - ] if ; inline + ] if ; inline recursive : block-if-empty ( mailbox timeout -- mailbox ) over check-disposed @@ -58,11 +58,7 @@ M: mailbox dispose* threads>> notify-all ; f mailbox-get-all-timeout ; : while-mailbox-empty ( mailbox quot -- ) - over mailbox-empty? [ - dup >r dip r> while-mailbox-empty - ] [ - 2drop - ] if ; inline + [ [ mailbox-empty? ] curry ] dip [ ] while ; inline : mailbox-get-timeout? ( mailbox timeout pred -- obj ) 3dup block-unless-pred diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 929c4d44f4..f782870783 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -47,7 +47,7 @@ SYMBOL: exit } match-cond ; [ -5 ] [ - [ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set + [ 0 [ counter ] loop ] "Counter" spawn "counter" set { increment 10 } "counter" get send { decrement 15 } "counter" get send [ value , self , ] { } make "counter" get send diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index bd33954436..63381811d1 100755 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -55,7 +55,7 @@ os { winnt linux macosx } member? [ dup print flush dup parent-directory [ right-trim-separators "xyz" tail? ] either? not - ] [ ] [ ] while + ] loop "c1" get count-down @@ -64,7 +64,7 @@ os { winnt linux macosx } member? [ dup print flush dup parent-directory [ right-trim-separators "yxy" tail? ] either? not - ] [ ] [ ] while + ] loop "c2" get count-down ] "Monitor test thread" spawn drop diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 8346c2c2c3..f80af233d7 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -64,8 +64,8 @@ C: quote local-index 1+ [ get-local ] curry ; : localize-writer ( obj args -- quot ) - >r "local-reader" word-prop r> - read-local-quot [ set-local-value ] append ; + >r "local-reader" word-prop r> + read-local-quot [ set-local-value ] append ; : localize ( obj args -- quot ) { @@ -275,7 +275,7 @@ M: wlet local-rewrite* : parse-locals ( -- vars assoc ) ")" parse-effect word [ over "declared-effect" set-word-prop ] when* - effect-in make-locals dup push-locals ; + in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; : parse-locals-definition ( word -- word quot ) scan "(" assert= parse-locals \ ; (parse-lambda) diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 4dcb215138..4d71b25174 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -23,12 +23,12 @@ GENERIC: sqrt ( x -- y ) foldable M: real sqrt >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; -: each-bit ( n quot -- ) +: each-bit ( n quot: ( ? -- ) -- ) over 0 number= pick -1 number= or [ 2drop ] [ 2dup >r >r >r odd? r> call r> 2/ r> each-bit - ] if ; inline + ] if ; inline recursive GENERIC: (^) ( x y -- z ) foldable diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor index c0e516e471..3ec793f458 100644 --- a/extra/sequences/deep/deep.factor +++ b/extra/sequences/deep/deep.factor @@ -10,25 +10,25 @@ IN: sequences.deep dup string? swap number? or not ] [ drop f ] if ; -: deep-each ( obj quot -- ) +: deep-each ( obj quot: ( elt -- ) -- ) [ call ] 2keep over branch? - [ [ deep-each ] curry each ] [ 2drop ] if ; inline + [ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive -: deep-map ( obj quot -- newobj ) +: deep-map ( obj quot: ( elt -- elt' ) -- newobj ) [ call ] keep over branch? - [ [ deep-map ] curry map ] [ drop ] if ; inline + [ [ deep-map ] curry map ] [ drop ] if ; inline recursive -: deep-filter ( obj quot -- seq ) +: deep-filter ( obj quot: ( elt -- ? ) -- seq ) over >r pusher >r deep-each r> - r> dup branch? [ like ] [ drop ] if ; inline + r> dup branch? [ like ] [ drop ] if ; inline recursive -: deep-find-from ( obj quot -- elt ? ) +: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? ) [ call ] 2keep rot [ drop t ] [ over branch? [ f -rot [ >r nip r> deep-find-from ] curry find drop >boolean ] [ 2drop f f ] if - ] if ; inline + ] if ; inline recursive : deep-find ( obj quot -- elt ) deep-find-from drop ; inline @@ -37,10 +37,10 @@ IN: sequences.deep : deep-all? ( obj quot -- ? ) [ not ] compose deep-contains? not ; inline -: deep-change-each ( obj quot -- ) +: deep-change-each ( obj quot: ( elt -- elt' ) -- ) over branch? [ [ [ call ] keep over >r deep-change-each r> - ] curry change-each ] [ 2drop ] if ; inline + ] curry change-each ] [ 2drop ] if ; inline recursive : flatten ( obj -- seq ) [ branch? not ] deep-filter ; diff --git a/extra/sorting/insertion/insertion.factor b/extra/sorting/insertion/insertion.factor index 3a46eb83fd..8bc12e2704 100644 --- a/extra/sorting/insertion/insertion.factor +++ b/extra/sorting/insertion/insertion.factor @@ -2,13 +2,13 @@ USING: locals sequences kernel math ; IN: sorting.insertion = [ n n 1- seq exchange seq quot n 1- insert ] unless - ] unless ; inline + ] unless ; inline recursive PRIVATE> : insertion-sort ( seq quot -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 0085376eaa..8d176b9c63 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -16,10 +16,7 @@ SINGLETON: cocoa-ui-backend M: cocoa-ui-backend do-events ( -- ) [ - [ - NSApp [ dup do-event ] [ ] [ ] while drop - ui-wait - ] ui-try + [ NSApp [ do-event ] curry loop ui-wait ] ui-try ] with-autorelease-pool ; TUPLE: pasteboard handle ; diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 3512bbf670..85bf5d335e 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -142,7 +142,7 @@ M: freetype-renderer string-height ( open-font string -- h ) i end < [ i j bitmap texture copy-pixel bitmap texture end (copy-row) - ] when ; inline + ] when ; inline recursive :: copy-row ( i j bitmap texture width width2 -- i j ) i j bitmap texture i width + (copy-row)