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

basis/io/directories/directories-docs.factor

@@ -50,6 +50,10 @@ HELP: with-directory-files
 { $values { "path" "a pathname string" } { "quot" quotation } }
 { $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ".  Restores the current directory after the quotation is called." } ;
 
+HELP: with-directory-entries
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ".  Restores the current directory after the quotation is called." } ;
+
 HELP: delete-file
 { $values { "path" "a pathname string" } }
 { $description "Deletes a file." }
@@ -122,6 +126,7 @@ ARTICLE: "io.directories.listing" "Directory listing"
 "Directory listing:"
 { $subsection directory-entries }
 { $subsection directory-files }
+{ $subsection with-directory-entries }
 { $subsection with-directory-files } ;
 
 ARTICLE: "io.directories.create" "Creating directories"

basis/io/directories/directories.factor

@@ -41,6 +41,9 @@ HOOK: (directory-entries) os ( path -- seq )
 : directory-files ( path -- seq )
     directory-entries [ name>> ] map ;
 
+: with-directory-entries ( path quot -- )
+    '[ "" directory-entries @ ] with-directory ; inline
+
 : with-directory-files ( path quot -- )
     '[ "" directory-files @ ] with-directory ; inline
 

basis/io/files/info/unix/unix.factor

@@ -114,30 +114,6 @@ M: file-info file-mode? [ permissions>> ] dip mask? ;
 
 PRIVATE>
 
-: ch>file-type ( ch -- type )
-    {
-        { CHAR: b [ +block-device+ ] }
-        { CHAR: c [ +character-device+ ] }
-        { CHAR: d [ +directory+ ] }
-        { CHAR: l [ +symbolic-link+ ] }
-        { CHAR: s [ +socket+ ] }
-        { CHAR: p [ +fifo+ ] }
-        { CHAR: - [ +regular-file+ ] }
-        [ drop +unknown+ ]
-    } case ;
-
-: file-type>ch ( type -- string )
-    {
-        { +block-device+ [ CHAR: b ] }
-        { +character-device+ [ CHAR: c ] }
-        { +directory+ [ CHAR: d ] }
-        { +symbolic-link+ [ CHAR: l ] }
-        { +socket+ [ CHAR: s ] }
-        { +fifo+ [ CHAR: p ] }
-        { +regular-file+ [ CHAR: - ] }
-        [ drop CHAR: - ]
-    } case ;
-
 : UID           OCT: 0004000 ; inline
 : GID           OCT: 0002000 ; inline
 : STICKY        OCT: 0001000 ; inline
@@ -251,3 +227,47 @@ M: string set-file-group ( path string -- )
 
 : file-group-name ( path -- string )
     file-group-id group-name ;
+
+: ch>file-type ( ch -- type )
+    {
+        { CHAR: b [ +block-device+ ] }
+        { CHAR: c [ +character-device+ ] }
+        { CHAR: d [ +directory+ ] }
+        { CHAR: l [ +symbolic-link+ ] }
+        { CHAR: s [ +socket+ ] }
+        { CHAR: p [ +fifo+ ] }
+        { CHAR: - [ +regular-file+ ] }
+        [ drop +unknown+ ]
+    } case ;
+
+: file-type>ch ( type -- ch )
+    {
+        { +block-device+ [ CHAR: b ] }
+        { +character-device+ [ CHAR: c ] }
+        { +directory+ [ CHAR: d ] }
+        { +symbolic-link+ [ CHAR: l ] }
+        { +socket+ [ CHAR: s ] }
+        { +fifo+ [ CHAR: p ] }
+        { +regular-file+ [ CHAR: - ] }
+        [ drop CHAR: - ]
+    } case ;
+
+<PRIVATE
+
+: file-type>executable ( directory-entry -- string )
+    name>> any-execute? "*" "" ? ;
+
+PRIVATE>
+
+: file-type>trailing ( directory-entry -- string )
+    dup type>>
+    {
+        { +directory+ [ drop "/" ] }
+        { +symbolic-link+ [ drop "@" ] }
+        { +fifo+ [ drop "|" ] }
+        { +socket+ [ drop "=" ] }
+        { +whiteout+ [ drop "%" ] }
+        { +unknown+ [ file-type>executable ] }
+        { +regular-file+ [ file-type>executable ] }
+        [ drop file-type>executable ]
+    } case ;

basis/sorting/slots/slots-docs.factor

