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

basis/bootstrap/help/help.factor

@@ -4,6 +4,7 @@ parser vocabs.loader vocabs.loader.private accessors assocs ;
 IN: bootstrap.help
 
 : load-help ( -- )
+    "help.lint" require
     "alien.syntax" require
     "compiler" require
 

basis/db/tester/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Doug Coleman

basis/db/tester/tester-tests.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db.tester ;
+IN: db.tester.tests
+
+[ ] [ sqlite-test-db db-tester ] unit-test
+[ ] [ sqlite-test-db db-tester2 ] unit-test

basis/db/tester/tester.factor

@@ -0,0 +1,57 @@
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.combinators db.pools db.sqlite db.tuples
+db.types kernel math random threads tools.test db sequences
+io prettyprint ;
+IN: db.tester
+
+TUPLE: test-1 id a b c ;
+
+test-1 "TEST1" {
+   { "id" "ID" INTEGER +db-assigned-id+ }
+   { "a" "A" { VARCHAR 256 } +not-null+ }
+   { "b" "B" { VARCHAR 256 } +not-null+ }
+   { "c" "C" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+TUPLE: test-2 id x y z ;
+
+test-2 "TEST2" {
+   { "id" "ID" INTEGER +db-assigned-id+ }
+   { "x" "X" { VARCHAR 256 } +not-null+ }
+   { "y" "Y" { VARCHAR 256 } +not-null+ }
+   { "z" "Z" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
+: test-db ( -- db ) "test.db" <sqlite-db> ;
+
+: db-tester ( test-db -- )
+    [
+        [
+            test-1 ensure-table
+            test-2 ensure-table
+        ] with-db
+    ] [
+        10 [
+            drop
+            10 [
+                dup [
+                    f 100 random 100 random 100 random test-1 boa
+                    insert-tuple yield
+                ] with-db
+            ] times
+        ] with parallel-each
+    ] bi ;
+
+: db-tester2 ( test-db -- )
+    [
+        [ test-1 recreate-table ] with-db
+    ] [
+        [
+            2 [
+                    10 random 100 random 100 random 100 random test-1 boa
+                    insert-tuple yield
+            ] parallel-each
+        ] with-db
+    ] bi ;

basis/grouping/grouping-docs.factor

@@ -49,7 +49,7 @@ HELP: <groups>
     }
     { $example
         "USING: kernel prettyprint sequences grouping ;"
-        "{ 1 2 3 4 5 6 } 3 <groups> 0 swap nth ."
+        "{ 1 2 3 4 5 6 } 3 <groups> first ."
         "{ 1 2 3 }"
     }
 } ;
@@ -66,7 +66,7 @@ HELP: <sliced-groups>
     }
     { $example
         "USING: kernel prettyprint sequences grouping ;"
-        "{ 1 2 3 4 5 6 } 3 <sliced-groups> 1 swap nth ."
+        "{ 1 2 3 4 5 6 } 3 <sliced-groups> second ."
         "T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }"
     }
 } ;

basis/sorting/human/human-docs.factor

