Merge branch 'master' of git://factorcode.org/git/factor
commit
0f9a707c55
|
@ -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
|
||||
|
|
|
@ -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: <simple-statement> db ( str in out -- statement )
|
||||
HOOK: <prepared-statement> db ( str in out -- statement )
|
||||
HOOK: <simple-statement> db ( string in out -- statement )
|
||||
HOOK: <prepared-statement> db ( string in out -- statement )
|
||||
GENERIC: prepare-statement ( statement -- )
|
||||
GENERIC: bind-statement* ( statement -- )
|
||||
GENERIC: low-level-bind ( statement -- )
|
||||
|
|
|
@ -6,6 +6,5 @@ IN: db.errors
|
|||
ERROR: db-error ;
|
||||
ERROR: sql-error ;
|
||||
|
||||
|
||||
ERROR: table-exists ;
|
||||
ERROR: bad-schema ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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@ ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -57,8 +57,7 @@ IN: db.sqlite.tests
|
|||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
[ ] [
|
||||
test.db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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>> ;
|
||||
|
||||
|
|
|
@ -246,7 +246,7 @@ IN: tools.deploy.shaker
|
|||
word
|
||||
} %
|
||||
|
||||
{ } { "optimizer.math.partial" } strip-vocab-globals %
|
||||
{ } { "math.partial-dispatch" } strip-vocab-globals %
|
||||
] when
|
||||
|
||||
strip-prettyprint? [
|
||||
|
|
|
@ -0,0 +1,4 @@
|
|||
IN: ui.gadgets.canvas.tests
|
||||
USING: ui.gadgets.canvas tools.test kernel ;
|
||||
|
||||
{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as
|
|
@ -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
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 >= [
|
||||
|
|
|
@ -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:"
|
||||
|
|
Loading…
Reference in New Issue