diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index 81930cdf49..f8864351a4 100644 --- a/basis/calendar/format/format-tests.factor +++ b/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 + + diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 15a4cb8266..916d3499fe 100644 --- a/basis/calendar/format/format.factor +++ b/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 ; diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 512d26f4bf..1c6e7b796e 100644 --- a/basis/compiler/compiler-docs.factor +++ b/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" } "." -{ $subsection "compiler-usage" } +"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" } "." +$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" diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index b1bc9aa1a2..60141bc830 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/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 -db.private ; +io.encodings.string accessors shuffle io 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 -- ) -"resetting: " write dup . sqlite3_reset sqlite-check-result ; +: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; : sqlite-clear-bindings ( handle -- ) sqlite3_clear_bindings sqlite-check-result ; : sqlite-#columns ( query -- int ) sqlite3_column_count ; diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 5ad4b0c889..b6e756a3dd 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/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 insert-tuple f select-tuple 1 1 insert-tuple - f select-tuple + f f select-tuple hi drop-table foo drop-table ] with-db ] unit-test -[ ] [ - test.db [ - hi create-table - hi drop-table - ] with-db -] unit-test + +! Test SQLite triggers TUPLE: show id ; TUPLE: user username data ; @@ -142,12 +140,12 @@ show "SHOW" { } define-persistent watch "WATCH" { - { "user" "USER" TEXT +not-null+ - { +foreign-id+ user "USERNAME" } +user-assigned-id+ } - { "show" "SHOW" BIG-INTEGER +not-null+ - { +foreign-id+ show "ID" } +user-assigned-id+ } + { "user" "USER" TEXT +not-null+ +user-assigned-id+ + { +foreign-id+ user "USERNAME" } } + { "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+ + { +foreign-id+ show "ID" } } } define-persistent - + [ T{ user { username "littledan" } { data "foo" } } ] [ test.db [ user create-table @@ -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 diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index d006145ea8..19cfc5d0b7 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/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 ( 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"') - WHERE NEW.${foreign-table-id} IS NOT NULL + 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.${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"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + 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; 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"') - WHERE NEW.${foreign-table-id} IS NOT NULL + 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.${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"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; + 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; 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" [ - [ >reference-string ] keep - first2 [ db-table-name "foreign-table-name" set ] - [ "foreign-table-id" set ] bi* - create-sqlite-triggers - ] } + { "references" [ >reference-string ] } [ 2drop ] } case ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 219116aefd..9edd5bac69 100644 --- a/basis/db/tuples/tuples.factor +++ b/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 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>> [ ] cache [ bind-tuple ] keep execute-statement ; : delete-tuples ( tuple -- ) - dup dup class [ + dup + dup class ensure-defined-persistent + [ [ bind-tuple ] keep execute-statement ] with-disposal ; @@ -132,8 +149,8 @@ M: tuple >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 - [ f ] [ first ] if-empty ; + >query 1 >>limit [ tuple>> ] [ query>statement ] bi + do-select [ f ] [ first ] if-empty ; : count-tuples ( query/tuple -- n ) >query [ tuple>> ] [ ] bi do-count diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 79387f9820..fa717a70fa 100644 --- a/basis/editors/emacs/emacs.factor +++ b/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 , - os windows? [ "--no-wait" , ] unless - "+" swap number>string append , + { [ \ emacsclient-path get ] [ default-emacsclient ] } 0|| , + "--no-wait" , + 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 - diff --git a/basis/editors/emacs/windows/authors.txt b/basis/editors/emacs/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/editors/emacs/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor new file mode 100755 index 0000000000..e18c39ed60 --- /dev/null +++ b/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|| ; diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index ac21bb8f78..14877110d3 100644 --- a/basis/ftp/client/client.factor +++ b/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 ; diff --git a/basis/ftp/ftp.factor b/basis/ftp/ftp.factor index adf7d5b41b..eea98c0172 100644 --- a/basis/ftp/ftp.factor +++ b/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 -SINGLETON: passive +SYMBOLS: +active+ +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 diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor new file mode 100644 index 0000000000..d7d9d8384d --- /dev/null +++ b/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 + + [ start-server* ] + [ + sockets>> first addr>> port>> + + 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 diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 20a753785c..8438aae94e 100644 --- a/basis/ftp/server/server.factor +++ b/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 -io.encodings.8-bit io.encodings io.encodings.binary -io.encodings.utf8 io.files io.files.info io.directories -io.sockets kernel math.parser namespaces make sequences -ftp io.launcher.unix.parser unicode.case splitting -assocs classes io.servers.connection destructors calendar -io.timeouts io.streams.duplex threads continuations math -concurrency.promises byte-arrays io.backend tools.hexdump -io.streams.string math.bitwise tools.files io.pathnames ; +USING: accessors assocs byte-arrays calendar classes +combinators combinators.short-circuit concurrency.promises +continuations destructors ftp io io.backend io.directories +io.encodings io.encodings.8-bit io.encodings.binary +tools.files io.encodings.utf8 io.files io.files.info +io.pathnames io.launcher.unix.parser io.servers.connection +io.sockets io.streams.duplex io.streams.string io.timeouts +kernel make math math.bitwise math.parser namespaces sequences +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 ; - -: ( url -- ftp-client ) - ftp-client new - swap >>url ; - +SYMBOL: server SYMBOL: client -: ftp-server-directory ( -- str ) - \ ftp-server-directory get-global "resource:temp" or - normalize-path ; +TUPLE: ftp-server < threaded-server { serving-directory string } ; + +TUPLE: ftp-client user password extra-connection ; TUPLE: ftp-command raw tokenized ; - -: ( -- obj ) - ftp-command new ; +: ( str -- obj ) + dup \ DEBUG log-message + ftp-command new + over >>raw + swap tokenize-command >>tokenized ; TUPLE: ftp-get path ; - : ( path -- obj ) ftp-get new swap >>path ; TUPLE: ftp-put path ; - : ( path -- obj ) ftp-put new swap >>path ; TUPLE: ftp-list ; - C: ftp-list -: read-command ( -- ftp-command ) - readln - [ >>raw ] [ tokenize-command >>tokenized ] bi ; +TUPLE: ftp-disconnect ; +C: ftp-disconnect : (send-response) ( n string separator -- ) [ number>string write ] 2dip write ftp-send ; @@ -56,28 +50,42 @@ C: 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 - swap add-response-line swap >>n + swap add-response-line send-response ; -: ftp-error ( string -- ) - 500 "Unrecognized command: " rot append server-response ; +: serving? ( path -- ? ) + 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 : 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 ; - -: if-command-promise ( quot -- ) - [ client get command-promise>> ] dip - [ "Establish an active or passive connection first" ftp-error ] if* ; - -: handle-STOR ( obj -- ) - [ - tokenized>> second - [ [ ] dip fulfill ] if-command-promise - ] [ - 2drop - ] recover ; - -! EPRT |2|::1|62138| -! : handle-EPRT ( obj -- ) - ! tokenized>> second "|" split harvest ; + "UNIX Type: L8" 215 server-response ; : 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 service-command ( stream obj -- ) +M: ftp-list handle-passive-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 - finish-directory ; + ] with-output-stream finish-directory ; -: transfer-outgoing-file ( path -- ) - [ - 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 -- ) +M: ftp-get handle-passive-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 -- ) - [ - [ - |dispose - 30 seconds over set-timeout - accept drop &dispose - client get command-promise>> - 30 seconds ?promise-timeout - service-command - ] - [ client get f >>command-promise drop ] - [ drop ] cleanup - ] with-destructors ; +M: ftp-disconnect handle-passive-command ( stream obj -- ) + drop dispose ; + +: fulfill-client ( obj -- ) + client get extra-connection>> [ + fulfill + ] [ + drop + "Establish an active or passive connection first" ftp-error + ] if* ; + +: handle-STOR ( obj -- ) + tokenized>> second + dup can-serve-file? [ + fulfill-client + ] [ + drop + fulfill-client + ] if ; : handle-LIST ( obj -- ) - drop - [ [ ] dip fulfill ] if-command-promise ; - -: handle-SIZE ( obj -- ) - [ - [ 213 ] dip - tokenized>> second file-info size>> - number>string server-response + drop current-directory get + can-serve-directory? [ + fulfill-client ] [ - 2drop - 550 "Could not get file size" server-response - ] recover ; + fulfill-client + ] if ; + +: not-a-plain-file ( path -- ) + ": not a plain file." append ftp-error ; : handle-RETR ( obj -- ) - [ tokenized>> second swap fulfill ] - curry if-command-promise ; + tokenized>> second + dup can-serve-file? [ + fulfill-client + ] [ + not-a-plain-file + 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 ) + client get (>>extra-connection) random-local-server - client get >>command-promise drop [ [ passive-loop ] curry in-thread ] [ addr>> port>> ] bi ; : handle-PASV ( obj -- ) - drop client get passive >>mode drop - 221 + drop 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>> [ - "You already have a passive stream" ftp-error - ] [ - 229 - expect-connection number>string - "Entering Extended Passive Mode (|||" "|)" surround - server-response - ] if ; + client get f >>extra-connection drop + expect-connection number>string + "Entering Extended Passive Mode (|||" "|)" surround + 229 server-response ; -! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 -! : handle-LPRT ( obj -- ) tokenized>> "," split ; - -ERROR: not-a-directory ; -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 +: handle-MDTM ( obj -- ) + tokenized>> 1 swap ?nth [ + dup file-info dup directory? [ + drop not-a-plain-file ] [ - not-a-directory + nip + modified>> timestamp>mdtm + 213 server-response ] if ] [ - 2drop - 550 "Failed to change directory." server-response - ] recover ; + "" not-a-plain-file + ] if* ; -: unrecognized-command ( obj -- ) raw>> ftp-error ; +ERROR: not-a-directory ; +ERROR: no-directory-permissions ; -: handle-client-loop ( -- ) - readln - USE: prettyprint global [ dup . flush ] bind - [ >>raw ] - [ tokenize-command >>tokenized ] bi +: directory-change-success ( -- ) + "Directory successully changed." 250 server-response ; + +: directory-change-failed ( -- ) + "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" [ ] } - ! { "HELP" [ ] } - - ! { "SITE" [ ] } - ! { "NOOP" [ ] } - - ! { "EPRT" [ handle-EPRT ] } - ! { "LPRT" [ handle-LPRT ] } + { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] } + { "PWD" [ handle-PWD t ] } + { "TYPE" [ handle-TYPE t ] } + { "CWD" [ handle-CWD t ] } + { "PASV" [ handle-PASV t ] } { "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 ] [ ] 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 [ - host-name client set - send-banner handle-client-loop - ] with-directory + "New client" \ handle-client* DEBUG log-message + ftp-client new client set + [ server set ] [ serve-directory ] bi ] with-destructors ; -: ( port -- 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 -- ) start-server ; -: ftpd-main ( -- ) 2100 ftpd ; +: ftpd-main ( path -- ) 2100 ftpd ; MAIN: ftpd-main diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index ebc711d527..3fe09de263 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/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" } ; diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 39b5a13e30..36496ac5c4 100644 --- a/basis/help/handbook/handbook.factor +++ b/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" } } { "sets 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 "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 } } } diff --git a/basis/images/images.factor b/basis/images/images.factor index c2dc33608e..5ac0da7a28 100644 --- a/basis/images/images.factor +++ b/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 new ; inline @@ -63,4 +81,4 @@ M: image normalize-scan-line-order ; : normalize-image ( image -- image ) [ >byte-array ] change-bitmap normalize-component-order - normalize-scan-line-order ; + normalize-scan-line-order ; \ No newline at end of file diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 41031f8ac3..b56fb7b6a3 100755 --- a/basis/io/directories/search/search.factor +++ b/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 ; diff --git a/basis/io/encodings/korean/korean-docs.factor b/basis/io/encodings/korean/korean-docs.factor new file mode 100644 index 0000000000..2500e794a7 --- /dev/null +++ b/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" } ; diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor index cd98bb1eb0..a021cfce33 100644 --- a/basis/io/encodings/korean/korean.factor +++ b/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 diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 5dddca4f9d..72401004ae 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/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 ; diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index 2f38c39e02..7d2a6ee4f3 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/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 ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index bc90915213..589a50d2eb 100644 --- a/basis/io/servers/connection/connection.factor +++ b/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 diff --git a/basis/io/servers/packet/datagram.factor b/basis/io/servers/packet/packet.factor similarity index 83% rename from basis/io/servers/packet/datagram.factor rename to basis/io/servers/packet/packet.factor index c081dfb0fa..2a346b4d13 100644 --- a/basis/io/servers/packet/datagram.factor +++ b/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 ( 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 diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor index 07a84ec5c6..5406d8fcd0 100644 --- a/basis/logging/parser/parser.factor +++ b/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 ; diff --git a/basis/math/bits/authors.txt b/basis/math/bits/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/basis/math/bits/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/basis/math/bits/bits-docs.factor b/basis/math/bits/bits-docs.factor new file mode 100644 index 0000000000..6ae83f7af0 --- /dev/null +++ b/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 } +{ $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 } " or " { $link make-bits } "." } ; + +HELP: +{ $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 }" } +} ; diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor new file mode 100644 index 0000000000..0503d27f33 --- /dev/null +++ b/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 second ] unit-test +[ { t t t } ] [ BIN: 111111 3 >array ] unit-test +[ f ] [ BIN: 111101 3 second ] unit-test +[ { f f t } ] [ BIN: 111100 3 >array ] unit-test +[ 3 ] [ BIN: 111111 3 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 diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor new file mode 100644 index 0000000000..8920955df3 --- /dev/null +++ b/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 + +: make-bits ( number -- bits ) + dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ ] if ; inline + +M: bits length length>> ; + +M: bits nth-unsafe number>> swap bit? ; + +INSTANCE: bits immutable-sequence diff --git a/basis/math/bits/summary.txt b/basis/math/bits/summary.txt new file mode 100644 index 0000000000..265a7b8277 --- /dev/null +++ b/basis/math/bits/summary.txt @@ -0,0 +1 @@ +Virtual sequence for bits of an integer diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 339703c0a6..4f639c02a7 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/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 0 [ [ 1+ ] when ] reduce ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] (( byte -- table )) define-declared diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index ea3da55082..33a5d96fc4 100644 --- a/basis/math/functions/functions-docs.factor +++ b/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" } ":" diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 85b4d711ac..7e2ac0884c 100644 --- a/basis/math/functions/functions.factor +++ b/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? [ diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index c3b9797a36..5b314a3154 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/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:" diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5926f08d8c..db8abac441 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/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" diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 7508c37cac..8d882099de 100755 --- a/basis/tools/files/files.factor +++ b/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 -file-date file-time file-datetime uid gid user group link-target unix-datetime -directory-or-size ; +SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+ ++nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+ ++uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+ ++directory-or-size+ ; TUPLE: listing-tool path specs sort ; @@ -48,10 +49,10 @@ C: file-listing : ( 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>> ] } - { directory-or-size [ file-info>> dir-or-size ] } - { file-size [ file-info>> size>> number>string ] } - { file-date [ file-info>> modified>> listing-date ] } - { file-time [ file-info>> modified>> listing-time ] } - { file-datetime [ file-info>> modified>> timestamp>ymdhms ] } + { +file-name+ [ directory-entry>> name>> ] } + { +directory-or-size+ [ file-info>> dir-or-size ] } + { +file-size+ [ file-info>> size>> number>string ] } + { +file-date+ [ file-info>> modified>> listing-date ] } + { +file-time+ [ file-info>> modified>> listing-time ] } + { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] } [ unknown-file-spec ] } case ; @@ -85,22 +86,22 @@ HOOK: (directory.) os ( path -- lines ) : directory. ( path -- ) (directory.) simple-table. ; -SYMBOLS: device-name mount-point type -available-space free-space used-space total-space -percent-used percent-free ; +SYMBOLS: +device-name+ +mount-point+ +type+ ++available-space+ +free-space+ +used-space+ +total-space+ ++percent-used+ +percent-free+ ; : percent ( real -- integer ) 100 * >integer ; inline : file-system-spec ( file-system-info obj -- str ) { - { device-name [ device-name>> "" or ] } - { mount-point [ mount-point>> "" or ] } - { type [ type>> "" or ] } - { available-space [ available-space>> 0 or ] } - { free-space [ free-space>> 0 or ] } - { used-space [ used-space>> 0 or ] } - { total-space [ total-space>> 0 or ] } - { percent-used [ + { +device-name+ [ device-name>> "" or ] } + { +mount-point+ [ mount-point>> "" or ] } + { +type+ [ type>> "" or ] } + { +available-space+ [ available-space>> 0 or ] } + { +free-space+ [ free-space>> 0 or ] } + { +used-space+ [ used-space>> 0 or ] } + { +total-space+ [ total-space>> 0 or ] } + { +percent-used+ [ [ used-space>> ] [ total-space>> ] bi [ 0 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 - total-space percent-used mount-point + +device-name+ +available-space+ +free-space+ +used-space+ + +total-space+ +percent-used+ +mount-point+ } print-file-systems ; { diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index e63ab09076..90e91529a1 100755 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -47,21 +47,24 @@ IN: tools.files.unix M: unix (directory.) ( path -- lines ) - { 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 ] } - { nlinks [ file-info>> nlink>> number>string ] } - { user [ file-info>> uid>> user-name ] } - { group [ file-info>> gid>> group-name ] } - { uid [ file-info>> uid>> number>string ] } - { gid [ file-info>> gid>> number>string ] } + { +permissions+ [ file-info>> permissions-string ] } + { +nlinks+ [ file-info>> nlink>> number>string ] } + { +user+ [ file-info>> uid>> user-name ] } + { +group+ [ file-info>> gid>> group-name ] } + { +uid+ [ file-info>> uid>> number>string ] } + { +gid+ [ file-info>> gid>> number>string ] } [ call-next-method ] } case ; diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor index f321c2fc7f..874b2ef5c1 100755 --- a/basis/tools/files/windows/windows.factor +++ b/basis/tools/files/windows/windows.factor @@ -9,7 +9,7 @@ IN: tools.files.windows M: windows (directory.) ( entries -- lines ) - { file-datetime directory-or-size file-name } >>specs + { +file-datetime+ +directory-or-size+ +file-name+ } >>specs { { directory-entry>> name>> <=> } } >>sort list-files ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 0469f3564a..32cab65904 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/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:" diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index f5ecf5add1..8368afeb19 100644 --- a/core/compiler/errors/errors-docs.factor +++ b/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:" -{ $subsection compiler-errors } -"These notifications can be viewed later:" +"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." +$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 } diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index a4f261391a..f5ad6e533b 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/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 } " and " { $link } " 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: { $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 } diff --git a/core/io/pathnames/pathnames-tests.factor b/core/io/pathnames/pathnames-tests.factor index 41498fa15a..c3e419e60d 100644 --- a/core/io/pathnames/pathnames-tests.factor +++ b/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 diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 96ac872826..eba3e6a19f 100644 --- a/core/io/pathnames/pathnames.factor +++ b/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 ; diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index ce3b5ea024..527da053fb 100644 --- a/core/vocabs/loader/loader-docs.factor +++ b/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 } diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index c340554119..bf8aef3a07 100644 --- a/extra/annotations/annotations-docs.factor +++ b/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 ] - [ [ \ $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 ] - [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ] - [ 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 ] - + [ [ \ $annotation swap 2array 1array ] [ comment-word set-word-help ] bi ] + [ [ \ $annotation-usage swap 2array 1array ] [ comment-usage-word set-word-help ] bi ] + [ [ \ $annotation-usage. swap 2array 1array ] [ comment-usage.-word set-word-help ] bi ] [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ] } cleave ] each diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor index e292981876..286a313fda 100644 --- a/extra/crypto/passwd-md5/passwd-md5.factor +++ b/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 concat ] keep head-slice append - password [ length ] [ first ] bi - '[ [ CHAR: \0 _ ? , ] each-bit ] "" make append + password [ length make-bits ] [ first ] bi + '[ CHAR: \0 _ ? ] "" map-as append md5 checksum-bytes ] | 1000 [ "" swap diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 2bf8f1b98d..403708e880 100644 --- a/extra/fuel/fuel.factor +++ b/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 ; diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 55183734b3..64d77566b5 100644 --- a/extra/fuel/help/help.factor +++ b/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 diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index da69c2ced3..a54bba1629 100644 --- a/extra/id3/id3-docs.factor +++ b/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 diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index fdbaf69f03..bcdc312440 100644 --- a/extra/id3/id3-tests.factor +++ b/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 } } - { frames - { - T{ frame - { frame-id "COMM" } - { flags B{ 0 0 } } - { size 19 } - { data "eng, AG# 08E1C12E" } - } - 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�}`�#��K�H�*(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{ id3-info + { title "BLAH" } + { artist "ARTIST" } + { album "ALBUM" } + { year "2009" } + { comment "COMMENT" } + { genre "Bluegrass" } + } +] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test [ - T{ mp3v2-file - { header - T{ header { version t } { flags 0 } { size 1405 } } + T{ id3-info + { title "Anthem of the Trinity" } + { 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 - { title - "BLAH" - } - { artist - "ARTIST" - } - { album - "ALBUM" - } - { year "2009" } - { comment - "COMMENT" - } - { genre 89 } - } -] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test + T{ id3-info + { title "Stormy Weather" } + { artist "Frank Sinatra" } + { album "Night and Day Frank Sinatra" } + { comment "eng, AG# 08E1C12E" } + { genre "Big Band" } + } +] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 5b0d3f373e..f2bbd08996 100644 --- a/extra/id3/id3.factor +++ b/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 + ( -- object ) mp3v1-file new ; +: ( -- object ) id3-info new ; -: ( header frames -- object ) mp3v2-file boa ; +: ( header frames -- object ) id3v2-info boa ; :
( -- object ) header new ; : ( -- object ) frame new ; - ] 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,9 +229,21 @@ 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 ) - drop-header read-v2-header swap read-frames ; +: parse-frames ( id3v2-info -- 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 parse-frames ; + ! v1 information : skip-to-v1-data ( seq -- seq ) @@ -125,14 +268,14 @@ TUPLE: mp3v1-file title artist album year comment genre ; [ 124 ] dip nth ; : (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip + [ ] dip { - [ read-title ascii decode filter-text-data >>title ] - [ read-artist ascii decode filter-text-data >>artist ] - [ read-album ascii decode filter-text-data >>album ] - [ read-year ascii decode filter-text-data >>year ] - [ read-comment ascii decode filter-text-data >>comment ] - [ read-genre >fixnum >>genre ] + [ read-title utf8 decode filter-text-data >>title ] + [ read-artist utf8 decode filter-text-data >>artist ] + [ read-album utf8 decode filter-text-data >>album ] + [ read-year utf8 decode filter-text-data >>year ] + [ read-comment utf8 decode filter-text-data >>comment ] + [ 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 id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) + { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 ) + { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info ) [ drop f ] ! ( mmap -- f ) } cond ] with-mapped-uchar-file ; diff --git a/extra/literals/literals-docs.factor b/extra/literals/literals-docs.factor index ae25c75495..6525264f6a 100644 --- a/extra/literals/literals-docs.factor +++ b/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 <" diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index 34ea4d6415..0e933d5209 100644 --- a/extra/literals/literals-tests.factor +++ b/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 diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index 6df51a35ef..d3cfcaae23 100644 --- a/extra/literals/literals.factor +++ b/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 diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/derivatives/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor new file mode 100644 index 0000000000..4905f260bc --- /dev/null +++ b/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" diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor new file mode 100644 index 0000000000..c6a9d1a357 --- /dev/null +++ b/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 * ] diff --git a/extra/math/derivatives/syntax/authors.txt b/extra/math/derivatives/syntax/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/derivatives/syntax/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/derivatives/syntax/syntax-docs.factor b/extra/math/derivatives/syntax/syntax-docs.factor new file mode 100644 index 0000000000..2273e7b83c --- /dev/null +++ b/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" diff --git a/extra/math/derivatives/syntax/syntax.factor b/extra/math/derivatives/syntax/syntax.factor new file mode 100644 index 0000000000..02b0608ed8 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/extra/math/dual/authors.txt b/extra/math/dual/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/dual/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor new file mode 100644 index 0000000000..67b3d6ae97 --- /dev/null +++ b/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: +{ $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 ""} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "* = " } ". 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() = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "." +; + +ABOUT: "math.dual" diff --git a/extra/math/dual/dual-tests.factor b/extra/math/dual/dual-tests.factor new file mode 100644 index 0000000000..dbafe74d6a --- /dev/null +++ b/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 dsin unpack-dual ] unit-test +[ 1.0 0.0 ] [ 0 1 dcos unpack-dual ] unit-test +[ 3 5 ] [ 1 5 2 d+ unpack-dual ] unit-test +[ 0 -1 ] [ 1 5 1 6 d- unpack-dual ] unit-test +[ 2 1 ] [ 2 3 1 -1 d* unpack-dual ] unit-test +[ 1/2 -1/4 ] [ 2 1 1 swap d/ unpack-dual ] unit-test +[ 2 ] [ 1 1 2 d^ epsilon-part>> ] unit-test +[ 2.0 .25 ] [ 4 1 dsqrt unpack-dual ] unit-test +[ 2 -1 ] [ -2 1 dabs unpack-dual ] unit-test +[ -2 -1 ] [ 2 1 dneg unpack-dual ] unit-test \ No newline at end of file diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor new file mode 100644 index 0000000000..3e0e5437b4 --- /dev/null +++ b/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 + +! 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 ; + +> length ; + +MACRO: ordinary-op ( word -- o ) + [ input-length ] keep + '[ [ ordinary-part>> ] _ napply _ execute ] ; + +! Takes N dual numbers ... 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 + '[ _ @ @ ] ; + +: 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 \ No newline at end of file diff --git a/misc/fuel/README b/misc/fuel/README index d712560b03..79b8f49f9a 100644 --- a/misc/fuel/README +++ b/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 | diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index 76919702bb..d02e4fcfb9 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/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)) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 9e8210a3e3..985722854f 100644 --- a/misc/fuel/fuel-eval.el +++ b/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)))) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 504308fccd..c4f08f3c62 100644 --- a/misc/fuel/fuel-mode.el +++ b/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)