diff --git a/basis/db/db-tests.factor b/basis/db/db-tests.factor index 0d95e3aea7..3f1dab2c37 100755 --- a/basis/db/db-tests.factor +++ b/basis/db/db-tests.factor @@ -1,5 +1,5 @@ -IN: db.tests USING: tools.test db kernel ; +IN: db.tests { 1 0 } [ [ drop ] query-each ] must-infer-as { 1 1 } [ [ ] query-map ] must-infer-as diff --git a/basis/db/db.factor b/basis/db/db.factor index c52d1db148..c269341240 100755 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations destructors kernel math namespaces sequences sequences.lib classes.tuple words strings -tools.walker accessors combinators.lib ; +tools.walker accessors combinators.lib combinators ; IN: db TUPLE: db @@ -15,24 +15,25 @@ TUPLE: db new H{ } clone >>insert-statements H{ } clone >>update-statements - H{ } clone >>delete-statements ; + H{ } clone >>delete-statements ; inline -GENERIC: make-db* ( seq class -- db ) +GENERIC: make-db* ( seq db -- db ) -: make-db ( seq class -- db ) - new-db make-db* ; +: make-db ( seq class -- db ) new-db make-db* ; GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) : dispose-statements ( assoc -- ) values dispose-each ; -: dispose-db ( db -- ) +: db-dispose ( db -- ) dup db [ - dup insert-statements>> dispose-statements - dup update-statements>> dispose-statements - dup delete-statements>> dispose-statements - handle>> db-close + { + [ insert-statements>> dispose-statements ] + [ update-statements>> dispose-statements ] + [ delete-statements>> dispose-statements ] + [ handle>> db-close ] + } cleave ] with-variable ; TUPLE: statement handle sql in-params out-params bind-params bound? type retries ; @@ -47,8 +48,8 @@ TUPLE: result-set sql in-params out-params handle n max ; swap >>in-params swap >>sql ; -HOOK: db ( str in out -- statement ) -HOOK: db ( str in out -- statement ) +HOOK: db ( string in out -- statement ) +HOOK: db ( string in out -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( statement -- ) GENERIC: low-level-bind ( statement -- ) diff --git a/basis/db/errors/errors.factor b/basis/db/errors/errors.factor index 1e0d1e7fb4..da6301639f 100644 --- a/basis/db/errors/errors.factor +++ b/basis/db/errors/errors.factor @@ -6,6 +6,5 @@ IN: db.errors ERROR: db-error ; ERROR: sql-error ; - ERROR: table-exists ; ERROR: bad-schema ; diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index e57efbc360..692241fab0 100755 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -16,7 +16,7 @@ TUPLE: postgresql-statement < statement ; TUPLE: postgresql-result-set < result-set ; -M: postgresql-db make-db* ( seq tuple -- db ) +M: postgresql-db make-db* ( seq db -- db ) >r first4 r> swap >>db swap >>pass diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 3a751a9736..e5334703f6 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -43,13 +43,6 @@ M: random-id-generator eval-generator ( singleton -- obj ) : interval-comparison ( ? str -- str ) "from" = " >" " <" ? swap [ "= " append ] when ; -: fp-infinity? ( float -- ? ) - dup float? [ - double>bits -52 shift 11 2^ 1- [ bitand ] keep = - ] [ - drop f - ] if ; - : (infinite-interval?) ( interval -- ?1 ?2 ) [ from>> ] [ to>> ] bi [ first fp-infinity? ] bi@ ; diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index b443f53e78..9f033a1d3c 100755 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -118,6 +118,7 @@ FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; +! Bind the same function as above, but for unsigned 64bit integers : sqlite3-bind-uint64 ( pStmt index in64 -- int ) "int" "sqlite" "sqlite3_bind_int64" { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; @@ -131,6 +132,7 @@ FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; +! Bind the same function as above, but for unsigned 64bit integers : sqlite3-column-uint64 ( pStmt col -- uint64 ) "sqlite3_uint64" "sqlite" "sqlite3_column_int64" { "sqlite3_stmt*" "int" } alien-invoke ; diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index b30cb4ba80..67eac2702b 100755 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -57,8 +57,7 @@ IN: db.sqlite.tests ] with-db ] unit-test -[ -] [ +[ ] [ test.db [ [ "insert into person(name, country) values('Jose', 'Mexico')" diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 231b60e083..49d79b1b8c 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -19,7 +19,7 @@ M: sqlite-db db-open ( db -- db ) dup path>> sqlite-open >>handle ; M: sqlite-db db-close ( handle -- ) sqlite-close ; -M: sqlite-db dispose ( db -- ) dispose-db ; +M: sqlite-db dispose ( db -- ) db-dispose ; TUPLE: sqlite-statement < statement ; diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index c3480093c5..2efa41c401 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -8,7 +8,7 @@ classes.singleton accessors quotations random ; IN: db.types HOOK: persistent-table db ( -- hash ) -HOOK: compound db ( str obj -- hash ) +HOOK: compound db ( string obj -- hash ) TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; @@ -78,7 +78,7 @@ FACTOR-BLOB NULL URL ; swap >>class dup normalize-spec ; -: number>string* ( n/str -- str ) +: number>string* ( n/string -- string ) dup number? [ number>string ] when ; : remove-db-assigned-id ( specs -- obj ) @@ -97,7 +97,7 @@ FACTOR-BLOB NULL URL ; ERROR: unknown-modifier ; -: lookup-modifier ( obj -- str ) +: lookup-modifier ( obj -- string ) { { [ dup array? ] [ unclip lookup-modifier swap compound ] } [ persistent-table at* [ unknown-modifier ] unless third ] @@ -105,43 +105,43 @@ ERROR: unknown-modifier ; ERROR: no-sql-type ; -: (lookup-type) ( obj -- str ) +: (lookup-type) ( obj -- string ) persistent-table at* [ no-sql-type ] unless ; -: lookup-type ( obj -- str ) +: lookup-type ( obj -- string ) dup array? [ unclip (lookup-type) first nip ] [ (lookup-type) first ] if ; -: lookup-create-type ( obj -- str ) +: lookup-create-type ( obj -- string ) dup array? [ unclip (lookup-type) second swap compound ] [ (lookup-type) second ] if ; -: single-quote ( str -- newstr ) +: single-quote ( string -- new-string ) "'" swap "'" 3append ; -: double-quote ( str -- newstr ) +: double-quote ( string -- new-string ) "\"" swap "\"" 3append ; -: paren ( str -- newstr ) +: paren ( string -- new-string ) "(" swap ")" 3append ; -: join-space ( str1 str2 -- newstr ) +: join-space ( string1 string2 -- new-string ) " " swap 3append ; -: modifiers ( spec -- str ) +: modifiers ( spec -- string ) modifiers>> [ lookup-modifier ] map " " join dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) -: offset-of-slot ( str obj -- n ) +: offset-of-slot ( string obj -- n ) class superclasses [ "slots" word-prop ] map concat slot-named offset>> ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 36fe015611..833528018b 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -246,7 +246,7 @@ IN: tools.deploy.shaker word } % - { } { "optimizer.math.partial" } strip-vocab-globals % + { } { "math.partial-dispatch" } strip-vocab-globals % ] when strip-prettyprint? [ diff --git a/basis/ui/gadgets/canvas/canvas-tests.factor b/basis/ui/gadgets/canvas/canvas-tests.factor new file mode 100755 index 0000000000..bc87064c92 --- /dev/null +++ b/basis/ui/gadgets/canvas/canvas-tests.factor @@ -0,0 +1,4 @@ +IN: ui.gadgets.canvas.tests +USING: ui.gadgets.canvas tools.test kernel ; + +{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor old mode 100644 new mode 100755 index b137fd888d..85149f4551 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -16,8 +16,8 @@ TUPLE: canvas < gadget dlist ; [ f >>dlist drop ] tri ; : make-canvas-dlist ( canvas quot -- dlist ) - [ GL_COMPILE ] dip make-dlist - [ >>dlist drop ] keep ; + [ drop ] [ GL_COMPILE swap make-dlist ] 2bi + [ >>dlist drop ] keep ; inline : cache-canvas-dlist ( canvas quot -- dlist ) over dlist>> dup diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index cc59094529..b38baa5cc9 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -301,6 +301,16 @@ HELP: fp-nan? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; +HELP: fp-infinity? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } +{ $examples + { $example "USING: math prettyprint ;" "1/0. fp-infinity? ." "t" } + { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi [ \"negative infinity\" print ] when" "negative infinity" } +} ; + +{ fp-nan? fp-infinity? } related-words + HELP: real-part { $values { "z" number } { "x" real } } { $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index fcd3b929ea..d72bb67970 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -9,3 +9,10 @@ IN: math.tests [ [ 0 1 2 3 4 ] ] [ [ 5 [ , ] each-integer ] [ ] make ] unit-test [ [ ] ] [ [ -1 [ , ] each-integer ] [ ] make ] unit-test +[ f ] [ 1/0. fp-nan? ] unit-test +[ f ] [ -1/0. fp-nan? ] unit-test +[ t ] [ -0/0. fp-nan? ] unit-test + +[ t ] [ 1/0. fp-infinity? ] unit-test +[ t ] [ -1/0. fp-infinity? ] unit-test +[ f ] [ -0/0. fp-infinity? ] unit-test diff --git a/core/math/math.factor b/core/math/math.factor index 024a32087e..6efdd53825 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -88,8 +88,20 @@ M: object fp-nan? drop f ; M: float fp-nan? - double>bits -51 shift BIN: 111111111111 [ bitand ] keep - number= ; + double>bits -51 shift HEX: fff [ bitand ] keep = ; + +GENERIC: fp-infinity? ( x -- ? ) + +M: object fp-infinity? + drop f ; + +M: float fp-infinity? ( float -- ? ) + double>bits + dup -52 shift HEX: 7ff [ bitand ] keep = [ + HEX: fffffffffffff bitand 0 = + ] [ + drop f + ] if ; : (next-power-of-2) ( i n -- n ) 2dup >= [ diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 5aac0a8e8c..49886492ec 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -14,8 +14,7 @@ ARTICLE: "system" "System interface" "Getting the current time:" { $subsection millis } "Exiting the Factor VM:" -{ $subsection exit } -{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; +{ $subsection exit } ; ARTICLE: "environment-variables" "Environment variables" "Reading environment variables:"