diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 9c5f40d883..02e0e45544 100755 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private math math.private sequences -sequences.private ; +USING: accessors kernel kernel.private math math.private +sequences sequences.private ; IN: arrays M: array clone (clone) ; -M: array length array-capacity ; +M: array length length>> ; M: array nth-unsafe >r >fixnum r> array-nth ; M: array set-nth-unsafe >r >fixnum r> set-array-nth ; M: array resize resize-array ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 6cb8958298..b613147f29 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) ; @@ -158,6 +158,9 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ; : zip ( keys values -- alist ) 2array flip ; inline +: unzip ( assoc -- keys values ) + dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ; + : search-alist ( key alist -- pair i ) [ first = ] with find swap ; inline 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/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 04e53046fe..f25eafeb17 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -37,7 +37,7 @@ nl array? hashtable? vector? tuple? sbuf? node? tombstone? - array-capacity array-nth set-array-nth + array-nth set-array-nth wrap probe diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index b2b6dc4e59..b512ea6380 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -6,7 +6,8 @@ sequences strings vectors words quotations assocs layouts classes classes.builtin classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions slots classes.union classes.intersection classes.predicate -compiler.units bootstrap.image.private io.files accessors combinators ; +compiler.units bootstrap.image.private io.files accessors +combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -225,7 +226,9 @@ bi { "imaginary" { "real" "math" } read-only } } define-builtin -"array" "arrays" create { } define-builtin +"array" "arrays" create { + { "length" { "array-capacity" "sequences.private" } read-only } +} define-builtin "wrapper" "kernel" create { { "wrapped" read-only } @@ -261,7 +264,9 @@ bi { "sub-primitive" read-only } } define-builtin -"byte-array" "byte-arrays" create { } define-builtin +"byte-array" "byte-arrays" create { + { "length" { "array-capacity" "sequences.private" } read-only } +} define-builtin "callstack" "kernel" create { } define-builtin @@ -306,9 +311,12 @@ tuple } prepare-slots define-tuple-class "curry" "kernel" lookup -[ f "inline" set-word-prop ] -[ ] -[ tuple-layout [ ] curry ] tri +{ + [ f "inline" set-word-prop ] + [ make-flushable ] + [ ] + [ tuple-layout [ ] curry ] +} cleave (( obj quot -- curry )) define-declared "compose" "kernel" create @@ -319,9 +327,12 @@ tuple } prepare-slots define-tuple-class "compose" "kernel" lookup -[ f "inline" set-word-prop ] -[ ] -[ tuple-layout [ ] curry ] tri +{ + [ f "inline" set-word-prop ] + [ make-flushable ] + [ ] + [ tuple-layout [ ] curry ] +} cleave (( quot1 quot2 -- compose )) define-declared ! Sub-primitive words diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 64402ca2e1..5c55bb15ca 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -32,7 +32,6 @@ load-help? off "libc" require "io.streams.c" require - "io.thread" require "vocabs.loader" require "syntax" require diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3b98e89095..c6afdfe749 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -56,6 +56,8 @@ parse-command-line "-no-crossref" cli-args member? [ do-crossref ] unless +"io.thread" require + ! Set dll paths os wince? [ "windows.ce" require ] when os winnt? [ "windows.nt" require ] when 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/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index d603470810..5461da2b84 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien.accessors sequences +USING: accessors kernel kernel.private alien.accessors sequences sequences.private math ; IN: byte-arrays M: byte-array clone (clone) ; -M: byte-array length array-capacity ; +M: byte-array length length>> ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 17d8e36935..4216a5dc3d 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -91,7 +91,7 @@ ERROR: bad-superclass class ; #! 4 slot == superclasses>> rot dup tuple? [ layout-of 4 slot - 2dup array-capacity fixnum< + 2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if ] [ 3drop f ] if ; inline 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 e804bb76fa..32fda7d2fb 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -12,7 +12,7 @@ TUPLE: hashtable > 1 fixnum-fast fixnum-bitand ; inline : hash@ ( key array -- i ) >r hashcode >fixnum dup fixnum+fast r> wrap ; inline @@ -27,10 +27,10 @@ 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 array-capacity 0 eq? + array>> dup length>> 0 eq? [ no-key ] [ 2dup hash@ (key@) ] if ; inline : ( n -- array ) @@ -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 @@ -71,7 +71,7 @@ TUPLE: hashtable : hash-large? ( hash -- ? ) [ count>> 3 fixnum*fast 1 fixnum+fast ] - [ array>> array-capacity ] bi fixnum> ; inline + [ array>> length>> ] bi fixnum> ; inline : hash-stale? ( hash -- ? ) [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; 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/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 15234ee310..c16a031690 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -77,10 +77,6 @@ unit-test [ "-101.0e-2" string>number number>string ] unit-test -[ 5.0 ] -[ "10.0/2" string>number ] -unit-test - [ f ] [ "1e1/2" string>number ] unit-test @@ -104,3 +100,11 @@ unit-test [ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test [ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test + +[ 0.0/0.0 ] [ "0/0." string>number ] unit-test + +[ 1.0/0.0 ] [ "1/0." string>number ] unit-test + +[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test + +[ "-0.0" ] [ -0.0 number>string ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 5d048f0b8e..1cb2ae6cdf 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -55,8 +55,9 @@ SYMBOL: negative? dup [ (base>) ] [ drop 0 swap ] if ; : string>ratio ( str -- a/b ) + "-" ?head dup negative? set swap "/" split1 (base>) >r whole-part r> - 3dup and and [ / + ] [ 3drop f ] if ; + 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ; : valid-digits? ( seq -- ? ) { @@ -66,20 +67,23 @@ SYMBOL: negative? } cond ; : string>integer ( str -- n/f ) + "-" ?head swap string>digits dup valid-digits? - [ radix get digits>integer ] [ drop f ] if ; + [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ; PRIVATE> : base> ( str radix -- n/f ) [ - "-" ?head dup negative? set >r - { - { [ CHAR: / over member? ] [ string>ratio ] } - { [ CHAR: . over member? ] [ string>float ] } - [ string>integer ] - } cond - r> [ dup [ neg ] when ] when + CHAR: / over member? [ + string>ratio + ] [ + CHAR: . over member? [ + string>float + ] [ + string>integer + ] if + ] if ] with-radix ; : string>number ( str -- n/f ) 10 base> ; 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/quotations/quotations.factor b/core/quotations/quotations.factor index 9e7ded1836..617dac3323 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -5,11 +5,19 @@ kernel kernel.private math assocs quotations.private slots.private ; IN: quotations + + M: quotation call (call) ; -M: curry call dup 3 slot swap 4 slot call ; +M: curry call uncurry call ; -M: compose call dup 3 slot swap 4 slot slip call ; +M: compose call uncompose slip call ; M: wrapper equal? over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 11cfb975df..349d68adc5 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -60,9 +60,6 @@ INSTANCE: immutable-sequence sequence r swap - r> new-sequence dup 0 ] 3keep @@ -653,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? [ @@ -668,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/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 7ab11abd6d..3c1a794121 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -1,20 +1,68 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences namespaces fry ; +USING: kernel continuations combinators sequences quotations arrays namespaces + fry summary assocs math math.order macros ; IN: backtrack SYMBOL: failure -: amb ( seq -- elt ) - failure get - '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each - , continue ] callcc1 ; +ERROR: amb-failure ; + +M: amb-failure summary drop "Backtracking failure" ; : fail ( -- ) - f amb drop ; + failure get [ continue ] + [ amb-failure ] if* ; : require ( ? -- ) [ fail ] unless ; +MACRO: checkpoint ( quot -- quot' ) + '[ failure get , + '[ '[ failure set , continue ] callcc0 + , failure set @ ] callcc0 ] ; + +: number-from ( from -- from+n ) + [ 1 + number-from ] checkpoint ; + + + +: amb-lazy ( seq -- elt ) + [ amb-integer ] [ nth ] bi ; + +: amb ( seq -- elt ) + dup empty? + [ drop fail f ] + [ unsafe-amb ] if ; inline + +MACRO: amb-execute ( seq -- quot ) + [ length 1 - ] [ [ 1quotation ] assoc-map ] bi + '[ , 0 unsafe-number-from-to nip , case ] ; + +: if-amb ( true false -- ) + [ + [ { t f } amb ] + [ '[ @ require t ] ] + [ '[ @ f ] ] + tri* if + ] with-scope ; inline + diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor old mode 100644 new mode 100755 index 0ffaaa4867..df67872b11 --- a/extra/benchmark/backtrack/backtrack.factor +++ b/extra/benchmark/backtrack/backtrack.factor @@ -12,18 +12,6 @@ IN: benchmark.backtrack : nop ; -MACRO: amb-execute ( seq -- quot ) - [ length ] [ [ 1quotation ] assoc-map ] bi - '[ , amb , case ] ; - -: if-amb ( true false -- ) - [ - [ { t f } amb ] - [ '[ @ require t ] ] - [ '[ @ f ] ] - tri* if - ] with-scope ; inline - : do-something ( a b -- c ) { + - * } amb-execute ; 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/disjoint-set/disjoint-set.factor b/extra/disjoint-set/disjoint-set.factor deleted file mode 100644 index 6f3b1e63e8..0000000000 --- a/extra/disjoint-set/disjoint-set.factor +++ /dev/null @@ -1,72 +0,0 @@ -USING: accessors arrays hints kernel locals math sequences ; - -IN: disjoint-set - -> nth ; inline - -: add-count ( p a disjoint-set -- ) - [ count [ + ] curry ] keep counts>> swap change-nth ; inline - -: parent ( a disjoint-set -- p ) - parents>> nth ; inline - -: set-parent ( p a disjoint-set -- ) - parents>> set-nth ; inline - -: link-sets ( p a disjoint-set -- ) - [ set-parent ] - [ add-count ] 3bi ; inline - -: rank ( a disjoint-set -- r ) - ranks>> nth ; inline - -: inc-rank ( a disjoint-set -- ) - ranks>> [ 1+ ] change-nth ; inline - -: representative? ( a disjoint-set -- ? ) - dupd parent = ; inline - -: representative ( a disjoint-set -- p ) - 2dup representative? [ drop ] [ - [ [ parent ] keep representative dup ] 2keep set-parent - ] if ; - -: representatives ( a b disjoint-set -- r r ) - [ representative ] curry bi@ ; inline - -: ranks ( a b disjoint-set -- r r ) - [ rank ] curry bi@ ; inline - -:: branch ( a b neg zero pos -- ) - a b = zero [ a b < neg pos if ] if ; inline - -PRIVATE> - -: ( n -- disjoint-set ) - [ >array ] - [ 0 ] - [ 1 ] tri - disjoint-set boa ; - -: equiv-set-size ( a disjoint-set -- n ) - [ representative ] keep count ; - -: equiv? ( a b disjoint-set -- ? ) - representatives = ; inline - -:: equate ( a b disjoint-set -- ) - a b disjoint-set representatives - 2dup = [ 2drop ] [ - 2dup disjoint-set ranks - [ swap ] [ over disjoint-set inc-rank ] [ ] branch - disjoint-set link-sets - ] if ; - -HINTS: equate disjoint-set ; -HINTS: representative disjoint-set ; -HINTS: equiv-set-size disjoint-set ; diff --git a/extra/disjoint-set/authors.txt b/extra/disjoint-sets/authors.txt similarity index 100% rename from extra/disjoint-set/authors.txt rename to extra/disjoint-sets/authors.txt diff --git a/extra/disjoint-sets/disjoint-sets.factor b/extra/disjoint-sets/disjoint-sets.factor new file mode 100644 index 0000000000..7879f3fbb6 --- /dev/null +++ b/extra/disjoint-sets/disjoint-sets.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2008 Eric Mertens. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays hints kernel locals math hashtables +assocs ; + +IN: disjoint-sets + +TUPLE: disjoint-set +{ parents hashtable read-only } +{ ranks hashtable read-only } +{ counts hashtable read-only } ; + +> at ; inline + +: add-count ( p a disjoint-set -- ) + [ count [ + ] curry ] keep counts>> swap change-at ; inline + +: parent ( a disjoint-set -- p ) + parents>> at ; inline + +: set-parent ( p a disjoint-set -- ) + parents>> set-at ; inline + +: link-sets ( p a disjoint-set -- ) + [ set-parent ] [ add-count ] 3bi ; inline + +: rank ( a disjoint-set -- r ) + ranks>> at ; inline + +: inc-rank ( a disjoint-set -- ) + ranks>> [ 1+ ] change-at ; inline + +: representative? ( a disjoint-set -- ? ) + dupd parent = ; inline + +PRIVATE> + +GENERIC: representative ( a disjoint-set -- p ) + +M: disjoint-set representative + 2dup representative? [ drop ] [ + [ [ parent ] keep representative dup ] 2keep set-parent + ] if ; + + + +: ( -- disjoint-set ) + H{ } clone H{ } clone H{ } clone disjoint-set boa ; + +GENERIC: add-atom ( a disjoint-set -- ) + +M: disjoint-set add-atom + [ dupd parents>> set-at ] + [ 0 -rot ranks>> set-at ] + [ 1 -rot counts>> set-at ] + 2tri ; + +GENERIC: equiv-set-size ( a disjoint-set -- n ) + +M: disjoint-set equiv-set-size [ representative ] keep count ; + +GENERIC: equiv? ( a b disjoint-set -- ? ) + +M: disjoint-set equiv? representatives = ; + +GENERIC: equate ( a b disjoint-set -- ) + +M:: disjoint-set equate ( a b disjoint-set -- ) + a b disjoint-set representatives + 2dup = [ 2drop ] [ + 2dup disjoint-set ranks + [ swap ] [ over disjoint-set inc-rank ] [ ] branch + disjoint-set link-sets + ] if ; diff --git a/extra/disjoint-set/summary.txt b/extra/disjoint-sets/summary.txt similarity index 100% rename from extra/disjoint-set/summary.txt rename to extra/disjoint-sets/summary.txt diff --git a/extra/disjoint-set/tags.txt b/extra/disjoint-sets/tags.txt similarity index 100% rename from extra/disjoint-set/tags.txt rename to extra/disjoint-sets/tags.txt diff --git a/extra/fry/fry-docs.factor b/extra/fry/fry-docs.factor index eba2f95727..05cde62c1f 100755 --- a/extra/fry/fry-docs.factor +++ b/extra/fry/fry-docs.factor @@ -19,10 +19,11 @@ HELP: fry HELP: '[ { $syntax "code... ]" } -{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ; +{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." } +{ $examples "See " { $link "fry.examples" } "." } ; ARTICLE: "fry.examples" "Examples of fried quotations" -"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples." +"The easiest way to understand fried quotations is to look at some examples." $nl "If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":" { $code "{ 10 20 30 } '[ . ] each" } @@ -38,9 +39,10 @@ $nl "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map" "{ 10 20 30 } [ 3 5 / ] map" } -"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:" +"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:" { $code "{ 10 20 30 } [ sq ] '[ @ . ] each" + "{ 10 20 30 } [ sq ] [ call . ] curry each" "{ 10 20 30 } [ sq ] [ . ] compose each" "{ 10 20 30 } [ sq . ] each" } @@ -50,16 +52,17 @@ $nl "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map" "{ 8 13 14 27 } [ even? dup 5 ? ] map" } -"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":" +"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:" { $code "{ 10 20 30 } 1 '[ , _ / ] map" + "{ 10 20 30 } 1 [ [ ] curry dip / ] curry map" "{ 10 20 30 } 1 [ swap / ] curry map" "{ 10 20 30 } [ 1 swap / ] map" } "For any quotation body " { $snippet "X" } ", the following two are equivalent:" { $code - "[ >r X r> ]" - "[ X _ ]" + "[ [ X ] dip ]" + "'[ X _ ]" } "Here are some built-in combinators rewritten in terms of fried quotations:" { $table @@ -73,8 +76,11 @@ $nl } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" -"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "." -$nl +"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:" +{ $code + "'[ [ , key? ] all? ] filter" + "[ [ key? ] curry all? ] curry filter" +} "There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:" { $code "'[ 3 , + 4 , / ]" @@ -87,7 +93,7 @@ $nl } ; ARTICLE: "fry.limitations" "Fried quotation limitations" -"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ; +"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ; ARTICLE: "fry" "Fried quotations" "A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation." diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 9ffd241915..fc0d00e94d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections" { $subsection "heaps" } { $subsection "graphs" } { $subsection "buffers" } -"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ; +"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-sets" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ; USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ; diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 221dca3c62..0926a30adc 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -29,7 +29,7 @@ IN: help.lint : effect-values ( word -- seq ) stack-effect [ in>> ] [ out>> ] bi append - [ (stack-picture) ] map + [ dup pair? [ first ] when effect>string ] map prune natural-sort ; : contains-funky-elements? ( element -- ? ) 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/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 2883e47b81..100724ea58 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,7 +1,7 @@ USING: kernel tools.test accessors arrays sequences qualified io.streams.string io.streams.duplex namespaces threads calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes ; + concurrency.mailboxes classes assocs ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -20,28 +20,6 @@ IN: irc.client.tests : with-dummy-client ( quot -- ) rot with-variable ; inline -! Parsing tests -irc-message new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message f >>timestamp ] unit-test - -privmsg new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing - "#factortest" >>name -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line f >>timestamp ] unit-test - { "" } make-client dup "factorbot" set-nick current-irc-client [ { t } [ irc> profile>> nickname>> me? ] unit-test @@ -64,21 +42,29 @@ privmsg new ":some.where 001 factorbot :Welcome factorbot" } make-client [ connect-irc ] keep 1 seconds sleep - profile>> nickname>> ] unit-test + profile>> nickname>> ] unit-test { join_ "#factortest" } [ - { ":factorbot!n=factorbo@some.where JOIN :#factortest" + { ":factorbot!n=factorbo@some.where JOIN :#factortest" ":ircserver.net MODE #factortest +ns" ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" } make-client dup "factorbot" set-nick [ connect-irc ] keep 1 seconds sleep - join-messages>> 5 seconds mailbox-get-timeout + join-messages>> 1 seconds mailbox-get-timeout [ class ] [ trailing>> ] bi ] unit-test -! TODO: user join -! ":somedude!n=user@isp.net JOIN :#factortest" + +{ +join+ "somebody" } [ + { ":somebody!n=somebody@some.where JOIN :#factortest" + } make-client dup "factorbot" set-nick + [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri + [ action>> ] [ nick>> ] bi + ] unit-test ! TODO: channel message -! ":somedude!n=user@isp.net PRIVMSG #factortest :hello" +! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" ! TODO: direct private message ! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 2dbbe8b8f5..405d8ed9ed 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -31,6 +31,20 @@ TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-nick-listener < irc-listener name ; SYMBOL: +server-listener+ +! participant modes +SYMBOL: +operator+ +SYMBOL: +voice+ +SYMBOL: +normal+ + +: participant-mode ( n -- mode ) + H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; + +! participant changed actions +SYMBOL: +join+ +SYMBOL: +part+ +SYMBOL: +mode+ + +! listener objects : ( -- irc-listener ) irc-listener boa ; : ( -- irc-server-listener ) @@ -46,6 +60,9 @@ SYMBOL: +server-listener+ ! Message objects ! ====================================== +TUPLE: participant-changed nick action ; +C: participant-changed + SINGLETON: irc-end ! sent when the client isn't running anymore SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established @@ -70,19 +87,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : listener> ( name -- listener/f ) irc> listeners>> at ; : unregister-listener ( name -- ) irc> listeners>> delete-at ; -: to-listener ( message name -- ) +GENERIC: to-listener ( message obj -- ) + +M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* - [ in-messages>> mailbox-put ] [ drop ] if* ; + [ to-listener ] [ drop ] if* ; + +M: irc-listener to-listener ( message irc-listener -- ) + in-messages>> mailbox-put ; : remove-participant ( nick channel -- ) listener> [ participants>> delete-at ] [ drop ] if* ; -: remove-participant-from-all ( nick -- ) - irc> listeners>> - [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with - assoc-each ; +: listeners-with-participant ( nick -- seq ) + irc> listeners>> values + [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ] + with filter ; -: add-participant ( nick mode channel -- ) +: remove-participant-from-all ( nick -- ) + dup listeners-with-participant [ delete-at ] with each ; + +: add-participant ( mode nick channel -- ) listener> [ participants>> set-at ] [ 2drop ] if* ; DEFER: me? @@ -142,12 +167,31 @@ DEFER: me? dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; : broadcast-message-to-listeners ( message -- ) - irc> listeners>> values [ in-messages>> mailbox-put ] with each ; + irc> listeners>> values [ to-listener ] with each ; + +GENERIC: handle-participant-change ( irc-message -- ) + +M: join handle-participant-change ( join -- ) + [ prefix>> parse-name +join+ ] + [ trailing>> ] bi to-listener ; + +M: part handle-participant-change ( part -- ) + [ prefix>> parse-name +part+ ] + [ channel>> ] bi to-listener ; + +M: kick handle-participant-change ( kick -- ) + [ who>> +part+ ] + [ channel>> ] bi to-listener ; + +M: quit handle-participant-change ( quit -- ) + prefix>> parse-name + [ +part+ ] [ listeners-with-participant ] bi + [ to-listener ] with each ; GENERIC: handle-incoming-irc ( irc-message -- ) M: irc-message handle-incoming-irc ( irc-message -- ) - +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ; + +server-listener+ listener> [ to-listener ] [ drop ] if* ; M: logged-in handle-incoming-irc ( logged-in -- ) name>> irc> profile>> (>>nickname) ; @@ -162,34 +206,43 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - [ maybe-forward-join ] - [ dup trailing>> to-listener ] - [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] - tri ; + { [ maybe-forward-join ] ! keep + [ dup trailing>> to-listener ] + [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + [ handle-participant-change ] + } cleave ; M: part handle-incoming-irc ( part -- ) - [ dup channel>> to-listener ] keep - [ prefix>> parse-name ] [ channel>> ] bi remove-participant ; - -M: kick handle-incoming-irc ( kick -- ) - [ dup channel>> to-listener ] - [ [ who>> ] [ channel>> ] bi remove-participant ] - [ dup who>> me? [ unregister-listener ] [ drop ] if ] + [ dup channel>> to-listener ] + [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] + [ handle-participant-change ] tri ; +M: kick handle-incoming-irc ( kick -- ) + { [ dup channel>> to-listener ] + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ handle-participant-change ] + [ dup who>> me? [ unregister-listener ] [ drop ] if ] + } cleave ; + M: quit handle-incoming-irc ( quit -- ) - [ prefix>> parse-name remove-participant-from-all ] keep - call-next-method ; + { [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ handle-participant-change ] + [ prefix>> parse-name remove-participant-from-all ] + [ ] + } cleave call-next-method ; : >nick/mode ( string -- nick mode ) - dup first "+@" member? [ unclip ] [ f ] if ; + dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; : names-reply>participants ( names-reply -- participants ) trailing>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; M: names-reply handle-incoming-irc ( names-reply -- ) - [ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ; + [ names-reply>participants ] [ channel>> listener> ] bi + [ (>>participants) ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; @@ -200,8 +253,8 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) GENERIC: handle-outgoing-irc ( obj -- ) -! M: irc-message handle-outgoing-irc ( irc-message -- ) -! irc-message>string irc-print ; +M: irc-message handle-outgoing-irc ( irc-message -- ) + irc-message>client-line irc-print ; M: privmsg handle-outgoing-irc ( privmsg -- ) [ name>> ] [ trailing>> ] bi /PRIVMSG ; @@ -213,11 +266,6 @@ M: part handle-outgoing-irc ( part -- ) ! Reader/Writer ! ====================================== -: irc-mailbox-get ( mailbox quot -- ) - [ 5 seconds ] dip - '[ , , , [ mailbox-get-timeout ] dip call ] - [ drop ] recover ; inline - : handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ; @@ -225,7 +273,7 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ [ irc-disconnected ] dip in-messages>> mailbox-put ] + [ [ irc-disconnected ] dip to-listener ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; @@ -247,14 +295,14 @@ DEFER: (connect-irc) [ (reader-loop) ] [ handle-disconnect ] recover ; : writer-loop ( -- ) - irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ; + irc> out-messages>> mailbox-get handle-outgoing-irc ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ) - irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ; + irc> in-messages>> mailbox-get handle-incoming-irc ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -267,9 +315,8 @@ DEFER: (connect-irc) } cond ; : listener-loop ( name listener -- ) - out-messages>> swap - '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ] - irc-mailbox-get ; + out-messages>> mailbox-get maybe-annotate-with-name + irc> out-messages>> mailbox-put ; : spawn-irc-loop ( quot name -- ) [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor new file mode 100644 index 0000000000..1bd6088f82 --- /dev/null +++ b/extra/irc/messages/messages-tests.factor @@ -0,0 +1,37 @@ +USING: kernel tools.test accessors arrays qualified + irc.messages irc.messages.private ; +EXCLUDE: sequences => join ; +IN: irc.messages.tests + +! Parsing tests +irc-message new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + string>irc-message f >>timestamp ] unit-test + +privmsg new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing + "#factortest" >>name +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line f >>timestamp ] unit-test + +join new + ":someuser!n=user@some.where JOIN :#factortest" >>line + "someuser!n=user@some.where" >>prefix + "JOIN" >>command + { } >>parameters + "#factortest" >>trailing +1array +[ ":someuser!n=user@some.where JOIN :#factortest" + parse-irc-line f >>timestamp ] unit-test + diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 205630d790..5813c72723 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -21,6 +21,10 @@ TUPLE: mode < irc-message name channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; +: ( command parameters trailing -- irc-message ) + irc-message new now >>timestamp + [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; + GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) @@ -30,6 +34,7 @@ M: irc-message irc-message>client-line ( irc-message -- string ) tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) + M: irc-message irc-message>server-line ( irc-message -- string ) drop "not implemented yet" ; @@ -58,6 +63,8 @@ M: irc-message irc-message>server-line ( irc-message -- string ) : split-trailing ( string -- string string/f ) ":" split1 ; +PRIVATE> + : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip @@ -82,4 +89,3 @@ M: irc-message irc-message>server-line ( irc-message -- string ) [ [ tuple-slots ] [ parameters>> ] bi append ] dip [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; -PRIVATE> diff --git a/extra/irc/ui/load/load.factor b/extra/irc/ui/load/load.factor index 6655f310e7..e6f4d07b56 100755 --- a/extra/irc/ui/load/load.factor +++ b/extra/irc/ui/load/load.factor @@ -5,7 +5,7 @@ USING: kernel io.files parser editors sequences ; IN: irc.ui.load -: file-or ( path path -- path ) over exists? ? ; +: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ; : personal-ui-rc ( -- path ) home ".ircui-rc" append-path ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 12f9d01183..a79920efe5 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -5,8 +5,8 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures - ui.gadgets.tabs ui.gadgets.grids - io io.styles namespaces calendar calendar.format + ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels + io io.styles namespaces calendar calendar.format models irc.client irc.client.private irc.messages irc.messages.private irc.ui.commandparser irc.ui.load ; @@ -18,11 +18,18 @@ SYMBOL: client TUPLE: ui-window client tabs ; +TUPLE: irc-tab < frame listener client listmodel ; + : write-color ( str color -- ) foreground associate format ; : red { 0.5 0 0 1 } ; : green { 0 0.5 0 1 } ; : blue { 0 0 1 1 } ; +: black { 0 0 0 1 } ; + +: colors H{ { +operator+ { 0 0.5 0 1 } } + { +voice+ { 0 0 1 1 } } + { +normal+ { 0 0 0 1 } } } ; : dot-or-parens ( string -- string ) dup empty? [ drop "." ] @@ -64,6 +71,14 @@ M: quit write-irc " has left IRC" red write-color trailing>> dot-or-parens red write-color ; +M: mode write-irc + "* " blue write-color + [ name>> write ] keep + " has applied mode " blue write-color + [ mode>> write ] keep + " to " blue write-color + channel>> write ; + M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -84,20 +99,39 @@ M: irc-message write-irc [ print-irc ] [ listener get write-message ] bi ; -: display ( stream listener -- ) +GENERIC: handle-inbox ( tab message -- ) + +: filter-participants ( assoc val -- alist ) + [ >alist ] dip + '[ second , = ] filter ; + +: update-participants ( tab -- ) + [ listmodel>> ] [ listener>> participants>> ] bi + [ +operator+ filter-participants ] + [ +voice+ filter-participants ] + [ +normal+ filter-participants ] tri + append append swap set-model ; + +M: participant-changed handle-inbox + drop update-participants ; + +M: object handle-inbox + nip print-irc ; + +: display ( stream tab -- ) '[ , [ [ t ] - [ , read-message print-irc ] + [ , dup listener>> read-message handle-inbox ] [ ] while ] with-output-stream ] "ircv" spawn drop ; -: ( listener -- pane ) +: ( tab -- tab pane ) - [ swap display ] keep ; + [ swap display ] 2keep ; TUPLE: irc-editor < editor outstream listener client ; -: ( page pane listener -- client editor ) - irc-editor new-editor - swap >>listener swap >>outstream +: ( tab pane -- tab editor ) + over irc-editor new-editor + swap listener>> >>listener swap >>outstream over client>> >>client ; : editor-send ( irc-editor -- ) @@ -113,25 +147,36 @@ irc-editor "general" f { { T{ key-down f f "ENTER" } editor-send } } define-command-map -TUPLE: irc-page < frame listener client ; +: ( -- gadget model ) + [ drop ] + [ first2 [