Merge branch 'master' into regexp

basis/calendar/format/format-tests.factor

@@ -51,6 +51,11 @@ IN: calendar.format.tests
     timestamp>string
 ] unit-test
 
+[ "20080504070000" ] [
+    "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
+    timestamp>mdtm
+] unit-test
+
 [
     T{ timestamp f
         2008
@@ -74,3 +79,5 @@ IN: calendar.format.tests
         { gmt-offset T{ duration f 0 0 0 0 0 0 } }
     }
 ] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test
+
+

basis/calendar/format/format.factor

@@ -78,6 +78,9 @@ M: integer year. ( n -- )
 M: timestamp year. ( timestamp -- )
     year>> year. ;
 
+: timestamp>mdtm ( timestamp -- str )
+    [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
+
 : (timestamp>string) ( timestamp -- )
     { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
 

basis/compiler/compiler-docs.factor

@@ -19,15 +19,19 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "Higher-level words can be found in " { $link "compilation-units" } "." ;
 
 ARTICLE: "compiler" "Optimizing compiler"
-"Factor is a fully compiled language implementation with two distinct compilers:"
+"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
+$nl
+"The two compilers differ in the level of analysis they perform:"
 { $list
     { "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." }
     { "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." }
 }
-"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
+"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
-{ $subsection "compiler-usage" }
+$nl
+"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
 { $subsection "compiler-errors" }
-{ $subsection "hints" } ;
+{ $subsection "hints" }
+{ $subsection "compiler-usage" } ;
 
 ABOUT: "compiler"
 

basis/db/sqlite/lib/lib.factor

@@ -5,8 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators
 continuations db.types calendar.format serialize
 io.streams.byte-array byte-arrays io.encodings.binary
 io.backend db.errors present urls io.encodings.utf8
-io.encodings.string accessors shuffle io prettyprint
+io.encodings.string accessors shuffle io db.private ;
-db.private ;
 IN: db.sqlite.lib
 
 ERROR: sqlite-error < db-error n string ;
@@ -125,8 +124,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
     ] if* (sqlite-bind-type) ;
 
 : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
-: sqlite-reset ( handle -- )
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
-"resetting: " write dup . sqlite3_reset sqlite-check-result ;
 : sqlite-clear-bindings ( handle -- )
     sqlite3_clear_bindings sqlite-check-result ;
 : sqlite-#columns ( query -- int ) sqlite3_column_count ;

basis/db/sqlite/sqlite-tests.factor

@@ -1,6 +1,7 @@
 USING: io io.files io.files.temp io.directories io.launcher
 kernel namespaces prettyprint tools.test db.sqlite db sequences
-continuations db.types db.tuples unicode.case ;
+continuations db.types db.tuples unicode.case accessors arrays
+sorting ;
 IN: db.sqlite.tests
 
 : db-path ( -- path ) "test.db" temp-file ;
@@ -74,8 +75,9 @@ IN: db.sqlite.tests
     ] with-db
 ] unit-test
 
+[ \ swap ensure-table ] must-fail
+
 ! You don't need a primary key
-USING: accessors arrays sorting ;
 TUPLE: things one two ;
 
 things "THINGS" {
@@ -115,18 +117,14 @@ hi "HELLO" {
         1 <foo> insert-tuple
         f <foo> select-tuple
         1 1 <hi> insert-tuple
-        f <hi> select-tuple
+        f f <hi> select-tuple
         hi drop-table
         foo drop-table
     ] with-db
 ] unit-test
 
-[ ] [
+
-    test.db [
+! Test SQLite triggers
-        hi create-table
-        hi drop-table
-    ] with-db
-] unit-test
 
 TUPLE: show id ;
 TUPLE: user username data ;
@@ -142,10 +140,10 @@ show "SHOW" {
 } define-persistent
 
 watch "WATCH" {
-    { "user" "USER" TEXT +not-null+
+    { "user" "USER" TEXT +not-null+ +user-assigned-id+
-        { +foreign-id+ user "USERNAME" } +user-assigned-id+ }
+        { +foreign-id+ user "USERNAME" } }
-    { "show" "SHOW" BIG-INTEGER +not-null+
+    { "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+
-        { +foreign-id+ show "ID" } +user-assigned-id+ }
+        { +foreign-id+ show "ID" } }
 } define-persistent
     
 [ T{ user { username "littledan" } { data "foo" } } ] [
@@ -158,10 +156,9 @@ watch "WATCH" {
         show new insert-tuple
         show new select-tuple
         "littledan" f user boa select-tuple
+        [ id>> ] [ username>> ] bi*
         watch boa insert-tuple
         watch new select-tuple
         user>> f user boa select-tuple
     ] with-db
 ] unit-test
-
-[ \ swap ensure-table ] must-fail

basis/db/sqlite/sqlite.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays assocs classes compiler db hashtables
-io.files kernel math math.parser namespaces prettyprint
+io.files kernel math math.parser namespaces prettyprint fry
 sequences strings classes.tuple alien.c-types continuations
 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
 math.intervals io nmake accessors vectors math.ranges random
 math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make db.private ;
+io.streams.string multiline make db.private sequences.deep ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -126,30 +126,6 @@ M: sqlite-statement query-results ( query -- result-set )
     dup handle>> sqlite-result-set new-result-set
     dup advance-row ;
 
-M: sqlite-db-connection create-sql-statement ( class -- statement )
-    [
-        dupd
-        "create table " 0% 0%
-        "(" 0% [ ", " 0% ] [
-            dup "sql-spec" set
-            dup column-name>> [ "table-id" set ] [ 0% ] bi
-            " " 0%
-            dup type>> lookup-create-type 0%
-            modifiers 0%
-        ] interleave
-
-        find-primary-key [
-            ", " 0%
-            "primary key(" 0%
-            [ "," 0% ] [ column-name>> 0% ] interleave
-            ")" 0%
-        ] unless-empty
-        ");" 0%
-    ] query-make ;
-
-M: sqlite-db-connection drop-sql-statement ( class -- statement )
-    [ "drop table " 0% 0% ";" 0% drop ] query-make ;
-
 M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
     [
         "insert into " 0% 0%
@@ -225,10 +201,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : insert-trigger ( -- string )
     [
     <"
-        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+            SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
             WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
     "> interpolate
@@ -237,24 +213,31 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : insert-trigger-not-null ( -- string )
     [
     <"
-        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+            SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
-            WHERE NEW.${foreign-table-id} IS NOT NULL
+            WHERE NEW.${table-id} IS NOT NULL
                 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
     "> interpolate
     ] with-string-writer ;
 
+: drop-insert-trigger ( -- string )
+    [
+        <"
+            DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : update-trigger ( -- string )
     [
     <"
-        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+            SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+            WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
     "> interpolate
     ] with-string-writer ;
@@ -262,32 +245,46 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : update-trigger-not-null ( -- string )
     [
     <"
-        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+            SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
-            WHERE NEW.${foreign-table-id} IS NOT NULL
+            WHERE NEW.${table-id} IS NOT NULL
                 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
     "> interpolate
     ] with-string-writer ;
 
+: drop-update-trigger ( -- string )
+    [
+        <"
+            DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : delete-trigger-restrict ( -- string )
     [
     <"
-        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+            SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+            WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
         END;
     "> interpolate
     ] with-string-writer ;
 
+: drop-delete-trigger-restrict ( -- string )
+    [
+        <"
+            DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : delete-trigger-cascade ( -- string )
     [
     <"
-        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+        CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
             DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
@@ -295,6 +292,13 @@ M: sqlite-db-connection persistent-table ( -- assoc )
     "> interpolate
     ] with-string-writer ;
 
+: drop-delete-trigger-cascade ( -- string )
+    [
+        <"
+            DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
+        "> interpolate
+    ] with-string-writer ;
+
 : can-be-null? ( -- ? )
     "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
 
@@ -318,14 +322,70 @@ M: sqlite-db-connection persistent-table ( -- assoc )
         delete-trigger-restrict sqlite-trigger,
     ] if ;
 
+: drop-sqlite-triggers ( -- )
+    drop-insert-trigger sqlite-trigger,
+    drop-update-trigger sqlite-trigger,
+    delete-cascade? [
+        drop-delete-trigger-cascade sqlite-trigger,
+    ] [
+        drop-delete-trigger-restrict sqlite-trigger,
+    ] if ;
+
+: db-triggers ( sql-specs word -- )
+    '[
+        [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
+        [
+            [ class>> db-table-name "db-table" set ]
+            [
+                [ "sql-spec" set ]
+                [ column-name>> "table-id" set ]
+                [ ] tri
+                modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
+                [
+                    [ second db-table-name "foreign-table-name" set ]
+                    [ third "foreign-table-id" set ] bi
+                    _ execute
+                ] each
+            ] bi
+        ] each
+    ] call ; inline
+
+: sqlite-create-table ( sql-specs class-name -- )
+    [
+        "create table " 0% 0%
+        "(" 0% [ ", " 0% ] [
+            dup "sql-spec" set
+            dup column-name>> [ "table-id" set ] [ 0% ] bi
+            " " 0%
+            dup type>> lookup-create-type 0%
+            modifiers 0%
+        ] interleave
+    ] [
+        drop
+        find-primary-key [
+            ", " 0%
+            "primary key(" 0%
+            [ "," 0% ] [ column-name>> 0% ] interleave
+            ")" 0%
+        ] unless-empty
+        ");" 0%
+    ] 2bi ;
+
+M: sqlite-db-connection create-sql-statement ( class -- statement )
+    [
+        ! specs name
+        [ sqlite-create-table ]
+        [ drop \ create-sqlite-triggers db-triggers ] 2bi
+    ] query-make ;
+
+M: sqlite-db-connection drop-sql-statement ( class -- statements )
+    [
+        nip "drop table " 0% 0% ";" 0%
+    ] query-make ;
+
 M: sqlite-db-connection compound ( string seq -- new-string )
     over {
         { "default" [ first number>string " " glue ] }
-        { "references" [
+        { "references" [ >reference-string ] }
-            [ >reference-string ] keep
-            first2 [ db-table-name "foreign-table-name" set ]
-            [ "foreign-table-id" set ] bi*
-            create-sqlite-triggers
-        ] }
         [ 2drop ]
     } case ;

basis/db/tuples/tuples.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-destructors mirrors sets db.types db.private ;
+destructors mirrors sets db.types db.private fry
+combinators.short-circuit ;
 IN: db.tuples
 
 HOOK: create-sql-statement db-connection ( class -- object )
@@ -29,7 +30,7 @@ GENERIC: eval-generator ( singleton -- object )
 
 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
     rot class new [
-        [ [ slot-name>> ] dip set-slot-named ] curry 2each
+        '[ slot-name>> _ set-slot-named ] 2each
     ] keep ;
 
 : query-tuples ( exemplar-tuple statement -- seq )
@@ -98,33 +99,49 @@ M: query >query clone ;
 
 M: tuple >query <query> swap >>tuple ;
 
+ERROR: no-defined-persistent object ;
+
+: ensure-defined-persistent ( object -- object )
+    dup { [ class? ] [ "db-table" word-prop ] } 1&& [
+        no-defined-persistent
+    ] unless ;
+
 : create-table ( class -- )
+    ensure-defined-persistent
     create-sql-statement [ execute-statement ] with-disposals ;
 
 : drop-table ( class -- )
+    ensure-defined-persistent
     drop-sql-statement [ execute-statement ] with-disposals ;
 
 : recreate-table ( class -- )
+    ensure-defined-persistent
     [
-        [ drop-sql-statement [ execute-statement ] with-disposals
+        '[
-        ] curry ignore-errors
+            _ drop-sql-statement [ execute-statement ] with-disposals
+        ] ignore-errors
     ] [ create-table ] bi ;
 
-: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
+: ensure-table ( class -- )
+    ensure-defined-persistent
+    '[ _ create-table ] ignore-errors ;
 
 : ensure-tables ( classes -- ) [ ensure-table ] each ;
 
 : insert-tuple ( tuple -- )
-    dup class db-columns find-primary-key db-assigned-id-spec?
+    dup class ensure-defined-persistent
+    db-columns find-primary-key db-assigned-id-spec?
     [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 
 : update-tuple ( tuple -- )
-    dup class
+    dup class ensure-defined-persistent
     db-connection get update-statements>> [ <update-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : delete-tuples ( tuple -- )
-    dup dup class <delete-tuples-statement> [
+    dup
+    dup class ensure-defined-persistent
+    <delete-tuples-statement> [
         [ bind-tuple ] keep execute-statement
     ] with-disposal ;
 
@@ -132,8 +149,8 @@ M: tuple >query <query> swap >>tuple ;
     >query [ tuple>> ] [ query>statement ] bi do-select ;
 
 : select-tuple ( query/tuple -- tuple/f )
-    >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
+    >query 1 >>limit [ tuple>> ] [ query>statement ] bi
-    [ f ] [ first ] if-empty ;
+    do-select [ f ] [ first ] if-empty ;
 
 : count-tuples ( query/tuple -- n )
     >query [ tuple>> ] [ <count-statement> ] bi do-count

basis/editors/emacs/emacs.factor

@@ -1,17 +1,24 @@
 USING: definitions io.launcher kernel parser words sequences math
-math.parser namespaces editors make system ;
+math.parser namespaces editors make system combinators.short-circuit
+fry threads ;
 IN: editors.emacs
 
+SYMBOL: emacsclient-path
+
+HOOK: default-emacsclient os ( -- path )
+
+M: object default-emacsclient ( -- path ) "emacsclient" ;
+
 : emacsclient ( file line -- )
     [
-        \ emacsclient get "emacsclient" or ,
+        { [ \ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
-        os windows? [ "--no-wait" , ] unless
+        "--no-wait" ,
-        "+" swap number>string append ,
+        number>string "+" prepend ,
         ,
-    ] { } make try-process ;
+    ] { } make
+    os windows? [ run-detached drop ] [ try-process ] if ;
 
 : emacs ( word -- )
     where first2 emacsclient ;
 
 [ emacsclient ] edit-hook set-global
-

basis/editors/emacs/windows/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/editors/emacs/windows/windows.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: editors.emacs io.directories.search.windows kernel sequences
+system combinators.short-circuit ;
+IN: editors.emacs.windows
+
+M: windows default-emacsclient
+    {
+        [ "Emacs" t [ "emacsclientw.exe" tail? ] find-in-program-files ]
+        [ "Emacs" t [ "emacsclient.exe" tail? ] find-in-program-files ]
+        [ "emacsclient.exe" ]
+    } 0|| ;

basis/ftp/client/client.factor

@@ -93,7 +93,7 @@ ERROR: ftp-error got expected ;
 : ensure-login ( url -- url )
     dup username>> [
         "anonymous" >>username
-        "ftp-client" >>password
+        "ftp-client@factorcode.org" >>password
     ] unless ;
 
 : >ftp-url ( url -- url' ) >url ensure-port ensure-login ;

basis/ftp/ftp.factor

@@ -4,8 +4,7 @@ USING: accessors arrays assocs combinators io io.files kernel
 math.parser sequences strings ;
 IN: ftp
 
-SINGLETON: active
+SYMBOLS: +active+ +passive+ ;
-SINGLETON: passive
 
 TUPLE: ftp-response n strings parsed ;
 
@@ -17,5 +16,3 @@ TUPLE: ftp-response n strings parsed ;
     over strings>> push ;
 
 : ftp-send ( string -- ) write "\r\n" write flush ;
-: ftp-ipv4 1 ; inline
-: ftp-ipv6 2 ; inline

basis/ftp/server/server-tests.factor

@@ -0,0 +1,50 @@
+USING: calendar ftp.server io.encodings.ascii io.files
+io.files.unique namespaces threads tools.test kernel
+io.servers.connection ftp.client accessors urls
+io.pathnames io.directories sequences fry ;
+IN: ftp.server.tests
+
+: test-file-contents ( -- string )
+    "Files are so boring anymore." ;
+
+: create-test-file ( -- path )
+    test-file-contents
+    "ftp.server" "test" make-unique-file
+    [ ascii set-file-contents ] keep canonicalize-path ;
+
+: test-ftp-server ( quot -- )
+    '[
+        current-temporary-directory get 0
+        <ftp-server>
+        [ start-server* ]
+        [
+            sockets>> first addr>> port>>
+            <url>
+                swap >>port
+                "ftp" >>protocol
+                "localhost" >>host
+                create-test-file >>path
+                _ call
+        ]
+        [ stop-server ] tri
+    ] with-unique-directory drop ; inline
+
+[ t ]
+[
+    
+    [
+        unique-directory [
+            [ ftp-get ] [ path>> file-name ascii file-contents ] bi
+        ] with-directory
+    ] test-ftp-server test-file-contents =
+] unit-test
+
+[
+    
+    [
+        "/" >>path
+        unique-directory [
+            [ ftp-get ] [ path>> file-name ascii file-contents ] bi
+        ] with-directory
+    ] test-ftp-server test-file-contents =
+] must-fail

basis/ftp/server/server.factor

@@ -1,52 +1,46 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit accessors combinators io
+USING: accessors assocs byte-arrays calendar classes
-io.encodings.8-bit io.encodings io.encodings.binary
+combinators combinators.short-circuit concurrency.promises
-io.encodings.utf8 io.files io.files.info io.directories
+continuations destructors ftp io io.backend io.directories
-io.sockets kernel math.parser namespaces make sequences
+io.encodings io.encodings.8-bit io.encodings.binary
-ftp io.launcher.unix.parser unicode.case splitting
+tools.files io.encodings.utf8 io.files io.files.info
-assocs classes io.servers.connection destructors calendar
+io.pathnames io.launcher.unix.parser io.servers.connection
-io.timeouts io.streams.duplex threads continuations math
+io.sockets io.streams.duplex io.streams.string io.timeouts
-concurrency.promises byte-arrays io.backend tools.hexdump
+kernel make math math.bitwise math.parser namespaces sequences
-io.streams.string math.bitwise tools.files io.pathnames ;
+splitting threads unicode.case logging calendar.format
+strings io.files.links io.files.types ;
 IN: ftp.server
 
-TUPLE: ftp-client url mode state command-promise user password ;
+SYMBOL: server
-
-: <ftp-client> ( url -- ftp-client )
-    ftp-client new
-        swap >>url ;
-    
 SYMBOL: client
 
-: ftp-server-directory ( -- str )
+TUPLE: ftp-server < threaded-server { serving-directory string } ;
-    \ ftp-server-directory get-global "resource:temp" or
+
-    normalize-path ;
+TUPLE: ftp-client user password extra-connection ;
 
 TUPLE: ftp-command raw tokenized ;
-
+: <ftp-command> ( str -- obj )
-: <ftp-command> ( -- obj )
+    dup \ <ftp-command> DEBUG log-message
-    ftp-command new ;
+    ftp-command new
+        over >>raw
+        swap tokenize-command >>tokenized ;
 
 TUPLE: ftp-get path ;
-
 : <ftp-get> ( path -- obj )
     ftp-get new
         swap >>path ;
 
 TUPLE: ftp-put path ;
-
 : <ftp-put> ( path -- obj )
     ftp-put new
         swap >>path ;
 
 TUPLE: ftp-list ;
-
 C: <ftp-list> ftp-list
 
-: read-command ( -- ftp-command )
+TUPLE: ftp-disconnect ;
-    <ftp-command> readln
+C: <ftp-disconnect> ftp-disconnect
-    [ >>raw ] [ tokenize-command >>tokenized ] bi ;
 
 : (send-response) ( n string separator -- )
     [ number>string write ] 2dip write ftp-send ;
@@ -56,28 +50,42 @@ C: <ftp-list> ftp-list
     [ but-last-slice [ "-" (send-response) ] with each ]
     [ first " " (send-response) ] 2bi ;
 
-: server-response ( n string -- )
+: server-response ( string n -- )
+    2dup number>string swap ":" glue \ server-response DEBUG log-message
     <ftp-response>
-        swap add-response-line
         swap >>n
+        swap add-response-line
     send-response ;
 
-: ftp-error ( string -- )
+: serving? ( path -- ? )
-    500 "Unrecognized command: " rot append server-response ;
+    canonicalize-path server get serving-directory>> head? ;
+
+: can-serve-directory? ( path -- ? )
+    { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
+
+: can-serve-file? ( path -- ? )
+    {
+        [ exists? ]
+        [ file-info type>> +regular-file+ = ]
+        [ serving? ]
+    } 1&& ;
+
+: ftp-error ( string -- ) 500 server-response ;
+: ftp-unimplemented ( string -- ) 502 server-response ;
 
 : send-banner ( -- )
-    220 "Welcome to " host-name append server-response ;
+    "Welcome to " host-name append 220 server-response ;
 
 : anonymous-only ( -- )
-    530 "This FTP server is anonymous only." server-response ;
+    "This FTP server is anonymous only." 530 server-response ;
 
 : handle-QUIT ( obj -- )
-    drop 221 "Goodbye." server-response ;
+    drop "Goodbye." 221 server-response ;
 
 : handle-USER ( ftp-command -- )
     [
         tokenized>> second client get (>>user)
-        331 "Please specify the password." server-response
+        "Please specify the password." 331 server-response
     ] [
         2drop "bad USER" ftp-error
     ] recover ;
@@ -85,7 +93,7 @@ C: <ftp-list> ftp-list
 : handle-PASS ( ftp-command -- )
     [
         tokenized>> second client get (>>password)
-        230 "Login successful" server-response
+        "Login successful" 230 server-response
     ] [
         2drop "PASS error" ftp-error
     ] recover ;
@@ -102,7 +110,7 @@ ERROR: type-error type ;
 : handle-TYPE ( obj -- )
     [
         tokenized>> second parse-type
-        [ 200 ] dip "Switching to " " mode" surround server-response
+        "Switching to " " mode" surround 200 server-response
     ] [
         2drop "TYPE is binary only" ftp-error
     ] recover ;
@@ -115,65 +123,57 @@ ERROR: type-error type ;
 
 : handle-PWD ( obj -- )
     drop
-    257 current-directory get "\"" dup surround server-response ;
+    current-directory get "\"" dup surround 257 server-response ;
 
 : handle-SYST ( obj -- )
     drop
-    215 "UNIX Type: L8" server-response ;
+    "UNIX Type: L8" 215 server-response ;
-
-: if-command-promise ( quot -- )
-    [ client get command-promise>> ] dip
-    [ "Establish an active or passive connection first" ftp-error ] if* ;
-
-: handle-STOR ( obj -- )
-    [
-        tokenized>> second
-        [ [ <ftp-put> ] dip fulfill ] if-command-promise
-    ] [
-        2drop
-    ] recover ;
-
-! EPRT |2|::1|62138|
-! : handle-EPRT ( obj -- )
-    ! tokenized>> second "|" split harvest ;
 
 : start-directory ( -- )
-    150 "Here comes the directory listing." server-response ;
+    "Here comes the directory listing." 150 server-response ;
+
+: transfer-outgoing-file ( path -- )
+    [ "Opening BINARY mode data connection for " ] dip
+    [ file-name ] [
+        file-info size>> number>string
+        "(" " bytes)." surround
+    ] bi " " glue append 150 server-response ;
+
+: transfer-incoming-file ( path -- )
+    "Opening BINARY mode data connection for " prepend
+    150 server-response ;
+
+: finish-file-transfer ( -- )
+    "File send OK." 226 server-response ;
+
+GENERIC: handle-passive-command ( stream obj -- )
+
+: passive-loop ( server -- )
+    [
+        [
+            |dispose
+            30 seconds over set-timeout
+            accept drop &dispose
+            client get extra-connection>>
+            30 seconds ?promise-timeout
+            handle-passive-command
+        ]
+        [ client get f >>extra-connection drop ]
+        [ drop ] cleanup
+    ] with-destructors ;
 
 : finish-directory ( -- )
-    226 "Directory send OK." server-response ;
+    "Directory send OK." 226 server-response ;
 
-GENERIC: service-command ( stream obj -- )
+M: ftp-list handle-passive-command ( stream obj -- )
-
-M: ftp-list service-command ( stream obj -- )
     drop
     start-directory [
         utf8 encode-output
         [ current-directory get directory. ] with-string-writer string-lines
         harvest [ ftp-send ] each
-    ] with-output-stream
+    ] with-output-stream finish-directory ;
-    finish-directory ;
 
-: transfer-outgoing-file ( path -- )
+M: ftp-get handle-passive-command ( stream obj -- )
-    [
-        150
-        "Opening BINARY mode data connection for "
-    ] dip
-    [
-        file-name
-    ] [
-        file-info size>> number>string
-        "(" " bytes)." surround
-    ] bi " " glue append server-response ;
-
-: transfer-incoming-file ( path -- )
-    [ 150 ] dip "Opening BINARY mode data connection for " prepend
-    server-response ;
-
-: finish-file-transfer ( -- )
-    226 "File send OK." server-response ;
-
-M: ftp-get service-command ( stream obj -- )
     [
         path>>
         [ transfer-outgoing-file ]
@@ -183,7 +183,7 @@ M: ftp-get service-command ( stream obj -- )
         3drop "File transfer failed" ftp-error
     ] recover ;
 
-M: ftp-put service-command ( stream obj -- )
+M: ftp-put handle-passive-command ( stream obj -- )
     [
         path>>
         [ transfer-incoming-file ]
@@ -193,165 +193,165 @@ M: ftp-put service-command ( stream obj -- )
         3drop "File transfer failed" ftp-error
     ] recover ;
 
-: passive-loop ( server -- )
+M: ftp-disconnect handle-passive-command ( stream obj -- )
-    [
+    drop dispose ;
-        [
+
-            |dispose
+: fulfill-client ( obj -- )
-            30 seconds over set-timeout
+    client get extra-connection>> [
-            accept drop &dispose
+        fulfill
-            client get command-promise>>
+    ] [
-            30 seconds ?promise-timeout
+        drop
-            service-command
+        "Establish an active or passive connection first" ftp-error
-        ]
+    ] if* ;
-        [ client get f >>command-promise drop ]
+
-        [ drop ] cleanup
+: handle-STOR ( obj -- )
-    ] with-destructors ;
+    tokenized>> second
+    dup can-serve-file? [
+        <ftp-put> fulfill-client
+    ] [
+        drop 
+        <ftp-disconnect> fulfill-client
+    ] if ;
 
 : handle-LIST ( obj -- )
-    drop
+    drop current-directory get
-    [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
+    can-serve-directory? [
-
+        <ftp-list> fulfill-client
-: handle-SIZE ( obj -- )
-    [
-        [ 213 ] dip
-        tokenized>> second file-info size>>
-        number>string server-response
     ] [
-        2drop
+        <ftp-disconnect> fulfill-client
-        550 "Could not get file size" server-response
+    ] if ;
-    ] recover ;
+
+: not-a-plain-file ( path -- )
+    ": not a plain file." append ftp-error ;
 
 : handle-RETR ( obj -- )
-    [ tokenized>> second <ftp-get> swap fulfill ]
+    tokenized>> second
-    curry if-command-promise ;
+    dup can-serve-file? [
+        <ftp-get> fulfill-client
+    ] [
+        not-a-plain-file
+        <ftp-disconnect> fulfill-client
+    ] if ;
+
+: handle-SIZE ( obj -- )
+    tokenized>> second
+    dup can-serve-file? [
+        file-info size>> number>string 213 server-response
+    ] [
+        not-a-plain-file
+    ] if ;
 
 : expect-connection ( -- port )
+    <promise> client get (>>extra-connection)
     random-local-server
-    client get <promise> >>command-promise drop
     [ [ passive-loop ] curry in-thread ]
     [ addr>> port>> ] bi ;
 
 : handle-PASV ( obj -- )
-    drop client get passive >>mode drop
+    drop
-    221
     expect-connection port>bytes [ number>string ] bi@ "," glue
     "Entering Passive Mode (127,0,0,1," ")" surround
-    server-response ;
+    221 server-response ;
 
 : handle-EPSV ( obj -- )
     drop
-    client get command-promise>> [
+    client get f >>extra-connection drop
-        "You already have a passive stream" ftp-error
+    expect-connection number>string
-    ] [
+    "Entering Extended Passive Mode (|||" "|)" surround
-        229
+    229 server-response ;
-        expect-connection number>string
-        "Entering Extended Passive Mode (|||" "|)" surround
-        server-response
-    ] if ;
 
-! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
+: handle-MDTM ( obj -- )
-! : handle-LPRT ( obj -- ) tokenized>> "," split ;
+    tokenized>> 1 swap ?nth [
-
+        dup file-info dup directory? [
-ERROR: not-a-directory ;
+            drop not-a-plain-file
-ERROR: no-permissions ;
-
-: handle-CWD ( obj -- )
-    [
-        tokenized>> second dup normalize-path
-        dup ftp-server-directory head? [
-            no-permissions
-        ] unless
-
-        file-info directory? [
-            set-current-directory
-            250 "Directory successully changed." server-response
         ] [
-            not-a-directory
+            nip
+            modified>> timestamp>mdtm
+            213 server-response
         ] if
     ] [
-        2drop
+        "" not-a-plain-file
-        550 "Failed to change directory." server-response
+    ] if* ;
-    ] recover ;
 
-: unrecognized-command ( obj -- ) raw>> ftp-error ;
+ERROR: not-a-directory ;
+ERROR: no-directory-permissions ;
 
-: handle-client-loop ( -- )
+: directory-change-success ( -- )
-    <ftp-command> readln
+    "Directory successully changed." 250 server-response ;
-    USE: prettyprint    global [ dup . flush ] bind
+
-    [ >>raw ]
+: directory-change-failed ( -- )
-    [ tokenize-command >>tokenized ] bi
+    "Failed to change directory." 553 server-response ;
+
+: handle-CWD ( obj -- )
+    tokenized>> 1 swap ?nth [
+        dup can-serve-directory? [
+            set-current-directory
+            directory-change-success
+        ] [
+            drop
+            directory-change-failed
+        ] if
+    ] [
+        directory-change-success
+    ] if* ;
+
+: unrecognized-command ( obj -- )
+    raw>> "Unrecognized command: " prepend ftp-error ;
+
+: client-loop-dispatch ( str/f -- ? )
     dup tokenized>> first >upper {
+        { "QUIT" [ handle-QUIT f ] }
         { "USER" [ handle-USER t ] }
         { "PASS" [ handle-PASS t ] }
-        { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
-        { "CWD" [ handle-CWD t ] }
-        ! { "XCWD" [ ] }
-        ! { "CDUP" [ ] }
-        ! { "SMNT" [ ] }
-
-        ! { "REIN" [ drop client get reset-ftp-client t ] }
-        { "QUIT" [ handle-QUIT f ] }
-
-        ! { "PORT" [  ] } ! TODO
-        { "PASV" [ handle-PASV t ] }
-        ! { "MODE" [ ] }
-        { "TYPE" [ handle-TYPE t ] }
-        ! { "STRU" [ ] }
-
-        ! { "ALLO" [ ] }
-        ! { "REST" [ ] }
-        { "STOR" [ handle-STOR t ] }
-        ! { "STOU" [ ] }
-        { "RETR" [ handle-RETR t ] }
-        { "LIST" [ handle-LIST t ] }
-        { "SIZE" [ handle-SIZE t ] }
-        ! { "NLST" [ ] }
-        ! { "APPE" [ ] }
-        ! { "RNFR" [ ] }
-        ! { "RNTO" [ ] }
-        ! { "DELE" [ handle-DELE t ] }
-        ! { "RMD" [ handle-RMD t ] }
-        ! ! { "XRMD" [ handle-XRMD t ] }
-        ! { "MKD" [ handle-MKD t ] }
-        { "PWD" [ handle-PWD t ] }
-        ! { "ABOR" [ ] }
-
         { "SYST" [ handle-SYST t ] }
-        ! { "STAT" [ ] }
+        { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] }
-        ! { "HELP" [ ] }
+        { "PWD" [ handle-PWD t ] }
-
+        { "TYPE" [ handle-TYPE t ] }
-        ! { "SITE" [ ] }
+        { "CWD" [ handle-CWD t ] }
-        ! { "NOOP" [ ] }
+        { "PASV" [ handle-PASV t ] }
-
-        ! { "EPRT" [ handle-EPRT ] }
-        ! { "LPRT" [ handle-LPRT ] }
         { "EPSV" [ handle-EPSV t ] }
-        ! { "LPSV" [ drop handle-LPSV t ] }
+        { "LIST" [ handle-LIST t ] }
+        { "STOR" [ handle-STOR t ] }
+        { "RETR" [ handle-RETR t ] }
+        { "SIZE" [ handle-SIZE t ] }
+        { "MDTM" [ handle-MDTM t ] }
         [ drop unrecognized-command t ]
-    } case [ handle-client-loop ] when ;
+    } case ;
 
-TUPLE: ftp-server < threaded-server ;
+: read-command ( -- ftp-command/f )
+    readln [ f ] [ <ftp-command> ] if-empty ;
+
+: handle-client-loop ( -- )
+    read-command [
+        client-loop-dispatch
+        [ handle-client-loop ] when
+    ] when* ;
+
+: serve-directory ( server -- )
+    serving-directory>> [
+        send-banner
+        handle-client-loop
+    ] with-directory ;
 
 M: ftp-server handle-client* ( server -- )
-    drop
     [
-        ftp-server-directory [
+        "New client" \ handle-client* DEBUG log-message
-            host-name <ftp-client> client set
+        ftp-client new client set
-            send-banner handle-client-loop
+        [ server set ] [ serve-directory ] bi
-        ] with-directory
     ] with-destructors ;
 
-: <ftp-server> ( port -- server )
+: <ftp-server> ( directory port -- server )
     ftp-server new-threaded-server
         swap >>insecure
+        swap canonicalize-path >>serving-directory
         "ftp.server" >>name
         5 minutes >>timeout
         latin1 >>encoding ;
 
-: ftpd ( port -- )
+: ftpd ( directory port -- )
     <ftp-server> start-server ;
 
-: ftpd-main ( -- ) 2100 ftpd ;
+: ftpd-main ( path -- ) 2100 ftpd ;
 
 MAIN: ftpd-main
 

basis/help/cookbook/cookbook.factor

@@ -220,24 +220,6 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
     "io"
 } ;
 
-ARTICLE: "cookbook-compiler" "Compiler cookbook"
-"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is a fully transparent process. However, there are a few things worth knowing about the compilation process."
-$nl
-"The optimizing compiler trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
-$nl
-"After loading a vocabulary, you might see messages like:"
-{ $code
-    ":errors - print 2 compiler errors."
-    ":warnings - print 50 compiler warnings."
-}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
-{ $references
-    "To learn more about the compiler and static stack effect inference, read these articles:"
-    "compiler"
-    "compiler-errors"
-    "inference"
-} ;
-
 ARTICLE: "cookbook-application" "Application cookbook"
 "Vocabularies can define a main entry point:"
 { $code "IN: game-of-life"
@@ -396,7 +378,6 @@ ARTICLE: "cookbook" "Factor cookbook"
 { $subsection "cookbook-io" }
 { $subsection "cookbook-application" }
 { $subsection "cookbook-scripts" }
-{ $subsection "cookbook-compiler" }
 { $subsection "cookbook-philosophy" }
 { $subsection "cookbook-pitfalls" }
 { $subsection "cookbook-next" } ;

basis/help/handbook/handbook.factor

@@ -33,8 +33,8 @@ $nl
     { { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
     { { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
     { { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
-    { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } }
+    { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } }
-    { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } }
+    { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } }
     { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } }
     { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
 }

basis/images/images.factor

@@ -9,6 +9,24 @@ IN: images
 SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
 
+: bytes-per-pixel ( component-order -- n )
+    {
+        { BGR [ 3 ] }
+        { RGB [ 3 ] }
+        { BGRA [ 4 ] }
+        { RGBA [ 4 ] }
+        { ABGR [ 4 ] }
+        { ARGB [ 4 ] }
+        { RGBX [ 4 ] }
+        { XRGB [ 4 ] }
+        { BGRX [ 4 ] }
+        { XBGR [ 4 ] }
+        { R16G16B16 [ 6 ] }
+        { R32G32B32 [ 12 ] }
+        { R16G16B16A16 [ 8 ] }
+        { R32G32B32A32 [ 16 ] }
+    } case ;
+
 TUPLE: image dim component-order bitmap ;
 
 : <image> ( -- image ) image new ; inline

basis/io/directories/search/search.factor

@@ -57,8 +57,14 @@ PRIVATE>
         pusher [ [ f ] compose iterate-directory drop ] dip
     ] [ drop f ] recover ; inline
 
+ERROR: file-not-found ;
+
 : find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
-    '[ _ _ find-file ] attempt-all ;
+    [
+        '[ _ _ find-file [ file-not-found ] unless* ] attempt-all
+    ] [
+        drop f
+    ] recover ;
 
 : find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
     '[ _ _ find-all-files ] map concat ;

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

@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Yun, Jonghyouk.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup ;
+IN: io.encodings.korean
+
+ARTICLE: "io.encodings.korean" "Korean text encodings"
+"The " { $vocab-link "io.encodings.korean" } " vocabulary implements encodings used for Korean text besides the standard UTF encodings for Unicode strings."
+{ $subsection cp949 } ;
+
+ABOUT: "io.encodings.korean"
+
+HELP: cp949
+{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR. " }
+{ $see-also "encodings-introduction" } ;

basis/io/encodings/korean/korean.factor

@@ -6,6 +6,8 @@ math.order math.parser memoize multiline sequences splitting
 values hashtables io.binary ;
 IN: io.encodings.korean
 
+! TODO: migrate to common code-table parser (by Dan).
+
 SINGLETON: cp949
 
 cp949 "EUC-KR" register-encoding

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

@@ -72,13 +72,14 @@ M: linux file-systems
     ] map ;
 
 : (find-mount-point) ( path mtab-paths -- mtab-entry )
-    [ follow-links ] dip 2dup at* [
+    2dup at* [
         2nip
     ] [
         drop [ parent-directory ] dip (find-mount-point)
     ] if ;
 
 : find-mount-point ( path -- mtab-entry )
+    canonicalize-path
     parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
 
 ERROR: file-system-not-found ;

basis/io/files/links/unix/unix.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend io.files.links system unix ;
+USING: io.backend io.files.links system unix io.pathnames kernel
+io.files sequences ;
 IN: io.files.links.unix
 
 M: unix make-link ( path1 path2 -- )
@@ -8,3 +9,7 @@ M: unix make-link ( path1 path2 -- )
 
 M: unix read-link ( path -- path' )
     normalize-path read-symbolic-link ;
+
+M: unix canonicalize-path ( path -- path' )
+    path-components "/"
+    [ append-path dup exists? [ follow-links ] when ] reduce ;

basis/io/servers/connection/connection.factor

@@ -12,6 +12,7 @@ IN: io.servers.connection
 
 TUPLE: threaded-server
 name
+log-level
 secure insecure
 secure-config
 sockets
@@ -29,6 +30,7 @@ ready ;
 : new-threaded-server ( class -- threaded-server )
     new
         "server" >>name
+        DEBUG >>log-level
         ascii >>encoding
         1 minutes >>timeout
         V{ } clone >>sockets
@@ -115,7 +117,7 @@ M: threaded-server handle-client* handler>> call ;
 : (start-server) ( threaded-server -- )
     init-server
     dup threaded-server [
-        dup name>> [
+        [ ] [ name>> ] bi [
             [ listen-on [ start-accept-loop ] parallel-each ]
             [ ready>> raise-flag ]
             bi

basis/io/servers/packet/packet.factor

@@ -1,4 +1,6 @@
-IN: io.servers.datagram
+USING: concurrency.combinators destructors fry
+io.sockets kernel logging ;
+IN: io.servers.packet
 
 <PRIVATE
 

basis/logging/logging-docs.factor

@@ -8,6 +8,9 @@ HELP: DEBUG
 HELP: NOTICE
 { $description "Log level for ordinary messages." } ;
 
+HELP: WARNING
+{ $description "Log level for warnings." } ;
+
 HELP: ERROR
 { $description "Log level for error messages." } ;
 
@@ -18,6 +21,7 @@ ARTICLE: "logging.levels" "Log levels"
 "Several log levels are supported, from lowest to highest:"
 { $subsection DEBUG }
 { $subsection NOTICE }
+{ $subsection WARNING }
 { $subsection ERROR }
 { $subsection CRITICAL } ;
 
@@ -36,7 +40,7 @@ ARTICLE: "logging.files" "Log files"
 
 HELP: log-message
 { $values { "msg" string } { "word" word } { "level" "a log level" } }
-{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
+{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
 
 HELP: add-logging
 { $values { "level" "a log level" } { "word" word } }
@@ -91,7 +95,7 @@ HELP: close-logs
 
 HELP: with-logging
 { $values { "service" "a log service name" } { "quot" quotation } }
-{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ;
+{ $description "Calls the quotation a new dynamic scope where all logging calls more urgent than " { $link log-level } " are sent to the log file for " { $snippet "service" } "." } ;
 
 ARTICLE: "logging.rotation" "Log rotation"
 "Log files should be rotated periodically to prevent unbounded growth."
@@ -120,4 +124,3 @@ ARTICLE: "logging" "Logging framework"
 { $subsection "logging.server" } ;
 
 ABOUT: "logging"
-

basis/logging/logging.factor

@@ -4,25 +4,47 @@ USING: logging.server sequences namespaces concurrency.messaging
 words kernel arrays shuffle tools.annotations
 prettyprint.config prettyprint debugger io.streams.string
 splitting continuations effects generalizations parser strings
-quotations fry accessors ;
+quotations fry accessors math assocs math.order ;
 IN: logging
 
 SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
 
-: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
+SYMBOL: log-level
+
+log-level [ DEBUG ] initialize
+
+: log-levels ( -- assoc )
+    H{
+        { DEBUG 0 }
+        { NOTICE 10 }
+        { WARNING 20 }
+        { ERROR 30 }
+        { CRITICAL 40 }
+    } ;
+
+ERROR: undefined-log-level ;
+
+: log-level<=> ( log-level log-level -- ? )
+    [ log-levels at* [ undefined-log-level ] unless ] bi@ <=> ;
+
+: log? ( log-level -- ? )
+    log-level get log-level<=> +lt+ = not ;
 
 : send-to-log-server ( array string -- )
     prefix "log-server" get send ;
 
 SYMBOL: log-service
 
+ERROR: bad-log-message-parameters msg word level ;
+
 : check-log-message ( msg word level -- msg word level )
     3dup [ string? ] [ word? ] [ word? ] tri* and and
-    [ "Bad parameters to log-message" throw ] unless ; inline
+    [ bad-log-message-parameters ] unless ; inline
 
 : log-message ( msg word level -- )
     check-log-message
-    log-service get dup [
+    log-service get
+    2dup [ log? ] [ ] bi* and [
         [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip
         4array "log-message" send-to-log-server
     ] [
@@ -36,7 +58,7 @@ SYMBOL: log-service
     { } "close-logs" send-to-log-server ;
 
 : with-logging ( service quot -- )
-    log-service swap with-variable ; inline
+    [ log-service ] dip with-variable ; inline
 
 ! Aspect-oriented programming idioms
 

basis/logging/parser/parser.factor

@@ -3,7 +3,7 @@
 USING: accessors peg peg.parsers memoize kernel sequences
 logging arrays words strings vectors io io.files
 io.encodings.utf8 namespaces make combinators logging.server
-calendar calendar.format ;
+calendar calendar.format assocs ;
 IN: logging.parser
 
 TUPLE: log-entry date level word-name message ;
@@ -21,7 +21,7 @@ SYMBOL: multiline
     "[" "]" surrounded-by ;
 
 : 'log-level' ( -- parser )
-    log-levels [
+    log-levels keys [
         [ name>> token ] keep [ nip ] curry action
     ] map choice ;
 

basis/math/bits/authors.txt

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

basis/math/bits/bits-docs.factor

@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup math ;
+IN: math.bits
+
+ABOUT: "math.bits"
+
+ARTICLE: "math.bits" "Number bits virtual sequence"
+{ $subsection bits }
+{ $subsection <bits> }
+{ $subsection make-bits } ;
+
+HELP: bits
+{ $class-description "Virtual sequence class of bits of a number. The first bit is the least significant bit. This can be constructed with " { $link <bits> } " or " { $link make-bits } "." } ;
+
+HELP: <bits>
+{ $values { "number" integer } { "length" integer } { "bits" bits } }
+{ $description "Creates a virtual sequence of bits of a number in little endian order, with the given length." } ;
+
+HELP: make-bits
+{ $values { "number" integer } { "bits" bits } }
+{ $description "Creates a " { $link bits } " object out of the given number, using its log base 2 as the length. This implies that the last element, corresponding to the most significant bit, will be 1." }
+{ $examples
+    { $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
+    { $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
+} ;

basis/math/bits/bits-tests.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.bits sequences arrays ;
+IN: math.bits.tests
+
+[ t ] [ BIN: 111111 3 <bits> second ] unit-test
+[ { t t t } ] [ BIN: 111111 3 <bits> >array ] unit-test
+[ f ] [ BIN: 111101 3 <bits> second ] unit-test
+[ { f f t } ] [ BIN: 111100 3 <bits> >array ] unit-test
+[ 3 ] [ BIN: 111111 3 <bits> length ] unit-test
+[ 6 ] [ BIN: 111111 make-bits length ] unit-test
+[ 0 ] [ 0 make-bits length ] unit-test
+[ 2 ] [ 3 make-bits length ] unit-test
+[ 2 ] [ -3 make-bits length ] unit-test
+[ 1 ] [ 1 make-bits length ] unit-test
+[ 1 ] [ -1 make-bits length ] unit-test

basis/math/bits/bits.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel math accessors sequences.private ;
+IN: math.bits
+
+TUPLE: bits { number read-only } { length read-only } ;
+C: <bits> bits
+
+: make-bits ( number -- bits )
+    dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
+
+M: bits length length>> ;
+
+M: bits nth-unsafe number>> swap bit? ;
+
+INSTANCE: bits immutable-sequence

basis/math/bits/summary.txt

@@ -0,0 +1 @@
+Virtual sequence for bits of an integer

basis/math/bitwise/bitwise.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions sequences
+USING: arrays kernel math sequences accessors math.bits
 sequences.private words namespaces macros hints
 combinators fry io.binary combinators.smart ;
 IN: math.bitwise
@@ -65,7 +65,7 @@ DEFER: byte-bit-count
 
 \ byte-bit-count
 256 [
-    0 swap [ [ 1+ ] when ] each-bit
+    8 <bits> 0 [ [ 1+ ] when ] reduce
 ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
 (( byte -- table )) define-declared
 

basis/math/functions/functions-docs.factor

@@ -235,7 +235,7 @@ HELP: arg
 
 HELP: >polar
 { $values { "z" number } { "abs" "a non-negative real number" } { "arg" "a number in the interval " { $snippet "(-pi,pi]" } } }
-{ $description "Creates a complex number from an absolute value and argument (polar form)." } ;
+{ $description "Converts a complex number into an absolute value and argument (polar form)." } ;
 
 HELP: cis
 { $values { "arg" "a real number" } { "z" "a complex number on the unit circle" } }
@@ -278,14 +278,6 @@ HELP: mod-inv
     { $example "USING: math prettyprint ;" "173 815 * 1119 mod ." "1" }
 } ;
 
-HELP: each-bit
-{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } }
-{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." }
-{ $examples
-    { $example "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
-    { $example "USING: math.functions make prettyprint ;" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" }
-} ;
-
 HELP: ~
 { $values { "x" real } { "y" real } { "epsilon" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " and " { $snippet "y" } " are approximately equal to each other. There are three possible comparison tests, chosen based on the sign of " { $snippet "epsilon" } ":"

basis/math/functions/functions.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel math.constants math.private
+USING: math kernel math.constants math.private math.bits
 math.libm combinators math.order sequences ;
 IN: math.functions
 
@@ -26,16 +26,6 @@ GENERIC: sqrt ( x -- y ) foldable
 M: real sqrt
     >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
 
-: each-bit ( n quot: ( ? -- ) -- )
-    over [ 0 = ] [ -1 = ] bi or [
-        2drop
-    ] [
-        2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread
-    ] if ; inline recursive
-
-: map-bits ( n quot: ( ? -- obj ) -- seq )
-    accumulator [ each-bit ] dip ; inline
-
 : factor-2s ( n -- r s )
     #! factor an integer into 2^r * s
     dup 0 = [ 1 ] [
@@ -47,7 +37,7 @@ M: real sqrt
 GENERIC# ^n 1 ( z w -- z^w )
 
 : (^n) ( z w -- z^w )
-    1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
+    make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
 
 M: integer ^n
     [ factor-2s ] dip [ (^n) ] keep rot * shift ;
@@ -94,9 +84,9 @@ PRIVATE>
     dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
 
 : (^mod) ( n x y -- z )
-    1 swap [
+    make-bits 1 [
         [ dupd * pick mod ] when [ sq over mod ] dip
-    ] each-bit 2nip ; inline
+    ] reduce 2nip ; inline
 
 : (gcd) ( b a x y -- a d )
     over zero? [

basis/stack-checker/errors/errors-docs.factor

@@ -87,6 +87,8 @@ HELP: inconsistent-recursive-call-error
 } ;
 
 ARTICLE: "inference-errors" "Inference warnings and errors"
+"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
+$nl
 "Main wrapper for all inference warnings and errors:"
 { $subsection inference-error }
 "Inference warnings:"

basis/stack-checker/stack-checker-docs.factor

@@ -56,7 +56,7 @@ ARTICLE: "inference-recursive" "Stack effects of recursive words"
 "When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect."
 $nl
 "Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":"
-{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." }
+{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." }
 "If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ;
 
 ARTICLE: "inference-recursive-combinators" "Recursive combinator inference"

basis/tools/files/files.factor

@@ -35,9 +35,10 @@ IN: tools.files
 
 PRIVATE>
 
-SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
+SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+
-file-date file-time file-datetime uid gid user group link-target unix-datetime
++nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+
-directory-or-size ;
++uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+
++directory-or-size+ ;
 
 TUPLE: listing-tool path specs sort ;
 
@@ -48,10 +49,10 @@ C: <file-listing> file-listing
 : <listing-tool> ( path -- listing-tool )
     listing-tool new
         swap >>path
-        { file-name } >>specs ;
+        { +file-name+ } >>specs ;
 
 : list-slow? ( listing-tool -- ? )
-    specs>> { file-name } sequence= not ;
+    specs>> { +file-name+ } sequence= not ;
 
 ERROR: unknown-file-spec symbol ;
 
@@ -59,12 +60,12 @@ HOOK: file-spec>string os ( file-listing spec -- string )
 
 M: object file-spec>string ( file-listing spec -- string )
     {
-        { file-name [ directory-entry>> name>> ] }
+        { +file-name+ [ directory-entry>> name>> ] }
-        { directory-or-size [ file-info>> dir-or-size ] }
+        { +directory-or-size+ [ file-info>> dir-or-size ] }
-        { file-size [ file-info>> size>> number>string ] }
+        { +file-size+ [ file-info>> size>> number>string ] }
-        { file-date [ file-info>> modified>> listing-date ] }
+        { +file-date+ [ file-info>> modified>> listing-date ] }
-        { file-time [ file-info>> modified>> listing-time ] }
+        { +file-time+ [ file-info>> modified>> listing-time ] }
-        { file-datetime [ file-info>> modified>> timestamp>ymdhms ] }
+        { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] }
         [ unknown-file-spec ]
     } case ;
 
@@ -85,22 +86,22 @@ HOOK: (directory.) os ( path -- lines )
 
 : directory. ( path -- ) (directory.) simple-table. ;
 
-SYMBOLS: device-name mount-point type
+SYMBOLS: +device-name+ +mount-point+ +type+
-available-space free-space used-space total-space
++available-space+ +free-space+ +used-space+ +total-space+
-percent-used percent-free ;
++percent-used+ +percent-free+ ;
 
 : percent ( real -- integer ) 100 * >integer ; inline
 
 : file-system-spec ( file-system-info obj -- str )
     {
-        { device-name [ device-name>> "" or ] }
+        { +device-name+ [ device-name>> "" or ] }
-        { mount-point [ mount-point>> "" or ] }
+        { +mount-point+ [ mount-point>> "" or ] }
-        { type [ type>> "" or ] }
+        { +type+ [ type>> "" or ] }
-        { available-space [ available-space>> 0 or ] }
+        { +available-space+ [ available-space>> 0 or ] }
-        { free-space [ free-space>> 0 or ] }
+        { +free-space+ [ free-space>> 0 or ] }
-        { used-space [ used-space>> 0 or ] }
+        { +used-space+ [ used-space>> 0 or ] }
-        { total-space [ total-space>> 0 or ] }
+        { +total-space+ [ total-space>> 0 or ] }
-        { percent-used [
+        { +percent-used+ [
             [ used-space>> ] [ total-space>> ] bi
             [ 0 or ] bi@ dup 0 =
             [ 2drop 0 ] [ / percent ] if
@@ -116,8 +117,8 @@ percent-used percent-free ;
 
 : file-systems. ( -- )
     {
-        device-name available-space free-space used-space
+        +device-name+ +available-space+ +free-space+ +used-space+
-        total-space percent-used mount-point
+        +total-space+ +percent-used+ +mount-point+
     } print-file-systems ;
 
 {

basis/tools/files/unix/unix.factor

@@ -47,21 +47,24 @@ IN: tools.files.unix
 
 M: unix (directory.) ( path -- lines )
     <listing-tool>
-        { permissions nlinks user group file-size file-date file-name } >>specs
+        {
+            +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 [
+        { +file-name/type+ [
             directory-entry>> [ name>> ] [ file-type>trailing ] bi append
         ] }
-        { permissions [ file-info>> permissions-string ] }
+        { +permissions+ [ file-info>> permissions-string ] }
-        { nlinks [ file-info>> nlink>> number>string ] }
+        { +nlinks+ [ file-info>> nlink>> number>string ] }
-        { user [ file-info>> uid>> user-name ] }
+        { +user+ [ file-info>> uid>> user-name ] }
-        { group [ file-info>> gid>> group-name ] }
+        { +group+ [ file-info>> gid>> group-name ] }
-        { uid [ file-info>> uid>> number>string ] }
+        { +uid+ [ file-info>> uid>> number>string ] }
-        { gid [ file-info>> gid>> number>string ] }
+        { +gid+ [ file-info>> gid>> number>string ] }
         [ call-next-method ]
     } case ;
 

basis/tools/files/windows/windows.factor

@@ -9,7 +9,7 @@ IN: tools.files.windows
 
 M: windows (directory.) ( entries -- lines )
     <listing-tool>
-        { file-datetime directory-or-size file-name } >>specs
+        { +file-datetime+ +directory-or-size+ +file-name+ } >>specs
         { { directory-entry>> name>> <=> } } >>sort
     list-files ;
 

core/classes/tuple/tuple-docs.factor

@@ -22,7 +22,7 @@ ARTICLE: "slot-class-declaration" "Slot class declarations"
 ARTICLE: "slot-class-coercion" "Coercive slot declarations"
 "If the class of a slot is declared to be one of " { $link fixnum } " or " { $link float } ", then rather than testing values with the class predicate, writer words coerce values to the relevant type with " { $link >fixnum } " or " { $link >float } ". This may still result in error, but permits a wider range of values than a class predicate test. It also results in a possible loss of precision; for example, storing a large integer into a " { $link fixnum } " slot will silently overflow and discard high bits, and storing a ratio into a " { $link float } " slot may lose precision if the ratio is one which cannot be represented exactly with floating-point."
 $nl
-"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus hsould avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ;
+"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus should avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ;
 
 ARTICLE: "tuple-declarations" "Tuple slot declarations"
 "The slot specifier syntax of the " { $link POSTPONE: TUPLE: } " parsing word understands the following slot attributes:"

core/compiler/errors/errors-docs.factor

@@ -3,9 +3,16 @@ USING: help.markup help.syntax vocabs.loader words io
 quotations words.symbol ;
 
 ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"The compiler saves " { $link "inference-errors" } " in a global variable:"
+"After loading a vocabulary, you might see messages like:"
-{ $subsection compiler-errors }
+{ $code
-"These notifications can be viewed later:"
+    ":errors - print 2 compiler errors."
+    ":warnings - print 50 compiler warnings."
+}
+"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
+$nl
+"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
+$nl
+"Words to view warnings and errors:"
 { $subsection :errors }
 { $subsection :warnings }
 { $subsection :linkage }

core/io/pathnames/pathnames-docs.factor

@@ -1,4 +1,5 @@
-USING: help.markup help.syntax io.backend io.files strings ;
+USING: help.markup help.syntax io.backend io.files strings
+sequences ;
 IN: io.pathnames
 
 HELP: path-separator?
@@ -22,6 +23,10 @@ HELP: file-name
     { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
 } ;
 
+HELP: path-components
+{ $values { "path" "a pathnames string" } { "seq" sequence } }
+{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ;
+
 HELP: append-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
 { $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
@@ -57,6 +62,10 @@ HELP: normalize-path
 { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
 { $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
 
+HELP: canonicalize-path
+{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
+{ $description "Returns an canonical name for a path. The canonical name is an absolute path containing no symlinks." } ;
+
 HELP: <pathname>
 { $values { "string" "a pathname string" } { "pathname" pathname } }
 { $description "Creates a new " { $link pathname } "." } ;
@@ -74,9 +83,12 @@ ARTICLE: "io.pathnames" "Pathname manipulation"
 { $subsection POSTPONE: P" }
 "Pathname manipulation:"
 { $subsection normalize-path }
+{ $subsection canonicalize-path }
 { $subsection parent-directory }
 { $subsection file-name }
 { $subsection last-path-separator }
+{ $subsection path-components }
+{ $subsection prepend-path }
 { $subsection append-path }
 "Pathname presentations:"
 { $subsection pathname }

core/io/pathnames/pathnames-tests.factor

@@ -66,3 +66,7 @@ IN: io.pathnames.tests
 ] with-scope
 
 [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
+
+! Regression test for bug in file-extension
+[ f ] [ "/funny.directory/file-with-no-extension" file-extension ] unit-test
+[ "" ] [ "/funny.directory/file-with-no-extension." file-extension ] unit-test

core/io/pathnames/pathnames.factor

@@ -119,7 +119,14 @@ PRIVATE>
     ] unless ;
 
 : file-extension ( filename -- extension )
-    "." split1-last nip ;
+    file-name "." split1-last nip ;
+
+: path-components ( path -- seq )
+    normalize-path path-separator split harvest ;
+
+HOOK: canonicalize-path os ( path -- path' )
+
+M: object canonicalize-path normalize-path ;
 
 : resource-path ( path -- newpath )
     "resource-path" get prepend-path ;

core/vocabs/loader/loader-docs.factor

@@ -34,13 +34,20 @@ $nl
 { $subsection "vocabs.roots" }
 "Vocabulary names map directly to source files. A vocabulary named " { $snippet "foo.bar" } " must be defined in a " { $snippet "bar" } " directory nested inside a " { $snippet "foo" } " directory of a vocabulary root. Any level of vocabulary nesting is permitted."
 $nl
-"The vocabulary directory - " { $snippet "bar" } " in our example - can contain the following files; the first is required while the rest are optional:"
+"The vocabulary directory - " { $snippet "bar" } " in our example - contains a source file:"
+{ $list
+  { { $snippet "foo/bar/bar.factor" } " - the source file, must define words in the " { $snippet "foo.bar" } " vocabulary with an " { $snippet "IN: foo.bar" } " form" }
+}
+"Two other Factor source files, storing documentation and tests, respectively, are optional:"
 { $list
-    { { $snippet "foo/bar/bar.factor" } " - the source file, defines words in the " { $snippet "foo.bar" } " vocabulary" }
     { { $snippet "foo/bar/bar-docs.factor" } " - documentation, see " { $link "writing-help" } }
     { { $snippet "foo/bar/bar-tests.factor" } " - unit tests, see " { $link "tools.test" } }
+}
+"Finally, three text files can contain meta-data:"
+{ $list
+    { { $snippet "foo/bar/authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } }
     { { $snippet "foo/bar/summary.txt" } " - a one-line description" }
-    { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary" }
+    { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can re-use" }
 }
 "While " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " load vocabularies which have not been loaded before adding them to the search path, it is also possible to load a vocabulary without adding it to the search path:"
 { $subsection require }

extra/annotations/annotations-docs.factor

@@ -9,6 +9,22 @@ IN: annotations
 : comment-usage.-word ( base -- word ) "s." append "annotations" lookup ; 
 PRIVATE>
 
+: $annotation ( element -- )
+    first
+    [ "!" " your comment here" surround 1array $syntax ]
+    [ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ]
+    [ ": foo ( x y z -- w )\n    !" " --w-ó()ò-w-- kilroy was here\n    + * ;" surround 1array $unchecked-example ]
+    tri ;
+
+: $annotation-usage. ( element -- )
+    first
+    [ "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 3array $description ;
+
+: $annotation-usage ( element -- )
+    first
+    { "usages" sequence } $values
+    [ "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray ] bi 1array $description ;
+
 "Code annotations"
 {
     "The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism."
@@ -26,17 +42,9 @@ annotation-tags natural-sort
 
 annotation-tags [
     {
-        [ [ \ $syntax ] dip "!" " your comment here" surround 2array ]
+        [ [ \ $annotation swap 2array 1array ] [ comment-word set-word-help ] bi ]
-        [ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ]
+        [ [ \ $annotation-usage swap 2array 1array ] [ comment-usage-word set-word-help ] bi ]
-        [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n    !" " --w-ó()ò-w-- kilroy was here\n    + * ;" surround 2array 3array ]
+        [ [ \ $annotation-usage. swap 2array 1array ] [ comment-usage.-word set-word-help ] bi ]
-        [ comment-word set-word-help ]
-
-        [ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ]
-        [ comment-usage.-word set-word-help ]
-
-        [ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ]
-        [ comment-usage-word set-word-help ]
-
         [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ]
     } cleave
 ] each

extra/crypto/passwd-md5/passwd-md5.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel base64 checksums.md5 sequences checksums
-locals prettyprint math math.bitwise grouping io combinators
+locals prettyprint math math.bits grouping io combinators
 fry make combinators.short-circuit math.functions splitting ;
 IN: crypto.passwd-md5
 
@@ -22,8 +22,8 @@ PRIVATE>
                 password length
                 [ 16 / ceiling swap <repetition> concat ] keep
                 head-slice append
-                password [ length ] [ first ] bi
+                password [ length make-bits ] [ first ] bi
-                '[ [ CHAR: \0 _ ? , ] each-bit ] "" make append
+                '[ CHAR: \0 _ ? ] "" map-as append
                 md5 checksum-bytes ] |
         1000 [
             "" swap

extra/fuel/fuel.factor

@@ -99,6 +99,8 @@ PRIVATE>
 
 : fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ;
 
+: fuel-word-synopsis ( word usings -- ) (fuel-word-synopsis) fuel-eval-set-result ;
+
 : fuel-vocab-summary ( name -- )
     (fuel-vocab-summary) fuel-eval-set-result ;
 

extra/fuel/help/help.factor

@@ -90,6 +90,12 @@ PRIVATE>
 : (fuel-word-help) ( name -- elem )
     fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ;
 
+: (fuel-word-synopsis) ( word usings -- str/f )
+    [
+        [ vocab ] filter interactive-vocabs [ append ] change
+        fuel-find-word [ synopsis ] [ f ] if*
+    ] with-scope ;
+
 : (fuel-word-see) ( word -- elem )
     [ name>> \ article swap ]
     [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline

extra/id3/id3-docs.factor

@@ -1,13 +1,19 @@
 ! Copyright (C) 2008 Tim Wawrzynczak
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax sequences kernel ;
+USING: help.markup help.syntax sequences kernel accessors ;
 IN: id3
 
 HELP: file-id3-tags
 { $values 
     { "path" "a path string" } 
     { "object/f" "a tuple storing ID3 metadata or f" } }
-{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ;
+    { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present.  Currently, the parser supports the following tags: "
+      $nl { $link title>> }
+      $nl { $link artist>> }
+      $nl { $link album>> }
+      $nl { $link year>> }
+      $nl { $link genre>> }
+      $nl { $link comment>> } } ;
 
 ARTICLE: "id3" "ID3 tags"
 "The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl

extra/id3/id3-tests.factor

@@ -1,182 +1,35 @@
 ! Copyright (C) 2009 Tim Wawrzynczak
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test id3 ;
+USING: tools.test id3 id3.private ;
 IN: id3.tests
 
-[ T{ mp3v2-file
+[
-     { header  T{ header f t 0 502 } }
+    T{ id3-info
-     { frames
+       { title "BLAH" }
-       {
+       { artist "ARTIST" }
-           T{ frame
+       { album "ALBUM" }
-              { frame-id "COMM" }
+       { year "2009" }
-              { flags B{ 0 0 } }
+       { comment "COMMENT" }
-              { size 19 }
+       { genre "Bluegrass" }
-              { data "eng, AG# 08E1C12E" }
+    }
-           }
+] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test
-           T{ frame
-              { frame-id "TIT2" }
-              { flags B{ 0 0 } }
-              { size 15 }
-              { data "Stormy Weather" }
-           }
-           T{ frame
-              { frame-id "TRCK" }
-              { flags B{ 0 0 } }
-              { size 3 }
-              { data "32" }
-           }
-           T{ frame
-              { frame-id "TCON" }
-              { flags B{ 0 0 } }
-              { size 5 }
-              { data "(96)" }
-           }
-           T{ frame
-              { frame-id "TALB" }
-              { flags B{ 0 0 } }
-              { size 28 }
-              { data "Night and Day Frank Sinatra" }
-           }
-           T{ frame
-              { frame-id "PRIV" }
-              { flags B{ 0 0 } }
-              { size 39 }
-              { data "WM/MediaClassPrimaryID<49>}`<60>#<23><>K<EFBFBD>H<EFBFBD>*(D" }
-           }
-           T{ frame
-              { frame-id "PRIV" }
-              { flags B{ 0 0 } }
-              { size 41 }
-              { data "WM/MediaClassSecondaryID" }
-           }
-           T{ frame
-              { frame-id "TPE1" }
-              { flags B{ 0 0 } }
-              { size 14 }
-              { data "Frank Sinatra" }
-           }
-       }
-     }
-}
-] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
 
 [
-    T{ mp3v2-file
+    T{ id3-info
-    { header
+       { title "Anthem of the Trinity" }
-        T{ header { version t } { flags 0 } { size 1405 } }
+       { artist "Terry Riley" }
+       { album "Shri Camel" }
+       { genre "Classical" }
     }
-    { frames
-        {
-            T{ frame
-                { frame-id "TIT2" }
-                { flags B{ 0 0 } }
-                { size 22 }
-                { data "Anthem of the Trinity" }
-            }
-            T{ frame
-                { frame-id "TPE1" }
-                { flags B{ 0 0 } }
-                { size 12 }
-                { data "Terry Riley" }
-            }
-            T{ frame
-                { frame-id "TALB" }
-                { flags B{ 0 0 } }
-                { size 11 }
-                { data "Shri Camel" }
-            }
-            T{ frame
-                { frame-id "TCON" }
-                { flags B{ 0 0 } }
-                { size 10 }
-                { data "Classical" }
-            }
-            T{ frame
-                { frame-id "UFID" }
-                { flags B{ 0 0 } }
-                { size 23 }
-                { data "http://musicbrainz.org" }
-            }
-            T{ frame
-                { frame-id "TXXX" }
-                { flags B{ 0 0 } }
-                { size 23 }
-                { data "MusicBrainz Artist Id" }
-            }
-            T{ frame
-                { frame-id "TXXX" }
-                { flags B{ 0 0 } }
-                { size 22 }
-                { data "musicbrainz_artistid" }
-            }
-            T{ frame
-                { frame-id "TRCK" }
-                { flags B{ 0 0 } }
-                { size 2 }
-                { data "1" }
-            }
-            T{ frame
-                { frame-id "TXXX" }
-                { flags B{ 0 0 } }
-                { size 22 }
-                { data "MusicBrainz Album Id" }
-            }
-            T{ frame
-                { frame-id "TXXX" }
-                { flags B{ 0 0 } }
-                { size 21 }
-                { data "musicbrainz_albumid" }
-            }
-            T{ frame
-                { frame-id "TXXX" }
-                { flags B{ 0 0 } }
-                { size 29 }
-                { data "MusicBrainz Album Artist Id" }
-            }
-            T{ frame
-                { frame-id "TXXX" }
-                { flags B{ 0 0 } }
-                { size 27 }
-                { data "musicbrainz_albumartistid" }
-            }
-            T{ frame
-                { frame-id "TPOS" }
-                { flags B{ 0 0 } }
-                { size 2 }
-                { data "1" }
-            }
-            T{ frame
-                { frame-id "TSOP" }
-                { flags B{ 0 0 } }
-                { size 1 }
-            }
-            T{ frame
-                { frame-id "TMED" }
-                { flags B{ 0 0 } }
-                { size 4 }
-                { data "DIG" }
-            }
-        }
-    }
-}
 ] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test
 
 [    
-  T{ mp3v1-file
+    T{ id3-info
-     { title
+       { title "Stormy Weather" }
-       "BLAH"
+       { artist "Frank Sinatra" }
-     }
+       { album "Night and Day Frank Sinatra" }
-     { artist
+       { comment "eng, AG# 08E1C12E" }
-       "ARTIST"
+       { genre "Big Band" }
-     }
+    }
-     { album
+] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
-       "ALBUM"
-     }
-     { year "2009" }
-     { comment
-       "COMMENT"
-     }
-     { genre 89 }
-  }
-] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test
 

extra/id3/id3.factor

@@ -1,28 +1,159 @@
 ! Copyright (C) 2009 Tim Wawrzynczak
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ;
+USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf8 assocs math.parser ;
 IN: id3
 
+<PRIVATE
+
+! genres
+CONSTANT: genres
+  H{
+    { 0 "Blues" }
+    { 1 "Classic Rock" }
+    { 2 "Country" }
+    { 3 "Dance" }
+    { 4 "Disco" }
+    { 5 "Funk" }
+    { 6 "Grunge" }
+    { 7 "Hip-Hop" }
+    { 8 "Jazz" }
+    { 9 "Metal" }
+    { 10 "New Age" }
+    { 11 "Oldies" }
+    { 12 "Other" }
+    { 13 "Pop" }
+    { 14 "R&B" }
+    { 15 "Rap" }
+    { 16 "Reggae" }
+    { 17 "Rock" }
+    { 18 "Techno" }
+    { 19 "Industrial" }
+    { 20 "Alternative" }
+    { 21 "Ska" }
+    { 22 "Death Metal" }
+    { 23 "Pranks" }
+    { 24 "Soundtrack" }
+    { 25 "Euro-Techno" }
+    { 26 "Ambient" }
+    { 27 "Trip-Hop" }
+    { 28 "Vocal" }
+    { 29 "Jazz+Funk" }
+    { 30 "Fusion" }
+    { 31 "Trance" }
+    { 32 "Classical" }
+    { 33 "Instrumental" }
+    { 34 "Acid" }
+    { 35 "House" }
+    { 36 "Game" }
+    { 37 "Sound Clip" }
+    { 38 "Gospel" }
+    { 39 "Noise" }
+    { 40 "AlternRock" }
+    { 41 "Bass" }
+    { 42 "Soul" }
+    { 43 "Punk" }
+    { 44 "Space" }
+    { 45 "Meditative" }
+    { 46 "Instrumental Pop" }
+    { 47 "Instrumental Rock" }
+    { 48 "Ethnic" }
+    { 49 "Gothic" }
+    { 50 "Darkwave" }
+    { 51 "Techno-Industrial" }
+    { 52 "Electronic" }
+    { 53 "Pop-Folk" }
+    { 54 "Eurodance" }
+    { 55 "Dream" }
+    { 56 "Southern Rock" }
+    { 57 "Comedy" }
+    { 58 "Cult" }
+    { 59 "Gangsta" }
+    { 60 "Top 40" }
+    { 61 "Christian Rap" }
+    { 62 "Pop/Funk" }
+    { 63 "Jungle" }
+    { 64 "Native American" }
+    { 65 "Cabaret" }
+    { 66 "New Wave" }
+    { 67 "Psychedelic" }
+    { 68 "Rave" }
+    { 69 "Showtunes" }
+    { 70 "Trailer" }
+    { 71 "Lo-Fi" }
+    { 72 "Tribal" }
+    { 73 "Acid Punk" }
+    { 74 "Acid Jazz" }
+    { 75 "Polka" }
+    { 76 "Retro" }
+    { 77 "Musical" }
+    { 78 "Rock & Roll" }
+    { 79 "Hard Rock" }
+    { 80 "Folk" }
+    { 81 "Folk-Rock" }
+    { 82 "National Folk" }
+    { 83 "Swing" }
+    { 84 "Fast Fusion" }
+    { 85 "Bebop" }
+    { 86 "Latin" }
+    { 87 "Revival" }
+    { 88 "Celtic" }
+    { 89 "Bluegrass" }
+    { 90 "Avantgarde" }
+    { 91 "Gothic Rock" }
+    { 92 "Progressive Rock" }
+    { 93 "Psychedelic Rock" }
+    { 94 "Symphonic Rock" }
+    { 95 "Slow Rock" }
+    { 96 "Big Band" }
+    { 97 "Chorus" }
+    { 98 "Easy Listening" }
+    { 99 "Acoustic" }
+    { 100 "Humour" }
+    { 101 "Speech" }
+    { 102 "Chanson" }
+    { 103 "Opera" }
+    { 104 "Chamber Music" }
+    { 105 "Sonata" }
+    { 106 "Symphony" }
+    { 107 "Booty Bass" }
+    { 108 "Primus" }
+    { 109 "Porn Groove" }
+    { 110 "Satire" }
+    { 111 "Slow Jam" }
+    { 112 "Club" }
+    { 113 "Tango" }
+    { 114 "Samba" }
+    { 115 "Folklore" }
+    { 116 "Ballad" }
+    { 117 "Power Ballad" }
+    { 118 "Rhythmic Soul" }
+    { 119 "Freestyle" }
+    { 120 "Duet" }
+    { 121 "Punk Rock" }
+    { 122 "Drum Solo" }
+    { 123 "A capella" }
+    { 124 "Euro-House" }
+    { 125 "Dance Hall" }
+} ! end genre hashtable
+
 ! tuples
 
 TUPLE: header version flags size ;
 
 TUPLE: frame frame-id flags size data ;
 
-TUPLE: mp3v2-file header frames ;
+TUPLE: id3v2-info header frames ;
 
-TUPLE: mp3v1-file title artist album year comment genre ;
+TUPLE: id3-info title artist album year comment genre ;
 
-: <mp3v1-file> ( -- object ) mp3v1-file new ;
+: <id3-info> ( -- object ) id3-info new ;
 
-: <mp3v2-file> ( header frames -- object ) mp3v2-file boa ;
+: <id3v2-info> ( header frames -- object ) id3v2-info boa ;
 
 : <header> ( -- object ) header new ;
 
 : <frame> ( -- object ) frame new ;
 
-<PRIVATE
-
 ! utility words
 
 : id3v2? ( mmap -- ? )
@@ -59,10 +190,10 @@ TUPLE: mp3v1-file title artist album year comment genre ;
 : (read-frame) ( mmap -- frame )
     [ <frame> ] dip
     {
-        [ read-frame-id    ascii decode >>frame-id ]
+        [ read-frame-id    utf8 decode  >>frame-id ]
         [ read-frame-flags >byte-array  >>flags ]
         [ read-frame-size  >28bitword   >>size ]
-        [ read-frame-data  ascii decode >>data ]
+        [ read-frame-data  utf8 decode  >>data ]
     } cleave ;
 
 : read-frame ( mmap -- frame/f )
@@ -98,8 +229,20 @@ TUPLE: mp3v1-file title artist album year comment genre ;
 : drop-header ( mmap -- seq1 seq2 )
     dup 10 tail-slice swap ;
 
-: read-v2-tag-data ( seq -- mp3v2-file )
+: parse-frames ( id3v2-info -- id3-info )
-    drop-header read-v2-header swap read-frames <mp3v2-file> ;
+    [ <id3-info> ] dip frames>>
+    {
+        [ [ frame-id>> "TIT2" = ] find nip [ data>> >>title ] when* ]
+        [ [ frame-id>> "TALB" = ] find nip [ data>> >>album ] when* ]
+        [ [ frame-id>> "TPE1" = ] find nip [ data>> >>artist ] when* ]
+        [ [ frame-id>> "TCON" = ] find nip [ data>> [ [ digit? ] filter string>number ] keep swap [ genres at nip ] when*
+          >>genre ] when* ]
+        [ [ frame-id>> "COMM" = ] find nip [ data>> >>comment ] when* ]
+        [ [ frame-id>> "TYER" = ] find nip [ data>> >>year ] when* ]
+    } cleave ;
+
+: read-v2-tag-data ( seq -- id3-info )
+    drop-header read-v2-header swap read-frames <id3v2-info> parse-frames ;
     
 ! v1 information
 
@@ -125,14 +268,14 @@ TUPLE: mp3v1-file title artist album year comment genre ;
     [ 124 ] dip nth ;
 
 : (read-v1-tag-data) ( seq -- mp3-file )
-    [ <mp3v1-file> ] dip
+    [ <id3-info> ] dip
     {
-        [ read-title   ascii decode  filter-text-data >>title ]
+        [ read-title   utf8 decode  filter-text-data >>title   ]
-        [ read-artist  ascii decode  filter-text-data >>artist ]
+        [ read-artist  utf8 decode  filter-text-data >>artist  ]
-        [ read-album   ascii decode  filter-text-data >>album ]
+        [ read-album   utf8 decode  filter-text-data >>album   ]
-        [ read-year    ascii decode  filter-text-data >>year ]
+        [ read-year    utf8 decode  filter-text-data >>year    ]
-        [ read-comment ascii decode  filter-text-data >>comment ]
+        [ read-comment utf8 decode  filter-text-data >>comment ]
-        [ read-genre   >fixnum       >>genre ]
+        [ read-genre   >fixnum       genres at       >>genre ]
     } cleave ;
 
 : read-v1-tag-data ( seq -- mp3-file )
@@ -140,13 +283,13 @@ TUPLE: mp3v1-file title artist album year comment genre ;
 
 PRIVATE>
 
-! main stuff
+! public interface
 
 : file-id3-tags ( path -- object/f )
     [
         {
-            { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file )
+            { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 )
-            { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file )
+            { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info )
             [ drop f ] ! ( mmap -- f )
         } cond
     ] with-mapped-uchar-file ;

extra/literals/literals-docs.factor

@@ -1,19 +1,19 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax multiline ;
+USING: help.markup help.syntax kernel multiline ;
 IN: literals
 
 HELP: $
 { $syntax "$ word" }
 { $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
-{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." }
+{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
 { $examples
 
     { $example <"
 USING: kernel literals prettyprint ;
 IN: scratchpad
 
-<< : five 5 ; >>
+CONSTANT: five 5
 { $ five } .
     "> "{ 5 }" }
 
@@ -30,7 +30,7 @@ IN: scratchpad
 HELP: $[
 { $syntax "$[ code ]" }
 { $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
-{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." }
+{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
 { $examples
 
     { $example <"

extra/literals/literals-tests.factor

@@ -2,11 +2,12 @@ USING: kernel literals math tools.test ;
 IN: literals.tests
 
 <<
-: five 5 ;
-: seven-eleven 7 11 ;
 : six-six-six 6 6 6 ;
 >>
 
+: five 5 ;
+: seven-eleven 7 11 ;
+
 [ { 5 } ] [ { $ five } ] unit-test
 [ { 7 11 } ] [ { $ seven-eleven } ] unit-test
 [ { 6 6 6 } ] [ { $ six-six-six } ] unit-test

extra/literals/literals.factor

@@ -1,6 +1,6 @@
 ! (c) Joe Groff, see license for details
-USING: continuations kernel parser words quotations vectors ;
+USING: accessors continuations kernel parser words quotations vectors ;
 IN: literals
 
-: $ scan-word [ execute ] curry with-datastack >vector ; parsing
+: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing
 : $[ \ ] parse-until >quotation with-datastack >vector ; parsing

extra/math/derivatives/authors.txt

@@ -0,0 +1 @@
+Jason W. Merrill

extra/math/derivatives/derivatives-docs.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: math.derivatives
+
+ARTICLE: "math.derivatives" "Derivatives"
+"The " { $vocab-link "math.derivatives" } " vocabulary defines the derivative of many of the words in the " { $vocab-link "math" } " and " { $vocab-link "math.functions" } " vocabularies. The derivative for a word is given by a sequence of quotations stored in its " { $snippet "derivative" } " word property that give the partial derivative of the word with respect to each of its inputs."
+{ $see-also "math.derivatives.syntax" }
+;
+
+ABOUT: "math.derivatives"

extra/math/derivatives/derivatives.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.derivatives.syntax 
+    math.order math.parser summary accessors make combinators ;
+IN: math.derivatives
+
+ERROR: undefined-derivative point word ;
+M: undefined-derivative summary
+    [ dup "Derivative of " % word>> name>> % 
+    " is undefined at " % point>> # "." % ]
+    "" make ;
+
+DERIVATIVE: + [ 2drop ] [ 2drop ]
+DERIVATIVE: - [ 2drop ] [ 2drop neg ]
+DERIVATIVE: * [ nip * ] [ drop * ]
+DERIVATIVE: / [ nip / ] [ sq / neg * ]
+! Conditional checks if the epsilon-part of the exponent is 
+! 0 to avoid getting float answers for integer powers.
+DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ] 
+    [ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ]
+
+DERIVATIVE: abs 
+    [ 0 <=> 
+        { 
+            { +lt+ [ neg ] } 
+            { +eq+ [ 0 \ abs undefined-derivative ] } 
+            { +gt+ [ ] } 
+        } case
+    ]
+
+DERIVATIVE: sqrt [ sqrt 2 * / ]
+
+DERIVATIVE: exp [ exp * ]
+DERIVATIVE: log [ / ]
+
+DERIVATIVE: sin [ cos * ]
+DERIVATIVE: cos [ sin neg * ]
+DERIVATIVE: tan [ sec sq * ]
+
+DERIVATIVE: sinh [ cosh * ]
+DERIVATIVE: cosh [ sinh * ]
+DERIVATIVE: tanh [ sech sq * ]
+
+DERIVATIVE: asin [ sq neg 1 + sqrt / ]
+DERIVATIVE: acos [ sq neg 1 + sqrt neg / ]
+DERIVATIVE: atan [ sq 1 + / ]
+
+DERIVATIVE: asinh [ sq 1 + sqrt / ]
+DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ]
+DERIVATIVE: atanh [ sq neg 1 + / ]
+
+DERIVATIVE: neg [ drop neg ]
+DERIVATIVE: recip [ sq recip neg * ]

extra/math/derivatives/syntax/authors.txt

@@ -0,0 +1 @@
+Jason W. Merrill

extra/math/derivatives/syntax/syntax-docs.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: math.derivatives.syntax
+
+HELP: DERIVATIVE:
+{ $description "Defines the derivative of a word by setting its " { $snippet "derivative" } " word property.  Reads a word followed by " { $snippet "n" } " quotations, giving the " { $snippet "n" } " partial derivatives of the word with respect to each of its arguments successively.  Each quotation should take " { $snippet "n + 1" } " inputs, where the first input is an increment and the last " { $snippet "n" } " inputs are the point at which to evaluate the derivative.  The derivative should be a linear function of the increment, and should have the same number of outputs as the original word." }
+{ $examples 
+    { $unchecked-example "USING: math math.functions math.derivatives.syntax ;"
+    "DERIVATIVE: sin [ cos * ]"
+    "DERIVATIVE: * [ nip * ] [ drop * ]" "" }
+} ;
+
+ARTICLE: "math.derivatives.syntax" "Derivative Syntax"
+"The " { $vocab-link "math.derivatives.syntax" } " vocabulary provides the " { $link POSTPONE: DERIVATIVE: } " syntax for specifying the derivative of a word."
+;
+
+ABOUT: "math.derivatives.syntax"

extra/math/derivatives/syntax/syntax.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel parser words effects accessors sequences 
+    math.ranges ;
+    
+IN: math.derivatives.syntax
+
+: DERIVATIVE: scan-object dup stack-effect in>> length [1,b] 
+    [ drop scan-object ] map 
+    "derivative" set-word-prop ; parsing

extra/math/dual/authors.txt

@@ -0,0 +1 @@
+Jason W. Merrill

extra/math/dual/dual-docs.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel words math math.functions math.derivatives.syntax ;
+IN: math.dual
+
+HELP: <dual>
+{ $values
+    { "ordinary-part" real } { "epsilon-part" real }
+    { "dual" dual number }
+}
+{ $description "Creates a dual number from its ordinary and epsilon parts." } ;
+
+HELP: define-dual
+{ $values
+    { "word" word }
+}
+{ $description "Defines a word " { $snippet "d[word]" } " in the " { $vocab-link "math.dual" } " vocabulary that operates on dual numbers." }
+{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments.  This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ;
+
+{ define-dual dual-op POSTPONE: DERIVATIVE: } related-words
+
+HELP: dual
+{ $class-description "The class of dual numbers with non-zero epsilon part." } ;
+
+HELP: dual-op
+{ $values
+    { "word" word }
+}
+{ $description "Similar to " { $link execute } ", but promotes word to operate on duals." }
+{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } ". Once a derivative has been defined for a word, dual-op makes it easy to extend the definition to dual numbers." } 
+{ $examples 
+    { $unchecked-example "USING: math math.dual math.derivatives.syntax math.functions ;" 
+    "DERIVATIVE: sin [ cos * ]" 
+    "M: dual sin \\sin dual-op ;" "" }
+    { $unchecked-example "USING: math math.dual math.derivatives.syntax ;" 
+    "DERIVATIVE: * [ drop ] [ nip ]"
+    ": d* ( x y -- x*y ) \ * dual-op ;" "" }
+} ;
+
+HELP: unpack-dual
+{ $values
+    { "dual" dual }
+    { "ordinary-part" number } { "epsilon-part" number }
+}
+{ $description "Extracts the ordinary and epsilon part of a dual number." } ;
+
+ARTICLE: "math.dual" "Dual Numbers"
+"The " { $vocab-link "math.dual" } " vocabulary implements dual numbers, along with arithmetic methods for working with them. Many of the functions in " { $vocab-link "math.functions" } " are extended to work with dual numbers."
+$nl
+"Dual numbers are ordered pairs " { $snippet "<o,e>"} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "<o1,e1>*<o2,e2> = <o1*o2,e1*o2 + e2*o1>" } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f(<o1,e1>) = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "."
+;
+
+ABOUT: "math.dual"

extra/math/dual/dual-tests.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.dual kernel accessors math math.functions 
+    math.constants ;
+IN: math.dual.tests
+
+[ 0.0 1.0 ] [ 0 1 <dual> dsin unpack-dual ] unit-test
+[ 1.0 0.0 ] [ 0 1 <dual> dcos unpack-dual ] unit-test
+[ 3 5 ] [ 1 5 <dual> 2 d+ unpack-dual ] unit-test
+[ 0 -1 ] [ 1 5 <dual> 1 6 <dual> d- unpack-dual ] unit-test
+[ 2 1 ] [ 2 3 <dual> 1 -1 <dual> d* unpack-dual ] unit-test
+[ 1/2 -1/4 ] [ 2 1 <dual> 1 swap d/ unpack-dual ] unit-test
+[ 2 ] [ 1 1 <dual> 2 d^ epsilon-part>> ] unit-test
+[ 2.0 .25 ] [ 4 1 <dual> dsqrt unpack-dual ] unit-test
+[ 2 -1 ] [ -2 1 <dual> dabs unpack-dual ] unit-test
+[ -2 -1 ] [ 2 1 <dual> dneg unpack-dual ] unit-test

extra/math/dual/dual.factor

@@ -0,0 +1,83 @@
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.derivatives accessors
+    macros generic compiler.units words effects vocabs
+    sequences arrays assocs generalizations fry make
+    combinators.smart help help.markup ;
+
+IN: math.dual
+
+TUPLE: dual ordinary-part epsilon-part ;
+
+C: <dual> dual
+
+! Ordinary numbers implement the dual protocol by returning 
+! themselves as the ordinary part, and 0 as the epsilon part.
+M: number ordinary-part>> ;
+
+M: number epsilon-part>> drop 0 ;
+
+: unpack-dual ( dual -- ordinary-part epsilon-part )
+    [ ordinary-part>> ] [ epsilon-part>> ] bi ;
+
+<PRIVATE
+
+: input-length ( word -- n ) stack-effect in>> length ;
+
+MACRO: ordinary-op ( word -- o )
+    [ input-length ] keep
+    '[ [ ordinary-part>> ] _ napply _ execute ] ;
+
+! Takes N dual numbers <o1,e1> <o2,e2> ... <oN,eN> and weaves 
+! their ordinary and epsilon parts to produce
+! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN
+! This allows a set of partial derivatives each to be evaluated 
+! at the same point.
+MACRO: duals>nweave ( n -- )
+   dup dup dup
+   '[
+       [ [ epsilon-part>> ] _ napply ]
+       _ nkeep
+       [ ordinary-part>> ] _ napply
+       _ nweave
+    ] ;
+
+MACRO: chain-rule ( word -- e )
+    [ input-length '[ _ duals>nweave ] ]
+    [ "derivative" word-prop ]
+    [ input-length 1+ '[ _ nspread ] ]
+    tri
+    '[ [ @ _ @ ] sum-outputs ] ;
+
+: set-dual-help ( word dword -- ) 
+    [ swap
+        [ stack-effect [ in>> ] [ out>> ] bi append 
+            [ dual ] { } map>assoc { $values } prepend
+        ]
+        [ [ { $description } % "Version of " , 
+                   { $link } swap suffix , 
+                   " extended to work on dual numbers." , ] 
+            { } make
+        ]
+        bi* 2array
+    ] keep set-word-help ;
+
+PRIVATE>
+
+MACRO: dual-op ( word -- )
+    [ '[ _ ordinary-op ] ]
+    [ input-length '[ _ nkeep ] ]
+    [ '[ _ chain-rule ] ]
+    tri
+    '[ _ @ @ <dual> ] ;
+
+: define-dual ( word -- )
+    dup name>> "d" prepend "math.dual" create
+    [ [ stack-effect ] dip set-stack-effect ]
+    [ set-dual-help ]
+    [ swap '[ _ dual-op ] define ]
+    2tri ;
+
+! Specialize math functions to operate on dual numbers.
+[ all-words [ "derivative" word-prop ] filter
+    [ define-dual ] each ] with-compilation-unit

misc/fuel/README

@@ -111,6 +111,7 @@ beast.
     | C-cC-ev         | edit vocabulary (fuel-edit-vocabulary)                     |
     | C-cC-ew         | edit word (fuel-edit-word-at-point)                        |
     | C-cC-ed         | edit word's doc (C-u M-x fuel-edit-word-doc-at-point)      |
+    | C-cC-el         | load vocabs in USING: form                                 |
     |-----------------+------------------------------------------------------------|
     | C-cC-er         | eval region                                                |
     | C-M-r, C-cC-ee  | eval region, extending it to definition boundaries         |

misc/fuel/fuel-autodoc.el

@@ -32,6 +32,22 @@
   :type 'boolean)
 
 
+(defcustom fuel-autodoc-eval-using-form-p nil
+  "When enabled, automatically load vocabularies in USING: form
+to display autodoc messages.
+
+In order to show autodoc messages for words in a Factor buffer,
+the used vocabularies must be loaded in the Factor image. Setting
+this variable to `t' will do that automatically for you,
+asynchronously. That means that you'll be able to move around
+while the vocabs are being loaded, but no other FUEL
+functionality will be available until loading finishes (and it
+may take a while). Thus, this functionality is disabled by
+default. You can force loading the vocabs in a Factor buffer
+USING: form with \\[fuel-load-usings]."
+  :group 'fuel-autodoc
+  :type 'boolean)
+
 
 ;;; Eldoc function:
 
@@ -41,9 +57,10 @@
   (let ((word (or word (fuel-syntax-symbol-at-point)))
         (fuel-log--inhibit-p t))
     (when word
-      (let* ((cmd (if (fuel-syntax--in-using)
+      (let* ((usings (if fuel-autodoc-eval-using-form-p :usings t))
+             (cmd (if (fuel-syntax--in-using)
                       `(:fuel* (,word fuel-vocab-summary) :in t)
-                    `(:fuel* (((:quote ,word) synopsis :get)) :in)))
+                    `(:fuel* ((,word :usings fuel-word-synopsis)) t ,usings)))
              (ret (fuel-eval--send/wait cmd fuel-autodoc--timeout))
              (res (fuel-eval--retort-result ret)))
         (when (and ret (not (fuel-eval--retort-error ret)) (stringp res))

misc/fuel/fuel-eval.el

@@ -77,7 +77,7 @@
         (t (error "Invalid 'in' (%s)" in))))
 
 (defsubst factor--fuel-usings (usings)
-  (cond ((null usings) :usings)
+  (cond ((or (null usings) (eq usings :usings)) :usings)
         ((eq usings t) nil)
         ((listp usings) `(:array ,@usings))
         (t (error "Invalid 'usings' (%s)" usings))))

misc/fuel/fuel-mode.el

@@ -132,6 +132,18 @@ With prefix argument, ask for the file name."
   (let ((file (car (fuel-mode--read-file arg))))
     (when file (fuel-debug--uses-for-file file))))
 
+(defun fuel-load-usings ()
+  "Loads all vocabularies in the current buffer's USING: from.
+Useful to activate autodoc help messages in a vocabulary not yet
+loaded. See documentation for `fuel-autodoc-eval-using-form-p'
+for details."
+  (interactive)
+  (message "Loading all vocabularies in USING: form ...")
+  (let ((err (fuel-eval--retort-error
+              (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000))))
+    (message (if err "Warning: some vocabularies failed to load"
+               "All vocabularies loaded"))))
+
 
 ;;; Minor mode definition:
 
@@ -191,7 +203,8 @@ interacting with a factor listener is at your disposal.
 
 (fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point)
 (fuel-mode--key ?e ?e 'fuel-eval-extended-region)
-(fuel-mode--key ?e ?l 'fuel-run-file)
+(fuel-mode--key ?e ?k 'fuel-run-file)
+(fuel-mode--key ?e ?l 'fuel-load-usings)
 (fuel-mode--key ?e ?r 'fuel-eval-region)
 (fuel-mode--key ?e ?u 'fuel-update-usings)
 (fuel-mode--key ?e ?v 'fuel-edit-vocabulary)