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

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

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 )
+: make-db ( seq class -- db ) new-db make-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
+            [ insert-statements>> dispose-statements ]
-        dup delete-statements>> dispose-statements
+            [ update-statements>> dispose-statements ]
-        handle>> db-close
+            [ 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: <simple-statement> db ( str in out -- statement )
+HOOK: <simple-statement> db ( string in out -- statement )
-HOOK: <prepared-statement> db ( str in out -- statement )
+HOOK: <prepared-statement> db ( string in out -- statement )
 GENERIC: prepare-statement ( statement -- )
 GENERIC: bind-statement* ( statement -- )
 GENERIC: low-level-bind ( statement -- )

basis/db/errors/errors.factor

@@ -6,6 +6,5 @@ IN: db.errors
 ERROR: db-error ;
 ERROR: sql-error ;
 
-
 ERROR: table-exists ;
 ERROR: bad-schema ;

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

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@ ;

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 ;

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')"

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 ;
 

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>> ;
 

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? [

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

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
+    [ drop ] [ GL_COMPILE swap make-dlist ] 2bi
-    [ >>dlist drop ] keep ;
+    [ >>dlist drop ] keep ; inline
 
 : cache-canvas-dlist ( canvas quot -- dlist )
     over dlist>> dup

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." }

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

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
+    double>bits -51 shift HEX: fff [ bitand ] keep = ;
-    number= ;
+
+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 >= [

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 }
+{ $subsection exit } ;
-{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
 
 ARTICLE: "environment-variables" "Environment variables"
 "Reading environment variables:"