diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor index 5b49ce2802..145738ff45 100644 --- a/basis/bootstrap/help/help.factor +++ b/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 diff --git a/basis/db/tester/authors.txt b/basis/db/tester/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/basis/db/tester/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/basis/db/tester/tester-tests.factor b/basis/db/tester/tester-tests.factor new file mode 100644 index 0000000000..6b39a7e218 --- /dev/null +++ b/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 diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor new file mode 100644 index 0000000000..4e53ad3df7 --- /dev/null +++ b/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" ; +: test-db ( -- db ) "test.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 ; diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index 1eff4820dd..b9af98d1f8 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -49,7 +49,7 @@ HELP: } { $example "USING: kernel prettyprint sequences grouping ;" - "{ 1 2 3 4 5 6 } 3 0 swap nth ." + "{ 1 2 3 4 5 6 } 3 first ." "{ 1 2 3 }" } } ; @@ -66,7 +66,7 @@ HELP: } { $example "USING: kernel prettyprint sequences grouping ;" - "{ 1 2 3 4 5 6 } 3 1 swap nth ." + "{ 1 2 3 4 5 6 } 3 second ." "T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }" } } ; diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor new file mode 100644 index 0000000000..5342b28317 --- /dev/null +++ b/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" diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index 1c2ba419c7..2c4d391a60 100644 --- a/basis/sorting/human/human.factor +++ b/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 ; diff --git a/basis/sorting/slots/authors.txt b/basis/sorting/slots/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/basis/sorting/slots/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor new file mode 100644 index 0000000000..64d0a1efdf --- /dev/null +++ b/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" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor new file mode 100644 index 0000000000..ab130d1eed --- /dev/null +++ b/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 diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor new file mode 100644 index 0000000000..02a11428f9 --- /dev/null +++ b/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 + + + +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 ; diff --git a/basis/splitting/monotonic/monotonic-docs.factor b/basis/splitting/monotonic/monotonic-docs.factor new file mode 100644 index 0000000000..983c5b0dea --- /dev/null +++ b/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" diff --git a/basis/splitting/monotonic/monotonic-tests.factor b/basis/splitting/monotonic/monotonic-tests.factor index ab4c48b292..7bf9a38e8a 100644 --- a/basis/splitting/monotonic/monotonic-tests.factor +++ b/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 diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 5bc7a51522..e39bba25ab 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/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 + + : monotonic-split ( seq quot -- newseq ) over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline + + 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 ; diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 3670891e41..e6ca02d5f9 100755 --- a/basis/tools/files/files.factor +++ b/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 ; + array ( array -- quot ) + dup length '[ _ cleave _ narray ] ; + 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 ; diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 7e7ebd902a..75f5d64b5f 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/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 diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 60785a5b17..164afa46fb 100644 --- a/basis/unix/groups/groups.factor +++ b/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 ; diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index 0740561cc1..2d46ab2d81 100644 --- a/basis/unix/users/users-docs.factor +++ b/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:" diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor index 5a4639c856..f2a4b7bc27 100644 --- a/basis/unix/users/users-tests.factor +++ b/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 diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 21538080c9..da38972955 100644 --- a/basis/unix/users/users.factor +++ b/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 -- ) diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor index 866af469e9..59bf77da3a 100644 --- a/basis/values/values-docs.factor +++ b/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" } } diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index ef006bbc21..1bdd1009e9 100644 --- a/core/math/order/order-docs.factor +++ b/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." diff --git a/core/math/order/order.factor b/core/math/order/order.factor index aae5841185..a06209bf63 100644 --- a/core/math/order/order.factor +++ b/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 -- ? ) diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index d354fd820a..394f6c41f9 100644 --- a/misc/fuel/factor-mode.el +++ b/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 @@ -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))