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

basis/alien/structs/structs.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic hashtables kernel kernel.private
 math namespaces parser sequences strings words libc fry
-alien.c-types alien.structs.fields cpu.architecture ;
+alien.c-types alien.structs.fields cpu.architecture math.order ;
 IN: alien.structs
 
 TUPLE: struct-type size align fields ;
@@ -47,7 +47,7 @@ M: struct-type stack-size
     [ first2 <field-spec> ] with with map ;
 
 : compute-struct-align ( types -- n )
-    [ c-type-align ] map supremum ;
+    [ c-type-align ] [ max ] map-reduce ;
 
 : define-struct ( name vocab fields -- )
     [
@@ -59,5 +59,5 @@ M: struct-type stack-size
 
 : define-union ( name members -- )
     [ expand-constants ] map
-    [ [ heap-size ] map supremum ] keep
+    [ [ heap-size ] [ max ] map-reduce ] keep
     compute-struct-align f (define-struct) ;

basis/biassocs/biassocs-docs.factor

@@ -16,13 +16,22 @@ HELP: once-at
 { $values { "value" object } { "key" object } { "assoc" assoc } }
 { $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;
 
+HELP: >biassoc
+{ $values { "assoc" assoc } { "biassoc" biassoc } }
+{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ;
+
 ARTICLE: "biassocs" "Bidirectional assocs"
 "A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
 $nl
-"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
+"Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
+$nl
+"The class of biassocs:"
 { $subsection biassoc }
 { $subsection biassoc? }
+"Creating new biassocs:"
 { $subsection <biassoc> }
-{ $subsection <bihash> } ;
+{ $subsection <bihash> }
+"Converting existing assocs to biassocs:"
+{ $subsection >biassoc } ;
 
 ABOUT: "biassocs"

basis/biassocs/biassocs-tests.factor

@@ -20,3 +20,13 @@ USING: biassocs assocs namespaces tools.test ;
 [ 2 ] [ 1 "h" get value-at ] unit-test
 
 [ 2 ] [ "h" get assoc-size ] unit-test
+
+H{ { "a" "A" } { "b" "B" } } "a" set
+
+[ ] [ "a" get >biassoc "b" set ] unit-test
+
+[ t ] [ "b" get biassoc? ] unit-test
+
+[ "A" ] [ "a" "b" get at ] unit-test
+
+[ "a" ] [ "A" "b" get value-at ] unit-test

basis/biassocs/biassocs.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs accessors summary ;
+USING: kernel assocs accessors summary hashtables ;
 IN: biassocs
 
 TUPLE: biassoc from to ;
@@ -37,4 +37,10 @@ M: biassoc >alist
 M: biassoc clear-assoc
     [ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
 
+M: biassoc new-assoc
+    drop [ <hashtable> ] [ <hashtable> ] bi biassoc boa ;
+
 INSTANCE: biassoc assoc
+
+: >biassoc ( assoc -- biassoc )
+    T{ biassoc } assoc-clone-like ;

basis/compiler/tree/normalization/introductions/introductions.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences accessors math kernel
-compiler.tree ;
+compiler.tree math.order ;
 IN: compiler.tree.normalization.introductions
 
 SYMBOL: introductions
@@ -25,7 +25,7 @@ M: #introduce count-introductions*
 
 M: #branch count-introductions*
     children>>
-    [ count-introductions ] map supremum
+    [ count-introductions ] [ max ] map-reduce
     introductions+ ;
 
 M: #recursive count-introductions*

basis/compiler/tree/normalization/normalization.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry namespaces sequences math accessors kernel arrays
+USING: fry namespaces sequences math math.order accessors kernel arrays
 combinators compiler.utilities assocs
 stack-checker.backend
 stack-checker.branches
@@ -54,7 +54,7 @@ M: #branch normalize*
         ] map unzip swap
     ] change-children swap
     [ remaining-introductions set ]
-    [ [ length ] map infimum introduction-stack [ swap head ] change ]
+    [ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ]
     bi ;
 
 : eliminate-phi-introductions ( introductions seq terminated -- seq' )

basis/csv/csv-docs.factor

@@ -1,28 +1,52 @@
-USING: help.syntax help.markup kernel prettyprint sequences ;
+USING: help.syntax help.markup kernel prettyprint sequences
+io.pathnames ;
 IN: csv
 
 HELP: csv
 { $values { "stream" "an input stream" }
           { "rows" "an array of arrays of fields" } } 
-{ $description "parses a csv stream into an array of row arrays"
+{ $description "Parses a csv stream into an array of row arrays." } ;
-} ;
+
+HELP: file>csv
+{ $values
+    { "path" pathname } { "encoding" "an encoding descriptor" }
+    { "csv" "csv" }
+}
+{ $description "Opens a file and parses it into a sequence of comma-separated-value fields." } ;
+
+HELP: csv>file
+{ $values
+    { "rows" "a sequence of sequences of strings" }
+    { "path" pathname } { "encoding" "an encoding descriptor" }
+}
+{ $description "Writes a comma-separated-value structure to a file." } ;
 
 HELP: csv-row
 { $values { "stream" "an input stream" }
           { "row" "an array of fields" } } 
-{ $description "parses a row from a csv stream"
+{ $description "parses a row from a csv stream" } ;
-} ;
 
 HELP: write-csv
-{ $values { "rows" "an sequence of sequences of strings" }
+{ $values { "rows" "a sequence of sequences of strings" }
           { "stream" "an output stream" } } 
-{ $description "writes csv to the output stream, escaping where necessary"
+{ $description "Writes a sequence of sequences of comma-separated-values to the output stream, escaping where necessary." } ;
-} ;
-
 
 HELP: with-delimiter
-{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
+{ $values { "ch" "field delimiter (e.g. CHAR: \t)" }
           { "quot" "a quotation" } }
-{ $description "Sets the field delimiter for csv or csv-row words "
+{ $description "Sets the field delimiter for csv or csv-row words." } ;
-} ;
 
+ARTICLE: "csv" "Comma-separated-values parsing and writing"
+"The " { $vocab-link "csv" } " vocabulary can read and write CSV (comma-separated-value) files." $nl
+"Reading a csv file:"
+{ $subsection file>csv }
+"Writing a csv file:"
+{ $subsection csv>file }
+"Changing the delimiter from a comma:"
+{ $subsection with-delimiter }
+"Reading from a stream:"
+{ $subsection csv }
+"Writing to a stream:"
+{ $subsection write-csv } ;
+
+ABOUT: "csv"

basis/csv/csv-tests.factor

@@ -1,5 +1,7 @@
+USING: io.streams.string csv tools.test shuffle kernel strings
+io.pathnames io.files.unique io.encodings.utf8 io.files
+io.directories ;
 IN: csv.tests
-USING: io.streams.string csv tools.test shuffle kernel strings ;
 
 ! I like to name my unit tests
 : named-unit-test ( name output input -- ) 
@@ -76,3 +78,15 @@ USING: io.streams.string csv tools.test shuffle kernel strings ;
 "escapes quotes commas and newlines when writing"
 [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
 [ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
+
+[ { { "writing" "some" "csv" "tests" } } ]
+[
+    "writing,some,csv,tests"
+    "csv-test1-" unique-file utf8
+    [ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri
+] unit-test
+
+[ t ] [
+    { { "writing,some,csv,tests" } } dup "csv-test2-"
+    unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
+] unit-test

basis/csv/csv.factor

@@ -1,89 +1,100 @@
 ! Copyright (C) 2007, 2008 Phil Dawes
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: kernel sequences io namespaces make combinators
-! Simple CSV Parser
+unicode.categories io.files combinators.short-circuit ;
-! Phil Dawes phil@phildawes.net
-
-USING: kernel sequences io namespaces make
-combinators unicode.categories ;
 IN: csv
 
 SYMBOL: delimiter
 
 CHAR: , delimiter set-global
 
+<PRIVATE
+
 : delimiter> ( -- delimiter ) delimiter get ; inline
     
 DEFER: quoted-field ( -- endchar )
     
-! trims whitespace from either end of string
 : trim-whitespace ( str -- str )
-  [ blank? ] trim ; inline
+    [ blank? ] trim ; inline
 
 : skip-to-field-end ( -- endchar )
   "\n" delimiter> suffix read-until nip ; inline
   
 : not-quoted-field ( -- endchar )
-  "\"\n" delimiter> suffix read-until   ! "
+    "\"\n" delimiter> suffix read-until
-  dup
+    dup {
-  { { CHAR: "     [ drop drop quoted-field ] }  ! " 
+        { CHAR: "    [ 2drop quoted-field ] }
-    { delimiter> [ swap trim-whitespace % ] } 
+        { delimiter> [ swap trim-whitespace % ] }
-    { CHAR: \n    [ swap trim-whitespace % ] }    
+        { CHAR: \n   [ swap trim-whitespace % ] }
-    { f           [ swap trim-whitespace % ] }       ! eof
+        { f          [ swap trim-whitespace % ] }
-  } case ;
+    } case ;
   
 : maybe-escaped-quote ( -- endchar )
-  read1 dup 
+    read1 dup {
-  { { CHAR: "    [ , quoted-field ] }  ! " is an escaped quote
+        { CHAR: "    [ , quoted-field ] }
-    { delimiter> [ ] }                 ! end of quoted field 
+        { delimiter> [ ] }
-    { CHAR: \n   [ ] }
+        { CHAR: \n   [ ] }
-    [ 2drop skip-to-field-end ]       ! end of quoted field + padding
+        [ 2drop skip-to-field-end ]
-  } case ;
+    } case ;
   
 : quoted-field ( -- endchar )
-  "\"" read-until                                 ! "
+    "\"" read-until
-  drop % maybe-escaped-quote ;
+    drop % maybe-escaped-quote ;
 
 : field ( -- sep string )
-  [ not-quoted-field ] "" make  ; ! trim-whitespace
+    [ not-quoted-field ] "" make  ;
 
 : (row) ( -- sep )
-  field , 
+    field , 
-  dup delimiter get = [ drop (row) ] when ;
+    dup delimiter get = [ drop (row) ] when ;
 
 : row ( -- eof? array[string] )
-  [ (row) ] { } make ;
+    [ (row) ] { } make ;
-
-: append-if-row-not-empty ( row -- )
-  dup { "" } = [ drop ] [ , ] if ;
 
 : (csv) ( -- )
-  row append-if-row-not-empty
+    row harvest [ , ] unless-empty [ (csv) ] when ;
-  [ (csv) ] when ;
   
+PRIVATE>
+
 : csv-row ( stream -- row )
-  [ row nip ] with-input-stream ;
+    [ row nip ] with-input-stream ;
 
 : csv ( stream -- rows )
-  [ [ (csv) ] { } make ] with-input-stream ;
+    [ [ (csv) ] { } make ] with-input-stream ;
 
-: with-delimiter ( char quot -- )
+: file>csv ( path encoding -- csv )
-  delimiter swap with-variable ; inline
+    <file-reader> csv ;
+
+: with-delimiter ( ch quot -- )
+    [ delimiter ] dip with-variable ; inline
+
+<PRIVATE
 
 : needs-escaping? ( cell -- ? )
-  [ [ "\n\"" member? ] [ delimiter get = ] bi or ] any? ; inline
+    [ { [ "\n\"" member? ] [ delimiter get = ] } 1|| ] any? ; inline
 
 : escape-quotes ( cell -- cell' )
-  [ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
+    [
+        [
+            [ , ]
+            [ dup CHAR: " = [ , ] [ drop ] if ] bi
+        ] each
+    ] "" make ; inline
 
 : enclose-in-quotes ( cell -- cell' )
-  CHAR: " [ prefix ] [ suffix ] bi ; inline ! "
+    "\"" dup surround ; inline
     
 : escape-if-required ( cell -- cell' )
-  dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
+    dup needs-escaping?
+    [ escape-quotes enclose-in-quotes ] when ; inline
+
+PRIVATE>
     
 : write-row ( row -- )
-  [ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline
+    [ delimiter get write1 ]
+    [ escape-if-required write ] interleave nl ; inline
     
 : write-csv ( rows stream -- )
-  [ [ write-row ] each ] with-output-stream ;
+    [ [ write-row ] each ] with-output-stream ;
+
+: csv>file ( rows path encoding -- ) <file-writer> write-csv ;

basis/db/tuples/tuples-docs.factor

@@ -1,9 +1,13 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings multiline math db.types db ;
+quotations sequences strings multiline math db.types
+db.tuples.private db ;
 IN: db.tuples
 
+HELP: random-id-generator
+{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ;
+
 HELP: create-sql-statement
 { $values
      { "class" class }

basis/db/types/types-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes hashtables help.markup help.syntax io.streams.string
-kernel sequences strings math db.tuples db.tuples.private ;
+kernel sequences strings math ;
 IN: db.types
 
 HELP: +db-assigned-id+
@@ -89,31 +89,31 @@ HELP: VARCHAR
 
 HELP: user-assigned-id-spec?
 { $values
-     { "specs" "a sequence of sql specs" }
+     { "specs" "a sequence of SQL specs" }
      { "?" "a boolean" } }
-{ $description "Tests if any of the sql specs has the type " { $link +user-assigned-id+ } "." } ;
+{ $description "Tests if any of the SQL specs has the type " { $link +user-assigned-id+ } "." } ;
 
 HELP: bind#
 { $values
-     { "spec" "a sql spec" } { "obj" object } }
+     { "spec" "a SQL spec" } { "obj" object } }
 { $description "A generic word that lets a database construct a literal binding." } ;
 
 HELP: bind%
 { $values
-     { "spec" "a sql spec" } }
+     { "spec" "a SQL spec" } }
 { $description "A generic word that lets a database output a binding." } ;
 
 HELP: db-assigned-id-spec?
 { $values
-     { "specs" "a sequence of sql specs" }
+     { "specs" "a sequence of SQL specs" }
      { "?" "a boolean" } }
-{ $description "Tests if any of the sql specs has the type " { $link +db-assigned-id+ } "." } ;
+{ $description "Tests if any of the SQL specs has the type " { $link +db-assigned-id+ } "." } ;
 
 HELP: find-primary-key
 { $values
-     { "specs" "a sequence of sql-specs" }
+     { "specs" "a sequence of SQL specs" }
-     { "seq" "a sequence of sql-specs" } }
+     { "seq" "a sequence of SQL specs" } }
-{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
+{ $description "Returns the rows from the SQL specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
 { $notes "This is a low-level word." } ;
 
 HELP: get-slot-named
@@ -124,13 +124,13 @@ HELP: get-slot-named
 
 HELP: no-sql-type
 { $values
-     { "type" "a sql type" } }
+     { "type" "a SQL type" } }
-{ $description "Throws an error containing a sql type that is unsupported or the result of a typo." } ;
+{ $description "Throws an error containing a SQL type that is unsupported or the result of a typo." } ;
 
 HELP: normalize-spec
 { $values
-     { "spec" "a sql spec" } }
+     { "spec" "a SQL spec" } }
-{ $description "Normalizes a sql spec." } ;
+{ $description "Normalizes a SQL spec." } ;
 
 HELP: offset-of-slot
 { $values
@@ -140,22 +140,19 @@ HELP: offset-of-slot
 
 HELP: primary-key?
 { $values
-     { "spec" "a sql spec" }
+     { "spec" "a SQL spec" }
      { "?" "a boolean" } }
-{ $description "Returns true if a sql spec is a primary key." } ;
+{ $description "Returns true if a SQL spec is a primary key." } ;
-
-HELP: random-id-generator
-{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ;
 
 HELP: relation?
 { $values
-     { "spec" "a sql spec" }
+     { "spec" "a SQL spec" }
      { "?" "a boolean" } }
-{ $description "Returns true if a sql spec is a relation." } ;
+{ $description "Returns true if a SQL spec is a relation." } ;
 
 HELP: unknown-modifier
 { $values { "modifier" string } }
-{ $description "Throws an error containing an unknown sql modifier." } ;
+{ $description "Throws an error containing an unknown SQL modifier." } ;
 
 ARTICLE: "db.types" "Database types"
 "The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl

basis/farkup/farkup.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators html.elements io
+USING: accessors arrays combinators io
 io.streams.string kernel math namespaces peg peg.ebnf
 sequences sequences.deep strings xml.entities xml.literals
 vectors splitting xmode.code2html urls.encoding xml.data

basis/furnace/actions/actions.factor

@@ -10,7 +10,6 @@ furnace.utilities
 furnace.redirection
 furnace.conversations
 html.forms
-html.elements
 html.components
 html.components
 html.templates.chloe

basis/furnace/auth/auth-docs.factor

@@ -105,9 +105,8 @@ ARTICLE: "furnace.auth.realm-config" "Authentication realm configuration"
 "Instances of subclasses of " { $link realm } " have the following slots which may be set:"
 { $table
     { { $slot "name" } "A string identifying the realm for user interface purposes" }
-    { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } ". By default, the " { $link users-in-db } " provider is used." } }
+    { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } "). By default, the " { $link users-in-db } " provider is used." } }
     { { $slot "checksum" } { "An implementation of the checksum protocol used for verifying passwords (see " { $link "checksums" } "). The " { $link sha-256 } " checksum is used by default." } }
-    { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } } }
     { { $slot "secure" } { "A boolean, that when set to a true value, forces the client to access the authentication realm via HTTPS. An attempt to access the realm via HTTP results in a redirect to the corresponding HTTPS URL. On by default." } }
 } ;
 

basis/furnace/chloe-tags/chloe-tags.factor

@@ -8,6 +8,7 @@ xml.data
 xml.entities
 xml.writer
 xml.utilities
+xml.literals
 html.components
 html.elements
 html.forms
@@ -20,7 +21,6 @@ http.server
 http.server.redirection
 http.server.responses
 furnace.utilities ;
-QUALIFIED-WITH: assocs a
 IN: furnace.chloe-tags
 
 ! Chloe tags
@@ -56,11 +56,11 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
 
 : compile-link-attrs ( tag -- )
     #! Side-effects current namespace.
-    attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
+    '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
 
 : a-start-tag ( tag -- )
     [ <a ] [code]
-    [ non-chloe-attrs-only compile-attrs ]
+    [ attrs>> non-chloe-attrs-only compile-attrs ]
     [ compile-link-attrs ]
     [ compile-a-url ]
     tri
@@ -116,17 +116,18 @@ CHLOE: form
         } cleave
     ] compile-with-scope ;
 
-STRING: button-tag-markup
+: button-tag-markup ( -- xml )
-<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
+    <XML
-    <div style="display: inline;"><button type="submit"></button></div>
+        <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
-</t:form>
+            <div style="display: inline;"><button type="submit"></button></div>
-;
+        </t:form>
+    XML> ;
 
 : add-tag-attrs ( attrs tag -- )
     attrs>> swap update ;
 
 CHLOE: button
-    button-tag-markup string>xml body>>
+    button-tag-markup body>>
     {
         [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
         [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]

basis/help/html/html-tests.factor

@@ -1,5 +1,4 @@
 IN: help.html.tests
-USING: html.streams classes.predicate help.topics help.markup
+USING: help.html tools.test help.topics kernel ;
-io.streams.string accessors prettyprint kernel tools.test ;
 
-[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test
+[ ] [ "xml" >link help>html drop ] unit-test

basis/help/html/html.factor

@@ -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: io.encodings.utf8 io.encodings.ascii io.encodings.binary
-io.files io.files.temp io.directories html.streams html.elements help kernel
+io.files io.files.temp io.directories html.streams help kernel
 assocs sequences make words accessors arrays help.topics vocabs
 tools.vocabs tools.vocabs.browser namespaces prettyprint io
 vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger ;
+sorting debugger html xml.literals xml.writer ;
 IN: help.html
 
 : escape-char ( ch -- )
@@ -51,17 +51,21 @@ M: f topic>filename* drop \ f topic>filename* ;
         ] "" make
     ] [ 2drop f ] if ;
 
-M: topic browser-link-href topic>filename ;
+M: topic url-of topic>filename ;
 
-: help-stylesheet ( -- )
+: help-stylesheet ( -- string )
-    "resource:basis/help/html/stylesheet.css" ascii file-contents write ;
+    "resource:basis/help/html/stylesheet.css" ascii file-contents
+    [XML <style><-></style> XML] ;
 
-: help>html ( topic -- )
+: help>html ( topic -- xml )
-    dup topic>filename utf8 [
+    [ article-title ]
-        dup article-title
+    [ drop help-stylesheet ]
-        [ <style> help-stylesheet </style> ]
+    [ [ help ] with-html-writer ]
-        [ [ help ] with-html-writer ] simple-page
+    tri simple-page ;
-    ] with-file-writer ;
+          
+: generate-help-file ( topic -- )
+    dup .
+    dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
 
 : all-vocabs-really ( -- seq )
     #! Hack.
@@ -87,7 +91,7 @@ M: topic browser-link-href topic>filename ;
     all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
 
 : generate-help-files ( -- )
-    all-topics [ '[ _ help>html ] try ] each ;
+    all-topics [ '[ _ generate-help-file ] try ] each ;
 
 : generate-help ( -- )
     "docs" temp-file

basis/html/components/components-docs.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Your name.
+! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax io.streams.string kernel strings
 urls lcs inspector present io ;
@@ -100,6 +100,6 @@ $nl
 { $subsection farkup }
 "Creating custom components:"
 { $subsection render* }
-"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ;
+"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ;
 
 ABOUT: "html.components"

basis/html/components/components-tests.factor

@@ -1,7 +1,8 @@
 IN: html.components.tests
 USING: tools.test kernel io.streams.string
 io.streams.null accessors inspector html.streams
-html.elements html.components html.forms namespaces ;
+html.components html.forms namespaces
+xml.writer ;
 
 [ ] [ begin-form ] unit-test
 
@@ -31,6 +32,11 @@ TUPLE: color red green blue ;
     ] with-string-writer
 ] unit-test
 
+[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
+    [
+        "red" hidden render
+    ] with-string-writer
+] unit-test
 [ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
     [
         "red" hidden render
@@ -163,9 +169,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ t ] [
     [ "object" inspector render ] with-string-writer
-    USING: splitting sequences ;
+    "object" value [ describe ] with-html-writer xml>string
-    "\"" split "'" join ! replace " with ' for now
-    [ "object" value [ describe ] with-html-writer ] with-string-writer
     =
 ] unit-test
 
@@ -185,3 +189,9 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
         }
     }
 ] [ values ] unit-test
+
+[ ] [ "error" "blah" <validation-error> "error" set-value ] unit-test
+
+[ ] [
+    "error" hidden render
+] unit-test

basis/html/components/components.factor

@@ -6,7 +6,7 @@ hashtables combinators continuations math strings inspector
 fry locals calendar calendar.format xml.entities xml.data
 validators urls present xml.writer xml.literals xml
 xmode.code2html lcs.diff2html farkup io.streams.string
-html.elements html.streams html.forms ;
+html html.streams html.forms ;
 IN: html.components
 
 GENERIC: render* ( value name renderer -- xml )
@@ -15,19 +15,12 @@ GENERIC: render* ( value name renderer -- xml )
     prepare-value
     [
         dup validation-error?
-        [ [ message>> ] [ value>> ] bi ]
+        [ [ message>> render-error ] [ value>> ] bi ]
         [ f swap ]
         if
     ] 2dip
-    render* write-xml
+    render*
-    [ render-error ] when* ;
+    swap 2array write-xml ;
-
-<PRIVATE
-
-: render-input ( value name type -- xml )
-    [XML <input value=<-> name=<-> type=<->/> XML] ;
-
-PRIVATE>
 
 SINGLETON: label
 
@@ -37,7 +30,7 @@ M: label render*
 SINGLETON: hidden
 
 M: hidden render*
-    drop "hidden" render-input ;
+    drop [XML <input value=<-> name=<-> type="hidden"/> XML] ;
 
 : render-field ( value name size type -- xml )
     [XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
@@ -163,9 +156,7 @@ M: farkup render*
 SINGLETON: inspector
 
 M: inspector render*
-    2drop [
+    2drop [ describe ] with-html-writer ;
-        [ describe ] with-html-writer
-    ] with-string-writer <unescaped> ;
 
 ! Diff component
 SINGLETON: comparison

basis/html/elements/elements-docs.factor

@@ -1,5 +1,5 @@
+USING: help.markup help.syntax io present html ;
 IN: html.elements
-USING: help.markup help.syntax io present ;
 
 ARTICLE: "html.elements" "HTML elements"
 "The " { $vocab-link "html.elements" } " vocabulary provides words for writing HTML tags to the " { $link output-stream } " with a familiar look and feel in the code."
@@ -20,10 +20,6 @@ $nl
 $nl
 "Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
 { $subsection write-html }
-{ $subsection print-html }
+{ $subsection print-html } ;
-"Writing some common HTML patterns:"
-{ $subsection xhtml-preamble }
-{ $subsection simple-page }
-{ $subsection render-error } ;
 
 ABOUT: "html.elements"

basis/html/elements/elements.factor

@@ -3,8 +3,7 @@
 USING: io io.styles kernel namespaces prettyprint quotations
 sequences strings words xml.entities compiler.units effects
 xml.data xml.literals urls math math.parser combinators
-present fry io.streams.string xml.writer ;
+present fry io.streams.string xml.writer html ;
-
 IN: html.elements
 
 SYMBOL: html
@@ -127,24 +126,3 @@ SYMBOL: html
 ] [ define-attribute-word ] each
 
 >>
-
-: xhtml-preamble ( -- )
-    "<?xml version=\"1.0\"?>" write-html
-    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
-
-: simple-page ( title head-quot body-quot -- )
-    [ with-string-writer <unescaped> ] bi@
-    <XML
-        <?xml version="1.0"?>
-        <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
-        <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
-            <head>
-                <title><-></title>
-                <->
-            </head>
-            <body><-></body>
-        </html>
-    XML> write-xml ; inline
-
-: render-error ( message -- )
-    [XML <span class="error"><-></span> XML] write-xml ;

basis/html/forms/forms.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors strings namespaces assocs hashtables io
-mirrors math fry sequences words continuations html.elements
+mirrors math fry sequences words continuations
-xml.entities ;
+xml.entities xml.writer xml.literals ;
 IN: html.forms
 
 TUPLE: form errors values validation-failed ;
@@ -109,7 +109,6 @@ C: <validation-error> validation-error
 : render-validation-errors ( -- )
     form get errors>>
     [
-        <ul "errors" =class ul>
+        [ [XML <li><-></li> XML] ] map
-            [ <li> escape-string write </li> ] each
+        [XML <ul class="errors"><-></ul> XML] write-xml
-        </ul>
     ] unless-empty ;

basis/html/html.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg,
+! Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel xml.data xml.writer xml.literals urls.encoding ;
+IN: html
+
+: simple-page ( title head body -- xml )
+    <XML
+        <?xml version="1.0"?>
+        <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+        <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+            <head>
+                <title><-></title>
+                <->
+            </head>
+            <body><-></body>
+        </html>
+    XML> ; inline
+
+: render-error ( message -- xml )
+    [XML <span class="error"><-></span> XML] ;
+
+: simple-link ( xml url -- xml' )
+    url-encode swap [XML <a href=<->><-></a> XML] ;

basis/html/streams/streams-docs.factor

@@ -1,33 +1,33 @@
 IN: html.streams
 USING: help.markup help.syntax kernel strings io io.styles
-quotations ;
+quotations xml.data ;
 
-HELP: browser-link-href
+HELP: url-of
-{ $values { "presented" object } { "href" string } }
+{ $values { "object" object } { "url" string } }
-{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-stream } " instances." } ;
+{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-writer } " instances." } ;
 
-HELP: html-stream
+HELP: html-writer
-{ $class-description "A formatted output stream which emits HTML markup." } ;
+{ $class-description "A formatted output stream which accumulates HTML markup as " { $vocab-link "xml.data" } " types. The " { $slot "data" } " slot contains a sequence with all markup so far." } ;
 
-HELP: <html-stream>
+HELP: <html-writer>
-{ $values { "stream" "an output stream" } { "html-stream" html-stream } }
+{ $values { "html-writer" html-writer } }
-{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ;
+{ $description "Creates a new formatted output stream which accumulates HTML markup in its " { $snippet "data" } " slot." } ;
 
 HELP: with-html-writer
-{ $values { "quot" quotation } }
+{ $values { "quot" quotation } { "xml" xml-chunk } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-writer } ". When the quotation returns, outputs the accumulated HTML markup." }
 { $examples
     { $example
-        "USING: io io.styles html.streams ;"
+        "USING: io io.styles html.streams xml.writer ;"
-        "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer"
+        "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer write-xml"
-        "<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>"
+        "<span style=\"font-style: normal; font-weight: bold; \">Hello</span><br/>"
     }
 } ;
 
 ARTICLE: "html.streams" "HTML streams"
-"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream."
+"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "io.styles" } " by constructing HTML markup in the form of " { $vocab-link "xml.data" } " types."
-{ $subsection html-stream }
+{ $subsection html-writer }
-{ $subsection <html-stream> }
+{ $subsection <html-writer> }
 { $subsection with-html-writer } ;
 
 ABOUT: "html.streams"

basis/html/streams/streams-tests.factor

@@ -1,17 +1,14 @@
 USING: html.streams html.streams.private accessors io
 io.streams.string io.styles kernel namespaces tools.test
-xml.writer sbufs sequences inspector colors ;
+xml.writer sbufs sequences inspector colors xml.writer
+classes.predicate prettyprint ;
 IN: html.streams.tests
 
-: make-html-string
+: make-html-string ( quot -- string )
-    [ with-html-writer ] with-string-writer ; inline
+    [ with-html-writer write-xml ] with-string-writer ; inline
 
 [ [ ] make-html-string ] must-infer
 
-[ ] [
-    512 <sbuf> <html-stream> drop
-] unit-test
-
 [ "" ] [
     [ "" write ] make-html-string
 ] unit-test
@@ -24,22 +21,17 @@ IN: html.streams.tests
     [ "<" write ] make-html-string
 ] unit-test
 
-[ "<" ] [
-    [ "<" H{ } output-stream get format-html-span ] make-html-string
-] unit-test
-
 TUPLE: funky town ;
 
-M: funky browser-link-href
+M: funky url-of "http://www.funky-town.com/" swap town>> append ;
-    "http://www.funky-town.com/" swap town>> append ;
 
-[ "<a href='http://www.funky-town.com/austin'>&lt;</a>" ] [
+[ "<a href=\"http://www.funky-town.com/austin\">&lt;</a>" ] [
     [
         "<" "austin" funky boa write-object
     ] make-html-string
 ] unit-test
 
-[ "<span style='font-family: monospace; '>car</span>" ]
+[ "<span style=\"font-family: monospace; \">car</span>" ]
 [
     [
         "car"
@@ -48,7 +40,7 @@ M: funky browser-link-href
     ] make-html-string
 ] unit-test
 
-[ "<span style='color: #ff00ff; '>car</span>" ]
+[ "<span style=\"color: #ff00ff; \">car</span>" ]
 [
     [
         "car"
@@ -57,7 +49,7 @@ M: funky browser-link-href
     ] make-html-string
 ] unit-test
 
-[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
+[ "<div style=\"background-color: #ff00ff; white-space: pre; font-family: monospace;\">cdr</div>" ]
 [
     [
         H{ { page-color T{ rgba f 1 0 1 1 } } }
@@ -65,10 +57,10 @@ M: funky browser-link-href
     ] make-html-string
 ] unit-test
 
-[
+[ "<div style=\"white-space: pre; font-family: monospace;\"></div>" ] [
-    "<div style='white-space: pre; font-family: monospace; '></div>"
-] [
     [ H{ } [ ] with-nesting nl ] make-html-string
 ] unit-test
 
-[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test
+[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
+
+[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test

basis/html/streams/streams.factor

@@ -1,17 +1,17 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators generic assocs io io.styles
+USING: accessors kernel assocs io io.styles math math.order math.parser
-io.files continuations io.streams.string kernel math math.order
+sequences strings make words combinators macros xml.literals html fry
-math.parser namespaces make quotations assocs sequences strings
+destructors ;
-words html.elements xml.entities sbufs continuations destructors
-accessors arrays urls.encoding ;
 IN: html.streams
 
-GENERIC: browser-link-href ( presented -- href )
+GENERIC: url-of ( object -- url )
 
-M: object browser-link-href drop f ;
+M: object url-of drop f ;
 
-TUPLE: html-stream stream last-div ;
+TUPLE: html-writer data last-div ;
+
+<PRIVATE
 
 ! stream-nl after with-nesting or tabular-output is
 ! ignored, so that HTML stream output looks like
@@ -25,37 +25,28 @@ TUPLE: html-stream stream last-div ;
 : a-div ( stream -- stream )
     t >>last-div ; inline
 
-: <html-stream> ( stream -- html-stream )
+: new-html-writer ( class -- html-writer )
-    f html-stream boa ;
+    new V{ } clone >>data ; inline
 
-<PRIVATE
+TUPLE: html-sub-stream < html-writer style parent ;
-
-TUPLE: html-sub-stream < html-stream style parent ;
 
 : new-html-sub-stream ( style stream class -- stream )
-    new
+    new-html-writer
-        512 <sbuf> >>stream
         swap >>parent
         swap >>style ; inline
 
 : end-sub-stream ( substream -- string style stream )
-    [ stream>> >string ] [ style>> ] [ parent>> ] tri ;
+    [ data>> ] [ style>> ] [ parent>> ] tri ;
 
-: object-link-tag ( style quot -- )
+: object-link-tag ( xml style -- xml )
-    presented pick at [
+    presented swap at [ url-of [ simple-link ] when* ] when* ;
-        browser-link-href [
-            <a url-encode =href a> call </a>
-        ] [ call ] if*
-    ] [ call ] if* ; inline
 
-: href-link-tag ( style quot -- )
+: href-link-tag ( xml style -- xml )
-    href pick at [
+    href swap at [ simple-link ] when* ;
-        <a url-encode =href a> call </a>
-    ] [ call ] if* ; inline
 
 : hex-color, ( color -- )
     [ red>> ] [ green>> ] [ blue>> ] tri
-    [ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ;
+    [ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
 
 : fg-css, ( color -- )
     "color: #" % hex-color, "; " % ;
@@ -76,32 +67,29 @@ TUPLE: html-sub-stream < html-stream style parent ;
 : font-css, ( font -- )
     "font-family: " % % "; " % ;
 
-: apply-style ( style key quot -- style gadget )
+MACRO: make-css ( pairs -- str )
-    [ over at ] dip when* ; inline
+    [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
-
+    '[ [ _ cleave ] "" make ] ;
-: make-css ( style quot -- str )
-    "" make nip ; inline
 
 : span-css-style ( style -- str )
-    [
+    {
-        foreground [ fg-css,    ] apply-style
+        { foreground fg-css, }
-        background [ bg-css,    ] apply-style
+        { background bg-css, }
-        font       [ font-css,  ] apply-style
+        { font font-css, }
-        font-style [ style-css, ] apply-style
+        { font-style style-css, }
-        font-size  [ size-css,  ] apply-style
+        { font-size size-css, }
-    ] make-css ;
+    } make-css ;
 
-: span-tag ( style quot -- )
+: span-tag ( xml style -- xml )
-    over span-css-style [
+    span-css-style
-        call
+    [ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
-    ] [
+
-        <span =style span> call </span>
+: emit-html ( quot stream -- )
-    ] if-empty ; inline
+    dip data>> push ; inline
 
 : format-html-span ( string style stream -- )
-    stream>> [
+    [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
-        [ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag
+    emit-html ;
-    ] with-output-stream* ;
 
 TUPLE: html-span-stream < html-sub-stream ;
 
@@ -113,28 +101,26 @@ M: html-span-stream dispose
 
 : padding-css, ( padding -- ) "padding: " % # "px; " % ;
 
-: pre-css, ( margin -- )
+CONSTANT: pre-css "white-space: pre; font-family: monospace;"
-    [ "white-space: pre; font-family: monospace; " % ] unless ;
 
 : div-css-style ( style -- str )
     [
-        page-color   [ bg-css,      ] apply-style
+        {
-        border-color [ border-css,  ] apply-style
+            { page-color bg-css, }
-        border-width [ padding-css, ] apply-style
+            { border-color border-css, }
-        wrap-margin over at pre-css,
+            { border-width padding-css, }
-    ] make-css ;
+        } make-css
-
-: div-tag ( style quot -- )
-    swap div-css-style [
-        call
     ] [
-        <div =style div> call </div>
+        wrap-margin swap at
-    ] if-empty ; inline
+        [ pre-css append ] unless
+    ] bi ;
+
+: div-tag ( xml style -- xml' )
+    div-css-style
+    [ swap [XML <div style=<->><-></div> XML] ] unless-empty ;
 
 : format-html-div ( string style stream -- )
-    stream>> [
+    [ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
-        [ [ write ] div-tag ] object-link-tag
-    ] with-output-stream* ;
 
 TUPLE: html-block-stream < html-sub-stream ;
 
@@ -145,57 +131,51 @@ M: html-block-stream dispose ( quot style stream -- )
     "padding: " % first2 max 2 /i # "px; " % ;
 
 : table-style ( style -- str )
-    [
+    {
-        table-border [ border-css,         ] apply-style
+        { table-border border-css, }
-        table-gap    [ border-spacing-css, ] apply-style
+        { table-gap border-spacing-css, }
-    ] make-css ;
+    } make-css
-
+    " border-collapse: collapse;" append ;
-: table-attrs ( style -- )
-    table-style " border-collapse: collapse;" append =style ;
-
-: do-escaping ( string style -- string )
-    html swap at [ escape-string ] unless ;
 
 PRIVATE>
 
 ! Stream protocol
-M: html-stream stream-flush
+M: html-writer stream-flush drop ;
-    stream>> stream-flush ;
 
-M: html-stream stream-write1
+M: html-writer stream-write1
-    [ 1string ] dip stream-write ;
+    not-a-div [ 1string ] emit-html ;
 
-M: html-stream stream-write
+M: html-writer stream-write
-    not-a-div [ escape-string ] dip stream>> stream-write ;
+    not-a-div [ ] emit-html ;
 
-M: html-stream stream-format
+M: html-writer stream-format
-    [ html over at [ [ escape-string ] dip ] unless ] dip
     format-html-span ;
 
-M: html-stream stream-nl
+M: html-writer stream-nl
-    dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
+    dup last-div? [ drop ] [ [ [XML <br/> XML] ] emit-html ] if ;
 
-M: html-stream make-span-stream
+M: html-writer make-span-stream
     html-span-stream new-html-sub-stream ;
 
-M: html-stream make-block-stream
+M: html-writer make-block-stream
     html-block-stream new-html-sub-stream ;
 
-M: html-stream make-cell-stream
+M: html-writer make-cell-stream
     html-sub-stream new-html-sub-stream ;
 
-M: html-stream stream-write-table
+M: html-writer stream-write-table
-    a-div stream>> [
+    a-div [
-        <table dup table-attrs table> swap [
+        table-style swap [
-            <tr> [
+            [ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
-                <td "top" =valign swap table-style =style td>
+            [XML <tr><-></tr> XML]
-                    stream>> >string write
+        ] with map
-                </td>
+        [XML <table><-></table> XML]
-            ] with each </tr>
+    ] emit-html ;
-        ] with each </table>
-    ] with-output-stream* ;
 
-M: html-stream dispose stream>> dispose ;
+M: html-writer dispose drop ;
 
-: with-html-writer ( quot -- )
+: <html-writer> ( -- html-writer )
-    output-stream get <html-stream> swap with-output-stream* ; inline
+    html-writer new-html-writer ;
+
+: with-html-writer ( quot -- xml )
+    <html-writer> [ swap with-output-stream* ] keep data>> ; inline

basis/html/templates/chloe/chloe.factor

@@ -5,8 +5,9 @@ namespaces make classes.tuple assocs splitting words arrays io
 io.files io.files.info io.encodings.utf8 io.streams.string
 unicode.case mirrors math urls present multiline quotations xml
 logging continuations
-xml.data
+xml.data xml.writer xml.literals strings
 html.forms
+html
 html.elements
 html.components
 html.templates
@@ -15,7 +16,6 @@ html.templates.chloe.components
 html.templates.chloe.syntax ;
 IN: html.templates.chloe
 
-! Chloe is Ed's favorite web designer
 TUPLE: chloe path ;
 
 C: <chloe> chloe

basis/html/templates/chloe/compiler/compiler.factor

@@ -73,8 +73,8 @@ DEFER: compile-element
         [ compile-start-tag ]
         [ compile-children ]
         [ compile-end-tag ]
-        [ drop tag-stack get pop* ]
+    } cleave
-    } cleave ;
+    tag-stack get pop* ;
 
 ERROR: unknown-chloe-tag tag ;
 
@@ -116,7 +116,7 @@ ERROR: unknown-chloe-tag tag ;
     [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
 
 : compile-children>string ( tag -- )
-     [ with-string-writer ] process-children ;
+    [ with-string-writer ] process-children ;
 
 : compile-with-scope ( quot -- )
     compile-quot [ with-scope ] [code] ; inline

basis/html/templates/chloe/components/components.factor

@@ -21,7 +21,8 @@ M: singleton-class component-tag ( tag class -- )
     bi ;
 
 M: tuple-class component-tag ( tag class -- )
-    [ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
+    [ drop "name" required-attr compile-attr ]
+    [ compile-component-attrs ] 2bi
     [ render ] [code] ;
 
 : COMPONENT:

basis/html/templates/chloe/syntax/syntax.factor

@@ -6,7 +6,6 @@ classes.tuple assocs splitting words arrays memoize parser lexer
 io io.files io.encodings.utf8 io.streams.string
 unicode.case mirrors fry math urls
 multiline xml xml.data xml.writer xml.utilities
-html.elements
 html.components
 html.templates ;
 

basis/html/templates/fhtml/fhtml.factor

@@ -1,12 +1,10 @@
 ! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations sequences kernel namespaces debugger
-combinators math quotations generic strings splitting
+combinators math quotations generic strings splitting accessors
-accessors assocs fry vocabs.parser
+assocs fry vocabs.parser parser lexer io io.files
-parser lexer io io.files io.streams.string io.encodings.utf8
+io.streams.string io.encodings.utf8 html.templates ;
-html.elements
-html.templates ;
 IN: html.templates.fhtml
 
 ! We use a custom lexer so that %> ends a token even if not
@@ -34,13 +32,13 @@ DEFER: <% delimiter
     [
         over line-text>>
         [ column>> ] 2dip subseq parsed
-        \ write-html parsed
+        \ write parsed
     ] 2keep 2 + >>column drop ;
 
 : still-looking ( accum lexer -- accum )
     [
         [ line-text>> ] [ column>> ] bi tail
-        parsed \ print-html parsed
+        parsed \ print parsed
     ] keep next-line ;
 
 : parse-%> ( accum lexer -- accum )

basis/html/templates/templates.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel fry io io.encodings.utf8 io.files
 debugger prettyprint continuations namespaces boxes sequences
-arrays strings html.elements io.streams.string
+arrays strings html io.streams.string
-quotations xml.data xml.writer ;
+quotations xml.data xml.writer xml.literals ;
 IN: html.templates
 
 MIXIN: template
@@ -53,9 +53,13 @@ SYMBOL: atom-feeds
 
 : write-atom-feeds ( -- )
     atom-feeds get [
-        <link "alternate" =rel "application/atom+xml" =type
+        first2 [XML
-        first2 [ =title ] [ =href ] bi*
+            <link
-        link/>
+                rel="alternate"
+                type="application/atom+xml"
+                title=<->
+                href=<->/>
+        XML] write-xml
     ] each ;
 
 SYMBOL: nested-template?
@@ -63,7 +67,7 @@ SYMBOL: nested-template?
 SYMBOL: next-template
 
 : call-next-template ( -- )
-    next-template get write-html ;
+    next-template get write ;
 
 M: f call-template* drop call-next-template ;
 

basis/http/http-tests.factor

@@ -298,7 +298,7 @@ test-db [
 
 [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 
-USING: html.components html.elements html.forms
+USING: html.components html.forms
 xml xml.utilities validators
 furnace furnace.conversations ;
 
@@ -308,7 +308,7 @@ SYMBOL: a
     <dispatcher>
         <action>
             [ a get-global "a" set-value ] >>init
-            [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
+            [ [ "<html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
             [ { { "a" [ v-integer ] } } validate-params ] >>validate
             [ "a" value a set-global URL" " <redirect> ] >>submit
         <conversations>
@@ -322,7 +322,8 @@ SYMBOL: a
 
 3 a set-global
 
-: test-a string>xml "input" tag-named "value" attr ;
+: test-a ( xml -- value )
+    string>xml body>> "input" deep-tag-named "value" attr ;
 
 [ "3" ] [
     "http://localhost/" add-port http-get

basis/http/server/dispatchers/dispatchers-tests.factor

@@ -4,7 +4,6 @@ assocs arrays classes words urls ;
 IN: http.server.dispatchers.tests
 
 \ find-responder must-infer
-\ http-error. must-infer
 
 TUPLE: mock-responder path ;
 

basis/http/server/responses/responses.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: html.elements math.parser http accessors kernel
+USING: math.parser http accessors kernel xml.literals xml.writer
 io io.streams.string io.encodings.utf8 ;
 IN: http.server.responses
 
@@ -13,11 +13,13 @@ IN: http.server.responses
         swap >>body ;
     
 : trivial-response-body ( code message -- )
-    <html>
+    <XML
-        <body>
+        <html>
-            <h1> [ number>string write bl ] [ write ] bi* </h1>
+            <body>
-        </body>
+                <h1><-> <-></h1>
-    </html> ;
+            </body>
+        </html>
+    XML> write-xml ;
 
 : <trivial-response> ( code message -- response )
     2dup [ trivial-response-body ] with-string-writer

basis/http/server/server-tests.factor

@@ -2,3 +2,5 @@ USING: http http.server math sequences continuations tools.test ;
 IN: http.server.tests
 
 [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
+
+\ make-http-error must-infer

basis/http/server/server.factor

@@ -24,8 +24,9 @@ http.parsers
 http.server.responses
 http.server.remapping
 html.templates
-html.elements
+html.streams
-html.streams ;
+html
+xml.writer ;
 IN: http.server
 
 : check-absolute ( url -- url )
@@ -173,14 +174,14 @@ main-responder global [ <404> <trivial-responder> or ] change-at
 : call-responder ( path responder -- response )
     [ add-responder-nesting ] [ call-responder* ] 2bi ;
 
-: http-error. ( error -- )
+: make-http-error ( error -- xml )
-    "Internal server error" [ ] [
+    [ "Internal server error" f ] dip
-        [ print-error nl :c ] with-html-writer
+    [ print-error nl :c ] with-html-writer
-    ] simple-page ;
+    simple-page ;
 
 : <500> ( error -- response )
     500 "Internal server error" <trivial-response>
-    swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ;
+    swap development? get [ make-http-error >>body ] [ drop ] if ;
 
 : do-response ( response -- )
     [ request get swap write-full-response ]
@@ -189,7 +190,8 @@ main-responder global [ <404> <trivial-responder> or ] change-at
         [
             utf8 [
                 development? get
-                [ http-error. ] [ drop "Response error" write ] if
+                [ make-http-error ] [ drop "Response error" ] if
+                write-xml
             ] with-encoded-output
         ] bi
     ] recover ;

basis/http/server/static/static-tests.factor

@@ -0,0 +1,4 @@
+IN: http.server.static.tests
+USING: http.server.static tools.test xml.writer ;
+
+[ ] [ "resource:basis" directory>html write-xml ] unit-test

basis/http/server/static/static.factor

@@ -4,9 +4,9 @@ USING: calendar kernel math math.order math.parser namespaces
 parser sequences strings assocs hashtables debugger mime.types
 sorting logging calendar.format accessors splitting io io.files
 io.files.info io.directories io.pathnames io.encodings.binary
-fry xml.entities destructors urls html.elements
+fry xml.entities destructors urls html xml.literals
 html.templates.fhtml http http.server http.server.responses
-http.server.redirection ;
+http.server.redirection xml.writer ;
 IN: http.server.static
 
 TUPLE: file-responder root hook special allow-listings ;
@@ -56,23 +56,22 @@ TUPLE: file-responder root hook special allow-listings ;
 
 \ serve-file NOTICE add-input-logging
 
-: file. ( name -- )
+: file>html ( name -- xml )
     dup link-info directory? [ "/" append ] when
-    dup <a =href a> escape-string write </a> ;
+    dup [XML <li><a href=<->><-></a></li> XML] ;
 
-: directory. ( path -- )
+: directory>html ( path -- xml )
-    dup file-name [ ] [
+    [ file-name ]
-        [ <h1> file-name escape-string write </h1> ]
+    [ drop f ]
-        [
+    [
-            <ul>
+        [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
-                directory-files [ <li> file. </li> ] each
+        [XML <h1><-></h1> <ul><-></ul> XML]
-            </ul>
+    ] tri
-        ] bi
+    simple-page ;
-    ] simple-page ;
 
 : list-directory ( directory -- response )
     file-responder get allow-listings>> [
-        '[ _ directory. ] "text/html" <content>
+        directory>html "text/html" <content>
     ] [
         drop <403>
     ] if ;

basis/io/encodings/8-bit/8-bit.factor

@@ -45,7 +45,7 @@ IN: io.encodings.8-bit
 : ch>byte ( assoc -- newassoc )
     [ swap ] assoc-map >hashtable ;
 
-: parse-file ( path -- byte>ch ch>byte )
+: parse-file ( stream -- byte>ch ch>byte )
     lines process-contents
     [ byte>ch ] [ ch>byte ] bi ;
 

basis/io/encodings/japanese/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

basis/io/encodings/japanese/japanese-docs.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.japanese
+
+ARTICLE: "io.encodings.japanese" "Japanese text encodings"
+"Several encodings are used for Japanese text besides the standard UTF encodings for Unicode strings. These are mostly based on the character set defined in the JIS X 208 standard. Current coverage of encodings is incomplete."
+{ $subsection shift-jis }
+{ $subsection windows-31j } ;
+
+ABOUT: "io.encodings.japanese"
+
+HELP: windows-31j
+{ $class-description "The encoding descriptor Windows-31J, which is sometimes informally called Shift JIS. This is based on Code Page 932." }
+{ $see-also "encodings-introduction" shift-jis } ;
+
+HELP: shift-jis
+{ $class-description "The encoding descriptor for Shift JIS, or JIS X 208:1997 Appendix 1. Microsoft extensions are not included." }
+{ $see-also "encodings-introduction" windows-31j } ;

basis/io/encodings/japanese/japanese-tests.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.japanese tools.test io.encodings.string arrays strings ;
+IN: io.encodings.japanese.tests
+
+[ { CHAR: replacement-character } ] [ { 141 } shift-jis decode >array ] unit-test
+[ "" ] [ "" shift-jis decode >string ] unit-test
+[ "" ] [ "" shift-jis encode >string ] unit-test
+[ { CHAR: replacement-character } shift-jis encode ] must-fail
+[ "ab¥ｨ" ] [ { CHAR: a CHAR: b HEX: 5C HEX: A8 } shift-jis decode ] unit-test
+[ { CHAR: a CHAR: b HEX: 5C HEX: A8 } ] [ "ab¥ｨ" shift-jis encode >array ] unit-test
+[ "ab\\ｨ" ] [ { CHAR: a CHAR: b HEX: 5C HEX: A8 } windows-31j decode ] unit-test
+[ { CHAR: a CHAR: b HEX: 5C HEX: A8 } ] [ "ab\\ｨ" windows-31j encode >array ] unit-test
+[ "\u000081\u0000c8" ] [ CHAR: logical-and 1string windows-31j encode >string ] unit-test
+[ "\u000081\u0000c8" ] [ CHAR: logical-and 1string shift-jis encode >string ] unit-test
+[ { CHAR: logical-and } ] [ "\u000081\u0000c8" windows-31j decode >array ] unit-test
+[ { CHAR: logical-and } ] [ "\u000081\u0000c8" shift-jis decode >array ] unit-test

basis/io/encodings/japanese/japanese.factor

@@ -0,0 +1,61 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel io io.files combinators.short-circuit
+math.order values assocs io.encodings io.binary fry strings
+math io.encodings.ascii arrays accessors splitting math.parser
+biassocs ;
+IN: io.encodings.japanese
+
+VALUE: shift-jis
+
+VALUE: windows-31j
+
+<PRIVATE
+
+TUPLE: jis assoc ;
+
+: <jis> ( assoc -- jis )
+    [ nip ] assoc-filter H{ } assoc-like
+    >biassoc jis boa ;
+
+: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
+: jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ;
+
+: process-jis ( lines -- assoc )
+    [ "#" split1 drop ] map harvest [
+        "\t" split 2 head
+        [ 2 short tail hex> ] map
+    ] map ;
+
+: make-jis ( filename -- jis )
+    ascii file-lines process-jis <jis> ;
+
+"resource:basis/io/encodings/japanese/CP932.txt"
+make-jis to: windows-31j
+
+"resource:basis/io/encodings/japanese/sjis-0208-1997-std.txt"
+make-jis to: shift-jis
+
+: small? ( char -- ? )
+    ! ASCII range or single-byte halfwidth katakana
+    { [ 0 HEX: 7F between? ] [ HEX: A1 HEX: DF between? ] } 1|| ;
+
+: write-halfword ( stream halfword -- )
+    h>b/b swap B{ } 2sequence swap stream-write ;
+
+M: jis encode-char
+    swapd ch>jis
+    dup small?
+    [ swap stream-write1 ]
+    [ write-halfword ] if ;
+
+M: jis decode-char
+    swap dup stream-read1 [
+        dup small? [ nip swap jis>ch ] [
+            swap stream-read1
+            [ 2array be> swap jis>ch ]
+            [ 2drop replacement-char ] if*
+        ] if
+    ] [ 2drop f ] if* ;
+
+PRIVATE>

basis/io/encodings/japanese/summary.txt

@@ -0,0 +1 @@
+Japanese text encodings

basis/io/encodings/japanese/tags.txt

@@ -0,0 +1 @@
+text

basis/io/encodings/utf16/utf16-docs.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax io.encodings strings ;
 IN: io.encodings.utf16
 

basis/io/encodings/utf16/utf16-tests.factor

@@ -1,6 +1,7 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel tools.test io.encodings.utf16 arrays sbufs
 io.streams.byte-array sequences io.encodings io
-bootstrap.unicode
 io.encodings.string alien.c-types alien.strings accessors classes ;
 IN: io.encodings.utf16.tests
 
@@ -15,7 +16,6 @@ IN: io.encodings.utf16.tests
 [ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
 [ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
 [ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
 
 [ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
 

basis/io/encodings/utf16/utf16.factor

@@ -101,13 +101,9 @@ M: utf16le encode-char ( char stream encoding -- )
 
 ! UTF-16
 
-: bom-le B{ HEX: ff HEX: fe } ; inline
+CONSTANT: bom-le B{ HEX: ff HEX: fe }
 
-: bom-be B{ HEX: fe HEX: ff } ; inline
+CONSTANT: bom-be B{ HEX: fe HEX: ff }
-
-: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
-
-: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
 
 : bom>le/be ( bom -- le/be )
     dup bom-le sequence= [ drop utf16le ] [

basis/io/encodings/utf32/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

basis/io/encodings/utf32/summary.txt

@@ -0,0 +1 @@
+UTF32 encoding/decoding

basis/io/encodings/utf32/tags.txt

@@ -0,0 +1 @@
+text

basis/io/encodings/utf32/utf32-docs.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.encodings strings ;
+IN: io.encodings.utf32
+
+ARTICLE: "io.encodings.utf32" "UTF-32 encoding"
+"The UTF-32 encoding is a fixed-width encoding. Unicode code points are encoded as 4 byte sequences. There are three encoding descriptor classes for working with UTF-32, depending on endianness or the presence of a BOM:"
+{ $subsection utf32 }
+{ $subsection utf32le }
+{ $subsection utf32be } ;
+
+ABOUT: "io.encodings.utf32"
+
+HELP: utf32le
+{ $class-description "The encoding descriptor for UTF-32LE, that is, UTF-32 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf32be
+{ $class-description "The encoding descriptor for UTF-32BE, that is, UTF-32 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf32
+{ $class-description "The encoding descriptor for UTF-32, that is, UTF-32 with a byte order mark. This is the most useful for general input and output in UTF-32. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+{ utf32 utf32le utf32be } related-words
+

basis/io/encodings/utf32/utf32-tests.factor

@@ -0,0 +1,30 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test io.encodings.utf32 arrays sbufs
+io.streams.byte-array sequences io.encodings io
+io.encodings.string alien.c-types alien.strings accessors classes ;
+IN: io.encodings.utf32.tests
+
+[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test
+[ { } ] [ { } utf32be decode >array ] unit-test
+
+[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test
+
+[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test
+[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test
+[ { } ] [ { } utf32le decode >array ] unit-test
+
+[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test
+
+[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
+[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
+
+[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test
+

basis/io/encodings/utf32/utf32.factor

@@ -0,0 +1,56 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math kernel io.encodings combinators io io.encodings.utf16
+sequences io.binary ;
+IN: io.encodings.utf32
+
+SINGLETON: utf32be
+
+SINGLETON: utf32le
+
+SINGLETON: utf32
+
+<PRIVATE
+
+! Decoding
+
+: char> ( stream encoding quot -- ch )
+    nip swap 4 swap stream-read dup length {
+        { 0 [ 2drop f ] }
+        { 4 [ swap call ] }
+        [ 3drop replacement-char ]
+    } case ; inline
+
+M: utf32be decode-char
+    [ be> ] char> ;
+
+M: utf32le decode-char
+    [ le> ] char> ;
+
+! Encoding
+
+: >char ( char stream encoding quot -- )
+    nip 4 swap curry dip stream-write ; inline
+
+M: utf32be encode-char
+    [ >be ] >char ;
+
+M: utf32le encode-char
+    [ >le ] >char ;
+
+! UTF-32
+
+CONSTANT: bom-le B{ HEX: ff HEX: fe 0 0 }
+
+CONSTANT: bom-be B{ 0 0 HEX: fe HEX: ff }
+
+: bom>le/be ( bom -- le/be )
+    dup bom-le sequence= [ drop utf32le ] [
+        bom-be sequence= [ utf32be ] [ missing-bom ] if
+    ] if ;
+
+M: utf32 <decoder> ( stream utf32 -- decoder )
+    drop 4 over stream-read bom>le/be <decoder> ;
+
+M: utf32 <encoder> ( stream utf32 -- encoder )
+    drop bom-le over stream-write utf32le <encoder> ;

basis/math/blas/cblas/cblas.factor

@@ -1,9 +1,13 @@
-USING: alien alien.c-types alien.syntax kernel system combinators ;
+USING: alien alien.c-types alien.syntax kernel system
+combinators ;
 IN: math.blas.cblas
 
 <<
 : load-atlas ( -- )
     "atlas" "libatlas.so" "cdecl" add-library ;
+: load-fortran ( -- )
+    "I77" "libI77.so" "cdecl" add-library
+    "F77" "libF77.so" "cdecl" add-library ;
 : load-blas ( -- )
     "blas" "libblas.so" "cdecl" add-library ;
 
@@ -11,6 +15,10 @@ IN: math.blas.cblas
     { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
     { [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
     { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] }
+    { [ os netbsd? ] [ 
+        load-fortran load-blas
+        "/usr/local/lib/libcblas.so" "cdecl" add-library
+    ] }
     { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] }
     [ "libblas.so" "cdecl" add-library ]
 } cond

basis/math/libm/libm-docs.factor

@@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions"
 $nl
 "They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
 { $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
-{ $example "USE: math.libm" "2 facos ." "0.0/0.0" }
+{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" }
 "Trigonometric functions:"
 { $subsection fcos }
 { $subsection fsin }

basis/stack-checker/branches/branches.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry vectors sequences assocs math accessors kernel
+USING: fry vectors sequences assocs math math.order accessors kernel
 combinators quotations namespaces grouping stack-checker.state
 stack-checker.backend stack-checker.errors stack-checker.visitor
 stack-checker.values stack-checker.recursive-state ;
@@ -16,7 +16,7 @@ SYMBOL: +bottom+
 
 : pad-with-bottom ( seq -- newseq )
     dup empty? [
-        dup [ length ] map supremum
+        dup [ length ] [ max ] map-reduce
         '[ _ +bottom+ pad-head ] map
     ] unless ;
 

basis/tools/disassembler/udis/udis.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.disassembler namespaces combinators
 alien alien.syntax alien.c-types lexer parser kernel
-sequences layouts math math.parser system make fry arrays ;
+sequences layouts math math.order
+math.parser system make fry arrays ;
 IN: tools.disassembler.udis
 
 <<
@@ -56,7 +57,7 @@ SINGLETON: udis-disassembler
 : buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
 
 : format-disassembly ( lines -- lines' )
-    dup [ second length ] map supremum
+    dup [ second length ] [ max ] map-reduce
     '[
         [
             [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]

basis/unix/stat/netbsd/netbsd.factor

@@ -5,3 +5,34 @@ cell-bits {
     { 32 [ "unix.stat.netbsd.32" require ] }
     { 64 [ "unix.stat.netbsd.64" require ] }
 } case
+
+: _VFS_NAMELEN    32   ; inline
+: _VFS_MNAMELEN   1024 ; inline
+
+C-STRUCT: statvfs
+    { "ulong"   "f_flag" }   
+    { "ulong"   "f_bsize" }
+    { "ulong"   "f_frsize" }  
+    { "ulong"   "f_iosize" }  
+    { "fsblkcnt_t" "f_blocks" }       
+    { "fsblkcnt_t" "f_bfree" } 
+    { "fsblkcnt_t" "f_bavail" }       
+    { "fsblkcnt_t" "f_bresvd" }       
+    { "fsfilcnt_t" "f_files" }
+    { "fsfilcnt_t" "f_ffree" }
+    { "fsfilcnt_t" "f_favail" }       
+    { "fsfilcnt_t" "f_fresvd" }       
+    { "uint64_t"   "f_syncreads" }    
+    { "uint64_t"   "f_syncwrites" }   
+    { "uint64_t"   "f_asyncreads" }   
+    { "uint64_t"   "f_asyncwrites" }  
+    { "fsid_t"    "f_fsidx" }
+    { "ulong"   "f_fsid" }
+    { "ulong"   "f_namemax" }      
+    { "uid_t"   "f_owner" }
+    { { "uint32_t" 4 } "f_spare" }     
+    { { "char" _VFS_NAMELEN } "f_fstypename" }
+    { { "char" _VFS_NAMELEN } "f_mntonname" }
+    { { "char" _VFS_NAMELEN } "f_mntfromname" } ;
+
+FUNCTION: int statvfs ( char* path, statvfs* buf ) ;

basis/wrap/wrap-tests.factor

@@ -0,0 +1,48 @@
+IN: wrap.tests
+USING: tools.test wrap multiline sequences ;
+    
+[
+    {
+        {
+            T{ word f 1 10 f }
+            T{ word f 2 10 f }
+            T{ word f 3 2 t }
+        }
+        {
+            T{ word f 4 10 f }
+            T{ word f 5 10 f }
+        }
+    }
+] [
+    {
+        T{ word f 1 10 f }
+        T{ word f 2 10 f }
+        T{ word f 3 2 t }
+        T{ word f 4 10 f }
+        T{ word f 5 10 f }
+    } 35 wrap [ { } like ] map
+] unit-test
+
+[
+    <" This is a
+long piece
+of text
+that we
+wish to
+word wrap.">
+] [
+    <" This is a long piece of text that we wish to word wrap."> 10
+    wrap-string
+] unit-test
+    
+[
+    <"   This is a
+  long piece
+  of text
+  that we
+  wish to
+  word wrap.">
+] [
+    <" This is a long piece of text that we wish to word wrap."> 12
+    "  " wrap-indented-string
+] unit-test

basis/wrap/wrap.factor

@@ -1,32 +1,60 @@
-USING: sequences kernel namespaces make splitting math math.order ;
+USING: sequences kernel namespaces make splitting
+math math.order fry assocs accessors ;
 IN: wrap
 
-! Very stupid word wrapping/line breaking
+! Word wrapping/line breaking -- not Unicode-aware
-! This will be replaced by a Unicode-aware method,
+
-! which works with variable-width fonts
+TUPLE: word key width break? ;
+
+C: <word> word
+
+<PRIVATE
 
 SYMBOL: width
 
-: line-chunks ( string -- words-lines )
+: break-here? ( column word -- ? )
-    "\n" split [ " \t" split harvest ] map ;
+    break?>> not [ width get > ] [ drop f ] if ;
 
-: (split-chunk) ( words -- )
+: find-optimal-break ( words -- n )
-    -1 over [ length + 1+ dup width get > ] find drop nip
+    [ 0 ] dip [ [ width>> + dup ] keep break-here? ] find drop nip ;
-    [ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ;
 
-: split-chunk ( words -- lines )
+: (wrap) ( words -- )
-    [ (split-chunk) ] { } make ;
+    dup find-optimal-break
+    [ 1 max cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* ;
 
-: join-spaces ( words-seqs -- lines )
+: intersperse ( seq elt -- seq' )
-    [ [ " " join ] map ] map concat ;
+    [ '[ _ , ] [ , ] interleave ] { } make ;
 
-: broken-lines ( string width -- lines )
+: split-lines ( string -- words-lines )
+    string-lines [
+        " \t" split harvest
+        [ dup length f <word> ] map
+        " " 1 t <word> intersperse
+    ] map ;
+
+: join-words ( wrapped-lines -- lines )
+    [
+        [ break?>> ]
+        [ trim-head-slice ]
+        [ trim-tail-slice ] bi
+        [ key>> ] map concat
+    ] map ;
+
+: join-lines ( strings -- string )
+    "\n" join ;
+
+PRIVATE>
+
+: wrap ( words width -- lines )
     width [
-        line-chunks [ split-chunk ] map join-spaces
+        [ (wrap) ] { } make
     ] with-variable ;
 
-: line-break ( string width -- newstring )
+: wrap-lines ( lines width -- newlines )
-    broken-lines "\n" join ;
+    [ split-lines ] dip '[ _ wrap join-words ] map concat ;
 
-: indented-break ( string width indent -- newstring )
+: wrap-string ( string width -- newstring )
-    [ length - broken-lines ] keep [ prepend ] curry map "\n" join ;
+    wrap-lines join-lines ;
+
+: wrap-indented-string ( string width indent -- newstring )
+    [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;

basis/xml/utilities/utilities-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: xml xml.utilities tools.test xml.data ;
+USING: xml xml.utilities tools.test xml.data sequences ;
 IN: xml.utilities.tests
 
 [ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
@@ -12,3 +12,11 @@ IN: xml.utilities.tests
 XML-NS: foo http://blah.com
 
 [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
+
+[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
+
+[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test
+
+[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
+
+[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test

basis/xml/utilities/utilities.factor

@@ -8,8 +8,10 @@ IN: xml.utilities
 : children>string ( tag -- string )
     children>> {
         { [ dup empty? ] [ drop "" ] }
-        { [ dup [ string? not ] any? ]
+        {
-          [ "XML tag unexpectedly contains non-text children" throw ] }
+            [ dup [ string? not ] any? ]
+            [ "XML tag unexpectedly contains non-text children" throw ]
+        }
         [ concat ]
     } cond ;
 
@@ -22,20 +24,24 @@ IN: xml.utilities
 : tag-named? ( name elem -- ? )
     dup tag? [ names-match? ] [ 2drop f ] if ;
 
-: tags@ ( tag name -- children name )
-    [ { } like ] dip assure-name ;
-
-: deep-tag-named ( tag name/string -- matching-tag )
-    assure-name '[ _ swap tag-named? ] deep-find ;
-
-: deep-tags-named ( tag name/string -- tags-seq )
-    tags@ '[ _ swap tag-named? ] deep-filter ;
-
 : tag-named ( tag name/string -- matching-tag )
-    assure-name swap [ tag-named? ] with find nip ;
+    assure-name '[ _ swap tag-named? ] find nip ;
 
 : tags-named ( tag name/string -- tags-seq )
-    tags@ swap [ tag-named? ] with filter ;
+    assure-name '[ _ swap tag-named? ] filter { } like ;
+
+<PRIVATE
+
+: prepare-deep ( xml name/string -- tag name/string )
+    [ dup xml? [ body>> ] when ] [ assure-name ] bi* ;
+
+PRIVATE>
+
+: deep-tag-named ( tag name/string -- matching-tag )
+    prepare-deep '[ _ swap tag-named? ] deep-find ;
+
+: deep-tags-named ( tag name/string -- tags-seq )
+    prepare-deep '[ _ swap tag-named? ] deep-filter { } like ;
 
 : tag-with-attr? ( elem attr-value attr-name -- ? )
     rot dup tag? [ swap attr = ] [ 3drop f ] if ;
@@ -44,13 +50,13 @@ IN: xml.utilities
     assure-name '[ _ _ tag-with-attr? ] find nip ;
 
 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ '[ _ _ tag-with-attr? ] filter children>> ;
+    assure-name '[ _ _ tag-with-attr? ] filter children>> ;
 
 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
     assure-name '[ _ _ tag-with-attr? ] deep-find ;
 
 : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ '[ _ _ tag-with-attr? ] deep-filter ;
+    assure-name '[ _ _ tag-with-attr? ] deep-filter ;
 
 : get-id ( tag id -- elem )
     "id" deep-tag-with-attr ;

basis/xml/writer/writer.factor

@@ -69,7 +69,7 @@ M: string write-xml
     escape-string xml-pprint? get [
         dup [ blank? ] all?
         [ drop "" ]
-        [ nl 80 indent-string indented-break ] if
+        [ nl 80 indent-string wrap-indented-string ] if
     ] when write ;
 
 : write-tag ( tag -- )

basis/xmode/catalog/catalog.factor

@@ -52,9 +52,15 @@ SYMBOL: rule-sets
     dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
     dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
 
+DEFER: finalize-rule-set
+
 : resolve-delegate ( rule -- )
-    dup delegate>> dup string?
+    dup delegate>> dup string? [
-    [ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ;
+        get-rule-set
+        dup rule-set? [ "not a rule set" throw ] unless
+        swap rule-sets [ dup finalize-rule-set ] with-variable
+        >>delegate drop
+    ] [ 2drop ] if ;
 
 : each-rule ( rule-set quot -- )
     [ rules>> values concat ] dip each ; inline
@@ -74,26 +80,22 @@ SYMBOL: rule-sets
 : resolve-imports ( ruleset -- )
     dup imports>> [
         get-rule-set swap rule-sets [
-            dup resolve-delegates
+            [ nip resolve-delegates ]
-            2dup import-keywords
+            [ import-keywords ]
-            import-rules
+            [ import-rules ]
+            2tri
         ] with-variable
     ] with each ;
 
 ERROR: mutually-recursive-rulesets ruleset ;
+
 : finalize-rule-set ( ruleset -- )
-    dup finalized?>> {
+    dup finalized?>> [ drop ] [
-        { f [
+        t >>finalized?
-            {
+        [ resolve-imports ]
-                [ 1 >>finalized? drop ]
+        [ resolve-delegates ]
-                [ resolve-imports ]
+        bi
-                [ resolve-delegates ]
+    ] if ;
-                [ t >>finalized? drop ]
-            } cleave
-        ] }
-        { t [ drop ] }
-        { 1 [ mutually-recursive-rulesets ] }
-    } case ;
 
 : finalize-mode ( rulesets -- )
     rule-sets [

basis/xmode/code2html/code2html-tests.factor

@@ -1,7 +1,7 @@
 IN: xmode.code2html.tests
 USING: xmode.code2html xmode.catalog
 tools.test multiline splitting memoize
-kernel ;
+kernel io.streams.string xml.writer ;
 
 [ ] [ \ (load-mode) reset-memoized ] unit-test
 
@@ -9,4 +9,11 @@ kernel ;
     <" <style type="text/css" media="screen" >
     *        {margin:0; padding:0; border:0;} ">
     string-lines "html" htmlize-lines drop
+] unit-test
+
+[ ] [
+    "test.c"
+    <" int x = "hi";
+/* a comment */ "> <string-reader> htmlize-stream
+    write-xml
 ] unit-test

basis/xmode/code2html/code2html.factor

@@ -1,5 +1,5 @@
 USING: xmode.tokens xmode.marker xmode.catalog kernel locals
-html.elements io io.files sequences words io.encodings.utf8
+io io.files sequences words io.encodings.utf8
 namespaces xml.entities accessors xml.literals locals xml.writer ;
 IN: xmode.code2html
 
@@ -8,14 +8,15 @@ IN: xmode.code2html
         [ str>> ] [ id>> ] bi [
             name>> swap
             [XML <span class=<->><-></span> XML]
-        ] [ ] if*
+        ] when*
     ] map ;
 
 : htmlize-line ( line-context line rules -- line-context' xml )
     tokenize-line htmlize-tokens ;
 
 : htmlize-lines ( lines mode -- xml )
-    [ f ] 2dip load-mode [ htmlize-line ] curry map nip ;
+    [ f ] 2dip load-mode [ htmlize-line ] curry map nip
+    { "\n" } join ;
 
 : default-stylesheet ( -- xml )
     "resource:basis/xmode/code2html/stylesheet.css"
@@ -24,7 +25,7 @@ IN: xmode.code2html
 
 :: htmlize-stream ( path stream -- xml )
     stream lines
-    [ "" ] [ first find-mode path swap htmlize-lines ]
+    [ "" ] [ path over first find-mode htmlize-lines ]
     if-empty :> input
     default-stylesheet :> stylesheet
     <XML <html>

basis/xmode/loader/loader.factor

@@ -43,17 +43,17 @@ RULE: MARK_PREVIOUS mark-previous-rule
     shared-tag-attrs match-type-attr literal-start ;
 
 TAG: KEYWORDS ( rule-set tag -- key value )
-    ignore-case? get <keyword-map>
+    rule-set get ignore-case?>> <keyword-map>
     swap child-tags [ over parse-keyword-tag ] each
     swap (>>keywords) ;
 
 TAGS>
 
 : ?<regexp> ( string/f -- regexp/f )
-    dup [ ignore-case? get <regexp> ] when ;
+    dup [ rule-set get ignore-case?>> <regexp> ] when ;
 
 : (parse-rules-tag) ( tag -- rule-set )
-    <rule-set>
+    <rule-set> dup rule-set set
     {
         { "SET" string>rule-set-name (>>name) }
         { "IGNORE_CASE" string>boolean (>>ignore-case?) }
@@ -65,11 +65,11 @@ TAGS>
     } init-from-tag ;
 
 : parse-rules-tag ( tag -- rule-set )
-    dup (parse-rules-tag) [
+    [
-        dup ignore-case?>> ignore-case? [
+        [ (parse-rules-tag) ] [ child-tags ] bi
-            swap child-tags [ parse-rule-tag ] with each
+        [ parse-rule-tag ] with each
-        ] with-variable
+        rule-set get
-    ] keep ;
+    ] with-scope ;
 
 : merge-rule-set-props ( props rule-set -- )
     [ assoc-union ] change-props drop ;

basis/xmode/loader/syntax/syntax.factor

@@ -1,13 +1,11 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors xmode.tokens xmode.rules xmode.keyword-map
 xml.data xml.utilities xml assocs kernel combinators sequences
 math.parser namespaces make parser lexer xmode.utilities
-parser-combinators.regexp io.files ;
+parser-combinators.regexp io.files splitting arrays ;
 IN: xmode.loader.syntax
 
-SYMBOL: ignore-case?
-
 ! Rule tag parsing utilities
 : (parse-rule-tag) ( rule-set tag specs class -- )
     new swap init-from-tag swap add-rule ; inline
@@ -44,16 +42,19 @@ SYMBOL: ignore-case?
 
 : parse-literal-matcher ( tag -- matcher )
     dup children>string
-    ignore-case? get <string-matcher>
+    rule-set get ignore-case?>> <string-matcher>
     swap position-attrs <matcher> ;
 
 : parse-regexp-matcher ( tag -- matcher )
-    dup children>string ignore-case? get <regexp>
+    dup children>string rule-set get ignore-case?>> <regexp>
     swap position-attrs <matcher> ;
 
 : shared-tag-attrs ( -- )
     { "TYPE" string>token (>>body-token) } , ; inline
 
+: parse-delegate ( string -- pair )
+    "::" split1 [ rule-set get swap ] unless* 2array ;
+
 : delegate-attr ( -- )
     { "DELEGATE" f (>>delegate) } , ;
 

basis/xmode/marker/context/context.factor

@@ -1,4 +1,4 @@
-USING: accessors kernel ;
+USING: accessors kernel xmode.rules ;
 IN: xmode.marker.context
 
 ! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
@@ -10,7 +10,7 @@ end
 ;
 
 : <line-context> ( ruleset parent -- line-context )
-    over [ "no context" throw ] unless
+    over rule-set? [ "not a rule-set" throw ] unless
     line-context new
         swap >>parent
         swap >>in-rule-set ;

core/io/binary/binary-tests.factor

@@ -10,3 +10,7 @@ IN: io.binary.tests
 [ 1234 ] [ 1234 4 >le le> ] unit-test
 
 [ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test
+
+[ HEX: 56780000 HEX: 12340000 ] [ HEX: 1234000056780000 d>w/w ] unit-test
+[ HEX: 5678 HEX: 1234 ] [ HEX: 12345678 w>h/h ] unit-test
+[ HEX: 34 HEX: 12 ] [ HEX: 1234 h>b/b ] unit-test

core/io/binary/binary.factor

@@ -14,13 +14,13 @@ IN: io.binary
 : >be ( x n -- byte-array ) >le dup reverse-here ;
 
 : d>w/w ( d -- w1 w2 )
-    dup HEX: ffffffff bitand
+    [ HEX: ffffffff bitand ]
-    swap -32 shift HEX: ffffffff bitand ;
+    [ -32 shift HEX: ffffffff bitand ] bi ;
 
 : w>h/h ( w -- h1 h2 )
-    dup HEX: ffff bitand
+    [ HEX: ffff bitand ]
-    swap -16 shift HEX: ffff bitand ;
+    [ -16 shift HEX: ffff bitand ] bi ;
 
 : h>b/b ( h -- b1 b2 )
-    dup mask-byte
+    [ mask-byte ]
-    swap -8 shift mask-byte ;
+    [ -8 shift mask-byte ] bi ;

core/io/encodings/encodings-docs.factor

@@ -78,6 +78,7 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors"
 { $subsection "io.encodings.binary" }
 { $subsection "io.encodings.utf8" }
 { $subsection "io.encodings.utf16" }
+{ $vocab-subsection "UTF-32 encoding" "io.encodings.utf32" }
 { $vocab-subsection "Strict encodings" "io.encodings.strict" }
 "Legacy encodings:"
 { $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }

core/strings/strings-docs.factor

@@ -4,7 +4,7 @@ sbufs math ;
 IN: strings
 
 ARTICLE: "strings" "Strings"
-"A string is a fixed-size mutable sequence of Unicode 5.0 code points."
+"A string is a fixed-size mutable sequence of Unicode 5.1 code points."
 $nl
 "Characters are not a first-class type; they are simply represented as integers between 0 and 16777216 (2^24). Only characters up to 2097152 (2^21) have a defined meaning in Unicode."
 $nl

extra/lint/lint.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.accessors arrays assocs
-combinators.short-circuit fry hashtables html.elements io
+combinators.short-circuit fry hashtables io
 kernel math namespaces prettyprint quotations sequences
 sequences.deep sets slots.private vectors vocabs words
 kernel.private ;
@@ -54,7 +54,7 @@ SYMBOL: def-hash-keys
         [ drop f ]
         [ "cdecl" ]
         [ first ] [ second ] [ third ] [ fourth ]
-        [ ">" write-html ] [ "/>" write-html ]
+        [ ">" write ] [ "/>" write ]
     } ;
 
 ! ! Add definitions

extra/msxml-to-csv/msxml-to-csv-tests.factor

@@ -0,0 +1,10 @@
+IN: msxml-to-csv.tests
+USING: msxml-to-csv tools.test csv io.encodings.utf8
+io.files.temp kernel ;
+
+[ t ] [
+    "test.csv" temp-file
+    "resource:extra/msxml-to-csv/test.xml" msxml>csv
+    "test.csv" temp-file utf8 file>csv
+    "resource:extra/msxml-to-csv/test.csv" utf8 file>csv =
+] unit-test

extra/msxml-to-csv/msxml-to-csv.factor

@@ -3,7 +3,6 @@ io.encodings.ascii kernel ;
 IN: msxml-to-csv
 
 : (msxml>csv) ( xml -- table )
-    "Worksheet" tag-named
     "Table" tag-named
     "Row" tags-named [
         "Cell" tags-named [

extra/msxml-to-csv/test.csv

@@ -0,0 +1,2 @@
+A,B
+C,D

extra/msxml-to-csv/test.xml

@@ -0,0 +1 @@
+<Worksheet><Table><Row><Cell><Data>A</Data></Cell><Cell><Data>B</Data></Cell></Row><Row><Cell><Data>C</Data></Cell><Cell><Data>D</Data></Cell></Row></Table></Worksheet>

extra/project-euler/008/008.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: grouping math.parser sequences ;
+USING: grouping math.order math.parser sequences ;
 IN: project-euler.008
 
 ! http://projecteuler.net/index.php?section=problems&id=8
@@ -64,7 +64,7 @@ IN: project-euler.008
 PRIVATE>
 
 : euler008 ( -- answer )
-    source-008 5 clump [ string>digits product ] map supremum ;
+    source-008 5 clump [ string>digits product ] [ max ] map-reduce ;
 
 ! [ euler008 ] 100 ave-time
 ! 2 ms ave run time - 0.79 SD (100 trials)

extra/project-euler/011/011.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: grouping kernel make sequences ;
+USING: grouping kernel make math.order sequences ;
 IN: project-euler.011
 
 ! http://projecteuler.net/index.php?section=problems&id=11
@@ -88,7 +88,7 @@ IN: project-euler.011
 
 : max-product ( matrix width -- n )
     [ clump ] curry map concat
-    [ product ] map supremum ; inline
+    [ product ] [ max ] map-reduce ; inline
 
 PRIVATE>
 

extra/project-euler/044/044.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges project-euler.common sequences ;
+USING: kernel math math.functions math.ranges math.order
+project-euler.common sequences ;
 IN: project-euler.044
 
 ! http://projecteuler.net/index.php?section=problems&id=44
@@ -37,7 +38,7 @@ PRIVATE>
 
 : euler044 ( -- answer )
     2500 [1,b] [ nth-pentagonal ] map dup cartesian-product
-    [ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ;
+    [ first2 sum-and-diff? ] filter [ first2 - abs ] [ min ] map-reduce ;
 
 ! [ euler044 ] 10 ave-time
 ! 4996 ms ave run time - 87.46 SD (10 trials)

extra/project-euler/056/056.factor

@@ -23,7 +23,7 @@ IN: project-euler.056
 
 : euler056 ( -- answer )
     90 100 [a,b) dup cartesian-product
-    [ first2 ^ number>digits sum ] map supremum ;
+    [ first2 ^ number>digits sum ] [ max ] map-reduce ;
 
 ! [ euler056 ] 100 ave-time
 ! 22 ms ave run time - 2.13 SD (100 trials)

extra/sequences/modified/modified.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math sequences sequences.private shuffle ;
+USING: accessors arrays kernel math math.order
+sequences sequences.private shuffle ;
 IN: sequences.modified
 
 TUPLE: modified ;
@@ -50,7 +51,7 @@ M: offset modified-set-nth ( elt n seq -- )
 TUPLE: summed < modified seqs ;
 C: <summed> summed
 
-M: summed length seqs>> [ length ] map supremum ;
+M: summed length seqs>> [ length ] [ max ] map-reduce ;
 
 <PRIVATE
 : ?+ ( x/f y/f -- sum )

extra/svg/svg-tests.factor

@@ -1,6 +1,6 @@
 ! (c)2009 Joe Groff, see BSD license
-USING: arrays literals math math.affine-transforms math.functions multiline
+USING: accessors arrays literals math math.affine-transforms
-svg tools.test ;
+math.functions multiline sequences svg tools.test xml xml.utilities ;
 IN: svg.tests
 
 { 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [
@@ -94,3 +94,18 @@ IN: svg.tests
     A 5 6 7 1 0 8 9
     "> svg-path>array
 ] unit-test
+
+STRING: test-svg-string
+<svg xmlns="http://www.w3.org/2000/svg">
+        <path transform="translate(1 2)" d="M -1 -1 l 2 2" />
+</svg>
+;
+
+: test-svg-path
+    test-svg-string string>xml body>> children-tags first ;
+
+[ { T{ moveto f { -1.0 -1.0 } f } T{ lineto f { 2.0 2.0 } t } } ]
+[ test-svg-path tag-d ] unit-test
+
+[ T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 1.0 2.0 } } ]
+[ test-svg-path tag-transform ] unit-test

extra/svg/svg.factor

@@ -79,7 +79,7 @@ transform-list = wsp* transforms?:t wsp*
 ;EBNF
 
 : tag-transform ( tag -- transform )
-    "transform" svg-name swap at svg-transform>affine-transform ;
+    "transform" svg-name attr svg-transform>affine-transform ;
 
 TUPLE: moveto p relative? ;
 TUPLE: closepath ;
@@ -221,4 +221,4 @@ svg-path = wsp* moveto-drawto-command-groups?:x wsp* => [[ x ]]
 ;EBNF
 
 : tag-d ( tag -- d )
-    "d" svg-name swap at svg-path>array ;
+    "d" svg-name attr svg-path>array ;

extra/tetris/tetromino/tetromino.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays namespaces sequences math math.vectors
+USING: kernel arrays namespaces sequences math math.order
-colors random ;
+math.vectors colors random ;
 IN: tetris.tetromino
 
 TUPLE: tetromino states colour ;
@@ -104,7 +104,7 @@ SYMBOL: tetrominoes
     tetrominoes get random ;
 
 : blocks-max ( blocks quot -- max )
-    map [ 1+ ] map supremum ; inline
+    map [ 1+ ] [ max ] map-reduce ; inline
 
 : blocks-width ( blocks -- width )
     [ first ] blocks-max ;

extra/websites/concatenative/concatenative.factor

@@ -55,8 +55,6 @@ TUPLE: factor-website < dispatcher ;
 
 : <factor-website> ( -- responder )
     factor-website new-dispatcher
-        <wiki> "wiki" add-responder
-        <user-admin> "user-admin" add-responder
         URL" /wiki/view/Front Page" <redirect-responder> "" add-responder ;
 
 SYMBOL: key-password
@@ -76,8 +74,10 @@ SYMBOL: dh-file
     "password" key-password set-global
     common-configuration
     <factor-website>
-        <pastebin> <factor-boilerplate> <login-config> "pastebin" add-responder
+        <wiki> <login-config> <factor-boilerplate> "wiki" add-responder
-        <planet> <factor-boilerplate> <login-config> "planet" add-responder
+        <user-admin> <login-config> <factor-boilerplate> "user-admin" add-responder
+        <pastebin> <login-config> <factor-boilerplate> "pastebin" add-responder
+        <planet> <login-config> <factor-boilerplate> "planet" add-responder
         "/tmp/docs/" <help-webapp> "docs" add-responder
     test-db <alloy>
     main-responder set-global ;
@@ -90,7 +90,7 @@ SYMBOL: dh-file
 : init-production ( -- )
     common-configuration
     <vhost-dispatcher>
-        <factor-website> <login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
+        <factor-website> <wiki> <login-config> <factor-boilerplate> "wiki" add-responder test-db <alloy> "concatenative.org" add-responder
         <pastebin> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
         <planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
         home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder