diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor
index edfcf480b0..a469f5b816 100644
--- a/basis/io/directories/directories-docs.factor
+++ b/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"
diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor
index 2630be8ce2..6ae55b7f7b 100755
--- a/basis/io/directories/directories.factor
+++ b/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
diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor
index 9287e7f4ad..b7edc14c2c 100644
--- a/basis/io/files/info/unix/unix.factor
+++ b/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 ;
diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor
index 64d0a1efdf..a3bdbf9ac1 100644
--- a/basis/sorting/slots/slots-docs.factor
+++ b/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:"
diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor
index ab130d1eed..7a4eeb8e75 100644
--- a/basis/sorting/slots/slots-tests.factor
+++ b/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
diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
index 02a11428f9..56b6a115f0 100644
--- a/basis/sorting/slots/slots.factor
+++ b/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 ] ;
diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor
index 298124ffb4..ff7239ac8f 100644
--- a/extra/fuel/help/help.factor
+++ b/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
diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor
index 8204f7174c..6b575d6d08 100644
--- a/extra/inverse/inverse-docs.factor
+++ b/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" } }
diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor
index 5e662ed78f..a9234fcff4 100644
--- a/extra/inverse/inverse-tests.factor
+++ b/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
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index a38af644b0..924a6d3814 100755
--- a/extra/inverse/inverse.factor
+++ b/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
diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index 7f0fa313c2..b74b0afc11 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/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 "(]"))