Merge branch 'master' of git://factorcode.org/git/factor

basis/cocoa/windows/windows-docs.factor

@@ -2,11 +2,11 @@ USING: help.markup help.syntax ;
 IN: cocoa.windows
 
 HELP: <NSWindow>
-{ $values { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } }
+{ $values { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "class" "an Objective-C class" } { "window" "an " { $snippet "NSWindow" } } }
 { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions." } ;
 
 HELP: <ViewWindow>
-{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "window" "an " { $snippet "NSWindow" } } }
+{ $values { "view" "an " { $snippet "NSView" } } { "rect" "an " { $snippet "NSRect" } } { "style" "a style mask" } { "window" "an " { $snippet "NSWindow" } } }
 { $description "Creates a new " { $snippet "NSWindow" } " with the specified dimensions, containing the given view." } ;
 
 ARTICLE: "cocoa-window-utils" "Cocoa window utilities"

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -1,21 +1,66 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs heaps kernel namespaces sequences
+USING: accessors assocs heaps kernel namespaces sequences fry math
+combinators arrays sorting compiler.utilities
 compiler.cfg.linear-scan.allocation.coalescing
 compiler.cfg.linear-scan.allocation.spilling
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.allocation
 
+: relevant-ranges ( new inactive -- new' inactive' )
+    ! Slice off all ranges of 'inactive' that precede the start of 'new'
+    [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+
+: intersect-live-range ( range1 range2 -- n/f )
+    2dup [ from>> ] bi@ > [ swap ] when
+    2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+
+: intersect-live-ranges ( ranges1 ranges2 -- n )
+    {
+        { [ over empty? ] [ 2drop 1/0. ] }
+        { [ dup empty? ] [ 2drop 1/0. ] }
+        [
+            2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
+                drop
+                2dup [ first from>> ] bi@ <
+                [ [ rest-slice ] dip ] [ rest-slice ] if
+                intersect-live-ranges
+            ] if
+        ]
+    } cond ;
+
+: intersect-inactive ( new inactive -- n )
+    relevant-ranges intersect-live-ranges ;
+
+: compute-free-pos ( new -- free-pos )
+    dup vreg>>
+    [ nip reg-class>> registers get at [ 1/0. ] H{ } map>assoc ]
+    [ inactive-intervals-for [ [ reg>> swap ] keep intersect-inactive ] with H{ } map>assoc ]
+    [ nip active-intervals-for [ reg>> 0 ] H{ } map>assoc ]
+    2tri 3array assoc-combine
+    >alist alist-max ;
+
+: no-free-registers? ( result -- ? )
+    second 0 = ; inline
+
+: register-available? ( new result -- ? )
+    [ end>> ] [ second ] bi* < ; inline
+
+: register-available ( new result -- )
+    first >>reg add-active ;
+
+: register-partially-available ( new result -- )
+    [ second split-before-use ] keep
+    '[ _ register-available ] [ add-unhandled ] bi* ;
+
 : assign-register ( new -- )
     dup coalesce? [ coalesce ] [
-        dup vreg>> free-registers-for [
+        dup compute-free-pos {
-            dup intersecting-inactive
+            { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
-            [ assign-blocked-register ]
+            { [ 2dup register-available? ] [ register-available ] }
-            [ assign-inactive-register ]
+            [ register-partially-available ]
-            if-empty
+        } cond
-        ] [ assign-free-register ]
-        if-empty
     ] if ;
 
 : handle-interval ( live-interval -- )

basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor

@@ -1,12 +1,24 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting
+math sequences sets sorting splitting compiler.utilities
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.allocation.spilling
 
+: find-use ( live-interval n quot -- elt )
+    [ uses>> ] 2dip curry find nip ; inline
+
+: spill-existing? ( new existing -- ? )
+    #! Test if 'new' will be used before 'existing'.
+    over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
+
+: interval-to-spill ( active-intervals current -- live-interval )
+    #! We spill the interval with the most distant use location.
+    start>> '[ dup _ [ >= ] find-use ] { } map>assoc
+    alist-max first ;
+
 : split-for-spill ( live-interval n -- before after )
     split-interval
     [
@@ -17,14 +29,6 @@ IN: compiler.cfg.linear-scan.allocation.spilling
     [ ]
     2tri ;
 
-: find-use ( live-interval n quot -- i elt )
-    [ uses>> ] 2dip curry find ; inline
-
-: interval-to-spill ( active-intervals current -- live-interval )
-    #! We spill the interval with the most distant use location.
-    start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
-    [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
-
 : assign-spill ( before after -- before after )
     #! If it has been spilled already, reuse spill location.
     over reload-from>>
@@ -39,8 +43,8 @@ IN: compiler.cfg.linear-scan.allocation.spilling
     #! with the most distant use location. Spill the existing
     #! interval, then process the new interval and the tail end
     #! of the existing interval again.
-    [ reuse-register ]
     [ nip delete-active ]
+    [ reg>> >>reg add-active ]
     [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
 
 : spill-new ( new existing -- )
@@ -50,10 +54,6 @@ IN: compiler.cfg.linear-scan.allocation.spilling
     #! again.
     [ dup split-and-spill add-unhandled ] dip spill-existing ;
 
-: spill-existing? ( new existing -- ? )
-    #! Test if 'new' will be used before 'existing'.
-    over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
-
 : assign-blocked-register ( new -- )
     [ dup vreg>> active-intervals-for ] keep interval-to-spill
     2dup spill-existing? [ spill-existing ] [ spill-new ] if ;

basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor

@@ -28,9 +28,7 @@ IN: compiler.cfg.linear-scan.allocation.splitting
     '[ _ <= ] partition ;
 
 : record-split ( live-interval before after -- )
-    [ >>split-next drop ]
+    [ >>split-before ] [ >>split-after ] bi* drop ; inline
-    [ [ >>split-before ] [ >>split-after ] bi* drop ]
-    2bi ; inline
 
 ERROR: splitting-too-early ;
 
@@ -59,62 +57,21 @@ ERROR: splitting-atomic-interval ;
 
 HINTS: split-interval live-interval object ;
 
-: reuse-register ( new existing -- )
+: split-between-blocks ( new n -- before after )
-    reg>> >>reg add-active ;
+    split-interval
-
+    2dup [ compute-start/end ] bi@ ;
-: relevant-ranges ( new inactive -- new' inactive' )
-    ! Slice off all ranges of 'inactive' that precede the start of 'new'
-    [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
-
-: intersect-live-range ( range1 range2 -- n/f )
-    2dup [ from>> ] bi@ > [ swap ] when
-    2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
-
-: intersect-live-ranges ( ranges1 ranges2 -- n )
-    {
-        { [ over empty? ] [ 2drop 1/0. ] }
-        { [ dup empty? ] [ 2drop 1/0. ] }
-        [
-            2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
-                drop
-                2dup [ first from>> ] bi@ <
-                [ [ rest-slice ] dip ] [ rest-slice ] if
-                intersect-live-ranges
-            ] if
-        ]
-    } cond ;
-
-: intersect-inactive ( new inactive active-regs -- n/f )
-    ! If the interval's register is currently in use, we cannot
-    ! re-use it.
-    2dup [ reg>> ] dip key?
-    [ 3drop f ] [ drop relevant-ranges intersect-live-ranges ] if ;
-
-: intersecting-inactive ( new -- live-intervals )
-    dup vreg>>
-    [ inactive-intervals-for ]
-    [ active-intervals-for [ reg>> ] map unique ] bi
-    '[ tuck _ intersect-inactive ] with { } map>assoc
-    [ nip ] assoc-filter ;
 
 : insert-use-for-copy ( seq n -- seq' )
-    [ 1array split1 ] keep [ 1 - ] keep 2array glue ;
+    dup 1 + [ nip 1array split1 ] 2keep 2array glue ;
 
 : split-before-use ( new n -- before after )
     ! Find optimal split position
     ! Insert move instruction
-    [ '[ _ insert-use-for-copy ] change-uses ] keep
+    1 -
-    1 - split-interval
+    2dup swap covers? [
-    2dup [ compute-start/end ] bi@ ;
+        [ '[ _ insert-use-for-copy ] change-uses ] keep
-
+        split-between-blocks
-: assign-inactive-register ( new live-intervals -- )
+        2dup >>split-next drop
-    ! If there is an interval which is inactive for the entire lifetime
-    ! if the new interval, reuse its vreg. Otherwise, split new so that
-    ! the first half fits.
-    sort-values last
-    2dup [ end>> ] [ second ] bi* < [
-        first reuse-register
     ] [
-        [ second split-before-use ] keep
+        split-between-blocks
-        '[ _ first reuse-register ] [ add-unhandled ] bi*
     ] if ;

basis/compiler/cfg/linear-scan/allocation/state/state.factor

@@ -6,13 +6,7 @@ compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.allocation.state
 
 ! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
+SYMBOL: registers
-
-: free-registers-for ( vreg -- seq )
-    reg-class>> free-registers get at ;
-
-: deallocate-register ( live-interval -- )
-    [ reg>> ] [ vreg>> ] bi free-registers-for push ;
 
 ! Vector of active live intervals
 SYMBOL: active-intervals
@@ -47,7 +41,7 @@ SYMBOL: handled-intervals
 : finished? ( n live-interval -- ? ) end>> swap < ;
 
 : finish ( n live-interval -- keep? )
-    nip [ deallocate-register ] [ add-handled ] bi f ;
+    nip add-handled f ;
 
 SYMBOL: check-allocation?
 
@@ -121,7 +115,7 @@ SYMBOL: spill-counts
     spill-counts get [ dup 1 + ] change-at ;
 
 : init-allocator ( registers -- )
-    [ reverse >vector ] assoc-map free-registers set
+    registers set
     [ 0 ] reg-class-assoc spill-counts set
     <min-heap> unhandled-intervals set
     [ V{ } clone ] reg-class-assoc active-intervals set

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -102,7 +102,9 @@ M: vreg-insn assign-registers-in-insn
     >>regs drop ;
 
 : compute-live-registers ( insn -- regs )
-    active-intervals register-mapping ;
+    [ active-intervals ] [ temp-vregs ] bi
+    '[ vreg>> _ memq? not ] filter
+    register-mapping ;
 
 : compute-live-spill-slots ( -- spill-slots )
     spill-slots get values [ values ] map concat

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -79,7 +79,7 @@ check-allocation? on
         { end 10 }
         { uses V{ 0 1 3 7 10 } }
     }
-    4 [ >= ] find-use nip
+    4 [ >= ] find-use
 ] unit-test
 
 [ 4 ] [
@@ -89,7 +89,7 @@ check-allocation? on
         { end 10 }
         { uses V{ 0 1 3 4 10 } }
     }
-    4 [ >= ] find-use nip
+    4 [ >= ] find-use
 ] unit-test
 
 [ f ] [
@@ -99,7 +99,7 @@ check-allocation? on
         { end 10 }
         { uses V{ 0 1 3 4 10 } }
     }
-    100 [ >= ] find-use nip
+    100 [ >= ] find-use
 ] unit-test
 
 [
@@ -1324,7 +1324,7 @@ USING: math.private compiler.cfg.debugger ;
 
 ! Spill slot liveness was computed incorrectly, leading to a FEP
 ! early in bootstrap on x86-32
-[ t ] [
+[ t t ] [
     [
         H{ } clone live-ins set
         H{ } clone live-outs set
@@ -1349,7 +1349,9 @@ USING: math.private compiler.cfg.debugger ;
              }
            }
         } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
-        instructions>> first live-spill-slots>> empty?
+        instructions>> first
+        [ live-spill-slots>> empty? ]
+        [ live-registers>> empty? ] bi
     ] with-scope
 ] unit-test
 
@@ -1410,7 +1412,6 @@ USING: math.private compiler.cfg.debugger ;
        { uses { 5 10 } }
        { ranges V{ T{ live-range f 5 10 } } }
     }
-    H{ }
     intersect-inactive
 ] unit-test
 

basis/compiler/utilities/utilities.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private arrays vectors fry
-math.order namespaces assocs ;
+math math.order namespaces assocs ;
 IN: compiler.utilities
 
 : flattener ( seq quot -- seq vector quot' )
@@ -25,3 +25,6 @@ IN: compiler.utilities
 SYMBOL: yield-hook
 
 yield-hook [ [ ] ] initialize
+
+: alist-max ( alist -- pair )
+    [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;

basis/generalizations/generalizations-tests.factor

@@ -67,3 +67,8 @@ IN: generalizations.tests
 [ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test
 
 [ 15 3 ] [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test
+
+: nover-test ( -- a b c d e f g )
+   1 2 3 4 3 nover ;
+
+[ 1 2 3 4 1 2 3 ] [ nover-test ] unit-test

basis/generalizations/generalizations.factor

@@ -40,7 +40,7 @@ MACRO: npick ( n -- )
     1- [ dup ] [ '[ _ dip swap ] ] repeat ;
 
 MACRO: nover ( n -- )
-    dup '[ _ 1 + npick ] n*quot ;
+    dup 1 + '[ _ npick ] n*quot ;
 
 MACRO: ndup ( n -- )
     dup '[ _ npick ] n*quot ;

basis/models/range/range-docs.factor

@@ -7,7 +7,7 @@ HELP: range
 { $notes { $link "ui.gadgets.sliders" } " use range models." } ;
 
 HELP: <range>
-{ $values { "value" real } { "page" real } { "min" real } { "max" real } { "range" range } }
+{ $values { "value" real } { "page" real } { "min" real } { "max" real } { "step" real } { "range" range } }
 { $description "Creates a new " { $link range } " model." } ;
 
 HELP: range-model

basis/serialize/serialize.factor

@@ -12,7 +12,7 @@ vectors byte-arrays quotations hashtables assocs help.syntax
 help.markup splitting io.streams.byte-array io.encodings.string
 io.encodings.utf8 io.encodings.binary combinators accessors
 locals prettyprint compiler.units sequences.private
-classes.tuple.private ;
+classes.tuple.private vocabs.loader ;
 IN: serialize
 
 GENERIC: (serialize) ( obj -- )
@@ -202,7 +202,7 @@ SYMBOL: deserialized
     (deserialize-string) dup intern-object ;
 
 : deserialize-word ( -- word )
-    (deserialize) (deserialize) 2dup lookup
+    (deserialize) (deserialize) 2dup [ require ] keep lookup
     dup [ 2nip ] [
         drop
         2array unparse "Unknown word: " prepend throw

extra/histogram/histogram-docs.factor

@@ -8,7 +8,7 @@ HELP: histogram
 }
 { $examples 
     { $example "! Count the number of times an element appears in a sequence."
-               "USING: prettyprint sets ;"
+               "USING: prettyprint histogram ;"
                "\"aaabc\" histogram ."
                "H{ { 97 3 } { 98 1 } { 99 1 } }"
     }
@@ -22,7 +22,7 @@ HELP: histogram*
 }
 { $examples 
     { $example "! Count the number of times the elements of two sequences appear."
-               "USING: prettyprint sets ;"
+               "USING: prettyprint histogram ;"
                "\"aaabc\" histogram \"aaaaaabc\" histogram* ."
                "H{ { 97 9 } { 98 2 } { 99 2 } }"
     }
@@ -36,7 +36,7 @@ HELP: sequence>assoc
 }
 { $examples 
     { $example "! Iterate over a sequence and increment the count at each element"
-               "USING: assocs prettyprint sets ;"
+               "USING: assocs prettyprint histogram ;"
                "\"aaabc\" [ inc-at ] H{ } sequence>assoc ."
                "H{ { 97 3 } { 98 1 } { 99 1 } }"
     }
@@ -50,7 +50,7 @@ HELP: sequence>assoc*
 }
 { $examples 
     { $example "! Iterate over a sequence and add the counts to an existing assoc"
-               "USING: assocs prettyprint sets kernel ;"
+               "USING: assocs prettyprint histogram kernel ;"
                "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."
                "H{ { 97 5 } { 98 2 } { 99 1 } }"
     }
@@ -64,7 +64,7 @@ HELP: sequence>hashtable
 }
 { $examples 
     { $example "! Count the number of times an element occurs in a sequence"
-               "USING: assocs prettyprint sets ;"
+               "USING: assocs prettyprint histogram ;"
                "\"aaabc\" [ inc-at ] sequence>hashtable ."
                "H{ { 97 3 } { 98 1 } { 99 1 } }"
     }

extra/robots/robots.factor

@@ -1,15 +1,18 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors http.client kernel unicode.categories
+USING: accessors arrays assocs calendar.format combinators
-sequences urls splitting combinators splitting.monotonic
+combinators.short-circuit fry globs http.client kernel make
-combinators.short-circuit assocs unicode.case arrays
+math.parser multiline namespaces present regexp
-math.parser calendar.format make fry present globs
+regexp.combinators sequences sets splitting splitting.monotonic
-multiline regexp.combinators regexp ;
+unicode.case unicode.categories urls ;
 IN: robots
 
 ! visit-time is GMT, request-rate is pages/second 
 ! crawl-rate is seconds
 
+SYMBOL: robot-identities
+robot-identities [ { "FactorSpider" } ] initialize
+
 TUPLE: robots site sitemap rules rules-quot ;
 
 : <robots> ( site sitemap rules -- robots )
@@ -80,6 +83,13 @@ visit-time request-rate crawl-delay unknowns ;
         derive-urls [ <glob> ] map <and> <not>
     ] bi 2array <or> '[ _ matches? ] ;
 
+: relevant-rules ( robots -- rules )
+    [
+        user-agents>> [
+            robot-identities get [ swap glob-matches? ] with any?
+        ] any?
+    ] filter ;
+
 PRIVATE>
 
 : parse-robots.txt ( string -- sitemaps rules-seq )

extra/tokyo/alien/tctdb/tctdb.factor

@@ -76,7 +76,7 @@ FUNCTION: void tctdbdel ( TCTDB* tdb ) ;
 FUNCTION: int tctdbecode ( TCTDB* tdb ) ;
 FUNCTION: bool tctdbsetmutex ( TCTDB* tdb ) ;
 FUNCTION: bool tctdbtune ( TCTDB* tdb, longlong bnum, char apow, char fpow, uchar opts ) ;
-FUNCTION: bool tctdbsetcache ( TCTDB* tdb, int32_t rcnum, int32_t lcnum, int32_t ncnum ) ;
+FUNCTION: bool tctdbsetcache ( TCTDB* tdb, int rcnum, int lcnum, int ncnum ) ;
 FUNCTION: bool tctdbsetxmsiz ( TCTDB* tdb, longlong xmsiz ) ;
 FUNCTION: bool tctdbopen ( TCTDB* tdb, char* path, int omode ) ;
 FUNCTION: bool tctdbclose ( TCTDB* tdb ) ;