@@ -6,17 +6,17 @@ IN: sorting.slots
 
 HELP: compare-slots
 { $values
-     { "sort-specs" "a sequence of accessor/comparator pairs" }
+     { "sort-specs" "a sequence of accessors ending with a comparator" }
      { "<=>" { $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 } { "sort-specs" "a sequence of accessors ending with a comparator" }
      { "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." }
+{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
 { $examples
     "Sort by slot c, then b descending:"
     { $example
@@ -32,6 +32,13 @@ HELP: sort-by-slots
     }
 } ;
 
+HELP: split-by-slots
+{ $values
+     { "accessor-seqs" "a sequence of sequences of tuple accessors" }
+     { "quot" quotation }
+}
+{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
+
 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:"

basis/sorting/slots/slots-tests.factor

@@ -1,10 +1,12 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math.order sorting.slots tools.test
-sorting.human ;
+sorting.human arrays sequences kernel assocs multiline ;
 IN: sorting.literals.tests
 
-TUPLE: sort-test a b c ;
+TUPLE: sort-test a b c tuple2 ;
+
+TUPLE: tuple2 d ;
 
 [
     {
@@ -43,8 +45,101 @@ TUPLE: sort-test a b c ;
 ] unit-test
 
 [
-    { }
+    {
+        {
+            T{ sort-test { a 1 } { b 1 } { c 10 } }
+            T{ sort-test { a 1 } { b 1 } { c 11 } }
+        }
+        { T{ sort-test { a 1 } { b 3 } { c 9 } } }
+        {
+            T{ sort-test { a 2 } { b 5 } { c 3 } }
+            T{ sort-test { a 2 } { b 5 } { c 2 } }
+        }
+    }
 ] [
-    { }
-    { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+    {
+        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>> <=> } } [ sort-by-slots ] keep
+    [ but-last-slice ] map split-by-slots [ >array ] map
+] unit-test
+
+: split-test ( seq -- seq' )
+    { { a>> } { b>> } } split-by-slots ;
+
+[ split-test ] must-infer
+
+[ { } ]
+[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
+
+[
+    {
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
+        T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
+    }
+] [
+    {
+        T{ sort-test f 6 f f T{ tuple2 f 1 } }
+        T{ sort-test f 5 f f T{ tuple2 f 4 } }
+        T{ sort-test f 6 f f T{ tuple2 f 3 } }
+        T{ sort-test f 6 f f T{ tuple2 f 3 } }
+        T{ sort-test f 5 f f T{ tuple2 f 3 } }
+        T{ sort-test f 6 f f T{ tuple2 f 2 } }
+    } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
+] unit-test
+
+[
+    {
+        {
+            T{ sort-test
+                { a 6 }
+                { tuple2 T{ tuple2 { d 1 } } }
+            }
+        }
+        {
+            T{ sort-test
+                { a 6 }
+                { tuple2 T{ tuple2 { d 2 } } }
+            }
+        }
+        {
+            T{ sort-test
+                { a 5 }
+                { tuple2 T{ tuple2 { d 3 } } }
+            }
+        }
+        {
+            T{ sort-test
+                { a 6 }
+                { tuple2 T{ tuple2 { d 3 } } }
+            }
+            T{ sort-test
+                { a 6 }
+                { tuple2 T{ tuple2 { d 3 } } }
+            }
+        }
+        {
+            T{ sort-test
+                { a 5 }
+                { tuple2 T{ tuple2 { d 4 } } }
+            }
+        }
+    }
+] [
+    {
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
+        T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
+    } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
 ] unit-test

basis/sorting/slots/slots.factor

@@ -1,19 +1,30 @@
 ! 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 ;
+sequences words sorting sequences.deep assocs splitting.monotonic
+math ;
 IN: sorting.slots
 
 <PRIVATE
 
-: slot-comparator ( accessor comparator -- quot )
-    '[ [ _ execute ] bi@ _ execute dup +eq+ eq? [ drop f ] when ] ;
+: slot-comparator ( seq -- quot )
+    [
+        but-last-slice
+        [ '[ [ _ execute ] bi@ ] ] map concat
+    ] [
+        peek
+        '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+    ] bi ;
 
 PRIVATE>
 
 MACRO: compare-slots ( sort-specs -- <=> )
-    #! sort-spec: { accessor comparator }
-    [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+    #! sort-spec: { accessors comparator }
+    [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
 
 : sort-by-slots ( seq sort-specs -- seq' )
     '[ _ compare-slots ] sort ;
+
+MACRO: split-by-slots ( accessor-seqs -- quot )
+    [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
+    '[ [ _ 2&& ] slice monotonic-slice ] ;

extra/fuel/help/help.factor

@@ -95,7 +95,7 @@ PRIVATE>
     [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
 
 : (fuel-word-def) ( name -- str )
-    fuel-find-word [ [ def>> pprint ] with-string-writer ] when* ; inline
+    fuel-find-word [ [ def>> pprint ] with-string-writer ] [ f ] if* ; inline
 
 : (fuel-vocab-summary) ( name -- str ) >vocab-link summary ; inline
 

extra/inverse/inverse-docs.factor

@@ -14,7 +14,17 @@ HELP: undo
 HELP: define-inverse
 { $values { "word" "a word" } { "quot" "the inverse" } }
 { $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." }
-{ $see-also define-pop-inverse } ;
+{ $see-also define-dual define-involution define-pop-inverse } ;
+
+HELP: define-dual
+{ $values { "word1" "a word" } { "word2" "a word" } }
+{ $description "Defines the inverse of each word as being the other one." }
+{ $see-also define-inverse define-involution } ;
+
+HELP: define-involution
+{ $values { "word" "a word" } }
+{ $description "Defines a word as being its own inverse." }
+{ $see-also define-dual define-inverse } ;
 
 HELP: define-pop-inverse
 { $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } }

extra/inverse/inverse-tests.factor

@@ -75,3 +75,8 @@ C: <nil> nil
 [ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test
 [ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail
 [ { 1 2 3 } [ { 2 3 } prepend ] undo ] must-fail
+
+[ [ sq ] ] [ [ sqrt ] [undo] ] unit-test
+[ [ sqrt ] ] [ [ sq ] [undo] ] unit-test
+[ [ not ] ] [ [ not ] [undo] ] unit-test
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test

extra/inverse/inverse.factor

@@ -20,6 +20,11 @@ M: fail summary drop "Matching failed" ;
 
 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
 
+: define-dual ( word1 word2 -- )
+    2dup swap [ 1quotation define-inverse ] 2bi@ ;
+
+: define-involution ( word -- ) dup 1quotation define-inverse ;
+
 : define-math-inverse ( word quot1 quot2 -- )
     pick 1quotation 3array "math-inverse" set-word-prop ;
 
@@ -129,28 +134,24 @@ MACRO: undo ( quot -- ) [undo] ;
 
 ! Inverse of selected words
 
-\ swap [ swap ] define-inverse
+\ swap define-involution
 \ dup [ [ =/fail ] keep ] define-inverse
 \ 2dup [ over =/fail over =/fail ] define-inverse
 \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
 \ pick [ [ pick ] dip =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
-\ not [ not ] define-inverse
+\ not define-involution
 \ >boolean [ { t f } memq? assure ] define-inverse
 
-\ tuple>array [ >tuple ] define-inverse
-\ >tuple [ tuple>array ] define-inverse
-\ reverse [ reverse ] define-inverse
+\ tuple>array \ >tuple define-dual
+\ reverse define-involution
 
 \ undo 1 [ [ call ] curry ] define-pop-inverse
 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
 
-\ exp [ log ] define-inverse
-\ log [ exp ] define-inverse
-\ not [ not ] define-inverse
-\ sq [ sqrt ] define-inverse
-\ sqrt [ sq ] define-inverse
+\ exp \ log define-dual
+\ sq \ sqrt define-dual
 
 ERROR: missing-literal ;
 
@@ -204,8 +205,7 @@ DEFER: _
 \ first3 [ 3array ] define-inverse
 \ first4 [ 4array ] define-inverse
 
-\ prefix [ unclip ] define-inverse
-\ unclip [ prefix ] define-inverse
+\ prefix \ unclip define-dual
 \ suffix [ dup but-last swap peek ] define-inverse
 
 \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse

misc/fuel/fuel-syntax.el

@@ -94,7 +94,7 @@
   "\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>")
 
 (defconst fuel-syntax--bad-string-regex
-  "\"[^\"]*$")
+  "\"\\([^\"]\\|\\\\\"\\)*\n")
 
 (defconst fuel-syntax--word-definition-regex
   (fuel-syntax--second-word-regex
@@ -226,7 +226,7 @@
     ;; CHARs:
     ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
     ;; Strings
-    ("\\(\"\\)[^\n\r\f]*\\(\"\\)" (1 "\"") (2 "\""))
+    ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\\"?\\)*\\(\"\\)" (1 "\"") (3 "\""))
     ;; Let and lambda:
     ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
     ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))