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

db4
Slava Pestov 2008-09-03 03:47:15 -05:00
commit 0f9a707c55
16 changed files with 70 additions and 44 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -57,8 +57,7 @@ IN: db.sqlite.tests
] with-db
] unit-test
[
] [
[ ] [
test.db [
[
"insert into person(name, country) values('Jose', 'Mexico')"

View File

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

View File

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

View File

@ -246,7 +246,7 @@ IN: tools.deploy.shaker
word
} %
{ } { "optimizer.math.partial" } strip-vocab-globals %
{ } { "math.partial-dispatch" } strip-vocab-globals %
] when
strip-prettyprint? [

View File

@ -0,0 +1,4 @@
IN: ui.gadgets.canvas.tests
USING: ui.gadgets.canvas tools.test kernel ;
{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as

4
basis/ui/gadgets/canvas/canvas.factor Normal file → Executable file
View File

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

View File

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

View File

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

View File

@ -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 >= [

View File

@ -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:"