steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Daniel Ehrenberg 2009-01-13 19:13:13 -06:00
parent 85c6efa718 cefd85013c
commit a40af2bd87
41 changed files with 615 additions and 390 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/bootstrap/threads/threads.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs vocabs.loader kernel ;
USING: vocabs vocabs.loader kernel io.thread threads
compiler.utilities namespaces ;
IN: bootstrap.threads
USE: io.thread
USE: threads
"debugger" vocab [
"debugger.threads" require
] when
[ yield ] yield-hook set-global

9
basis/compiler/codegen/codegen.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays sets threads libc continuations.private
alien.strings alien.arrays sets libc continuations.private
fry cpu.architecture
compiler.errors
compiler.alien
@ -11,7 +11,8 @@ compiler.cfg
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.builder
compiler.codegen.fixup ;
compiler.codegen.fixup
compiler.utilities ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
@ -463,7 +464,7 @@ TUPLE: callback-context ;
dup current-callback eq? [
drop
] [
yield wait-to-return
yield-hook get call wait-to-return
] if ;
: do-callback ( quot token -- )

8
basis/compiler/compiler.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques io
graphs generic combinators deques search-deques io
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.optimizer compiler.cfg.linearization
compiler.cfg.two-operand compiler.cfg.linear-scan
compiler.cfg.stack-frame compiler.codegen ;
compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
@ -107,7 +107,7 @@ t compile-dependencies? set-global
] with-return ;
: compile-loop ( deque -- )
[ (compile) yield ] slurp-deque ;
[ (compile) yield-hook get call ] slurp-deque ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;

8
basis/compiler/utilities/utilities.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private arrays vectors fry
math.order ;
math.order namespaces assocs ;
IN: compiler.utilities
: flattener ( seq quot -- seq vector quot' )
@ -21,3 +21,7 @@ IN: compiler.utilities
: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
SYMBOL: yield-hook
yield-hook global [ [ ] or ] change-at

2
basis/delegate/protocols/protocols.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs
io definitions kernel continuations ;
io io.styles definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol

2
basis/help/handbook/handbook.factor
View File

@ -183,7 +183,7 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.streams.byte-array" }
{ $heading "Utilities" }
{ $subsection "stream-binary" }
{ $subsection "styles" }
{ $subsection "io.styles" }
{ $subsection "checksums" }
{ $heading "Implementation" }
{ $subsection "io.streams.c" }

2
basis/html/elements/elements.factor
View File

@ -3,7 +3,7 @@
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
urls math math.parser combinators present fry ;

5
basis/io/directories/directories-docs.factor
View File

@ -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"

3
basis/io/directories/directories.factor
View File

@ -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

2
basis/io/directories/search/search.factor
View File

@ -14,7 +14,7 @@ TUPLE: directory-iterator path bfs queue ;
: push-directory ( path iter -- )
[ qualified-directory ] dip [
dup queue>> swap bfs>>
[ queue>> ] [ bfs>> ] bi
[ push-front ] [ push-back ] if
] curry each ;

68
basis/io/files/info/unix/unix.factor
View File

@ -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 ;

130
basis/io/styles/styles-docs.factor
View File

@ -1,7 +1,116 @@
USING: help.markup help.syntax io.streams.plain io strings
hashtables ;
hashtables kernel quotations ;
IN: io.styles
HELP: stream-format
{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
$nl
"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-block-stream
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
$nl
"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-write-table
{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-cell-stream
{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
{ $contract "Creates an output stream which writes to a table cell object." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-span-stream
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." }
$io-error ;
HELP: format
{ $values { "str" string } { "style" "a hashtable" } }
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: with-nesting
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ;
HELP: tabular-output
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
{ $examples
{ $code
"{ { 1 2 } { 3 4 } }"
"H{ { table-gap { 10 10 } } } ["
" [ [ [ [ . ] with-cell ] each ] with-row ] each"
"] tabular-output"
}
}
$io-error ;
HELP: with-row
{ $values { "quot" quotation } }
{ $description "Calls a quotation which emits a series of table cells using " { $link with-cell } ". This word can only be called inside the quotation given to " { $link tabular-output } "." }
$io-error ;
HELP: with-cell
{ $values { "quot" quotation } }
{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
$io-error ;
HELP: write-cell
{ $values { "str" string } }
{ $description "Outputs a table cell containing a single string. This word can only be called inside the quotation given to " { $link with-row } "." }
$io-error ;
HELP: with-style
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ;
ARTICLE: "formatted-stream-protocol" "Formatted stream protocol"
"The " { $vocab-link "io.styles" } " vocabulary defines a protocol for output streams that support rich text."
{ $subsection stream-format }
{ $subsection make-span-stream }
{ $subsection make-block-stream }
{ $subsection make-cell-stream }
{ $subsection stream-write-table } ;
ARTICLE: "formatted-stdout" "Formatted output on the default stream"
"The below words perform formatted output on " { $link output-stream } "."
$nl
"Formatted output:"
{ $subsection format }
{ $subsection with-style }
{ $subsection with-nesting }
"Tabular output:"
{ $subsection tabular-output }
{ $subsection with-row }
{ $subsection with-cell }
{ $subsection write-cell } ;
ARTICLE: "character-styles" "Character styles"
"Character styles for " { $link stream-format } " and " { $link with-style } ":"
{ $subsection foreground }
@ -33,7 +142,7 @@ ARTICLE: "presentations" "Presentations"
"The " { $link presented } " style can be used to emit clickable objects. A utility word for outputting this style:"
{ $subsection write-object } ;
ARTICLE: "styles" "Formatted output"
ARTICLE: "styles" "Styled text"
"The " { $link stream-format } ", " { $link with-style } ", " { $link with-nesting } " and " { $link tabular-output } " words take a hashtable of style attributes. Output stream implementations are free to ignore style information."
$nl
"Style hashtables are keyed by symbols from the " { $vocab-link "io.styles" } " vocabulary."
@ -42,7 +151,13 @@ $nl
{ $subsection "table-styles" }
{ $subsection "presentations" } ;
ABOUT: "styles"
ARTICLE: "io.styles" "Formatted output"
"The " { $vocab-link "io.styles" } " vocabulary defines a protocol for formatted output. This is used by the prettyprinter, help system, and various developer tools. Implementations include " { $vocab-link "ui.gadgets.panes" } ", " { $vocab-link "html.streams" } ", and " { $vocab-link "io.streams.plain" } "."
{ $subsection "formatted-stream-protocol" }
{ $subsection "formatted-stdout" }
{ $subsection "styles" } ;
ABOUT: "io.styles"
HELP: plain
{ $description "A value for the " { $link font-style } " character style denoting plain text." } ;
@ -157,3 +272,12 @@ HELP: <input>
HELP: standard-table-style
{ $values { "style" hashtable } }
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
ARTICLE: "io.streams.plain" "Plain writer streams"
"Plain writer streams wrap an underlying stream and provide a default implementation of "
{ $link stream-nl } ", "
{ $link stream-format } ", "
{ $link make-span-stream } ", "
{ $link make-block-stream } " and "
{ $link make-cell-stream } "."
{ $subsection plain-writer } ;

136
basis/io/styles/styles.factor
View File

@ -1,9 +1,139 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io colors summary make accessors splitting
kernel ;
USING: hashtables io io.streams.plain io.streams.string
colors summary make accessors splitting math.order
kernel namespaces assocs destructors strings sequences ;
IN: io.styles
GENERIC: stream-format ( str style stream -- )
GENERIC: make-span-stream ( style stream -- stream' )
GENERIC: make-block-stream ( style stream -- stream' )
GENERIC: make-cell-stream ( style stream -- stream' )
GENERIC: stream-write-table ( table-cells style stream -- )
: format ( str style -- ) output-stream get stream-format ;
: tabular-output ( style quot -- )
swap [ { } make ] dip output-stream get stream-write-table ; inline
: with-row ( quot -- )
{ } make , ; inline
: with-cell ( quot -- )
H{ } output-stream get make-cell-stream
[ swap with-output-stream ] keep , ; inline
: write-cell ( str -- )
[ write ] with-cell ; inline
: with-style ( style quot -- )
swap dup assoc-empty? [
drop call
] [
output-stream get make-span-stream swap with-output-stream
] if ; inline
: with-nesting ( style quot -- )
[ output-stream get make-block-stream ] dip
with-output-stream ; inline
TUPLE: filter-writer stream ;
M: filter-writer stream-format
stream>> stream-format ;
M: filter-writer stream-write
stream>> stream-write ;
M: filter-writer stream-write1
stream>> stream-write1 ;
M: filter-writer make-span-stream
stream>> make-span-stream ;
M: filter-writer make-block-stream
stream>> make-block-stream ;
M: filter-writer make-cell-stream
stream>> make-cell-stream ;
M: filter-writer stream-flush
stream>> stream-flush ;
M: filter-writer stream-nl
stream>> stream-nl ;
M: filter-writer stream-write-table
stream>> stream-write-table ;
M: filter-writer dispose
stream>> dispose ;
TUPLE: ignore-close-stream < filter-writer ;
M: ignore-close-stream dispose drop ;
C: <ignore-close-stream> ignore-close-stream
TUPLE: style-stream < filter-writer style ;
: do-nested-style ( style style-stream -- style stream )
[ style>> swap assoc-union ] [ stream>> ] bi ; inline
C: <style-stream> style-stream
M: style-stream stream-format
do-nested-style stream-format ;
M: style-stream stream-write
[ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
[ 1string ] dip stream-write ;
M: style-stream make-span-stream
do-nested-style make-span-stream ;
M: style-stream make-block-stream
[ do-nested-style make-block-stream ] [ style>> ] bi
<style-stream> ;
M: style-stream make-cell-stream
[ do-nested-style make-cell-stream ] [ style>> ] bi
<style-stream> ;
M: style-stream stream-write-table
[ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
stream-write-table ;
M: plain-writer stream-format
nip stream-write ;
M: plain-writer make-span-stream
swap <style-stream> <ignore-close-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;
: format-column ( seq ? -- seq )
[
[ 0 [ length max ] reduce ] keep
swap [ CHAR: \s pad-right ] curry map
] unless ;
: map-last ( seq quot -- seq )
[ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
: format-table ( table -- seq )
flip [ format-column ] map-last
flip [ " " join ] map ;
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
! Font styles
SYMBOL: plain
SYMBOL: bold
SYMBOL: italic

2
basis/prettyprint/sections/sections.factor
View File

@ -3,7 +3,7 @@
USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
io.streams.nested accessors sets ;
accessors sets ;
IN: prettyprint.sections
! State

13
basis/sorting/slots/slots-docs.factor
View File

@ -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:"

105
basis/sorting/slots/slots-tests.factor
View File

@ -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

21
basis/sorting/slots/slots.factor
View File

@ -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 ] ;

4
basis/tools/files/files-tests.factor
View File

@ -1,10 +1,8 @@
! Copyright (C) 2008 Your name.
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test tools.files strings kernel ;
IN: tools.files.tests
\ directory. must-infer
[ ] [ "" directory. ] unit-test
[ ] [ file-systems. ] unit-test

98
basis/tools/files/files.factor
View File

@ -1,24 +1,29 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2008, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io io.files io.files.info
io.directories kernel math.parser sequences system vocabs.loader
calendar math fry prettyprint ;
USING: accessors arrays calendar combinators fry io io.directories
io.files.info kernel math math.parser prettyprint sequences system
vocabs.loader sorting.slots calendar.format ;
IN: tools.files
SYMBOLS: permissions file-name nlinks file-size date ;
<PRIVATE
: ls-time ( timestamp -- string )
: dir-or-size ( file-info -- str )
dup directory? [
drop "<DIR>" 20 CHAR: \s pad-right
] [
size>> number>string 20 CHAR: \s pad-left
] if ;
: listing-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
: ls-timestamp ( timestamp -- string )
: listing-date ( timestamp -- string )
[ month>> month-abbreviation ]
[ day>> number>string 2 CHAR: \s pad-left ]
[
dup year>> dup now year>> =
[ drop ls-time ] [ nip number>string ] if
[ drop listing-time ] [ nip number>string ] if
5 CHAR: \s pad-left
] tri 3array " " join ;
@ -28,12 +33,57 @@ SYMBOLS: permissions file-name nlinks file-size date ;
: execute>string ( ? -- string ) "x" "-" ? ; inline
HOOK: (directory.) os ( path -- lines )
PRIVATE>
: directory. ( path -- )
[ (directory.) ] with-directory-files [ print ] each ;
SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
file-date file-time file-datetime uid gid user group link-target unix-datetime
directory-or-size ;
TUPLE: listing-tool path specs sort ;
TUPLE: file-listing directory-entry file-info ;
C: <file-listing> file-listing
: <listing-tool> ( path -- listing-tool )
listing-tool new
swap >>path
{ file-name } >>specs ;
: list-slow? ( listing-tool -- ? )
specs>> { file-name } sequence= not ;
ERROR: unknown-file-spec symbol ;
HOOK: file-spec>string os ( file-listing spec -- string )
M: object file-spec>string ( file-listing spec -- string )
{
{ file-name [ directory-entry>> name>> ] }
{ directory-or-size [ file-info>> dir-or-size ] }
{ file-size [ file-info>> size>> number>string ] }
{ file-date [ file-info>> modified>> listing-date ] }
{ file-time [ file-info>> modified>> listing-time ] }
{ file-datetime [ file-info>> modified>> timestamp>ymdhms ] }
[ unknown-file-spec ]
} case ;
: list-files-fast ( listing-tool -- array )
path>> [ [ name>> 1array ] map ] with-directory-entries ; inline
: list-files-slow ( listing-tool -- array )
[ path>> ] [ sort>> ] [ specs>> ] tri '[
[ dup name>> file-info file-listing boa ] map
_ [ sort-by-slots ] when*
[ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline
: list-files ( listing-tool -- array )
dup list-slow? [ list-files-slow ] [ list-files-fast ] if ; inline
HOOK: (directory.) os ( path -- lines )
: directory. ( path -- ) (directory.) simple-table. ;
SYMBOLS: device-name mount-point type
available-space free-space used-space total-space
@ -43,16 +93,16 @@ percent-used percent-free ;
: file-system-spec ( file-system-info obj -- str )
{
{ device-name [ device-name>> [ "" ] unless* ] }
{ mount-point [ mount-point>> [ "" ] unless* ] }
{ type [ type>> [ "" ] unless* ] }
{ available-space [ available-space>> [ 0 ] unless* ] }
{ free-space [ free-space>> [ 0 ] unless* ] }
{ used-space [ used-space>> [ 0 ] unless* ] }
{ total-space [ total-space>> [ 0 ] unless* ] }
{ device-name [ device-name>> "" or ] }
{ mount-point [ mount-point>> "" or ] }
{ type [ type>> "" or ] }
{ available-space [ available-space>> 0 or ] }
{ free-space [ free-space>> 0 or ] }
{ used-space [ used-space>> 0 or ] }
{ total-space [ total-space>> 0 or ] }
{ percent-used [
[ used-space>> ] [ total-space>> ] bi
[ [ 0 ] unless* ] bi@ dup 0 =
[ 0 or ] bi@ dup 0 =
[ 2drop 0 ] [ / percent ] if
] }
} case ;
@ -65,8 +115,10 @@ percent-used percent-free ;
[ [ unparse ] map ] bi prefix simple-table. ;
: file-systems. ( -- )
{ device-name available-space free-space used-space total-space percent-used mount-point }
print-file-systems ;
{
device-name available-space free-space used-space
total-space percent-used mount-point
} print-file-systems ;
{
{ [ os unix? ] [ "tools.files.unix" ] }

37
basis/tools/files/unix/unix.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel system unicode.case io.files
io.files.info io.files.info.unix tools.files generalizations
io.files.info io.files.info.unix generalizations
strings arrays sequences math.parser unix.groups unix.users
tools.files.private unix.stat math fry macros combinators.smart ;
tools.files.private unix.stat math fry macros combinators.smart
io.files.info.unix io tools.files math.order prettyprint ;
IN: tools.files.unix
<PRIVATE
@ -45,19 +46,23 @@ IN: tools.files.unix
} cond ;
M: unix (directory.) ( path -- lines )
[ [
[
dup file-info [
{
[ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ]
[ uid>> user-name ]
[ gid>> group-name ]
[ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ]
} cleave
] output>array swap suffix " " join
] map
] with-group-cache ] with-user-cache ;
<listing-tool>
{ permissions nlinks user group file-size file-date file-name } >>specs
{ { directory-entry>> name>> <=> } } >>sort
[ [ list-files ] with-group-cache ] with-user-cache ;
M: unix file-spec>string ( file-listing spec -- string )
{
{ file-name/type [
directory-entry>> [ name>> ] [ file-type>trailing ] bi append
] }
{ permissions [ file-info>> permissions-string ] }
{ nlinks [ file-info>> nlink>> number>string ] }
{ user [ file-info>> uid>> user-name ] }
{ group [ file-info>> gid>> group-name ] }
{ uid [ file-info>> uid>> number>string ] }
{ gid [ file-info>> gid>> number>string ] }
[ call-next-method ]
} case ;
PRIVATE>

19
basis/tools/files/windows/windows.factor
View File

@ -2,24 +2,15 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar.format combinators io.files
kernel math.parser sequences splitting system tools.files
generalizations tools.files.private io.files.info ;
generalizations tools.files.private io.files.info math.order ;
IN: tools.files.windows
<PRIVATE
: directory-or-size ( file-info -- str )
dup directory? [
drop "<DIR>" 20 CHAR: \s pad-right
] [
size>> number>string 20 CHAR: \s pad-left
] if ;
M: windows (directory.) ( entries -- lines )
[
dup file-info {
[ modified>> timestamp>ymdhms ]
[ directory-or-size ]
} cleave 2 narray swap suffix " " join
] map ;
<listing-tool>
{ file-datetime directory-or-size file-name } >>specs
{ { directory-entry>> name>> <=> } } >>sort
list-files ;
PRIVATE>

4
basis/ui/gadgets/grids/grids.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors
io.styles math.vectors ui.gadgets columns accessors
math.geometry.rect locals fry ;
IN: ui.gadgets.grids

2
basis/ui/gadgets/panes/panes.factor
View File

@ -6,7 +6,7 @@ ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors sorting
splitting io.streams.nested assocs ui.gadgets.presentations
splitting assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect fry ;

5
basis/validators/validators-docs.factor
View File

@ -2,6 +2,10 @@ USING: help.markup help.syntax io.streams.string quotations
strings math regexp regexp.backend ;
IN: validators
HELP: v-checkbox
{ $values { "str" string } }
{ $description "Converts the string value of a checkbox component (either \"on\" or \"off\") to a boolean value." } ;
HELP: v-captcha
{ $values { "str" string } }
{ $description "Throws a validation error if the string is non-empty. This is used to create bait fields for spam-bots to fill in." } ;
@ -99,6 +103,7 @@ $nl
{ $subsection v-one-line }
{ $subsection v-one-word }
{ $subsection v-captcha }
{ $subsection v-checkbox }
"More complex validators:"
{ $subsection v-email }
{ $subsection v-url }

3
basis/validators/validators-tests.factor
View File

@ -10,6 +10,9 @@ namespaces assocs ;
[ "hello" ] [ "hello" v-one-word ] unit-test
[ "hello world" v-one-word ] must-fail
[ t ] [ "on" v-checkbox ] unit-test
[ f ] [ "off" v-checkbox ] unit-test
[ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test
[ 123 ] [ "123" v-integer ] unit-test

3
basis/validators/validators.factor
View File

@ -5,6 +5,9 @@ math.parser math.ranges assocs regexp unicode.categories arrays
hashtables words classes quotations xmode.catalog ;
IN: validators
: v-checkbox ( str -- ? )
"on" = ;
: v-default ( str def -- str/def )
over empty? spin ? ;

101
core/io/io-docs.factor
View File

@ -57,45 +57,6 @@ HELP: stream-nl
{ $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-format
{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
$nl
"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-block-stream
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
$nl
"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-write-table
{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-cell-stream
{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
{ $contract "Creates an output stream which writes to a table cell object." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-span-stream
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-print
{ $values { "str" string } { "stream" "an output stream" } }
@ -161,54 +122,6 @@ HELP: nl
{ $description "Writes a line terminator to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: format
{ $values { "str" string } { "style" "a hashtable" } }
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: with-nesting
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ;
HELP: tabular-output
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
{ $examples
{ $code
"{ { 1 2 } { 3 4 } }"
"H{ { table-gap { 10 10 } } } ["
" [ [ [ [ . ] with-cell ] each ] with-row ] each"
"] tabular-output"
}
}
$io-error ;
HELP: with-row
{ $values { "quot" quotation } }
{ $description "Calls a quotation which emits a series of table cells using " { $link with-cell } ". This word can only be called inside the quotation given to " { $link tabular-output } "." }
$io-error ;
HELP: with-cell
{ $values { "quot" quotation } }
{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
$io-error ;
HELP: write-cell
{ $values { "str" string } }
{ $description "Outputs a table cell containing a single string. This word can only be called inside the quotation given to " { $link with-row } "." }
$io-error ;
HELP: with-style
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ;
HELP: print
{ $values { "string" string } }
{ $description "Writes a newline-terminated string to " { $link output-stream } "." }
@ -279,12 +192,7 @@ $nl
{ $subsection stream-flush }
{ $subsection stream-write1 }
{ $subsection stream-write }
{ $subsection stream-format }
{ $subsection stream-nl }
{ $subsection make-span-stream }
{ $subsection make-block-stream }
{ $subsection make-cell-stream }
{ $subsection stream-write-table }
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "Default input and output streams"
@ -347,15 +255,6 @@ $nl
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
"Formatted output:"
{ $subsection format }
{ $subsection with-style }
{ $subsection with-nesting }
"Tabular output:"
{ $subsection tabular-output }
{ $subsection with-row }
{ $subsection with-cell }
{ $subsection write-cell }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }

32
core/io/io.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces make sequences
continuations destructors assocs ;
@ -13,11 +13,6 @@ GENERIC: stream-write1 ( ch stream -- )
GENERIC: stream-write ( str stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-nl ( stream -- )
GENERIC: stream-format ( str style stream -- )
GENERIC: make-span-stream ( style stream -- stream' )
GENERIC: make-block-stream ( style stream -- stream' )
GENERIC: make-cell-stream ( style stream -- stream' )
GENERIC: stream-write-table ( table-cells style stream -- )
: stream-print ( str stream -- )
[ stream-write ] keep stream-nl ;
@ -46,7 +41,6 @@ SYMBOL: error-stream
: flush ( -- ) output-stream get stream-flush ;
: nl ( -- ) output-stream get stream-nl ;
: format ( str style -- ) output-stream get stream-format ;
: with-input-stream* ( stream quot -- )
input-stream swap with-variable ; inline
@ -68,30 +62,6 @@ SYMBOL: error-stream
[ [ drop dispose dispose ] 3curry ] 3bi
[ ] cleanup ; inline
: tabular-output ( style quot -- )
swap [ { } make ] dip output-stream get stream-write-table ; inline
: with-row ( quot -- )
{ } make , ; inline
: with-cell ( quot -- )
H{ } output-stream get make-cell-stream
[ swap with-output-stream ] keep , ; inline
: write-cell ( str -- )
[ write ] with-cell ; inline
: with-style ( style quot -- )
swap dup assoc-empty? [
drop call
] [
output-stream get make-span-stream swap with-output-stream
] if ; inline
: with-nesting ( style quot -- )
[ output-stream get make-block-stream ] dip
with-output-stream ; inline
: print ( string -- ) output-stream get stream-print ;
: bl ( -- ) " " write ;

1
core/io/streams/nested/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

2
core/io/streams/nested/nested-docs.factor
View File

@ -1,2 +0,0 @@
USING: io io.streams.nested help.markup help.syntax ;

74
core/io/streams/nested/nested.factor
View File

@ -1,74 +0,0 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel namespaces strings
quotations io continuations destructors accessors sequences ;
IN: io.streams.nested
TUPLE: filter-writer stream ;
M: filter-writer stream-format
stream>> stream-format ;
M: filter-writer stream-write
stream>> stream-write ;
M: filter-writer stream-write1
stream>> stream-write1 ;
M: filter-writer make-span-stream
stream>> make-span-stream ;
M: filter-writer make-block-stream
stream>> make-block-stream ;
M: filter-writer make-cell-stream
stream>> make-cell-stream ;
M: filter-writer stream-flush
stream>> stream-flush ;
M: filter-writer stream-nl
stream>> stream-nl ;
M: filter-writer stream-write-table
stream>> stream-write-table ;
M: filter-writer dispose
stream>> dispose ;
TUPLE: ignore-close-stream < filter-writer ;
M: ignore-close-stream dispose drop ;
C: <ignore-close-stream> ignore-close-stream
TUPLE: style-stream < filter-writer style ;
: do-nested-style ( style style-stream -- style stream )
[ style>> swap assoc-union ] [ stream>> ] bi ; inline
C: <style-stream> style-stream
M: style-stream stream-format
do-nested-style stream-format ;
M: style-stream stream-write
[ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
[ 1string ] dip stream-write ;
M: style-stream make-span-stream
do-nested-style make-span-stream ;
M: style-stream make-block-stream
[ do-nested-style make-block-stream ] [ style>> ] bi
<style-stream> ;
M: style-stream make-cell-stream
[ do-nested-style make-cell-stream ] [ style>> ] bi
<style-stream> ;
M: style-stream stream-write-table
[ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
stream-write-table ;

1
core/io/streams/nested/summary.txt
View File

@ -1 +0,0 @@
Support for with-stream-style implementation

9
core/io/streams/plain/plain-docs.factor
View File

@ -1,15 +1,6 @@
USING: help.markup help.syntax io ;
IN: io.streams.plain
ARTICLE: "io.streams.plain" "Plain writer streams"
"Plain writer streams wrap an underlying stream and provide a default implementation of "
{ $link stream-nl } ", "
{ $link stream-format } ", "
{ $link make-span-stream } ", "
{ $link make-block-stream } " and "
{ $link make-cell-stream } "."
{ $subsection plain-writer } ;
ABOUT: "io.streams.plain"
HELP: plain-writer

15
core/io/streams/plain/plain.factor
View File

@ -1,18 +1,9 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.streams.nested ;
USING: kernel io ;
IN: io.streams.plain
MIXIN: plain-writer
M: plain-writer stream-nl
CHAR: \n swap stream-write1 ;
M: plain-writer stream-format
nip stream-write ;
M: plain-writer make-span-stream
swap <style-stream> <ignore-close-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;
CHAR: \n swap stream-write1 ;

20
core/io/streams/string/string.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces sequences sbufs
strings generic splitting continuations destructors
@ -17,21 +17,8 @@ SINGLETON: null-encoding
M: null-encoding decode-char drop stream-read1 ;
: format-column ( seq ? -- seq )
[
[ 0 [ length max ] reduce ] keep
swap [ CHAR: \s pad-right ] curry map
] unless ;
: map-last ( seq quot -- seq )
[ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
PRIVATE>
: format-table ( table -- seq )
flip [ format-column ] map-last
flip [ " " join ] map ;
M: growable dispose drop ;
M: growable stream-write1 push ;
@ -78,8 +65,3 @@ M: growable stream-read-partial
[ <string-reader> ] dip with-input-stream ; inline
INSTANCE: growable plain-writer
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;

2
core/vocabs/loader/loader.factor
View File

@ -57,8 +57,6 @@ PRIVATE>
SYMBOL: load-help?
ERROR: circular-dependency name ;
<PRIVATE
: load-source ( vocab -- )

2
extra/fuel/help/help.factor
View File

@ -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

12
extra/inverse/inverse-docs.factor
View File

@ -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" } }

5
extra/inverse/inverse-tests.factor
View File

@ -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

24
extra/inverse/inverse.factor
View File

@ -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

4
misc/fuel/fuel-syntax.el
View File

@ -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 "(]"))