diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 17294aed87..abce91f56f 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -29,7 +29,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; writer>> swap "writing" set-word-prop ; : reader-word ( class name vocab -- word ) - [ "-" swap 3append ] dip create ; + [ "-" glue ] dip create ; : writer-word ( class name vocab -- word ) [ [ swap "set-" % % "-" % % ] "" make ] dip create ; diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 4e79c4cd2d..b715223445 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -21,7 +21,7 @@ IN: compiler.tree.builder : build-tree-with ( in-stack quot -- nodes out-stack ) #! Not safe to call from inference transforms. [ - [ >vector meta-d set ] + [ >vector \ meta-d set ] [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder nip unclip-last in-d>> ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 83a4a7aef7..3a94029756 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -20,6 +20,10 @@ SYMBOL: node-count : count-nodes ( nodes -- ) 0 swap [ drop 1+ ] each-node node-count set ; +! We try not to inline the same word too many times, to avoid +! combinatorial explosion +SYMBOL: inlining-count + ! Splicing nodes GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) @@ -120,17 +124,25 @@ DEFER: (flat-length) bi and ] contains? ; +: node-count-bias ( -- n ) + 45 node-count get [-] 8 /i ; + +: body-length-bias ( word -- n ) + [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi * + 24 swap [-] 4 /i ; + : inlining-rank ( #call word -- n ) [ classes-known? 2 0 ? ] [ { - [ drop node-count get 45 swap [-] 8 /i ] - [ flat-length 24 swap [-] 4 /i ] + [ body-length-bias ] [ "default" word-prop -4 0 ? ] [ "specializer" word-prop 1 0 ? ] [ method-body? 1 0 ? ] } cleave - ] bi* + + + + + ; + node-count-bias + loop-nesting get 0 or 2 * + ] bi* + + + + + + ; : should-inline? ( #call word -- ? ) dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ; @@ -138,12 +150,12 @@ DEFER: (flat-length) SYMBOL: history : remember-inlining ( word -- ) - history [ swap suffix ] change ; + [ [ 1 ] dip inlining-count get at+ ] + [ history [ swap suffix ] change ] + bi ; : inline-word-def ( #call word quot -- ? ) - over history get memq? [ - 3drop f - ] [ + over history get memq? [ 3drop f ] [ [ swap remember-inlining dupd splicing-nodes >>body diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor index 9e4d99e462..d676102bde 100644 --- a/basis/compiler/tree/propagation/nodes/nodes.factor +++ b/basis/compiler/tree/propagation/nodes/nodes.factor @@ -6,6 +6,8 @@ compiler.tree.propagation.copy compiler.tree.propagation.info ; IN: compiler.tree.propagation.nodes +SYMBOL: loop-nesting + GENERIC: propagate-before ( node -- ) GENERIC: propagate-after ( node -- ) diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index b9822d2c6b..2a9825e3f1 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -19,5 +19,6 @@ IN: compiler.tree.propagation H{ } clone copies set H{ } clone 1array value-infos set H{ } clone 1array constraints set + H{ } clone inlining-count set dup count-nodes dup (propagate) ; diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 7f10f87016..ff9f262d28 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive M: #recursive propagate-around ( #recursive -- ) constraints [ H{ } clone suffix ] change [ + loop-nesting inc + constraints [ but-last H{ } clone suffix ] change child>> @@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- ) [ first propagate-recursive-phi ] [ (propagate) ] tri + + loop-nesting dec ] until-fixed-point ; : recursive-phi-infos ( node -- infos ) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 57a16fc8ef..90a875b8ff 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -266,8 +266,8 @@ M: postgresql-db persistent-table ( -- hashtable ) ERROR: no-compound-found string object ; M: postgresql-db compound ( string object -- string' ) over { - { "default" [ first number>string join-space ] } - { "varchar" [ first number>string paren append ] } + { "default" [ first number>string " " glue ] } + { "varchar" [ first number>string "(" ")" surround append ] } { "references" [ >reference-string ] } [ drop no-compound-found ] } case ; diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index b181aab23b..a96398ff2c 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -162,22 +162,19 @@ M: db ( tuple class -- statement ) where-clause ] query-make ; -: splice ( string1 string2 string3 -- string ) - swap 3append ; - : do-group ( tuple groups -- ) dup string? [ 1array ] when - [ ", " join " group by " splice ] curry change-sql drop ; + [ ", " join " group by " glue ] curry change-sql drop ; : do-order ( tuple order -- ) dup string? [ 1array ] when - [ ", " join " order by " splice ] curry change-sql drop ; + [ ", " join " order by " glue ] curry change-sql drop ; : do-offset ( tuple n -- ) - [ number>string " offset " splice ] curry change-sql drop ; + [ number>string " offset " glue ] curry change-sql drop ; : do-limit ( tuple n -- ) - [ number>string " limit " splice ] curry change-sql drop ; + [ number>string " limit " glue ] curry change-sql drop ; : make-query* ( tuple query -- tuple' ) dupd diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index c22bb3a2d8..4e96fb5a4d 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -308,7 +308,7 @@ M: sqlite-db persistent-table ( -- assoc ) M: sqlite-db compound ( string seq -- new-string ) over { - { "default" [ first number>string join-space ] } + { "default" [ first number>string " " glue ] } { "references" [ [ >reference-string ] keep first2 [ "foreign-table" set ] diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index f1a6ba6c6c..bd0b443fbe 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -147,12 +147,6 @@ HELP: get-slot-named { "value" "the value stored in the slot" } } { $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ; -HELP: join-space -{ $values - { "string1" string } { "string2" string } - { "new-string" null } } -{ $description "" } ; - HELP: literal-bind { $description "" } ; diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 6a889689ce..da9fe39b80 100644 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -158,12 +158,6 @@ ERROR: no-sql-type type ; modifiers>> [ lookup-modifier ] map " " join [ "" ] [ " " prepend ] if-empty ; -: join-space ( string1 string2 -- new-string ) - " " swap 3append ; - -: paren ( string -- new-string ) - "(" swap ")" 3append ; - HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) @@ -171,7 +165,7 @@ ERROR: no-column column ; : >reference-string ( string pair -- string ) first2 - [ [ unparse join-space ] [ db-columns ] bi ] dip + [ [ unparse " " glue ] [ db-columns ] bi ] dip swap [ column-name>> = ] with find nip [ no-column ] unless* - column-name>> paren append ; + column-name>> "(" ")" surround append ; diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor index aa5c5ef2a1..10152f53d5 100644 --- a/basis/editors/scite/scite.factor +++ b/basis/editors/scite/scite.factor @@ -14,7 +14,10 @@ IN: editors.scite : scite-path ( -- path ) \ scite-path get-global [ - program-files "wscite\\SciTE.exe" append-path + program-files "ScITE Source Code Editor\\SciTE.exe" append-path + dup exists? [ + drop program-files "wscite\\SciTE.exe" append-path + ] unless ] unless* ; : scite-command ( file line -- cmd ) diff --git a/basis/environment/environment.factor b/basis/environment/environment.factor index d6ce34dbcf..e60a52c995 100644 --- a/basis/environment/environment.factor +++ b/basis/environment/environment.factor @@ -18,7 +18,7 @@ HOOK: (set-os-envs) os ( seq -- ) (os-envs) [ "=" split1 ] H{ } map>assoc ; : set-os-envs ( assoc -- ) - [ "=" swap 3append ] { } assoc>map (set-os-envs) ; + [ "=" glue ] { } assoc>map (set-os-envs) ; { { [ os unix? ] [ "environment.unix" require ] } diff --git a/extra/ftp/client/authors.txt b/basis/ftp/client/authors.txt similarity index 100% rename from extra/ftp/client/authors.txt rename to basis/ftp/client/authors.txt diff --git a/extra/ftp/client/client.factor b/basis/ftp/client/client.factor similarity index 100% rename from extra/ftp/client/client.factor rename to basis/ftp/client/client.factor diff --git a/extra/ftp/client/listing-parser/authors.txt b/basis/ftp/client/listing-parser/authors.txt similarity index 100% rename from extra/ftp/client/listing-parser/authors.txt rename to basis/ftp/client/listing-parser/authors.txt diff --git a/extra/ftp/client/listing-parser/listing-parser.factor b/basis/ftp/client/listing-parser/listing-parser.factor similarity index 100% rename from extra/ftp/client/listing-parser/listing-parser.factor rename to basis/ftp/client/listing-parser/listing-parser.factor diff --git a/extra/ftp/client/tags.txt b/basis/ftp/client/tags.txt similarity index 100% rename from extra/ftp/client/tags.txt rename to basis/ftp/client/tags.txt diff --git a/extra/ftp/ftp.factor b/basis/ftp/ftp.factor similarity index 100% rename from extra/ftp/ftp.factor rename to basis/ftp/ftp.factor diff --git a/extra/ftp/server/server.factor b/basis/ftp/server/server.factor similarity index 98% rename from extra/ftp/server/server.factor rename to basis/ftp/server/server.factor index 342c6a3c95..b0ec340202 100644 --- a/extra/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -7,8 +7,7 @@ namespaces make sequences ftp io.unix.launcher.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 sequences.lib tools.hexdump tools.files -io.streams.string ; +io.backend tools.hexdump tools.files io.streams.string ; IN: ftp.server TUPLE: ftp-client url mode state command-promise user password ; @@ -231,7 +230,7 @@ M: ftp-put service-command ( stream obj -- ) expect-connection [ "Entering Passive Mode (127,0,0,1," % - port>bytes [ number>string ] bi@ "," splice % + port>bytes [ number>string ] bi@ "," glue % ")" % ] "" make 227 swap server-response ; diff --git a/extra/ftp/server/tags.txt b/basis/ftp/server/tags.txt similarity index 100% rename from extra/ftp/server/tags.txt rename to basis/ftp/server/tags.txt diff --git a/extra/ftp/tags.txt b/basis/ftp/tags.txt similarity index 100% rename from extra/ftp/tags.txt rename to basis/ftp/tags.txt diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index d5ac3b6878..7126806c3d 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -17,7 +17,7 @@ IN: functors scan-param parsed scan { { ";" [ tuple parsed f parsed ] } - { "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] } + { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] } [ [ tuple parsed ] dip [ parse-slot-name [ parse-tuple-slots ] when ] { } diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index f2b71fb89f..7f71a131ed 100644 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -7,7 +7,7 @@ http.server.redirection http.server.remapping ; IN: furnace.utilities : word>string ( word -- string ) - [ vocabulary>> ] [ name>> ] bi ":" swap 3append ; + [ vocabulary>> ] [ name>> ] bi ":" glue ; : words>strings ( seq -- seq' ) [ word>string ] map ; diff --git a/basis/http/http.factor b/basis/http/http.factor index c90a1872ce..d006c86462 100644 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -111,7 +111,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s { [ dup real? ] [ number>string ] } [ ] } cond - [ check-cookie-string ] bi@ "=" swap 3append , + [ check-cookie-string ] bi@ "=" glue , ] } case ; diff --git a/basis/interpolate/interpolate-tests.factor b/basis/interpolate/interpolate-tests.factor index 005ae87746..c15debd9b5 100644 --- a/basis/interpolate/interpolate-tests.factor +++ b/basis/interpolate/interpolate-tests.factor @@ -1,4 +1,22 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test interpolate ; +USING: interpolate io.streams.string namespaces tools.test locals ; IN: interpolate.tests + +[ "Hello, Jane." ] [ + "Jane" "name" set + [ "Hello, ${name}." interpolate ] with-string-writer +] unit-test + +[ "Sup Dawg, we heard you liked rims, so we put rims on your rims so you can roll while you roll." ] [ + "Dawg" "name" set + "rims" "noun" set + "roll" "verb" set + [ "Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your ${noun} so you can ${verb} while you ${verb}." interpolate ] with-string-writer +] unit-test + +[ "Oops, I accidentally the whole economy..." ] [ + [let | noun [ "economy" ] | + [ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer + ] +] unit-test diff --git a/basis/interpolate/interpolate.factor b/basis/interpolate/interpolate.factor index 27f0756f1f..5e4805a8ac 100644 --- a/basis/interpolate/interpolate.factor +++ b/basis/interpolate/interpolate.factor @@ -1,21 +1,40 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel macros make multiline namespaces parser -peg.ebnf present sequences strings ; +present sequences strings splitting fry accessors ; IN: interpolate -MACRO: interpolate ( string -- ) -[EBNF -var = "${" [^}]+ "}" => [[ second >string [ get present write ] curry ]] -text = [^$]+ => [[ >string [ write ] curry ]] -interpolate = (var|text)* => [[ [ ] join ]] -EBNF] ; +TUPLE: interpolate-var name ; -EBNF: interpolate-locals -var = "${" [^}]+ "}" => [[ [ second >string search , [ present write ] % ] [ ] make ]] -text = [^$]+ => [[ [ >string , [ write ] % ] [ ] make ]] -interpolate = (var|text)* => [[ [ ] join ]] -;EBNF +: (parse-interpolate) ( string -- ) + [ + "${" split1-slice [ >string , ] [ + [ + "}" split1-slice + [ >string interpolate-var boa , ] + [ (parse-interpolate) ] bi* + ] when* + ] bi* + ] unless-empty ; + +: parse-interpolate ( string -- seq ) + [ (parse-interpolate) ] { } make ; + +MACRO: interpolate ( string -- ) + parse-interpolate [ + dup interpolate-var? + [ name>> '[ _ get present write ] ] + [ '[ _ write ] ] + if + ] map [ ] join ; + +: interpolate-locals ( string -- quot ) + parse-interpolate [ + dup interpolate-var? + [ name>> search '[ _ present write ] ] + [ '[ _ write ] ] + if + ] map [ ] join ; : I[ "]I" parse-multiline-string interpolate-locals parsed \ call parsed ; parsing diff --git a/extra/io/files/unique/backend/backend.factor b/basis/io/files/unique/backend/backend.factor similarity index 100% rename from extra/io/files/unique/backend/backend.factor rename to basis/io/files/unique/backend/backend.factor diff --git a/extra/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor similarity index 100% rename from extra/io/files/unique/unique-docs.factor rename to basis/io/files/unique/unique-docs.factor diff --git a/extra/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor similarity index 100% rename from extra/io/files/unique/unique-tests.factor rename to basis/io/files/unique/unique-tests.factor diff --git a/extra/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor similarity index 87% rename from extra/io/files/unique/unique.factor rename to basis/io/files/unique/unique.factor index 3a6c556846..ec89517bbc 100644 --- a/extra/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.bitwise combinators.lib math.parser -random sequences sequences.lib continuations namespaces +USING: kernel math math.bitwise math.parser +random sequences continuations namespaces io.files io arrays io.files.unique.backend system combinators vocabs.loader fry ; IN: io.files.unique @@ -29,7 +29,7 @@ PRIVATE> : make-unique-file ( prefix suffix -- path ) temporary-path -rot [ - unique-length get random-name swap 3append append-path + unique-length get random-name glue append-path dup (make-unique-file) ] 3curry unique-retries get retry ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 6c7ff7e0f1..2d990e6483 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -79,7 +79,7 @@ M: threaded-server handle-client* handler>> call ; \ handle-client ERROR add-error-logging : thread-name ( server-name addrspec -- string ) - unparse-short " connection from " swap 3append ; + unparse-short " connection from " glue ; : accept-connection ( threaded-server -- ) [ accept ] [ addr>> ] bi diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index ce7c4f6ddd..fbfae333c0 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -115,7 +115,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ; : pad-inet6 ( string1 string2 -- seq ) 2dup [ length ] bi@ + 8 swap - dup 0 < [ "More than 8 components" throw ] when - swap 3append ; + glue ; : inet6-bytes ( seq -- bytes ) [ 2 >be ] { } map-as concat >byte-array ; diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor index c200331db5..23717b41a4 100644 --- a/basis/io/unix/files/netbsd/netbsd.factor +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix combinators system io.backend accessors alien.c-types io.encodings.utf8 alien.strings unix.types io.unix.files io.files unix.statvfs.netbsd unix.getfsstat.netbsd -grouping sequences ; +grouping sequences io.encodings.utf8 ; IN: io.unix.files.netbsd TUPLE: netbsd-file-system-info < unix-file-system-info @@ -40,13 +40,13 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf [ statvfs-f_namemax >>name-max ] [ statvfs-f_owner >>owner ] ! [ statvfs-f_spare >>spare ] - [ statvfs-f_fstypename alien>native-string >>type ] - [ statvfs-f_mntonname alien>native-string >>mount-point ] - [ statvfs-f_mntfromname alien>native-string >>device-name ] + [ statvfs-f_fstypename utf8 alien>string >>type ] + [ statvfs-f_mntonname utf8 alien>string >>mount-point ] + [ statvfs-f_mntfromname utf8 alien>string >>device-name ] } cleave ; M: netbsd file-systems ( -- array ) f 0 0 getvfsstat dup io-error "statvfs" dup dup length 0 getvfsstat io-error "statvfs" heap-size group - [ statvfs-f_mntonname alien>native-string file-system-info ] map ; + [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ; diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor index 7a1cac3ff1..c81da60e12 100644 --- a/basis/io/unix/launcher/launcher.factor +++ b/basis/io/unix/launcher/launcher.factor @@ -16,7 +16,7 @@ USE: unix command>> dup string? [ tokenize-command ] when ; : assoc>env ( assoc -- env ) - [ "=" swap 3append ] { } assoc>map ; + [ "=" glue ] { } assoc>map ; : setup-priority ( process -- process ) dup priority>> [ diff --git a/basis/io/windows/mmap/mmap-tests.factor b/basis/io/windows/mmap/mmap-tests.factor deleted file mode 100644 index a8430108e8..0000000000 --- a/basis/io/windows/mmap/mmap-tests.factor +++ /dev/null @@ -1,8 +0,0 @@ -USING: io io.mmap io.files kernel tools.test continuations -sequences io.encodings.ascii accessors ; -IN: io.windows.mmap.tests - -[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test -[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test -[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test -[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test diff --git a/extra/math/combinatorics/authors.txt b/basis/math/combinatorics/authors.txt similarity index 100% rename from extra/math/combinatorics/authors.txt rename to basis/math/combinatorics/authors.txt diff --git a/extra/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor similarity index 100% rename from extra/math/combinatorics/combinatorics-docs.factor rename to basis/math/combinatorics/combinatorics-docs.factor diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor similarity index 100% rename from extra/math/combinatorics/combinatorics-tests.factor rename to basis/math/combinatorics/combinatorics-tests.factor diff --git a/extra/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor similarity index 100% rename from extra/math/combinatorics/combinatorics.factor rename to basis/math/combinatorics/combinatorics.factor diff --git a/extra/math/combinatorics/summary.txt b/basis/math/combinatorics/summary.txt similarity index 100% rename from extra/math/combinatorics/summary.txt rename to basis/math/combinatorics/summary.txt diff --git a/extra/math/polynomials/authors.txt b/basis/math/polynomials/authors.txt similarity index 100% rename from extra/math/polynomials/authors.txt rename to basis/math/polynomials/authors.txt diff --git a/extra/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor similarity index 100% rename from extra/math/polynomials/polynomials-docs.factor rename to basis/math/polynomials/polynomials-docs.factor diff --git a/extra/math/polynomials/polynomials-tests.factor b/basis/math/polynomials/polynomials-tests.factor similarity index 100% rename from extra/math/polynomials/polynomials-tests.factor rename to basis/math/polynomials/polynomials-tests.factor diff --git a/extra/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor similarity index 100% rename from extra/math/polynomials/polynomials.factor rename to basis/math/polynomials/polynomials.factor diff --git a/extra/math/polynomials/summary.txt b/basis/math/polynomials/summary.txt similarity index 100% rename from extra/math/polynomials/summary.txt rename to basis/math/polynomials/summary.txt diff --git a/extra/math/quaternions/authors.txt b/basis/math/quaternions/authors.txt similarity index 100% rename from extra/math/quaternions/authors.txt rename to basis/math/quaternions/authors.txt diff --git a/extra/math/quaternions/quaternions-docs.factor b/basis/math/quaternions/quaternions-docs.factor similarity index 100% rename from extra/math/quaternions/quaternions-docs.factor rename to basis/math/quaternions/quaternions-docs.factor diff --git a/extra/math/quaternions/quaternions-tests.factor b/basis/math/quaternions/quaternions-tests.factor similarity index 100% rename from extra/math/quaternions/quaternions-tests.factor rename to basis/math/quaternions/quaternions-tests.factor diff --git a/extra/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor similarity index 100% rename from extra/math/quaternions/quaternions.factor rename to basis/math/quaternions/quaternions.factor diff --git a/extra/math/quaternions/summary.txt b/basis/math/quaternions/summary.txt similarity index 100% rename from extra/math/quaternions/summary.txt rename to basis/math/quaternions/summary.txt diff --git a/extra/math/statistics/authors.txt b/basis/math/statistics/authors.txt similarity index 100% rename from extra/math/statistics/authors.txt rename to basis/math/statistics/authors.txt diff --git a/extra/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor similarity index 84% rename from extra/math/statistics/statistics-docs.factor rename to basis/math/statistics/statistics-docs.factor index 695834b554..7a7eb70dd2 100644 --- a/extra/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -3,13 +3,14 @@ IN: math.statistics HELP: geometric-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } -{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } +{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } -{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } +{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } +{ $notes "Positive reals only." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; @@ -36,21 +37,21 @@ HELP: range HELP: std { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." } +{ $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" } { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; HELP: ste { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } - { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } + { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } { $examples { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" } { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ; HELP: var { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } +{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } { $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" } diff --git a/extra/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor similarity index 100% rename from extra/math/statistics/statistics-tests.factor rename to basis/math/statistics/statistics-tests.factor diff --git a/extra/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor similarity index 79% rename from extra/math/statistics/statistics.factor rename to basis/math/statistics/statistics.factor index 7568af5294..d2494ee32a 100644 --- a/extra/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -5,20 +5,15 @@ USING: arrays combinators kernel math math.analysis math.functions sequences IN: math.statistics : mean ( seq -- n ) - #! arithmetic mean, sum divided by length [ sum ] [ length ] bi / ; : geometric-mean ( seq -- n ) - #! geometric mean, nth root of product [ length ] [ product ] bi nth-root ; : harmonic-mean ( seq -- n ) - #! harmonic mean, reciprocal of sum of reciprocals. - #! positive reals only [ recip ] sigma recip ; : median ( seq -- n ) - #! middle number if odd, avg of two middle numbers if even natural-sort dup length even? [ [ midpoint@ dup 1- 2array ] keep nths mean ] [ @@ -26,11 +21,10 @@ IN: math.statistics ] if ; : range ( seq -- n ) - #! max - min minmax swap - ; : var ( seq -- x ) - #! variance, normalize by N-1 + #! normalize by N-1 dup length 1 <= [ drop 0 ] [ @@ -39,11 +33,9 @@ IN: math.statistics ] if ; : std ( seq -- x ) - #! standard deviation, sqrt of variance var sqrt ; : ste ( seq -- x ) - #! standard error, standard deviation / sqrt ( length of sequence ) [ std ] [ length ] bi sqrt / ; : ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) diff --git a/extra/math/statistics/summary.txt b/basis/math/statistics/summary.txt similarity index 100% rename from extra/math/statistics/summary.txt rename to basis/math/statistics/summary.txt diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 82acef9b72..7c4de1e973 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -129,7 +129,7 @@ SYMBOL: -> : remove-breakpoints ( quot pos -- quot' ) over quotation? [ 1+ cut [ (remove-breakpoints) ] bi@ - [ -> ] swap 3append + [ -> ] glue ] [ drop ] if ; diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 3097eafd15..357ab87966 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -15,11 +15,14 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ; : mt-m 397 ; inline : mt-a HEX: 9908b0df ; inline +: mersenne-wrap ( n -- n' ) + dup mt-n > [ mt-n - ] when ; inline + : wrap-nth ( n seq -- obj ) - [ length mod ] keep nth-unsafe ; inline + [ mersenne-wrap ] dip nth-unsafe ; inline : set-wrap-nth ( obj n seq -- ) - [ length mod ] keep set-nth-unsafe ; inline + [ mersenne-wrap ] dip set-nth-unsafe ; inline : calculate-y ( n seq -- y ) [ wrap-nth 31 mask-bit ] @@ -50,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ; : init-mt-seq ( seed -- seq ) 32 bits mt-n - [ set-first ] [ init-mt-rest ] [ ] tri ; + [ set-first ] [ init-mt-rest ] [ ] tri ; inline : mt-temper ( y -- yt ) dup -11 shift bitxor diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 2cde26b731..14fb739947 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -20,7 +20,7 @@ SET-NTH [ T dup c-setter array-accessor ] WHERE TUPLE: A -{ underlying alien read-only } +{ underlying c-ptr read-only } { length fixnum read-only } ; : ( alien len -- direct-array ) A boa ; inline diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor index 3bbba0fcb8..48cd10a7ee 100644 --- a/basis/stack-checker/backend/backend-tests.factor +++ b/basis/stack-checker/backend/backend-tests.factor @@ -3,20 +3,21 @@ stack-checker.state sequences ; IN: stack-checker.backend.tests [ ] [ - V{ } clone meta-d set - V{ } clone meta-r set + V{ } clone \ meta-d set + V{ } clone \ meta-r set + V{ } clone \ literals set 0 d-in set ] unit-test [ 0 ] [ 0 ensure-d length ] unit-test [ 2 ] [ 2 ensure-d length ] unit-test -[ 2 ] [ meta-d get length ] unit-test +[ 2 ] [ meta-d length ] unit-test [ 3 ] [ 3 ensure-d length ] unit-test -[ 3 ] [ meta-d get length ] unit-test +[ 3 ] [ meta-d length ] unit-test [ 1 ] [ 1 ensure-d length ] unit-test -[ 3 ] [ meta-d get length ] unit-test +[ 3 ] [ meta-d length ] unit-test [ ] [ 1 consume-d drop ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 8bb19b82f7..07030085a6 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -9,10 +9,10 @@ stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend -: push-d ( obj -- ) meta-d get push ; +: push-d ( obj -- ) meta-d push ; : pop-d ( -- obj ) - meta-d get [ + meta-d [ dup 1array #introduce, d-in inc ] [ pop ] if-empty ; @@ -22,46 +22,52 @@ IN: stack-checker.backend [ ] replicate ; : ensure-d ( n -- values ) - meta-d get 2dup length > [ + meta-d 2dup length > [ 2dup [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri - [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri - meta-d get push-all + [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri + meta-d push-all ] when swap tail* ; : shorten-by ( n seq -- ) [ length swap - ] keep shorten ; inline : consume-d ( n -- seq ) - [ ensure-d ] [ meta-d get shorten-by ] bi ; + [ ensure-d ] [ meta-d shorten-by ] bi ; -: output-d ( values -- ) meta-d get push-all ; +: output-d ( values -- ) meta-d push-all ; : produce-d ( n -- values ) - make-values dup meta-d get push-all ; + make-values dup meta-d push-all ; -: push-r ( obj -- ) meta-r get push ; +: push-r ( obj -- ) meta-r push ; -: pop-r ( -- obj ) - meta-r get dup empty? +: pop-r ( -- obj ) + meta-r dup empty? [ too-many-r> inference-error ] [ pop ] if ; : consume-r ( n -- seq ) - meta-r get 2dup length > + meta-r 2dup length > [ too-many-r> inference-error ] when [ swap tail* ] [ shorten-by ] 2bi ; -: output-r ( seq -- ) meta-r get push-all ; - -: pop-literal ( -- rstate obj ) - pop-d - [ 1array #drop, ] - [ literal [ recursion>> ] [ value>> ] bi ] bi ; - -GENERIC: apply-object ( obj -- ) +: output-r ( seq -- ) meta-r push-all ; : push-literal ( obj -- ) - dup make-known [ nip push-d ] [ #push, ] 2bi ; + literals get push ; + +: pop-literal ( -- rstate obj ) + literals get [ + pop-d + [ 1array #drop, ] + [ literal [ recursion>> ] [ value>> ] bi ] bi + ] [ pop recursive-state get swap ] if-empty ; + +: literals-available? ( n -- literals ? ) + literals get 2dup length <= + [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ; + +GENERIC: apply-object ( obj -- ) M: wrapper apply-object wrapped>> @@ -72,10 +78,17 @@ M: wrapper apply-object M: object apply-object push-literal ; : terminate ( -- ) - terminated? on meta-d get clone meta-r get clone #terminate, ; + terminated? on meta-d clone meta-r clone #terminate, ; + +: check->r ( -- ) + meta-r empty? [ \ too-many->r inference-error ] unless ; : infer-quot-here ( quot -- ) - [ apply-object terminated? get not ] all? drop ; + meta-r [ + V{ } clone \ meta-r set + [ apply-object terminated? get not ] all? + [ commit-literals check->r ] [ literals get delete-all ] if + ] dip \ meta-r set ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -103,10 +116,10 @@ M: object apply-object push-literal ; ] if ; : infer->r ( n -- ) - consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ; + consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ; : infer-r> ( n -- ) - consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ; + consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; : undo-infer ( -- ) recorded get [ f "inferred-effect" set-word-prop ] each ; @@ -127,13 +140,8 @@ M: object apply-object push-literal ; : infer-word-def ( word -- ) [ specialized-def ] [ add-recursive-state ] bi infer-quot ; -: check->r ( -- ) - meta-r get empty? terminated? get or - [ \ too-many->r inference-error ] unless ; - : end-infer ( -- ) - check->r - meta-d get clone #return, ; + meta-d clone #return, ; : effect-required? ( word -- ? ) { diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 7b461d0028..e4c11960de 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -57,9 +57,9 @@ SYMBOL: quotations branch-variable ; : datastack-phi ( seq -- phi-in phi-out ) - [ d-in branch-variable ] [ meta-d active-variable ] bi + [ d-in branch-variable ] [ \ meta-d active-variable ] bi unify-branches - [ d-in set ] [ ] [ dup >vector meta-d set ] tri* ; + [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ; : terminated-phi ( seq -- terminated ) terminated? branch-variable ; @@ -74,17 +74,25 @@ SYMBOL: quotations tri ; : copy-inference ( -- ) - meta-d [ clone ] change - V{ } clone meta-r set + \ meta-d [ clone ] change + literals [ clone ] change d-in [ ] change ; -: infer-branch ( literal -- namespace ) +GENERIC: infer-branch ( literal -- namespace ) + +M: literal infer-branch [ copy-inference nest-visitor [ value>> quotation set ] [ infer-literal-quot ] bi - check->r - ] H{ } make-assoc ; inline + ] H{ } make-assoc ; + +M: callable infer-branch + [ + copy-inference + nest-visitor + [ quotation set ] [ infer-quot-here ] bi + ] H{ } make-assoc ; : infer-branches ( branches -- input children data ) [ pop-d ] dip @@ -96,16 +104,19 @@ SYMBOL: quotations [ first2 #if, ] dip compute-phi-function ; : infer-if ( -- ) - 2 consume-d - dup [ known [ curried? ] [ composed? ] bi or ] contains? [ - output-d - [ rot [ drop call ] [ nip call ] if ] - infer-quot-here + 2 literals-available? [ + (infer-if) ] [ - [ #drop, ] [ [ literal ] map (infer-if) ] bi + drop 2 consume-d + dup [ known [ curried? ] [ composed? ] bi or ] contains? [ + output-d + [ rot [ drop call ] [ nip call ] if ] + infer-quot-here + ] [ + [ #drop, ] [ [ literal ] map (infer-if) ] bi + ] if ] if ; : infer-dispatch ( -- ) - pop-literal nip [ ] map - infer-branches + pop-literal nip infer-branches [ #dispatch, ] dip compute-phi-function ; diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index df0145b73e..23283fb6e3 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -51,14 +51,14 @@ SYMBOL: enter-out : prepare-stack ( word -- ) required-stack-effect in>> [ length ensure-d drop ] [ - meta-d get clone enter-in set - meta-d get swap make-copies enter-out set + meta-d clone enter-in set + meta-d swap make-copies enter-out set ] bi ; : emit-enter-recursive ( label -- ) enter-out get >>enter-out enter-in get enter-out get #enter-recursive, - enter-out get >vector meta-d set ; + enter-out get >vector \ meta-d set ; : entry-stack-height ( label -- stack ) enter-out>> length ; @@ -77,7 +77,7 @@ SYMBOL: enter-out : end-recursive-word ( word label -- ) [ check-return ] - [ meta-d get dup copy-values dup meta-d set #return-recursive, ] + [ meta-d dup copy-values dup \ meta-d set #return-recursive, ] bi ; : recursive-word-inputs ( label -- n ) @@ -95,10 +95,8 @@ SYMBOL: enter-out [ nip ] 2tri - check->r - dup recursive-word-inputs - meta-d get + meta-d stack-visitor get terminated? get ] with-scope ; @@ -116,7 +114,7 @@ SYMBOL: enter-out swap word>> required-stack-effect in>> length tail* ; : call-site-stack ( label -- stack ) - meta-d get trim-stack ; + meta-d trim-stack ; : trimmed-enter-out ( label -- stack ) dup enter-out>> trim-stack ; @@ -131,7 +129,7 @@ SYMBOL: enter-out : adjust-stack-effect ( effect -- effect' ) [ in>> ] [ out>> ] bi - meta-d get length pick length [-] + meta-d length pick length [-] object '[ _ prepend ] bi@ ; @@ -142,6 +140,7 @@ SYMBOL: enter-out ] [ drop undeclared-recursion-error inference-error ] if ; : inline-word ( word -- ) + commit-literals [ inlined-dependency depends-on ] [ dup inline-recursive-label [ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 12eb637964..26e1b81c93 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -63,7 +63,9 @@ IN: stack-checker.known-words GENERIC: infer-call* ( value known -- ) -: infer-call ( value -- ) dup known infer-call* ; +: (infer-call) ( value -- ) dup known infer-call* ; + +: infer-call ( -- ) pop-d (infer-call) ; M: literal infer-call* [ 1array #drop, ] [ infer-literal-quot ] bi* ; @@ -73,7 +75,7 @@ M: curried infer-call* [ uncurry ] infer-quot-here [ quot>> known pop-d [ set-known ] keep ] [ obj>> known pop-d [ set-known ] keep ] bi - push-d infer-call ; + push-d (infer-call) ; M: composed infer-call* swap push-d @@ -81,20 +83,41 @@ M: composed infer-call* [ quot2>> known pop-d [ set-known ] keep ] [ quot1>> known pop-d [ set-known ] keep ] bi push-d push-d - 1 infer->r pop-d infer-call - terminated? get [ 1 infer-r> pop-d infer-call ] unless ; + 1 infer->r infer-call + terminated? get [ 1 infer-r> infer-call ] unless ; M: object infer-call* \ literal-expected inference-warning ; : infer-slip ( -- ) - 1 infer->r pop-d infer-call 1 infer-r> ; + 1 infer->r infer-call 1 infer-r> ; : infer-2slip ( -- ) - 2 infer->r pop-d infer-call 2 infer-r> ; + 2 infer->r infer-call 2 infer-r> ; : infer-3slip ( -- ) - 3 infer->r pop-d infer-call 3 infer-r> ; + 3 infer->r infer-call 3 infer-r> ; + +: infer-dip ( -- ) + commit-literals + literals get + [ \ dip def>> infer-quot-here ] + [ pop 1 infer->r infer-quot-here 1 infer-r> ] + if-empty ; + +: infer-2dip ( -- ) + commit-literals + literals get + [ \ 2dip def>> infer-quot-here ] + [ pop 2 infer->r infer-quot-here 2 infer-r> ] + if-empty ; + +: infer-3dip ( -- ) + commit-literals + literals get + [ \ 3dip def>> infer-quot-here ] + [ pop 3 infer->r infer-quot-here 3 infer-r> ] + if-empty ; : infer-curry ( -- ) 2 consume-d @@ -157,11 +180,14 @@ M: object infer-call* { \ >r [ 1 infer->r ] } { \ r> [ 1 infer-r> ] } { \ declare [ infer-declare ] } - { \ call [ pop-d infer-call ] } - { \ (call) [ pop-d infer-call ] } + { \ call [ infer-call ] } + { \ (call) [ infer-call ] } { \ slip [ infer-slip ] } { \ 2slip [ infer-2slip ] } { \ 3slip [ infer-3slip ] } + { \ dip [ infer-dip ] } + { \ 2dip [ infer-2dip ] } + { \ 3dip [ infer-3dip ] } { \ curry [ infer-curry ] } { \ compose [ infer-compose ] } { \ execute [ infer-execute ] } @@ -190,10 +216,10 @@ M: object infer-call* "local-word-def" word-prop infer-quot-here ; { - >r r> declare call (call) slip 2slip 3slip curry compose - execute (execute) if dispatch (throw) - load-locals get-local drop-locals do-primitive alien-invoke - alien-indirect alien-callback + >r r> declare call (call) slip 2slip 3slip dip 2dip 3dip + curry compose execute (execute) if dispatch + (throw) load-locals get-local drop-locals do-primitive + alien-invoke alien-indirect alien-callback } [ t "special" set-word-prop ] each { call execute dispatch load-locals get-local drop-locals } diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 2706ec60ef..130147f798 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs arrays namespaces sequences kernel definitions math effects accessors words fry classes.algebra -compiler.units ; +compiler.units stack-checker.values stack-checker.visitor ; IN: stack-checker.state ! Did the current control-flow path throw an error? @@ -11,23 +11,40 @@ SYMBOL: terminated? ! Number of inputs current word expects from the stack SYMBOL: d-in +DEFER: commit-literals + ! Compile-time data stack -SYMBOL: meta-d +: meta-d ( -- stack ) commit-literals \ meta-d get ; ! Compile-time retain stack -SYMBOL: meta-r +: meta-r ( -- stack ) \ meta-r get ; -: current-stack-height ( -- n ) meta-d get length d-in get - ; +! Uncommitted literals. This is a form of local dead-code +! elimination; the goal is to reduce the number of IR nodes +! which get constructed. Technically it is redundant since +! we do global DCE later, but it speeds up compile time. +SYMBOL: literals + +: (push-literal) ( obj -- ) + dup make-known + [ nip \ meta-d get push ] [ #push, ] 2bi ; + +: commit-literals ( -- ) + literals get [ + [ [ (push-literal) ] each ] [ delete-all ] bi + ] unless-empty ; + +: current-stack-height ( -- n ) meta-d length d-in get - ; : current-effect ( -- effect ) d-in get - meta-d get length + meta-d length terminated? get >>terminated? ; : init-inference ( -- ) terminated? off - V{ } clone meta-d set - V{ } clone meta-r set + V{ } clone \ meta-d set + V{ } clone literals set 0 d-in set ; ! Words that the current quotation depends on diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 7eec29f94b..299dc1b551 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -19,11 +19,8 @@ IN: stack-checker.transforms rot with-datastack first2 dup [ [ - [ drop ] [ - [ length meta-d get '[ _ pop* ] times ] - [ #drop, ] - bi - ] bi* + [ drop ] + [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi* ] 2dip swap infer-quot ] [ diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 70f9a10a51..8c35ae25a8 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -10,7 +10,7 @@ IN: tools.memory : write-size ( n -- ) number>string - dup length 4 > [ 3 cut* "," swap 3append ] when + dup length 4 > [ 3 cut* "," glue ] when " KB" append write-cell ; : write-total/used/free ( free total str -- ) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index ef0c74d7c8..ab2d089d94 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -238,7 +238,7 @@ M: vocab-link summary vocab-summary ; vocab-dir append-path dup exists? [ subdirs ] [ drop { } ] if ] keep [ - swap [ "." swap 3append ] with map + swap [ "." glue ] with map ] unless-empty ; : vocabs-in-dir ( root name -- ) diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index f1a1e3c873..953291cc59 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -126,7 +126,7 @@ SYMBOL: +stopped+ [ 2dup length = [ nip [ break ] append ] [ 2dup nth \ break = [ nip ] [ - swap 1+ cut [ break ] swap 3append + swap 1+ cut [ break ] glue ] if ] if ] change-frame ; diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 0f2e12119d..58c7a5d10e 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -72,7 +72,7 @@ VALUE: grapheme-table grapheme-table nth nth not ; : chars ( i str n -- str[i] str[i+n] ) - swap >r dupd + r> [ ?nth ] curry bi@ ; + swap [ dupd + ] dip [ ?nth ] curry bi@ ; : find-index ( seq quot -- i ) find drop ; inline : find-last-index ( seq quot -- i ) find-last drop ; inline diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index 7f445b8513..90b280ee09 100644 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -124,7 +124,7 @@ PRIVATE> [ zero? ] tri@ and and ; : filter-ignorable ( weights -- weights' ) - >r f r> [ + f swap [ tuck primary>> zero? and [ swap ignorable?>> or ] [ swap completely-ignorable? or not ] 2bi diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index fa882609a5..f621384ede 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -91,6 +91,6 @@ PRIVATE> [ [ [ url-encode ] dip - [ url-encode "=" swap 3append , ] with each + [ url-encode "=" glue , ] with each ] assoc-each ] { } make "&" join ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 96301dbbe4..7d6f0ab5f2 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -315,10 +315,10 @@ C-STRUCT: MEMORY_BASIC_INFORMATION { "DWORD" "type" } ; C-STRUCT: GUID - { "ulong" "Data1" } - { "ushort" "Data2" } - { "ushort" "Data3" } - { { "uchar" 8 } "Data4" } ; + { "ULONG" "Data1" } + { "WORD" "Data2" } + { "WORD" "Data3" } + { { "UCHAR" 8 } "Data4" } ; : SE_CREATE_TOKEN_NAME "SeCreateTokenPrivilege" ; diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 6b1a57a098..63ee6627c4 100644 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -30,7 +30,7 @@ TYPEDEF: long* LPLONG TYPEDEF: long LONG_PTR TYPEDEF: long* PLONG_PTR -TYPEDEF: int ULONG +TYPEDEF: uint ULONG TYPEDEF: void* ULONG_PTR TYPEDEF: void* PULONG_PTR diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7a22306c50..f57be71ca8 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -79,6 +79,7 @@ $nl { $subsection continue-with } "Continuations as control-flow:" { $subsection attempt-all } +{ $subsection retry } { $subsection with-return } "Reflecting the datastack:" { $subsection with-datastack } @@ -237,6 +238,20 @@ HELP: attempt-all } } ; +HELP: retry +{ $values + { "quot" quotation } { "n" null } +} +{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." } +{ $examples + { $unchecked-example "USING: continuations math prettyprint ;" + "[ 5 random 0 = ] retry t" + "t" + } +} ; + +{ attempt-all retry } related-words + HELP: return { $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index af8cda37c6..0f55009608 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -154,6 +154,8 @@ ERROR: attempt-all-error ; ] { } make peek swap [ rethrow ] when ] if ; inline +: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline + TUPLE: condition error restarts continuation ; C: condition ( error restarts cc -- condition ) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 0c082477c7..db6b2461b5 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -26,7 +26,7 @@ GENERIC: effect>string ( obj -- str ) M: string effect>string ; M: word effect>string name>> ; M: integer effect>string number>string ; -M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; +M: pair effect>string first2 [ effect>string ] bi@ ": " glue ; : stack-picture ( seq -- string ) dup integer? [ "object" ] when diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 0cd5a35623..4eb39291a0 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -77,7 +77,7 @@ TUPLE: check-method class generic ; 3tri ; inline : method-word-name ( class word -- string ) - [ name>> ] bi@ "=>" swap 3append ; + [ name>> ] bi@ "=>" glue ; PREDICATE: method-body < word "method-generic" word-prop >boolean ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 91b18d834b..5ee12ddedc 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -758,12 +758,10 @@ $nl "Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" { $code "! First alternative; uses dip" - "[ [ 1 + ] dip 1 - dip ] 2 *" + "[ [ 1 + ] dip 1 - ] dip 2 *" "! Second alternative: uses tri*" "[ 1 + ] [ 1 - ] [ 2 * ] tri*" } - -$nl "A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." { $subsection "spread-shuffle-equivalence" } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index bbe2d348d8..98dc0e50fa 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -52,7 +52,9 @@ DEFER: if : ?if ( default cond true false -- ) pick [ roll 2drop call ] [ 2nip call ] if ; inline -! Slippers +! Slippers and dippers. +! Not declared inline because the compiler special-cases them + : slip ( quot x -- x ) #! 'slip' and 'dip' can be defined in terms of each other #! because the JIT special-cases a 'dip' preceeded by @@ -71,11 +73,11 @@ DEFER: if #! a literal quotation. [ call ] 3dip ; -: dip ( x quot -- x ) swap slip ; inline +: dip ( x quot -- x ) swap slip ; -: 2dip ( x y quot -- x y ) -rot 2slip ; inline +: 2dip ( x y quot -- x y ) -rot 2slip ; -: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline +: 3dip ( x y z quot -- x y z ) -roll 3slip ; ! Keepers : keep ( x quot -- x ) over slip ; inline diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index a1ba16c68a..5549ef79e9 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "floats" "Floats" "Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers." $nl "Introducing a floating point number in a computation forces the result to be expressed in floating point." -{ $example "5/4 1/2 + ." "7/4" } +{ $example "5/4 1/2 + ." "1+3/4" } { $example "5/4 0.5 + ." "1.75" } "Integers and rationals can be converted to floats:" { $subsection >float } diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 8fc6e6dd9e..ac6c5e9790 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -128,7 +128,7 @@ M: ratio >base [ [ numerator (>base) ] [ denominator (>base) ] bi - "/" swap 3append + "/" glue ] bi* append negative? get [ CHAR: - prefix ] when ] with-radix ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index cc8daba8c0..08831579bb 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -714,6 +714,26 @@ HELP: 3append } } ; +HELP: surround +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } } +{ $description "Outputs a new sequence with " { $snippet "seq1" } " inserted between " { $snippet "seq2" } " and " { $snippet "seq3" } "." } +{ $examples + { $example "USING: sequences prettyprint ;" + "\"sssssh\" \"(\" \")\" surround ." + "\"(sssssh)\"" + } +} ; + +HELP: glue +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } } +{ $description "Outputs a new sequence with " { $snippet "seq3" } " inserted between " { $snippet "seq1" } " and " { $snippet "seq2" } "." } +{ $examples + { $example "USING: sequences prettyprint ;" + "\"a\" \"b\" \",\" glue ." + "\"a,b\"" + } +} ; + HELP: subseq { $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } } { $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "from" } ", and up to but not including " { $snippet "to" } "." } @@ -1348,6 +1368,8 @@ ARTICLE: "sequences-appending" "Appending sequences" { $subsection append } { $subsection prepend } { $subsection 3append } +{ $subsection surround } +{ $subsection glue } { $subsection concat } { $subsection join } "A pair of words useful for aligning strings:" diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index e27f2410b3..0d795d453a 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -268,3 +268,6 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; [ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test [ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test + +[ "a,b" ] [ "a" "b" "," glue ] unit-test +[ "(abc)" ] [ "abc" "(" ")" surround ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 118969bd3c..3461266081 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -317,6 +317,10 @@ PRIVATE> : 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ; +: surround ( seq1 seq2 seq3 -- newseq ) swapd 3append ; inline + +: glue ( seq1 seq2 seq3 -- newseq ) swap 3append ; inline + : change-nth ( i seq quot -- ) [ [ nth ] dip call ] 3keep drop set-nth ; inline diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index 6bd2d69cfa..7b8e2d34c9 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -9,7 +9,7 @@ IN: benchmark.knucleotide "." split1 rot over length over < [ CHAR: 0 pad-right ] - [ head ] if "." swap 3append ; + [ head ] if "." glue ; : discard-lines ( -- ) readln diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 5eb41cd943..90e588be48 100755 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -80,7 +80,7 @@ M: check< summary drop "Number exceeds upper bound" ; [ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ; : define-slots ( prefix names quots -- ) - >r [ "-" swap 3append create-in ] with map r> + >r [ "-" glue create-in ] with map r> [ define ] 2each ; : define-accessors ( classname slots -- ) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 0ae86c48c4..ac8c3d11d8 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -135,9 +135,6 @@ MACRO: multikeep ( word out-indexes -- ... ) r> [ drop \ r> , ] each ] [ ] make ; -: retry ( quot n -- ) - [ drop ] rot compose attempt-all ; inline - : do-while ( pred body tail -- ) [ tuck 2slip ] dip while ; inline diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 214b45ce0c..be3ba40ac0 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -285,7 +285,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ get-label ] [ skip-label get-name ] 2bi - "." swap 3append + "." glue ] } } diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index c61a3c8b8a..6537661b3e 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -5,7 +5,7 @@ IN: hardware-info.windows.ce : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength - [ GlobalMemoryStatus ] keep ; + dup GlobalMemoryStatus ; M: wince cpus ( -- n ) 1 ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 51af5c5949..6274e7974c 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,18 +1,16 @@ USING: alien alien.c-types alien.strings kernel libc math namespaces hardware-info.backend -windows windows.advapi32 windows.kernel32 system ; +hardware-info.windows windows windows.advapi32 +windows.kernel32 system byte-arrays ; IN: hardware-info.windows.nt -: system-info ( -- SYSTEM_INFO ) - "SYSTEM_INFO" [ GetSystemInfo ] keep ; - M: winnt cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) "MEMORYSTATUSEX" "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength - [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; + dup GlobalMemoryStatusEx win32-error=0/f ; M: winnt memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; @@ -35,21 +33,12 @@ M: winnt total-virtual-mem ( -- n ) M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; -: pull-win32-string ( alien -- string ) - [ utf16n alien>string ] keep free ; - : computer-name ( -- string ) - MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep - dupd GetComputerName zero? [ - free win32-error f - ] [ - pull-win32-string - ] if ; + MAX_COMPUTERNAME_LENGTH 1+ + [ dup ] keep + GetComputerName win32-error=0/f alien>native-string ; : username ( -- string ) - UNLEN 1+ [ malloc ] keep - dupd GetUserName zero? [ - free win32-error f - ] [ - pull-win32-string - ] if ; + UNLEN 1+ + [ dup ] keep + GetUserName win32-error=0/f alien>native-string ; diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 3aa6824ff6..d3ebe87501 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -21,7 +21,7 @@ IN: hardware-info.windows : os-version ( -- os-version ) "OSVERSIONINFO" "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize - [ GetVersionEx ] keep swap zero? [ win32-error ] when ; + dup GetVersionEx win32-error=0/f ; : windows-major ( -- n ) os-version OSVERSIONINFO-dwMajorVersion ; @@ -36,7 +36,7 @@ IN: hardware-info.windows os-version OSVERSIONINFO-dwPlatformId ; : windows-service-pack ( -- string ) - os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ; + os-version OSVERSIONINFO-szCSDVersion alien>native-string ; : feature-present? ( n -- ? ) IsProcessorFeaturePresent zero? not ; @@ -51,8 +51,8 @@ IN: hardware-info.windows "ushort" ; : get-directory ( word -- str ) - >r MAX_UNICODE_PATH [ ] keep dupd r> - execute win32-error=0/f utf16n alien>string ; inline + [ MAX_UNICODE_PATH [ ] keep dupd ] dip + execute win32-error=0/f alien>native-string ; inline : windows-directory ( -- str ) \ GetWindowsDirectory get-directory ; diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 93ccb2b407..3b7694a347 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -31,7 +31,7 @@ M: object handle-message drop ; "git-log" , "--no-merges" , "--pretty=format:%h %an: %s" , - ".." swap 3append , + ".." glue , ] { } make latin1 [ input-stream get lines ] with-process-reader ; diff --git a/extra/math/blas/cblas/cblas.factor b/extra/math/blas/cblas/cblas.factor index 58f179af80..4c0a88f929 100644 --- a/extra/math/blas/cblas/cblas.factor +++ b/extra/math/blas/cblas/cblas.factor @@ -34,10 +34,10 @@ TYPEDEF: int CBLAS_SIDE TYPEDEF: int CBLAS_INDEX -C-STRUCT: CBLAS_C +C-STRUCT: float-complex { "float" "real" } { "float" "imag" } ; -C-STRUCT: CBLAS_Z +C-STRUCT: double-complex { "double" "real" } { "double" "imag" } ; @@ -53,14 +53,14 @@ FUNCTION: double cblas_ddot ( int N, double* X, int incX, double* Y, int incY ) ; FUNCTION: void cblas_cdotu_sub - ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotu ) ; + ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; FUNCTION: void cblas_cdotc_sub - ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ; + ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; FUNCTION: void cblas_zdotu_sub - ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ; + ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; FUNCTION: void cblas_zdotc_sub - ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotc ) ; + ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; FUNCTION: float cblas_snrm2 ( int N, float* X, int incX ) ; @@ -73,23 +73,23 @@ FUNCTION: double cblas_dasum ( int N, double* X, int incX ) ; FUNCTION: float cblas_scnrm2 - ( int N, CBLAS_C* X, int incX ) ; + ( int N, void* X, int incX ) ; FUNCTION: float cblas_scasum - ( int N, CBLAS_C* X, int incX ) ; + ( int N, void* X, int incX ) ; FUNCTION: double cblas_dznrm2 - ( int N, CBLAS_Z* X, int incX ) ; + ( int N, void* X, int incX ) ; FUNCTION: double cblas_dzasum - ( int N, CBLAS_Z* X, int incX ) ; + ( int N, void* X, int incX ) ; FUNCTION: CBLAS_INDEX cblas_isamax ( int N, float* X, int incX ) ; FUNCTION: CBLAS_INDEX cblas_idamax ( int N, double* X, int incX ) ; FUNCTION: CBLAS_INDEX cblas_icamax - ( int N, CBLAS_C* X, int incX ) ; + ( int N, void* X, int incX ) ; FUNCTION: CBLAS_INDEX cblas_izamax - ( int N, CBLAS_Z* X, int incX ) ; + ( int N, void* X, int incX ) ; FUNCTION: void cblas_sswap ( int N, float* X, int incX, float* Y, int incY ) ; @@ -106,31 +106,31 @@ FUNCTION: void cblas_daxpy ( int N, double alpha, double* X, int incX, double* Y, int incY ) ; FUNCTION: void cblas_cswap - ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ; + ( int N, void* X, int incX, void* Y, int incY ) ; FUNCTION: void cblas_ccopy - ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ; + ( int N, void* X, int incX, void* Y, int incY ) ; FUNCTION: void cblas_caxpy - ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ; + ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; FUNCTION: void cblas_zswap - ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ; + ( int N, void* X, int incX, void* Y, int incY ) ; FUNCTION: void cblas_zcopy - ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ; + ( int N, void* X, int incX, void* Y, int incY ) ; FUNCTION: void cblas_zaxpy - ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ; + ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; FUNCTION: void cblas_sscal ( int N, float alpha, float* X, int incX ) ; FUNCTION: void cblas_dscal ( int N, double alpha, double* X, int incX ) ; FUNCTION: void cblas_cscal - ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX ) ; + ( int N, void* alpha, void* X, int incX ) ; FUNCTION: void cblas_zscal - ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ; + ( int N, void* alpha, void* X, int incX ) ; FUNCTION: void cblas_csscal - ( int N, float alpha, CBLAS_C* X, int incX ) ; + ( int N, float alpha, void* X, int incX ) ; FUNCTION: void cblas_zdscal - ( int N, double alpha, CBLAS_Z* X, int incX ) ; + ( int N, double alpha, void* X, int incX ) ; FUNCTION: void cblas_srotg ( float* a, float* b, float* c, float* s ) ; diff --git a/extra/math/blas/matrices/matrices-docs.factor b/extra/math/blas/matrices/matrices-docs.factor index dc6a86017a..01e0997405 100644 --- a/extra/math/blas/matrices/matrices-docs.factor +++ b/extra/math/blas/matrices/matrices-docs.factor @@ -88,7 +88,7 @@ HELP: blas-matrix-base } "All of these subclasses share the same tuple layout:" { $list - { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" } + { { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" } { { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" } { { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" } { "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." } diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor index 0899e2d079..c8a4ee6292 100755 --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -1,31 +1,13 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators -combinators.lib combinators.short-circuit fry kernel locals macros +combinators.short-circuit fry kernel locals macros math math.blas.cblas math.blas.vectors math.blas.vectors.private -math.complex math.functions math.order multi-methods qualified -sequences sequences.merged sequences.private generalizations -shuffle symbols speicalized-arrays.float specialized-arrays.double ; -QUALIFIED: syntax +math.complex math.functions math.order functors words +sequences sequences.merged sequences.private shuffle symbols +specialized-arrays.direct.float specialized-arrays.direct.double +specialized-arrays.float specialized-arrays.double ; IN: math.blas.matrices -TUPLE: blas-matrix-base data ld rows cols transpose ; -TUPLE: float-blas-matrix < blas-matrix-base ; -TUPLE: double-blas-matrix < blas-matrix-base ; -TUPLE: float-complex-blas-matrix < blas-matrix-base ; -TUPLE: double-complex-blas-matrix < blas-matrix-base ; - -C: float-blas-matrix -C: double-blas-matrix -C: float-complex-blas-matrix -C: double-complex-blas-matrix - -METHOD: element-type { float-blas-matrix } - drop "float" ; -METHOD: element-type { double-blas-matrix } - drop "double" ; -METHOD: element-type { float-complex-blas-matrix } - drop "CBLAS_C" ; -METHOD: element-type { double-complex-blas-matrix } - drop "CBLAS_Z" ; +TUPLE: blas-matrix-base underlying ld rows cols transpose ; : Mtransposed? ( matrix -- ? ) transpose>> ; inline @@ -34,6 +16,11 @@ METHOD: element-type { double-complex-blas-matrix } : Mheight ( matrix -- height ) dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline +GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y ) +GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A ) +GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A ) +GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C ) + ; -METHOD: (blas-matrix-like) { object object object object object double-blas-matrix } - drop ; -METHOD: (blas-matrix-like) { object object object object object float-complex-blas-matrix } - drop ; -METHOD: (blas-matrix-like) { object object object object object double-complex-blas-matrix } - drop ; - -METHOD: (blas-matrix-like) { object object object object object float-blas-vector } - drop ; -METHOD: (blas-matrix-like) { object object object object object double-blas-vector } - drop ; -METHOD: (blas-matrix-like) { object object object object object float-complex-blas-vector } - drop ; -METHOD: (blas-matrix-like) { object object object object object double-complex-blas-vector } - drop ; - -METHOD: (blas-vector-like) { object object object float-blas-matrix } - drop ; -METHOD: (blas-vector-like) { object object object double-blas-matrix } - drop ; -METHOD: (blas-vector-like) { object object object float-complex-blas-matrix } - drop ; -METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } - drop ; - : (validate-gemv) ( A x y -- ) { [ drop [ Mwidth ] [ length>> ] bi* = ] [ nip [ Mheight ] [ length>> ] bi* = ] } 3&& - [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ] unless ; + [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ] + unless ; -:: (prepare-gemv) ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc y ) +:: (prepare-gemv) + ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc + y ) A x y (validate-gemv) CblasColMajor A (blas-transpose) A rows>> A cols>> alpha >c-arg call - A data>> + A underlying>> A ld>> - x data>> + x underlying>> x inc>> beta >c-arg call - y data>> + y underlying>> y inc>> y ; inline @@ -96,19 +59,22 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } [ nip [ length>> ] [ Mheight ] bi* = ] [ nipd [ length>> ] [ Mwidth ] bi* = ] } 3&& - [ "Mismatched vertices and matrix in vector outer product" throw ] unless ; + [ "Mismatched vertices and matrix in vector outer product" throw ] + unless ; -:: (prepare-ger) ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld A ) +:: (prepare-ger) + ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld + A ) x y A (validate-ger) CblasColMajor A rows>> A cols>> alpha >c-arg call - x data>> + x underlying>> x inc>> - y data>> + y underlying>> y inc>> - A data>> + A underlying>> A ld>> A f >>transpose ; inline @@ -117,9 +83,13 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } [ drop [ Mwidth ] [ Mheight ] bi* = ] [ nip [ Mheight ] bi@ = ] [ nipd [ Mwidth ] bi@ = ] - } 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ; + } 3&& + [ "Mismatched matrices in matrix multiplication" throw ] + unless ; -:: (prepare-gemm) ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld C ) +:: (prepare-gemm) + ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld + C ) A B C (validate-gemm) CblasColMajor A (blas-transpose) @@ -128,12 +98,12 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } C cols>> A Mwidth alpha >c-arg call - A data>> + A underlying>> A ld>> - B data>> + B underlying>> B ld>> beta >c-arg call - C data>> + C underlying>> C ld>> C f >>transpose ; inline @@ -142,65 +112,22 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } PRIVATE> -: >float-blas-matrix ( arrays -- matrix ) - [ >float-array underlying>> ] (>matrix) ; -: >double-blas-matrix ( arrays -- matrix ) - [ >double-array underlying>> ] (>matrix) ; -: >float-complex-blas-matrix ( arrays -- matrix ) - [ (flatten-complex-sequence) >float-array underlying>> ] (>matrix) - ; -: >double-complex-blas-matrix ( arrays -- matrix ) - [ (flatten-complex-sequence) >double-array underlying>> ] (>matrix) - ; - -GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y ) -GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A ) -GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A ) -GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C ) - -METHOD: n*M.V+n*V! { real float-blas-matrix float-blas-vector real float-blas-vector } - [ ] (prepare-gemv) [ cblas_sgemv ] dip ; -METHOD: n*M.V+n*V! { real double-blas-matrix double-blas-vector real double-blas-vector } - [ ] (prepare-gemv) [ cblas_dgemv ] dip ; -METHOD: n*M.V+n*V! { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector } - [ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ; -METHOD: n*M.V+n*V! { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector } - [ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ; - -METHOD: n*V(*)V+M! { real float-blas-vector float-blas-vector float-blas-matrix } - [ ] (prepare-ger) [ cblas_sger ] dip ; -METHOD: n*V(*)V+M! { real double-blas-vector double-blas-vector double-blas-matrix } - [ ] (prepare-ger) [ cblas_dger ] dip ; -METHOD: n*V(*)V+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix } - [ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ; -METHOD: n*V(*)V+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix } - [ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ; - -METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix } - [ ] (prepare-ger) [ cblas_sger ] dip ; -METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix } - [ ] (prepare-ger) [ cblas_dger ] dip ; -METHOD: n*V(*)Vconj+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix } - [ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ; -METHOD: n*V(*)Vconj+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix } - [ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ; - -METHOD: n*M.M+n*M! { real float-blas-matrix float-blas-matrix real float-blas-matrix } - [ ] (prepare-gemm) [ cblas_sgemm ] dip ; -METHOD: n*M.M+n*M! { real double-blas-matrix double-blas-matrix real double-blas-matrix } - [ ] (prepare-gemm) [ cblas_dgemm ] dip ; -METHOD: n*M.M+n*M! { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix } - [ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ; -METHOD: n*M.M+n*M! { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix } - [ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ; - ! XXX should do a dense clone -syntax:M: blas-matrix-base clone +M: blas-matrix-base clone [ - [ - { [ data>> ] [ ld>> ] [ cols>> ] [ element-type heap-size ] } cleave - * * memory>byte-array - ] [ { [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> ] } cleave ] bi + [ { + [ underlying>> ] + [ ld>> ] + [ cols>> ] + [ element-type heap-size ] + } cleave * * memory>byte-array ] + [ { + [ ld>> ] + [ rows>> ] + [ cols>> ] + [ transpose>> ] + } cleave ] + bi ] keep (blas-matrix-like) ; ! XXX try rounding stride to next 128 bit bound for better vectorizin' @@ -246,29 +173,31 @@ syntax:M: blas-matrix-base clone :: (Msub) ( matrix row col height width -- data ld rows cols ) matrix ld>> col * row + matrix element-type heap-size * - matrix data>> + matrix underlying>> matrix ld>> height width ; -: Msub ( matrix row col height width -- sub ) - 5 npick dup transpose>> - [ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep - swap (blas-matrix-like) ; +:: Msub ( matrix row col height width -- sub ) + matrix dup transpose>> + [ col row width height ] + [ row col height width ] if (Msub) + matrix transpose>> matrix (blas-matrix-like) ; -TUPLE: blas-matrix-rowcol-sequence parent inc rowcol-length rowcol-jump length ; +TUPLE: blas-matrix-rowcol-sequence + parent inc rowcol-length rowcol-jump length ; C: blas-matrix-rowcol-sequence INSTANCE: blas-matrix-rowcol-sequence sequence -syntax:M: blas-matrix-rowcol-sequence length +M: blas-matrix-rowcol-sequence length length>> ; -syntax:M: blas-matrix-rowcol-sequence nth-unsafe +M: blas-matrix-rowcol-sequence nth-unsafe { [ [ rowcol-jump>> ] [ parent>> element-type heap-size ] - [ parent>> data>> ] tri + [ parent>> underlying>> ] tri [ * * ] dip ] [ rowcol-length>> ] @@ -277,11 +206,11 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe } cleave (blas-vector-like) ; : (Mcols) ( A -- columns ) - { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } cleave - ; + { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } + cleave ; : (Mrows) ( A -- rows ) - { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave - ; + { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } + cleave ; : Mrows ( A -- rows ) dup transpose>> [ (Mcols) ] [ (Mrows) ] if ; @@ -300,11 +229,79 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe recip swap n*M ; inline : Mtranspose ( matrix -- matrix^T ) - [ { [ data>> ] [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> not ] } cleave ] keep (blas-matrix-like) ; + [ { + [ underlying>> ] + [ ld>> ] [ rows>> ] + [ cols>> ] + [ transpose>> not ] + } cleave ] keep (blas-matrix-like) ; -syntax:M: blas-matrix-base equal? +M: blas-matrix-base equal? { [ [ Mwidth ] bi@ = ] [ [ Mcols ] bi@ [ = ] 2all? ] } 2&& ; +<< + +FUNCTOR: (define-blas-matrix) ( TYPE T U C -- ) + +VECTOR IS ${TYPE}-blas-vector + IS <${TYPE}-blas-vector> +>ARRAY IS >${TYPE}-array +TYPE>ARG IS ${TYPE}>arg +XGEMV IS cblas_${T}gemv +XGEMM IS cblas_${T}gemm +XGERU IS cblas_${T}ger${U} +XGERC IS cblas_${T}ger${C} + +MATRIX DEFINES ${TYPE}-blas-matrix + DEFINES <${TYPE}-blas-matrix> +>MATRIX DEFINES >${TYPE}-blas-matrix + +WHERE + +TUPLE: MATRIX < blas-matrix-base ; +: ( underlying ld rows cols transpose -- matrix ) + MATRIX boa ; inline + +M: MATRIX element-type + drop TYPE ; +M: MATRIX (blas-matrix-like) + drop execute ; +M: VECTOR (blas-matrix-like) + drop execute ; +M: MATRIX (blas-vector-like) + drop execute ; + +: >MATRIX ( arrays -- matrix ) + [ >ARRAY execute underlying>> ] (>matrix) + execute ; + +M: VECTOR n*M.V+n*V! + [ TYPE>ARG execute ] (prepare-gemv) + [ XGEMV execute ] dip ; +M: MATRIX n*M.M+n*M! + [ TYPE>ARG execute ] (prepare-gemm) + [ XGEMM execute ] dip ; +M: MATRIX n*V(*)V+M! + [ TYPE>ARG execute ] (prepare-ger) + [ XGERU execute ] dip ; +M: MATRIX n*V(*)Vconj+M! + [ TYPE>ARG execute ] (prepare-ger) + [ XGERC execute ] dip ; + +;FUNCTOR + + +: define-real-blas-matrix ( TYPE T -- ) + "" "" (define-blas-matrix) ; +: define-complex-blas-matrix ( TYPE T -- ) + "u" "c" (define-blas-matrix) ; + +"float" "s" define-real-blas-matrix +"double" "d" define-real-blas-matrix +"float-complex" "c" define-complex-blas-matrix +"double-complex" "z" define-complex-blas-matrix + +>> diff --git a/extra/math/blas/syntax/syntax.factor b/extra/math/blas/syntax/syntax.factor index 6b40910687..95f9f7bd08 100644 --- a/extra/math/blas/syntax/syntax.factor +++ b/extra/math/blas/syntax/syntax.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.matrices math.blas.vectors parser +USING: kernel math.blas.vectors math.blas.matrices parser arrays prettyprint.backend sequences ; IN: math.blas.syntax @@ -20,15 +20,23 @@ IN: math.blas.syntax : zmatrix{ \ } [ >double-complex-blas-matrix ] parse-literal ; parsing -M: float-blas-vector pprint-delims drop \ svector{ \ } ; -M: double-blas-vector pprint-delims drop \ dvector{ \ } ; -M: float-complex-blas-vector pprint-delims drop \ cvector{ \ } ; -M: double-complex-blas-vector pprint-delims drop \ zvector{ \ } ; +M: float-blas-vector pprint-delims + drop \ svector{ \ } ; +M: double-blas-vector pprint-delims + drop \ dvector{ \ } ; +M: float-complex-blas-vector pprint-delims + drop \ cvector{ \ } ; +M: double-complex-blas-vector pprint-delims + drop \ zvector{ \ } ; -M: float-blas-matrix pprint-delims drop \ smatrix{ \ } ; -M: double-blas-matrix pprint-delims drop \ dmatrix{ \ } ; -M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ; -M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ; +M: float-blas-matrix pprint-delims + drop \ smatrix{ \ } ; +M: double-blas-matrix pprint-delims + drop \ dmatrix{ \ } ; +M: float-complex-blas-matrix pprint-delims + drop \ cmatrix{ \ } ; +M: double-complex-blas-matrix pprint-delims + drop \ zmatrix{ \ } ; M: blas-vector-base >pprint-sequence ; M: blas-vector-base pprint* pprint-object ; diff --git a/extra/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor index 0595f00989..cb26d67334 100644 --- a/extra/math/blas/vectors/vectors-docs.factor +++ b/extra/math/blas/vectors/vectors-docs.factor @@ -37,7 +37,7 @@ HELP: blas-vector-base } "All of these subclasses share the same tuple layout:" { $list - { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" } + { { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" } { { $snippet "length" } " indicates the length of the vector;" } { "and " { $snippet "inc" } " indicates the distance, in elements, between elements." } } } ; diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index f29ef30ab7..db027b0ffd 100755 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -1,231 +1,77 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators -combinators.short-circuit fry kernel macros math math.blas.cblas -math.complex math.functions math.order multi-methods qualified -sequences sequences.private generalizations +combinators.short-circuit fry kernel math math.blas.cblas +math.complex math.functions math.order sequences.complex +sequences.complex-components sequences sequences.private +functors words locals specialized-arrays.float specialized-arrays.double specialized-arrays.direct.float specialized-arrays.direct.double ; -QUALIFIED: syntax IN: math.blas.vectors -TUPLE: blas-vector-base data length inc ; -TUPLE: float-blas-vector < blas-vector-base ; -TUPLE: double-blas-vector < blas-vector-base ; -TUPLE: float-complex-blas-vector < blas-vector-base ; -TUPLE: double-complex-blas-vector < blas-vector-base ; +TUPLE: blas-vector-base underlying length inc ; -INSTANCE: float-blas-vector sequence -INSTANCE: double-blas-vector sequence -INSTANCE: float-complex-blas-vector sequence -INSTANCE: double-complex-blas-vector sequence +INSTANCE: blas-vector-base virtual-sequence -C: float-blas-vector -C: double-blas-vector -C: float-complex-blas-vector -C: double-complex-blas-vector +GENERIC: element-type ( v -- type ) GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y ) GENERIC: n*V! ( alpha x -- x=alpha*x ) - GENERIC: V. ( x y -- x.y ) GENERIC: V.conj ( x y -- xconj.y ) GENERIC: Vnorm ( x -- norm ) GENERIC: Vasum ( x -- sum ) GENERIC: Vswap ( x y -- x=y y=x ) - GENERIC: Viamax ( x -- max-i ) -GENERIC: element-type ( v -- type ) - -METHOD: element-type { float-blas-vector } - drop "float" ; -METHOD: element-type { double-blas-vector } - drop "double" ; -METHOD: element-type { float-complex-blas-vector } - drop "CBLAS_C" ; -METHOD: element-type { double-complex-blas-vector } - drop "CBLAS_Z" ; - ; -METHOD: (blas-vector-like) { object object object double-blas-vector } - drop ; -METHOD: (blas-vector-like) { object object object float-complex-blas-vector } - drop ; -METHOD: (blas-vector-like) { object object object double-complex-blas-vector } - drop ; +GENERIC: (blas-direct-array) ( blas-vector -- direct-array ) -: (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc ) - [ [ length>> ] [ data>> ] [ inc>> ] tri ] dip - 4 npick * - 1 ; +: shorter-length ( v1 v2 -- length ) + [ length>> ] bi@ min ; inline +: data-and-inc ( v -- data inc ) + [ underlying>> ] [ inc>> ] bi ; inline +: datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc ) + [ data-and-inc ] bi@ ; inline -MACRO: (do-copy) ( copy make-vector -- ) - '[ over 6 npick _ 2dip 1 @ ] ; +:: (prepare-copy) + ( v element-size -- length v-data v-inc v-dest-data v-dest-inc + copy-data copy-length copy-inc ) + v [ length>> ] [ data-and-inc ] bi + v length>> element-size * + 1 + over v length>> 1 ; -: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 ) - [ - [ [ length>> ] bi@ min ] - [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi - ] 2keep ; +: (prepare-swap) + ( v1 v2 -- length v1-data v1-inc v2-data v2-inc + v1 v2 ) + [ shorter-length ] [ datas-and-incs ] [ ] 2tri ; -: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 ) - [ - [ [ length>> ] bi@ min swap ] - [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi - ] keep ; +:: (prepare-axpy) + ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc + v2 ) + v1 v2 shorter-length + n + v1 v2 datas-and-incs + v2 ; -: (prepare-scal) ( n v -- length n v-data v-inc v ) - [ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ; +:: (prepare-scal) + ( n v -- length n v-data v-inc + v ) + v length>> + n + v data-and-inc + v ; : (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc ) - [ [ length>> ] bi@ min ] - [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ; + [ shorter-length ] [ datas-and-incs ] 2bi ; -: (prepare-nrm2) ( v -- length v1-data v1-inc ) - [ length>> ] [ data>> ] [ inc>> ] tri ; - -: (flatten-complex-sequence) ( seq -- seq' ) - [ [ real-part ] [ imaginary-part ] bi 2array ] map concat ; - -: (>c-complex) ( complex -- alien ) - [ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ; -: (>z-complex) ( complex -- alien ) - [ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ; - -: (c-complex>) ( alien -- complex ) - 2 first2 rect> ; -: (z-complex>) ( alien -- complex ) - 2 first2 rect> ; - -: (prepare-nth) ( n v -- n*inc v-data ) - [ inc>> ] [ data>> ] bi [ * ] dip ; - -MACRO: (complex-nth) ( nth-quot -- ) - '[ - [ 2 * dup 1+ ] dip - _ curry bi@ rect> - ] ; - -: (c-complex-nth) ( n alien -- complex ) - [ float-nth ] (complex-nth) ; -: (z-complex-nth) ( n alien -- complex ) - [ double-nth ] (complex-nth) ; - -MACRO: (set-complex-nth) ( set-nth-quot -- ) - '[ - [ - [ [ real-part ] [ imaginary-part ] bi ] - [ 2 * dup 1+ ] bi* - swapd - ] dip - _ curry 2bi@ - ] ; - -: (set-c-complex-nth) ( complex n alien -- ) - [ set-float-nth ] (set-complex-nth) ; -: (set-z-complex-nth) ( complex n alien -- ) - [ set-double-nth ] (set-complex-nth) ; +: (prepare-nrm2) ( v -- length data inc ) + [ length>> ] [ data-and-inc ] bi ; PRIVATE> -: ( exemplar -- zero ) - [ element-type ] - [ length>> 0 ] - [ (blas-vector-like) ] tri ; - -: ( length exemplar -- vector ) - [ element-type ] - [ 1 swap ] 2bi - (blas-vector-like) ; - -syntax:M: blas-vector-base length - length>> ; - -syntax:M: float-blas-vector nth-unsafe - (prepare-nth) float-nth ; -syntax:M: float-blas-vector set-nth-unsafe - (prepare-nth) set-float-nth ; - -syntax:M: double-blas-vector nth-unsafe - (prepare-nth) double-nth ; -syntax:M: double-blas-vector set-nth-unsafe - (prepare-nth) set-double-nth ; - -syntax:M: float-complex-blas-vector nth-unsafe - (prepare-nth) (c-complex-nth) ; -syntax:M: float-complex-blas-vector set-nth-unsafe - (prepare-nth) (set-c-complex-nth) ; - -syntax:M: double-complex-blas-vector nth-unsafe - (prepare-nth) (z-complex-nth) ; -syntax:M: double-complex-blas-vector set-nth-unsafe - (prepare-nth) (set-z-complex-nth) ; - -syntax:M: blas-vector-base equal? - { - [ [ length ] bi@ = ] - [ [ = ] 2all? ] - } 2&& ; - -: >float-blas-vector ( seq -- v ) - [ >float-array underlying>> ] [ length ] bi 1 ; -: >double-blas-vector ( seq -- v ) - [ >double-array underlying>> ] [ length ] bi 1 ; -: >float-complex-blas-vector ( seq -- v ) - [ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi - 1 ; -: >double-complex-blas-vector ( seq -- v ) - [ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi - 1 ; - -syntax:M: float-blas-vector clone - "float" heap-size (prepare-copy) - [ cblas_scopy ] [ ] (do-copy) ; -syntax:M: double-blas-vector clone - "double" heap-size (prepare-copy) - [ cblas_dcopy ] [ ] (do-copy) ; -syntax:M: float-complex-blas-vector clone - "CBLAS_C" heap-size (prepare-copy) - [ cblas_ccopy ] [ ] (do-copy) ; -syntax:M: double-complex-blas-vector clone - "CBLAS_Z" heap-size (prepare-copy) - [ cblas_zcopy ] [ ] (do-copy) ; - -METHOD: Vswap { float-blas-vector float-blas-vector } - (prepare-swap) [ cblas_sswap ] 2dip ; -METHOD: Vswap { double-blas-vector double-blas-vector } - (prepare-swap) [ cblas_dswap ] 2dip ; -METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector } - (prepare-swap) [ cblas_cswap ] 2dip ; -METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector } - (prepare-swap) [ cblas_zswap ] 2dip ; - -METHOD: n*V+V! { real float-blas-vector float-blas-vector } - (prepare-axpy) [ cblas_saxpy ] dip ; -METHOD: n*V+V! { real double-blas-vector double-blas-vector } - (prepare-axpy) [ cblas_daxpy ] dip ; -METHOD: n*V+V! { number float-complex-blas-vector float-complex-blas-vector } - [ (>c-complex) ] 2dip - (prepare-axpy) [ cblas_caxpy ] dip ; -METHOD: n*V+V! { number double-complex-blas-vector double-complex-blas-vector } - [ (>z-complex) ] 2dip - (prepare-axpy) [ cblas_zaxpy ] dip ; - -METHOD: n*V! { real float-blas-vector } - (prepare-scal) [ cblas_sscal ] dip ; -METHOD: n*V! { real double-blas-vector } - (prepare-scal) [ cblas_dscal ] dip ; -METHOD: n*V! { number float-complex-blas-vector } - [ (>c-complex) ] dip - (prepare-scal) [ cblas_cscal ] dip ; -METHOD: n*V! { number double-complex-blas-vector } - [ (>z-complex) ] dip - (prepare-scal) [ cblas_zscal ] dip ; - : n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline : n*V ( alpha x -- alpha*x ) clone n*V! ; inline @@ -242,62 +88,185 @@ METHOD: n*V! { number double-complex-blas-vector } : V/n ( x alpha -- x/alpha ) recip swap n*V ; inline -METHOD: V. { float-blas-vector float-blas-vector } - (prepare-dot) cblas_sdot ; -METHOD: V. { double-blas-vector double-blas-vector } - (prepare-dot) cblas_ddot ; -METHOD: V. { float-complex-blas-vector float-complex-blas-vector } - (prepare-dot) - "CBLAS_C" [ cblas_cdotu_sub ] keep (c-complex>) ; -METHOD: V. { double-complex-blas-vector double-complex-blas-vector } - (prepare-dot) - "CBLAS_Z" [ cblas_zdotu_sub ] keep (z-complex>) ; - -METHOD: V.conj { float-blas-vector float-blas-vector } - (prepare-dot) cblas_sdot ; -METHOD: V.conj { double-blas-vector double-blas-vector } - (prepare-dot) cblas_ddot ; -METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector } - (prepare-dot) - "CBLAS_C" [ cblas_cdotc_sub ] keep (c-complex>) ; -METHOD: V.conj { double-complex-blas-vector double-complex-blas-vector } - (prepare-dot) - "CBLAS_Z" [ cblas_zdotc_sub ] keep (z-complex>) ; - -METHOD: Vnorm { float-blas-vector } - (prepare-nrm2) cblas_snrm2 ; -METHOD: Vnorm { double-blas-vector } - (prepare-nrm2) cblas_dnrm2 ; -METHOD: Vnorm { float-complex-blas-vector } - (prepare-nrm2) cblas_scnrm2 ; -METHOD: Vnorm { double-complex-blas-vector } - (prepare-nrm2) cblas_dznrm2 ; - -METHOD: Vasum { float-blas-vector } - (prepare-nrm2) cblas_sasum ; -METHOD: Vasum { double-blas-vector } - (prepare-nrm2) cblas_dasum ; -METHOD: Vasum { float-complex-blas-vector } - (prepare-nrm2) cblas_scasum ; -METHOD: Vasum { double-complex-blas-vector } - (prepare-nrm2) cblas_dzasum ; - -METHOD: Viamax { float-blas-vector } - (prepare-nrm2) cblas_isamax ; -METHOD: Viamax { double-blas-vector } - (prepare-nrm2) cblas_idamax ; -METHOD: Viamax { float-complex-blas-vector } - (prepare-nrm2) cblas_icamax ; -METHOD: Viamax { double-complex-blas-vector } - (prepare-nrm2) cblas_izamax ; - : Vamax ( x -- max ) [ Viamax ] keep nth ; inline -: Vsub ( v start length -- sub ) - rot [ - [ - nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri - [ * * ] dip - ] [ swap 2nip ] [ 2nip inc>> ] 3tri - ] keep (blas-vector-like) ; +:: Vsub ( v start length -- sub ) + v inc>> start * v element-type heap-size * + v underlying>> + length v inc>> v (blas-vector-like) ; + +: ( exemplar -- zero ) + [ element-type ] + [ length>> 0 ] + [ (blas-vector-like) ] tri ; + +: ( length exemplar -- vector ) + [ element-type ] + [ 1 swap ] 2bi + (blas-vector-like) ; + +M: blas-vector-base equal? + { + [ [ length ] bi@ = ] + [ [ = ] 2all? ] + } 2&& ; + +M: blas-vector-base length + length>> ; +M: blas-vector-base virtual-seq + (blas-direct-array) ; +M: blas-vector-base virtual@ + [ inc>> * ] [ nip (blas-direct-array) ] 2bi ; + +: float>arg ( f -- f ) ; inline +: double>arg ( f -- f ) ; inline +: arg>float ( f -- f ) ; inline +: arg>double ( f -- f ) ; inline + +<< + +FUNCTOR: (define-blas-vector) ( TYPE T -- ) + + IS +>ARRAY IS >${TYPE}-array +XCOPY IS cblas_${T}copy +XSWAP IS cblas_${T}swap +IXAMAX IS cblas_i${T}amax + +VECTOR DEFINES ${TYPE}-blas-vector + DEFINES <${TYPE}-blas-vector> +>VECTOR DEFINES >${TYPE}-blas-vector + +WHERE + +TUPLE: VECTOR < blas-vector-base ; +: ( underlying length inc -- vector ) VECTOR boa ; inline + +: >VECTOR ( seq -- v ) + [ >ARRAY execute underlying>> ] [ length ] bi 1 execute ; + +M: VECTOR clone + TYPE heap-size (prepare-copy) + [ XCOPY execute ] 3dip execute ; + +M: VECTOR element-type + drop TYPE ; +M: VECTOR Vswap + (prepare-swap) [ XSWAP execute ] 2dip ; +M: VECTOR Viamax + (prepare-nrm2) IXAMAX execute ; + +M: VECTOR (blas-vector-like) + drop execute ; + +M: VECTOR (blas-direct-array) + [ underlying>> ] + [ [ length>> ] [ inc>> ] bi * ] bi + execute ; + +;FUNCTOR + + +FUNCTOR: (define-real-blas-vector) ( TYPE T -- ) + +VECTOR IS ${TYPE}-blas-vector +XDOT IS cblas_${T}dot +XNRM2 IS cblas_${T}nrm2 +XASUM IS cblas_${T}asum +XAXPY IS cblas_${T}axpy +XSCAL IS cblas_${T}scal + +WHERE + +M: VECTOR V. + (prepare-dot) XDOT execute ; +M: VECTOR V.conj + (prepare-dot) XDOT execute ; +M: VECTOR Vnorm + (prepare-nrm2) XNRM2 execute ; +M: VECTOR Vasum + (prepare-nrm2) XASUM execute ; +M: VECTOR n*V+V! + (prepare-axpy) [ XAXPY execute ] dip ; +M: VECTOR n*V! + (prepare-scal) [ XSCAL execute ] dip ; + +;FUNCTOR + + +FUNCTOR: (define-complex-helpers) ( TYPE -- ) + + DEFINES +>COMPLEX-ARRAY DEFINES >${TYPE}-complex-array +ARG>COMPLEX DEFINES arg>${TYPE}-complex +COMPLEX>ARG DEFINES ${TYPE}-complex>arg + IS +>ARRAY IS >${TYPE}-array + +WHERE + +: ( alien len -- sequence ) + 1 shift execute ; +: >COMPLEX-ARRAY ( sequence -- sequence ) + >ARRAY execute ; +: COMPLEX>ARG ( complex -- alien ) + >rect 2array >ARRAY execute underlying>> ; +: ARG>COMPLEX ( alien -- complex ) + 2 execute first2 rect> ; + +;FUNCTOR + + +FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- ) + +VECTOR IS ${TYPE}-blas-vector +XDOTU_SUB IS cblas_${C}dotu_sub +XDOTC_SUB IS cblas_${C}dotc_sub +XXNRM2 IS cblas_${S}${C}nrm2 +XXASUM IS cblas_${S}${C}asum +XAXPY IS cblas_${C}axpy +XSCAL IS cblas_${C}scal +TYPE>ARG IS ${TYPE}>arg +ARG>TYPE IS arg>${TYPE} + +WHERE + +M: VECTOR V. + (prepare-dot) TYPE + [ XDOTU_SUB execute ] keep + ARG>TYPE execute ; +M: VECTOR V.conj + (prepare-dot) TYPE + [ XDOTC_SUB execute ] keep + ARG>TYPE execute ; +M: VECTOR Vnorm + (prepare-nrm2) XXNRM2 execute ; +M: VECTOR Vasum + (prepare-nrm2) XXASUM execute ; +M: VECTOR n*V+V! + [ TYPE>ARG execute ] 2dip + (prepare-axpy) [ XAXPY execute ] dip ; +M: VECTOR n*V! + [ TYPE>ARG execute ] dip + (prepare-scal) [ XSCAL execute ] dip ; + +;FUNCTOR + + +: define-real-blas-vector ( TYPE T -- ) + [ (define-blas-vector) ] + [ (define-real-blas-vector) ] 2bi ; +:: define-complex-blas-vector ( TYPE C S -- ) + TYPE (define-complex-helpers) + TYPE "-complex" append + [ C (define-blas-vector) ] + [ C S (define-complex-blas-vector) ] bi ; + +"float" "s" define-real-blas-vector +"double" "d" define-real-blas-vector +"float" "c" "s" define-complex-blas-vector +"double" "z" "d" define-complex-blas-vector + +>> + diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor index 7f3a87f9a5..9e5b5c67aa 100644 --- a/extra/math/floating-point/floating-point-tests.factor +++ b/extra/math/floating-point/floating-point-tests.factor @@ -1,7 +1,15 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test math.floating-point math.constants kernel ; +USING: tools.test math.floating-point math.constants kernel +math.constants fry sequences kernel math ; IN: math.floating-point.tests [ t ] [ pi >double< >double pi = ] unit-test [ t ] [ -1.0 >double< >double -1.0 = ] unit-test + +[ t ] [ 1/0. infinity? ] unit-test +[ t ] [ -1/0. infinity? ] unit-test +[ f ] [ 0/0. infinity? ] unit-test +[ f ] [ 10. infinity? ] unit-test +[ f ] [ -10. infinity? ] unit-test +[ f ] [ 0. infinity? ] unit-test diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor index 0d224bfc9d..522f149bc1 100644 --- a/extra/math/floating-point/floating-point.factor +++ b/extra/math/floating-point/floating-point.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences prettyprint math.parser io -math.functions math.bitwise ; +math.functions math.bitwise combinators.short-circuit ; IN: math.floating-point : (double-sign) ( bits -- n ) -63 shift ; inline @@ -37,3 +37,10 @@ IN: math.floating-point (double-mantissa-bits) >bin 52 CHAR: 0 pad-left 11 [ bl ] times print ] tri ; + +: infinity? ( double -- ? ) + double>bits + { + [ (double-exponent-bits) 11 on-bits = ] + [ (double-mantissa-bits) 0 = ] + } 1&& ; diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index 58dab74cdb..41f19b9b07 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -56,7 +56,7 @@ SYMBOL: and-needed? : text-with-scale ( index seq -- str ) [ nth 3digits>text ] [ drop scale-numbers ] 2bi - [ " " swap 3append ] unless-empty ; + [ " " glue ] unless-empty ; : append-with-conjunction ( str1 str2 -- newstr ) over length zero? [ diff --git a/extra/money/money.factor b/extra/money/money.factor index b7da97ca06..553c473cce 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -12,7 +12,7 @@ CHAR: $ \ currency-token set-global : (money>string) ( dollars cents -- string ) [ number>string ] bi@ [ 3 group "," join ] - [ 2 CHAR: 0 pad-left ] bi* "." swap 3append ; + [ 2 CHAR: 0 pad-left ] bi* "." glue ; : money>string ( object -- string ) dollars/cents (money>string) currency-token get prefix ; diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 0120891e12..ac02efba69 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -28,7 +28,7 @@ IN: printf [ 0 ] [ string>number ] if-empty ; : pad-digits ( string digits -- string' ) - [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ; + [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ; : max-digits ( n digits -- n' ) 10 swap ^ [ * round ] keep / ; diff --git a/extra/project-euler/002/002-tests.factor b/extra/project-euler/002/002-tests.factor index bb02518580..46015bee3e 100644 --- a/extra/project-euler/002/002-tests.factor +++ b/extra/project-euler/002/002-tests.factor @@ -3,3 +3,4 @@ IN: project-euler.002.tests [ 4613732 ] [ euler002 ] unit-test [ 4613732 ] [ euler002a ] unit-test +[ 4613732 ] [ euler002b ] unit-test diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index fae535cba9..da20c874b5 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer, Alexander Solovyov. +! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences shuffle ; IN: project-euler.002 @@ -50,4 +50,31 @@ PRIVATE> ! [ euler002a ] 100 ave-time ! 0 ms ave run time - 0.2 SD (100 trials) -MAIN: euler002a + + [ + 3drop + ] [ + [ ?retotal next-fibs ] dip (sum-even-fibs-below) + ] if ; + +PRIVATE> + +: sum-even-fibs-below ( max -- sum ) + [ 0 0 1 ] dip (sum-even-fibs-below) ; + +: euler002b ( -- answer ) + 4000000 sum-even-fibs-below ; + +! [ euler002b ] 100 ave-time +! 0 ms ave run time - 0.0 SD (100 trials) + +MAIN: euler002b diff --git a/extra/project-euler/050/050-tests.factor b/extra/project-euler/050/050-tests.factor new file mode 100644 index 0000000000..2bd5482f7e --- /dev/null +++ b/extra/project-euler/050/050-tests.factor @@ -0,0 +1,6 @@ +USING: project-euler.050 project-euler.050.private tools.test ; +IN: project-euler.050.tests + +[ 41 ] [ 100 solve ] unit-test +[ 953 ] [ 1000 solve ] unit-test +[ 997651 ] [ euler050 ] unit-test diff --git a/extra/project-euler/050/050.factor b/extra/project-euler/050/050.factor new file mode 100644 index 0000000000..f8ce68d173 --- /dev/null +++ b/extra/project-euler/050/050.factor @@ -0,0 +1,90 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel locals math math.primes sequences ; +IN: project-euler.050 + +! http://projecteuler.net/index.php?section=problems&id=50 + +! DESCRIPTION +! ----------- + +! The prime 41, can be written as the sum of six consecutive primes: + +! 41 = 2 + 3 + 5 + 7 + 11 + 13 + +! This is the longest sum of consecutive primes that adds to a prime below +! one-hundred. + +! The longest sum of consecutive primes below one-thousand that adds to a +! prime, contains 21 terms, and is equal to 953. + +! Which prime, below one-million, can be written as the sum of the most +! consecutive primes? + + +! SOLUTION +! -------- + +! 1) Create an sequence of all primes under 1000000. +! 2) Start summing elements in the sequence until the next number would put you +! over 1000000. +! 3) Check if that sum is prime, if not, subtract the last number added. +! 4) Repeat step 3 until you get a prime number, and store it along with the +! how many consecutive numbers from the original sequence it took to get there. +! 5) Drop the first number from the sequence of primes, and do steps 2-4 again +! 6) Compare the longest chain from the first run with the second run, and store +! the longer of the two. +! 7) If the sequence of primes is still longer than the longest chain, then +! repeat steps 5-7...otherwise, you've found the longest sum of consecutive +! primes! + + ] find + [ swapd - ] [ drop seq length swap ] if* ; + +: pop-until-prime ( seq sum -- seq prime ) + over length 0 > [ + [ unclip-last-slice ] dip swap - + dup prime? [ pop-until-prime ] unless + ] [ + 2drop { } 0 + ] if ; + +! a pair is { length of chain, prime the chain sums to } + +: longest-prime ( seq limit -- pair ) + dupd sum-upto dup prime? [ + 2array nip + ] [ + [ head-slice ] dip pop-until-prime + [ length ] dip 2array + ] if ; + +: longest ( pair pair -- longest ) + 2dup [ first ] bi@ > [ drop ] [ nip ] if ; + +: continue? ( pair seq -- ? ) + [ first ] [ length 1- ] bi* < ; + +: (find-longest) ( best seq limit -- best ) + [ longest-prime longest ] 2keep 2over continue? [ + [ rest-slice ] dip (find-longest) + ] [ 2drop ] if ; + +: find-longest ( seq limit -- best ) + { 1 2 } -rot (find-longest) ; + +: solve ( n -- answer ) + [ primes-upto ] keep find-longest second ; + +PRIVATE> + +: euler050 ( -- answer ) + 1000000 solve ; + +! [ euler050 ] 100 ave-time +! 291 ms run / 20.6 ms GC ave time - 100 trials + +MAIN: euler050 diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index f176bbc7d2..a7762836f1 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,21 +1,24 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: continuations fry io kernel make math math.functions math.parser math.statistics memory tools.time ; IN: project-euler.ave-time +: nth-place ( x n -- y ) + 10 swap ^ [ * round >integer ] keep /f ; + : collect-benchmarks ( quot n -- seq ) [ [ datastack ] - [ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ] + [ + '[ _ gc benchmark 1000 / , ] tuck + '[ _ _ with-datastack drop ] + ] [ 1- ] tri* swap times call ] { } make ; inline -: nth-place ( x n -- y ) - 10 swap ^ [ * round ] keep / ; - : ave-time ( quot n -- ) [ collect-benchmarks ] keep swap - [ std 2 nth-place ] [ mean round ] bi [ + [ std 2 nth-place ] [ mean round >integer ] bi [ # " ms ave run time - " % # " SD (" % # " trials)" % ] "" make print flush ; inline diff --git a/extra/sequences/complex-components/authors.txt b/extra/sequences/complex-components/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/sequences/complex-components/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/sequences/complex-components/complex-components-docs.factor b/extra/sequences/complex-components/complex-components-docs.factor new file mode 100644 index 0000000000..de1bed38a7 --- /dev/null +++ b/extra/sequences/complex-components/complex-components-docs.factor @@ -0,0 +1,33 @@ +USING: help.markup help.syntax math multiline +sequences sequences.complex-components ; +IN: sequences.complex-components + +ARTICLE: "sequences.complex-components" "Complex component virtual sequences" +"The " { $link complex-components } " class wraps a sequence of " { $link complex } " number values, presenting a sequence of " { $link real } " values made by interleaving the real and imaginary parts of the complex values in the original sequence." +{ $subsection complex-components } +{ $subsection } ; + +ABOUT: "sequences.complex-components" + +HELP: complex-components +{ $class-description "Sequence wrapper class that transforms a sequence of " { $link complex } " number values into a sequence of " { $link real } " values, interleaving the real and imaginary parts of the complex values in the original sequence." } +{ $examples { $example <" +USING: sequences arrays sequences.complex-components ; +{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } >array +"> "{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ; + +HELP: +{ $values { "sequence" sequence } { "complex-components" complex-components } } +{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-components } " wrapper." } +{ $examples +{ $example <" +USING: sequences arrays sequences.complex-components ; +{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } third +"> "-2.0" } +{ $example <" +USING: sequences arrays sequences.complex-components ; +{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } fourth +"> "0" } +} ; + +{ complex-components } related-words diff --git a/extra/sequences/complex-components/complex-components-tests.factor b/extra/sequences/complex-components/complex-components-tests.factor new file mode 100644 index 0000000000..f0c8e92c6e --- /dev/null +++ b/extra/sequences/complex-components/complex-components-tests.factor @@ -0,0 +1,16 @@ +USING: sequences.complex-components +kernel sequences tools.test arrays accessors ; +IN: sequences.complex-components.tests + +: test-array ( -- x ) + { C{ 1.0 2.0 } 3.0 C{ 5.0 6.0 } } ; + +[ 6 ] [ test-array length ] unit-test + +[ 1.0 ] [ test-array first ] unit-test +[ 2.0 ] [ test-array second ] unit-test +[ 3.0 ] [ test-array third ] unit-test +[ 0 ] [ test-array fourth ] unit-test + +[ { 1.0 2.0 3.0 0 5.0 6.0 } ] [ test-array >array ] unit-test + diff --git a/extra/sequences/complex-components/complex-components.factor b/extra/sequences/complex-components/complex-components.factor new file mode 100644 index 0000000000..bca7e2c0a2 --- /dev/null +++ b/extra/sequences/complex-components/complex-components.factor @@ -0,0 +1,28 @@ +USING: accessors kernel math math.functions combinators +sequences sequences.private ; +IN: sequences.complex-components + +TUPLE: complex-components seq ; +INSTANCE: complex-components sequence + +: ( sequence -- complex-sequence ) + complex-components boa ; inline + +> ] bi* ; inline +: complex-component ( remainder complex -- component ) + swap { + { 0 [ real-part ] } + { 1 [ imaginary-part ] } + } case ; + +PRIVATE> + +M: complex-components length + seq>> length 1 shift ; +M: complex-components nth-unsafe + complex-components@ nth-unsafe complex-component ; +M: complex-components set-nth-unsafe + immutable ; diff --git a/extra/sequences/complex-components/summary.txt b/extra/sequences/complex-components/summary.txt new file mode 100644 index 0000000000..af00158213 --- /dev/null +++ b/extra/sequences/complex-components/summary.txt @@ -0,0 +1 @@ +Virtual sequence wrapper to convert complex values into real value pairs diff --git a/extra/sequences/complex-components/tags.txt b/extra/sequences/complex-components/tags.txt new file mode 100644 index 0000000000..64cdcd9e69 --- /dev/null +++ b/extra/sequences/complex-components/tags.txt @@ -0,0 +1,2 @@ +sequences +math diff --git a/extra/sequences/complex/authors.txt b/extra/sequences/complex/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/sequences/complex/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/sequences/complex/complex-docs.factor b/extra/sequences/complex/complex-docs.factor new file mode 100644 index 0000000000..d4d8dfc7a2 --- /dev/null +++ b/extra/sequences/complex/complex-docs.factor @@ -0,0 +1,29 @@ +USING: help.markup help.syntax math multiline +sequences sequences.complex ; +IN: sequences.complex + +ARTICLE: "sequences.complex" "Complex virtual sequences" +"The " { $link complex-sequence } " class wraps a sequence of " { $link real } " number values, presenting a sequence of " { $link complex } " values made by treating the underlying sequence as pairs of alternating real and imaginary values." +{ $subsection complex-sequence } +{ $subsection } ; + +ABOUT: "sequences.complex" + +HELP: complex-sequence +{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." } +{ $examples { $example <" +USING: specialized-arrays.double sequences.complex +sequences arrays ; +double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } >array +"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ; + +HELP: +{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } } +{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." } +{ $examples { $example <" +USING: specialized-arrays.double sequences.complex +sequences arrays ; +double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } second +"> "C{ -2.0 2.0 }" } } ; + +{ complex-sequence } related-words diff --git a/extra/sequences/complex/complex-tests.factor b/extra/sequences/complex/complex-tests.factor new file mode 100644 index 0000000000..5861bc8b02 --- /dev/null +++ b/extra/sequences/complex/complex-tests.factor @@ -0,0 +1,26 @@ +USING: specialized-arrays.float sequences.complex +kernel sequences tools.test arrays accessors ; +IN: sequences.complex.tests + +: test-array ( -- x ) + float-array{ 1.0 2.0 3.0 4.0 } clone ; +: odd-length-test-array ( -- x ) + float-array{ 1.0 2.0 3.0 4.0 5.0 } clone ; + +[ 2 ] [ test-array length ] unit-test +[ 2 ] [ odd-length-test-array length ] unit-test + +[ C{ 1.0 2.0 } ] [ test-array first ] unit-test +[ C{ 3.0 4.0 } ] [ test-array second ] unit-test + +[ { C{ 1.0 2.0 } C{ 3.0 4.0 } } ] +[ test-array >array ] unit-test + +[ float-array{ 1.0 2.0 5.0 6.0 } ] +[ test-array [ C{ 5.0 6.0 } 1 rot set-nth ] [ seq>> ] bi ] +unit-test + +[ float-array{ 7.0 0.0 3.0 4.0 } ] +[ test-array [ 7.0 0 rot set-nth ] [ seq>> ] bi ] +unit-test + diff --git a/extra/sequences/complex/complex.factor b/extra/sequences/complex/complex.factor new file mode 100644 index 0000000000..93f9727f75 --- /dev/null +++ b/extra/sequences/complex/complex.factor @@ -0,0 +1,25 @@ +USING: accessors kernel math math.functions +sequences sequences.private ; +IN: sequences.complex + +TUPLE: complex-sequence seq ; +INSTANCE: complex-sequence sequence + +: ( sequence -- complex-sequence ) + complex-sequence boa ; inline + +> ] bi* ; inline + +PRIVATE> + +M: complex-sequence length + seq>> length -1 shift ; +M: complex-sequence nth-unsafe + complex@ [ nth-unsafe ] [ [ 1+ ] dip nth-unsafe ] 2bi rect> ; +M: complex-sequence set-nth-unsafe + complex@ + [ [ real-part ] [ ] [ ] tri* set-nth-unsafe ] + [ [ imaginary-part ] [ 1+ ] [ ] tri* set-nth-unsafe ] 3bi ; diff --git a/extra/sequences/complex/summary.txt b/extra/sequences/complex/summary.txt new file mode 100644 index 0000000000..d94c4ba0f0 --- /dev/null +++ b/extra/sequences/complex/summary.txt @@ -0,0 +1 @@ +Virtual sequence wrapper to convert real pairs into complex values diff --git a/extra/sequences/complex/tags.txt b/extra/sequences/complex/tags.txt new file mode 100644 index 0000000000..64cdcd9e69 --- /dev/null +++ b/extra/sequences/complex/tags.txt @@ -0,0 +1,2 @@ +sequences +math diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0674b8d9d2..72944c09b4 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -23,11 +23,11 @@ IN: sequences.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : each-percent ( seq quot -- ) - >r - dup length - dup [ / ] curry - [ 1+ ] prepose - r> compose + [ + dup length + dup [ / ] curry + [ 1+ ] prepose + ] dip compose 2each ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -68,7 +68,7 @@ IN: sequences.lib : minmax ( seq -- min max ) #! find the min and max of a seq in one pass - 1/0. -1/0. rot [ tuck max >r min r> ] each ; + 1/0. -1/0. rot [ tuck max [ min ] dip ] each ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -78,7 +78,7 @@ IN: sequences.lib : (monotonic-split) ( seq quot -- newseq ) [ - >r dup unclip suffix r> + [ dup unclip suffix ] dip v, [ pick ,, call [ v, ] unless ] curry 2each ,v ] { } make ; @@ -88,7 +88,7 @@ IN: sequences.lib ERROR: element-not-found ; : split-around ( seq quot -- before elem after ) dupd find over [ element-not-found ] unless - >r cut rest r> swap ; inline + [ cut rest ] dip swap ; inline : map-until ( seq quot pred -- newseq ) '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ; @@ -115,14 +115,14 @@ ERROR: element-not-found ; PRIVATE> : exact-strings ( alphabet length -- seqs ) - >r dup length r> exact-number-strings map-alphabet ; + [ dup length ] dip exact-number-strings map-alphabet ; : strings ( alphabet length -- seqs ) - >r dup length r> number-strings map-alphabet ; + [ dup length ] dip number-strings map-alphabet ; : switches ( seq1 seq -- subseq ) ! seq1 is a sequence of ones and zeroes - >r [ length ] keep [ nth 1 = ] curry filter r> + [ [ length ] keep [ nth 1 = ] curry filter ] dip [ nth ] curry { } map-as ; : power-set ( seq -- subsets ) @@ -147,7 +147,3 @@ PRIVATE> dup length 1 (a,b] [ dup random pick exchange ] each ; : enumerate ( seq -- seq' ) >alist ; - -: splice ( left-seq right-seq seq -- newseq ) swap 3append ; - -: surround ( seq left-seq right-seq -- newseq ) swapd 3append ; diff --git a/extra/sto/sto.factor b/extra/sto/sto.factor new file mode 100644 index 0000000000..b43c9cc359 --- /dev/null +++ b/extra/sto/sto.factor @@ -0,0 +1,20 @@ + +USING: kernel lexer parser words quotations compiler.units ; + +IN: sto + +! Use 'sto' to bind a value on the stack to a word. +! +! Example: +! +! 10 sto A + +: sto + \ 1quotation parsed + scan + current-vocab create + dup set-word + literalize parsed + \ swap parsed + [ define ] parsed + \ with-compilation-unit parsed ; parsing diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index e035090fb0..c16450bb25 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -50,7 +50,7 @@ M: entity feed-entry-date date>> ; TUPLE: post < entity title comments ; M: post feed-entry-title - [ author>> ] [ title>> ] bi ": " swap 3append ; + [ author>> ] [ title>> ] bi ": " glue ; M: post entity-url id>> view-post-url ; diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index af7c8b61ce..bc429a0af6 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math.ranges sequences random accessors combinators.lib +USING: math.ranges sequences random accessors kernel namespaces fry db.types db.tuples urls validators html.components html.forms http http.server.dispatchers furnace furnace.actions furnace.boilerplate furnace.redirection -furnace.utilities ; +furnace.utilities continuations ; IN: webapps.wee-url TUPLE: wee-url < dispatcher ;