@@ -0,0 +1,71 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel math.order quotations
+sequences strings ;
+IN: sorting.human
+
+HELP: find-numbers
+{ $values
+     { "string" string }
+     { "seq" sequence }
+}
+{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ;
+
+HELP: human-<=>
+{ $values
+     { "obj1" object } { "obj2" object }
+     { "<=>" "an ordering specifier" }
+}
+{ $description "Compares two objects after converting numbers in the string into integers." } ;
+
+HELP: human->=<
+{ $values
+     { "obj1" object } { "obj2" object }
+     { ">=<" "an ordering specifier" }
+}
+{ $description "Compares two objects using the " { $link human-<=> } " word and inverts the result." } ;
+
+HELP: human-compare
+{ $values
+     { "obj1" object } { "obj2" object } { "quot" quotation }
+     { "<=>" "an ordering specifier" }
+}
+{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
+
+HELP: human-sort
+{ $values
+     { "seq" sequence }
+     { "seq'" sequence }
+}
+{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
+
+HELP: human-sort-keys
+{ $values
+     { "seq" "an alist" }
+     { "sortedseq" "a new sorted sequence" }
+}
+{ $description "Sorts the elements comparing first elements of pairs using the " { $link human-<=> } " word." } ;
+
+HELP: human-sort-values
+{ $values
+     { "seq" "an alist" }
+     { "sortedseq" "a new sorted sequence" }
+}
+{ $description "Sorts the elements comparing second elements of pairs using the " { $link human-<=> } " word." } ;
+
+{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
+
+ARTICLE: "sorting.human" "sorting.human"
+"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
+"Comparing two objects:"
+{ $subsection human-<=> }
+{ $subsection human->=< }
+{ $subsection human-compare }
+"Sort a sequence:"
+{ $subsection human-sort }
+{ $subsection human-sort-keys }
+{ $subsection human-sort-values }
+"Splitting a string into substrings and integers:"
+{ $subsection find-numbers } ;
+
+ABOUT: "sorting.human"

basis/sorting/human/human.factor

@@ -1,10 +1,22 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: peg.ebnf math.parser kernel assocs sorting ;
+USING: peg.ebnf math.parser kernel assocs sorting fry
+math.order sequences ascii splitting.monotonic ;
 IN: sorting.human
 
 : find-numbers ( string -- seq )
     [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
 
-: human-sort ( seq -- seq' )
-    [ dup find-numbers ] { } map>assoc sort-values keys ;
+: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
+
+: human->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline
+
+: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ;
+
+: human-sort ( seq -- seq' ) [ human-<=> ] sort ;
+
+: human-sort-keys ( seq -- sortedseq )
+    [ [ first ] human-compare ] sort ;
+
+: human-sort-values ( seq -- sortedseq )
+    [ [ second ] human-compare ] sort ;

basis/sorting/slots/authors.txt

@@ -0,0 +1,2 @@
+Doug Coleman
+Slava Pestov

basis/sorting/slots/slots-docs.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations math.order
+sequences ;
+IN: sorting.slots
+
+HELP: compare-slots
+{ $values
+     { "sort-specs" "a sequence of accessor/comparator pairs" }
+     { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
+}
+{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
+
+HELP: sort-by-slots
+{ $values
+     { "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" }
+     { "seq'" sequence }
+}
+{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." }
+{ $examples
+    "Sort by slot c, then b descending:"
+    { $example
+        "USING: accessors math.order prettyprint sorting.slots ;"
+        "IN: scratchpad"
+        "TUPLE: sort-me a b ;"
+        "{"
+        "    T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
+        "    T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
+        "}"
+        "{ { a>> <=> } { b>> >=< } } sort-by-slots ."
+        "{\n    T{ sort-me { a 2 } { b 3 } }\n    T{ sort-me { a 2 } { b 1 } }\n    T{ sort-me { a 3 } { b 2 } }\n    T{ sort-me { a 4 } { b 3 } }\n}"
+    }
+} ;
+
+ARTICLE: "sorting.slots" "Sorting by slots"
+"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
+"Comparing two objects by a sequence of slots:"
+{ $subsection compare-slots }
+"Sorting a sequence by a sequence of slots:"
+{ $subsection sort-by-slots } ;
+
+ABOUT: "sorting.slots"

basis/sorting/slots/slots-tests.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.order sorting.slots tools.test
+sorting.human ;
+IN: sorting.literals.tests
+
+TUPLE: sort-test a b c ;
+
+[
+    {
+        T{ sort-test { a 1 } { b 3 } { c 9 } }
+        T{ sort-test { a 1 } { b 1 } { c 10 } }
+        T{ sort-test { a 1 } { b 1 } { c 11 } }
+        T{ sort-test { a 2 } { b 5 } { c 2 } }
+        T{ sort-test { a 2 } { b 5 } { c 3 } }
+    }
+] [
+    {
+        T{ sort-test f 1 3 9 }
+        T{ sort-test f 1 1 10 }
+        T{ sort-test f 1 1 11 }
+        T{ sort-test f 2 5 3 }
+        T{ sort-test f 2 5 2 }
+    } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+] unit-test
+
+[
+    {
+        T{ sort-test { a 1 } { b 3 } { c 9 } }
+        T{ sort-test { a 1 } { b 1 } { c 10 } }
+        T{ sort-test { a 1 } { b 1 } { c 11 } }
+        T{ sort-test { a 2 } { b 5 } { c 2 } }
+        T{ sort-test { a 2 } { b 5 } { c 3 } }
+    }
+] [
+    {
+        T{ sort-test f 1 3 9 }
+        T{ sort-test f 1 1 10 }
+        T{ sort-test f 1 1 11 }
+        T{ sort-test f 2 5 3 }
+        T{ sort-test f 2 5 2 }
+    } { { a>> human-<=> } { b>> human->=< } { c>> <=> } } sort-by-slots
+] unit-test
+
+[
+    { }
+] [
+    { }
+    { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+] unit-test

basis/sorting/slots/slots.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit fry kernel macros math.order
+sequences words sorting ;
+IN: sorting.slots
+
+<PRIVATE
+
+: slot-comparator ( accessor comparator -- quot )
+    '[ [ _ execute ] bi@ _ execute dup +eq+ eq? [ drop f ] when ] ;
+
+PRIVATE>
+
+MACRO: compare-slots ( sort-specs -- <=> )
+    #! sort-spec: { accessor comparator }
+    [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+
+: sort-by-slots ( seq sort-specs -- seq' )
+    '[ _ compare-slots ] sort ;

basis/splitting/monotonic/monotonic-docs.factor

@@ -0,0 +1,109 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations classes sequences
+multiline ;
+IN: splitting.monotonic
+
+HELP: monotonic-slice
+{ $values
+     { "seq" sequence } { "quot" quotation } { "class" class }
+     { "slices" "a sequence of slices" }
+}
+{ $description "Monotonically splits a sequence into slices of the type " { $snippet "class" } "." }
+{ $examples
+    { $example
+        "USING: splitting.monotonic math prettyprint ;"
+        "{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ."
+        <" {
+    T{ upward-slice
+        { from 0 }
+        { to 3 }
+        { seq { 1 2 3 2 3 4 } }
+    }
+    T{ upward-slice
+        { from 3 }
+        { to 6 }
+        { seq { 1 2 3 2 3 4 } }
+    }
+}">
+    }
+} ;
+
+HELP: monotonic-split
+{ $values
+     { "seq" sequence } { "quot" quotation }
+     { "newseq" "a sequence of sequences" }
+}
+{ $description "Compares pairs of elements in a sequence and collects elements into sequences while they satisfy the predicate. Once the predicate fails, a new sequence is started, and all sequences are returned in a single sequence." }
+{ $examples
+    { $example
+        "USING: splitting.monotonic math prettyprint ;"
+        "{ 1 2 3 2 3 4 } [ < ] monotonic-split ."
+        "{ V{ 1 2 3 } V{ 2 3 4 } }"
+    }
+} ;
+
+HELP: downward-slices
+{ $values
+     { "seq" sequence }
+     { "slices" "a sequence of downward-slices" }
+}
+{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: stable-slices
+{ $values
+    { "seq" sequence }
+    { "slices" "a sequence of stable-slices" }
+}
+{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: upward-slices
+{ $values
+    { "seq" sequence }
+    { "slices" "a sequence of upward-slices" }
+}
+{ $description "Returns an array of monotonically increasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: trends
+{ $values
+    { "seq" sequence }
+    { "slices" "a sequence of downward, stable, and upward slices" }
+}
+{ $description "Returns a sorted sequence of downward, stable, or upward slices. The endpoints of some slices may overlap with each other." }
+{ $examples
+    { $example
+        "USING: splitting.monotonic math prettyprint ;"
+        "{ 1 2 3 3 2 1 } trends ."
+        <" {
+    T{ upward-slice
+        { from 0 }
+        { to 3 }
+        { seq { 1 2 3 3 2 1 } }
+    }
+    T{ stable-slice
+        { from 2 }
+        { to 4 }
+        { seq { 1 2 3 3 2 1 } }
+    }
+    T{ downward-slice
+        { from 3 }
+        { to 6 }
+        { seq { 1 2 3 3 2 1 } }
+    }
+}">
+    }
+} ;
+
+ARTICLE: "splitting.monotonic" "Splitting trending sequences"
+"The " { $vocab-link "splitting.monotonic" } " vocabulary splits sequences that are trending downwards, upwards, or stably." $nl
+"Splitting into sequences:"
+{ $subsection monotonic-split }
+"Splitting into slices:"
+{ $subsection monotonic-slice }
+"Trending:"
+{ $subsection downward-slices }
+{ $subsection stable-slices }
+{ $subsection upward-slices }
+{ $subsection trends } ;
+
+ABOUT: "splitting.monotonic"

basis/splitting/monotonic/monotonic-tests.factor

@@ -6,3 +6,48 @@ USING: tools.test math arrays kernel sequences ;
 [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
 [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
 
+[ { } ]
+[ { } [ = ] slice monotonic-slice ] unit-test
+
+[ t ]
+[ { 1 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
+
+[ { { 1 } } ]
+[ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[ t ]
+[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
+
+[ { { 1 1 1 } { 2 2 } { 3 3 } { 4 } } ]
+[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[ { { 3 3 } } ]
+[ { 3 3 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[
+    {
+        T{ upward-slice { from 0 } { to 3 } { seq { 1 2 3 2 1 } } }
+        T{ downward-slice { from 2 } { to 5 } { seq { 1 2 3 2 1 } } }
+    }
+]
+[ { 1 2 3 2 1 } trends ] unit-test
+
+[
+    {
+        T{ upward-slice
+            { from 0 }
+            { to 3 }
+            { seq { 1 2 3 3 2 1 } }
+        }
+        T{ stable-slice
+            { from 2 }
+            { to 4 }
+            { seq { 1 2 3 3 2 1 } }
+        }
+        T{ downward-slice
+            { from 3 }
+            { to 6 }
+            { seq { 1 2 3 3 2 1 } }
+        }
+    }
+] [ { 1 2 3 3 2 1 } trends ] unit-test

basis/splitting/monotonic/monotonic.factor

@@ -1,8 +1,11 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: make namespaces sequences kernel fry ;
+USING: make namespaces sequences kernel fry arrays compiler.utilities
+math accessors circular grouping combinators sorting math.order ;
 IN: splitting.monotonic
 
+<PRIVATE
+
 : ,, ( obj -- ) building get peek push ;
 : v, ( -- ) V{ } clone , ;
 : ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
@@ -13,5 +16,52 @@ IN: splitting.monotonic
         v, '[ over ,, @ [ v, ] unless ] 2each ,v
     ] { } make ; inline
 
+PRIVATE>
+
 : monotonic-split ( seq quot -- newseq )
     over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline
+
+<PRIVATE
+
+: (monotonic-slice) ( seq quot class -- slices )
+    -rot
+    dupd '[
+        [ length ] [ ] [ <circular> 1 over change-circular-start ] tri
+        [ @ not [ , ] [ drop ] if ] 3each
+    ] { } make
+    dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
+    [ first2 [ 1+ ] bi@ rot roll boa ] with with map ; inline
+
+PRIVATE>
+
+: monotonic-slice ( seq quot class -- slices )
+    pick length {
+        { 0 [ 2drop ] }
+        { 1 [ nip [ 0 1 rot ] dip boa 1array ] }
+        [ drop (monotonic-slice) ]
+    } case ;
+
+TUPLE: downward-slice < slice ;
+TUPLE: stable-slice < slice ;
+TUPLE: upward-slice < slice ;
+
+: downward-slices ( seq -- slices )
+    [ > ] downward-slice monotonic-slice [ length 1 > ] filter ;
+
+: stable-slices ( seq -- slices )
+    [ = ] stable-slice monotonic-slice [ length 1 > ] filter ;
+
+: upward-slices ( seq -- slices )
+    [ < ] upward-slice monotonic-slice [ length 1 > ] filter ;
+
+: trends ( seq -- slices )
+    dup length {
+        { 0 [ ] }
+        { 1 [ [ 0 1 ] dip stable-slice boa ] }
+        [
+            drop
+            [ downward-slices ]
+            [ stable-slices ]
+            [ upward-slices ] tri 3append [ [ from>> ] compare ] sort
+        ]
+    } case ;

basis/tools/files/files.factor

@@ -5,6 +5,8 @@ io.directories kernel math.parser sequences system vocabs.loader
 calendar math fry prettyprint ;
 IN: tools.files
 
+SYMBOLS: permissions file-name nlinks file-size date ;
+
 <PRIVATE
 
 : ls-time ( timestamp -- string )

basis/tools/files/unix/unix.factor

@@ -3,9 +3,12 @@
 USING: accessors combinators kernel system unicode.case io.files
 io.files.info io.files.info.unix tools.files generalizations
 strings arrays sequences math.parser unix.groups unix.users
-tools.files.private unix.stat math ;
+tools.files.private unix.stat math fry macros ;
 IN: tools.files.unix
 
+MACRO: cleave>array ( array -- quot )
+    dup length '[ _ cleave _ narray ] ;
+
 <PRIVATE
 
 : unix-execute>string ( str bools -- str' )
@@ -28,7 +31,7 @@ IN: tools.files.unix
         [ other-read? read>string ]
         [ other-write? write>string ]
         [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
-    } cleave 10 narray concat ;
+    } cleave>array concat ;
 
 : mode>symbol ( mode -- ch )
     S_IFMT bitand
@@ -49,11 +52,11 @@ M: unix (directory.) ( path -- lines )
             {
                 [ permissions-string ]
                 [ nlink>> number>string 3 CHAR: \s pad-left ]
-                ! [ uid>> ]
-                ! [ gid>> ]
+                [ uid>> user-name ]
+                [ gid>> group-name ]
                 [ size>> number>string 15 CHAR: \s pad-left ]
                 [ modified>> ls-timestamp ]
-            } cleave 4 narray swap suffix " " join
+            } cleave>array swap suffix " " join
         ] map
     ] with-group-cache ] with-user-cache ;
 

basis/unix/groups/groups-tests.factor

@@ -3,7 +3,6 @@
 USING: tools.test unix.groups kernel strings math ;
 IN: unix.groups.tests
 
-
 [ ] [ all-groups drop ] unit-test
 
 \ all-groups must-infer
@@ -24,3 +23,7 @@ IN: unix.groups.tests
 [ ] [ effective-group-id [ ] with-effective-group ] unit-test
 
 [ ] [ [ ] with-group-cache ] unit-test
+
+[ ] [ real-group-id group-name drop ] unit-test
+
+[ "888888888888888" ] [ 888888888888888 group-name ] unit-test

basis/unix/groups/groups.factor

@@ -43,7 +43,7 @@ PRIVATE>
 
 : group-name ( id -- string )
     dup group-cache get [
-        at
+        dupd at* [ name>> nip ] [ drop number>string ] if
     ] [
         group-struct group-gr_name
     ] if*
@@ -71,7 +71,7 @@ M: string user-groups ( string -- seq )
     (user-groups) ; 
 
 M: integer user-groups ( id -- seq )
-    username (user-groups) ;
+    user-name (user-groups) ;
     
 : all-groups ( -- seq )
     [ getgrent dup ] [ group-struct>group ] [ drop ] produce ;

basis/unix/users/users-docs.factor

@@ -7,13 +7,13 @@ HELP: all-users
 { $values { "seq" sequence } }
 { $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
 
-HELP: effective-username
+HELP: effective-user-name
 { $values { "string" string } }
-{ $description "Returns the effective username for the current user." } ;
+{ $description "Returns the effective user-name for the current user." } ;
 
 HELP: effective-user-id
 { $values { "id" integer } }
-{ $description "Returns the effective username id for the current user." } ;
+{ $description "Returns the effective user-name id for the current user." } ;
 
 HELP: new-passwd
 { $values { "passwd" passwd } }
@@ -31,9 +31,9 @@ HELP: passwd>new-passwd
      { "new-passwd" "a passwd tuple" } }
 { $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
 
-HELP: real-username
+HELP: real-user-name
 { $values { "string" string } }
-{ $description "The real username of the current user." } ;
+{ $description "The real user-name of the current user." } ;
 
 HELP: real-user-id
 { $values { "id" integer } }
@@ -41,34 +41,34 @@ HELP: real-user-id
 
 HELP: set-effective-user
 { $values { "string/id" "a string or a user id" } }
-{ $description "Sets the current effective user given a username or a user id." } ;
+{ $description "Sets the current effective user given a user-name or a user id." } ;
 
 HELP: set-real-user
 { $values { "string/id" "a string or a user id" } }
-{ $description "Sets the current real user given a username or a user id." } ;
+{ $description "Sets the current real user given a user-name or a user id." } ;
 
 HELP: user-passwd
 { $values
      { "obj" object }
      { "passwd/f" "passwd or f" } }
-{ $description "Returns the passwd tuple given a username string or user id." } ;
+{ $description "Returns the passwd tuple given a user-name string or user id." } ;
 
-HELP: username
+HELP: user-name
 { $values
      { "id" integer }
      { "string" string } }
-{ $description "Returns the username associated with the user id." } ;
+{ $description "Returns the user-name associated with the user id." } ;
 
 HELP: user-id
 { $values
      { "string" string }
      { "id" integer } }
-{ $description "Returns the user id associated with the username." } ;
+{ $description "Returns the user id associated with the user-name." } ;
 
 HELP: with-effective-user
 { $values
      { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
+{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
 
 HELP: with-user-cache
 { $values
@@ -78,11 +78,11 @@ HELP: with-user-cache
 HELP: with-real-user
 { $values
      { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the real username and calls the quotation. Restores the current username on success or on error after the call." } ;
+{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
 
 {
-    real-username real-user-id set-real-user
-    effective-username effective-user-id          
+    real-user-name real-user-id set-real-user
+    effective-user-name effective-user-id          
     set-effective-user
 } related-words
 
@@ -93,11 +93,11 @@ $nl
 { $subsection all-users }
 "Returning a passwd tuple:"
 "Real user:"
-{ $subsection real-username }
+{ $subsection real-user-name }
 { $subsection real-user-id }
 { $subsection set-real-user }
 "Effective user:"
-{ $subsection effective-username }
+{ $subsection effective-user-name }
 { $subsection effective-user-id }
 { $subsection set-effective-user }
 "Combinators to change users:"

basis/unix/users/users-tests.factor

@@ -8,8 +8,8 @@ IN: unix.users.tests
 
 \ all-users must-infer
 
-[ t ] [ real-username string? ] unit-test
-[ t ] [ effective-username string? ] unit-test
+[ t ] [ real-user-name string? ] unit-test
+[ t ] [ effective-user-name string? ] unit-test
 
 [ t ] [ real-user-id integer? ] unit-test
 [ t ] [ effective-user-id integer? ] unit-test
@@ -17,14 +17,14 @@ IN: unix.users.tests
 [ ] [ real-user-id set-real-user ] unit-test
 [ ] [ effective-user-id set-effective-user ] unit-test
 
-[ ] [ real-username [ ] with-real-user ] unit-test
+[ ] [ real-user-name [ ] with-real-user ] unit-test
 [ ] [ real-user-id [ ] with-real-user ] unit-test
 
-[ ] [ effective-username [ ] with-effective-user ] unit-test
+[ ] [ effective-user-name [ ] with-effective-user ] unit-test
 [ ] [ effective-user-id [ ] with-effective-user ] unit-test
 
 [ ] [ [ ] with-user-cache ] unit-test
 
-[ "9999999999999999999" ] [ 9999999999999999999 username ] unit-test
+[ "9999999999999999999" ] [ 9999999999999999999 user-name ] unit-test
 
 [ f ] [ 89898989898989898989898989898 user-passwd ] unit-test

basis/unix/users/users.factor

@@ -7,7 +7,7 @@ accessors math.parser fry assocs namespaces continuations
 vocabs.loader system ;
 IN: unix.users
 
-TUPLE: passwd username password uid gid gecos dir shell ;
+TUPLE: passwd user-name password uid gid gecos dir shell ;
 
 HOOK: new-passwd os ( -- passwd )
 HOOK: passwd>new-passwd os ( passwd -- new-passwd )
@@ -20,7 +20,7 @@ M: unix new-passwd ( -- passwd )
 M: unix passwd>new-passwd ( passwd -- seq )
     [ new-passwd ] dip
     {
-        [ passwd-pw_name >>username ]
+        [ passwd-pw_name >>user-name ]
         [ passwd-pw_passwd >>password ]
         [ passwd-pw_uid >>uid ]
         [ passwd-pw_gid >>gid ]
@@ -56,9 +56,9 @@ M: integer user-passwd ( id -- passwd/f )
 M: string user-passwd ( string -- passwd/f )
     getpwnam dup [ passwd>new-passwd ] when ;
 
-: username ( id -- string )
+: user-name ( id -- string )
     dup user-passwd
-    [ nip username>> ] [ number>string ] if* ;
+    [ nip user-name>> ] [ number>string ] if* ;
 
 : user-id ( string -- id )
     user-passwd uid>> ;
@@ -66,14 +66,14 @@ M: string user-passwd ( string -- passwd/f )
 : real-user-id ( -- id )
     getuid ; inline
 
-: real-username ( -- string )
-    real-user-id username ; inline
+: real-user-name ( -- string )
+    real-user-id user-name ; inline
 
 : effective-user-id ( -- id )
     geteuid ; inline
 
-: effective-username ( -- string )
-    effective-user-id username ; inline
+: effective-user-name ( -- string )
+    effective-user-id user-name ; inline
 
 GENERIC: set-real-user ( string/id -- )
 

basis/values/values-docs.factor

@@ -15,7 +15,16 @@ ABOUT: "values"
 HELP: VALUE:
 { $syntax "VALUE: word" }
 { $values { "word" "a word to be created" } }
-{ $description "Creates a value on the given word, initializing it to hold " { $code f } ". To get the value, just run the word. To set it, use " { $link set-value } "." } ;
+{ $description "Creates a value on the given word, initializing it to hold " { $snippet "f" } ". To get the value, just run the word. To set it, use " { $link POSTPONE: to: } "." }
+{ $examples
+  { $example
+    "USING: values math prettyprint ;"
+    "VALUE: x"
+    "2 2 + to: x"
+    "x ."
+    "4"
+  }
+} ;
 
 HELP: get-value
 { $values { "word" "a value word" } { "value" "the contents" } }

core/math/order/order-docs.factor

@@ -15,6 +15,12 @@ HELP: <=>
     }
 } ;
 
+HELP: >=<
+{ $values { "obj1" object } { "obj2" object } { ">=<" "an ordering specifier" } }
+{ $description "Compares two objects using the " { $link <=> } " comparator and inverts the output." } ;
+
+{ <=> >=< } related-words
+
 HELP: +lt+
 { $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ;
 
@@ -85,6 +91,7 @@ ARTICLE: "order-specifiers" "Ordering specifiers"
 ARTICLE: "math.order" "Linear order protocol"
 "Some classes have an intrinsic order amongst instances:"
 { $subsection <=> }
+{ $subsection >=< }
 { $subsection compare }
 { $subsection invert-comparison }
 "The above words output order specifiers."

core/math/order/order.factor

@@ -13,6 +13,8 @@ SYMBOL: +gt+
 
 GENERIC: <=> ( obj1 obj2 -- <=> )
 
+: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
+
 M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
 
 GENERIC: before? ( obj1 obj2 -- ? )

misc/fuel/factor-mode.el

@@ -1,6 +1,6 @@
 ;;; factor-mode.el -- mode for editing Factor source
 
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -28,6 +28,14 @@
   :group 'fuel
   :group 'languages)
 
+(defcustom factor-mode-cycle-always-ask-p t
+  "Whether to always ask for file creation when cycling to a
+source/docs/tests file.
+
+When set to false, you'll be asked only once."
+  :type 'boolean
+  :group 'factor-mode)
+
 (defcustom factor-mode-use-fuel t
   "Whether to use the full FUEL facilities in factor mode.
 
@@ -174,33 +182,58 @@ code in the buffer."
 (defconst factor-mode--cycle-endings
   '(".factor" "-tests.factor" "-docs.factor"))
 
-(defconst factor-mode--regex-cycle-endings
-  (format "\\(.*?\\)\\(%s\\)$"
-          (regexp-opt factor-mode--cycle-endings)))
+(make-local-variable
+ (defvar factor-mode--cycling-no-ask nil))
 
-(defconst factor-mode--cycle-endings-ring
+(defvar factor-mode--cycle-ring
   (let ((ring (make-ring (length factor-mode--cycle-endings))))
     (dolist (e factor-mode--cycle-endings ring)
-      (ring-insert ring e))))
+      (ring-insert ring e))
+    ring))
+
+(defconst factor-mode--cycle-basename-regex
+  (format "\\(.+?\\)\\(%s\\)$" (regexp-opt factor-mode--cycle-endings)))
+
+(defun factor-mode--cycle-split (basename)
+  (when (string-match factor-mode--cycle-basename-regex basename)
+    (cons (match-string 1 basename) (match-string 2 basename))))
 
 (defun factor-mode--cycle-next (file)
-  (let* ((match (string-match factor-mode--regex-cycle-endings file))
-         (base (and match (match-string-no-properties 1 file)))
-         (ending (and match (match-string-no-properties 2 file)))
-         (idx (and ending (ring-member factor-mode--cycle-endings-ring ending)))
-         (gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i)))))
-    (if (not idx) file
-      (let ((l (length factor-mode--cycle-endings)) (i 1) next)
-        (while (and (not next) (< i l))
-          (when (file-exists-p (funcall gfl (+ idx i)))
-            (setq next (+ idx i)))
-          (setq i (1+ i)))
-        (funcall gfl (or next idx))))))
+  (let* ((dir (file-name-directory file))
+         (basename (file-name-nondirectory file))
+         (p/s (factor-mode--cycle-split basename))
+         (prefix (car p/s))
+         (ring factor-mode--cycle-ring)
+         (idx (or (ring-member ring (cdr p/s)) 0))
+         (len (ring-size ring))
+         (i 1)
+         (result nil))
+    (while (and (< i len) (not result))
+      (let* ((suffix (ring-ref ring (+ i idx)))
+             (path (expand-file-name (concat prefix suffix) dir)))
+        (when (or (file-exists-p path)
+                  (and (not (member suffix factor-mode--cycling-no-ask))
+                       (y-or-n-p (format "Create %s? " path))))
+          (setq result path))
+        (when (and (not factor-mode-cycle-always-ask-p)
+                   (not (member suffix factor-mode--cycling-no-ask)))
+          (setq factor-mode--cycling-no-ask
+                (cons name factor-mode--cycling-no-ask))))
+      (setq i (1+ i)))
+    result))
+
+(defsubst factor-mode--cycling-setup ()
+  (setq factor-mode--cycling-no-ask nil))
 
 (defun factor-mode-visit-other-file (&optional file)
   "Cycle between code, tests and docs factor files."
   (interactive)
-  (find-file (factor-mode--cycle-next (or file (buffer-file-name)))))
+  (let ((file (factor-mode--cycle-next (or file (buffer-file-name)))))
+    (unless file (error "No other file found"))
+    (find-file file)
+    (unless (file-exists-p file)
+      (set-buffer-modified-p t)
+      (save-buffer))))
 
 
 ;;; Keymap:
@@ -237,6 +270,7 @@ code in the buffer."
   (factor-mode--keymap-setup)
   (factor-mode--indentation-setup)
   (factor-mode--syntax-setup)
+  (factor-mode--cycling-setup)
   (when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode))
   (run-hooks 'factor-mode-hook))