steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2009-05-01 13:04:07 -05:00
parent 471fe2c272 06bc18342c
commit 45f196214f
8 changed files with 87 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/compiler/tree/propagation/info/info.factor
View File

@ -59,21 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
: <value-info> ( -- info ) \ value-info new ; : <value-info> ( -- info ) \ value-info new ;
: read-only-slots ( values class -- slots )
all-slots
[ read-only>> [ drop f ] unless ] 2map
f prefix ;
DEFER: <literal-info> DEFER: <literal-info>
: tuple-slot-infos ( tuple -- slots )
[ tuple-slots ] [ class all-slots ] bi
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
f prefix ;
: init-literal-info ( info -- info ) : init-literal-info ( info -- info )
dup literal>> class >>class dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [ dup literal>> dup real? [ [a,a] >>interval ] [
[ [-inf,inf] >>interval ] dip [ [-inf,inf] >>interval ] dip
dup tuple? [ dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
[ tuple-slots [ <literal-info> ] map ] [ class ] bi
read-only-slots >>slots
] [ drop ] if
] if ; inline ] if ; inline
: init-value-info ( info -- info ) : init-value-info ( info -- info )

7
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm specialized-arrays.double system sorting math.libm
math.intervals ; math.intervals quotations ;
IN: compiler.tree.propagation.tests IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test [ V{ } ] [ [ ] final-classes ] unit-test
@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test [ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
! Mutable tuples with circularity should not cause problems
TUPLE: circle me ;
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test

7
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -30,8 +30,13 @@ UNION: fixed-length-sequence array byte-array string ;
[ [ literal>> ] map ] dip prefix >tuple [ [ literal>> ] map ] dip prefix >tuple
<literal-info> ; <literal-info> ;
: read-only-slots ( values class -- slots )
all-slots
[ read-only>> [ value-info ] [ drop f ] if ] 2map
f prefix ;
: (propagate-tuple-constructor) ( values class -- info ) : (propagate-tuple-constructor) ( values class -- info )
[ [ value-info ] map ] dip [ read-only-slots ] keep [ read-only-slots ] keep
over rest-slice [ dup [ literal?>> ] when ] all? [ over rest-slice [ dup [ literal?>> ] when ] all? [
[ rest-slice ] dip fold-<tuple-boa> [ rest-slice ] dip fold-<tuple-boa>
] [ ] [

10
extra/bson/writer/writer.factor
View File

@ -6,11 +6,8 @@ io.encodings.utf8 io.streams.byte-array kernel math math.parser
namespaces quotations sequences sequences.private serialize strings namespaces quotations sequences sequences.private serialize strings
words combinators.short-circuit literals ; words combinators.short-circuit literals ;
IN: bson.writer IN: bson.writer
#! Writes the object out to a byte-vector in BSON format
<PRIVATE <PRIVATE
SYMBOL: shared-buffer SYMBOL: shared-buffer
@ -24,10 +21,9 @@ CONSTANT: INT64-SIZE 8
[ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline [ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
: >le-stream ( x n -- ) : >le-stream ( x n -- )
! >le write swap
swap '[ _ swap nth-byte 0 B{ 0 } '[ _ swap nth-byte 0 B{ 0 }
[ set-nth-unsafe ] keep write ] each [ set-nth-unsafe ] keep write ] each ; inline
; inline
PRIVATE> PRIVATE>

110
extra/mongodb/driver/driver-docs.factor
View File

@ -8,10 +8,8 @@ HELP: <mdb-collection>
{ "name" "name of the collection" } { "name" "name of the collection" }
{ "collection" "mdb-collection instance" } { "collection" "mdb-collection instance" }
} }
{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections. See also: " { $link mdb-collection } } { $examples { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" <mdb-collection> t >>capped 1000000 >>max" "" } }
{ $examples { $description "Creates a new mdb-collection instance. Use this to create capped/limited collections." } ;
{ $example "! creates a mdb-collection instance capped to a maximum of 1000000 entries"
"\"mycollection\" <mdb-collection> t >>capped 1000000 >>max" } } ;
HELP: <mdb> HELP: <mdb>
{ $values { $values
@ -22,7 +20,7 @@ HELP: <mdb>
} }
{ $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." } { $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." }
{ $examples { $examples
{ $example "\"db\" \"127.0.0.1\" 27017 <mdb>" } } ; { $unchecked-example "USING: mongodb.driver ;" "\"db\" \"127.0.0.1\" 27017 <mdb>" "" } } ;
HELP: <query> HELP: <query>
{ $values { $values
@ -35,7 +33,7 @@ HELP: <query>
"For more see: " "For more see: "
{ $link with-db } } { $link with-db } }
{ $examples { $examples
{ $example "\"mycollection\" H{ } <query>" } } ; { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" H{ } <query>" "" } } ;
HELP: <update> HELP: <update>
{ $values { $values
@ -118,22 +116,22 @@ HELP: drop-index
HELP: ensure-collection HELP: ensure-collection
{ $values { $values
{ "collection" "a collection; e.g. mycollection " } { "name" "a collection; e.g. mycollection " }
{ "fq-collection" "full qualified collection name; e.g. db.mycollection" }
} }
{ $description "ensures that the collection exists in the database and returns its full qualified name" } ; { $description "ensures that the collection exists in the database" } ;
HELP: ensure-index HELP: ensure-index
{ $values { $values
{ "collection" "a collection" } { "index-spec" "an index specification" }
{ "name" "index name" }
{ "spec" "index spec" }
} }
{ $description "Ensures the existence of the given index. " { $description "Ensures the existence of the given index. "
"For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } } "For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } }
{ $examples { $examples
{ $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index" } { $unchecked-example "USING: mongodb.driver ;"
{ $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index" } } ; "\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
{ $unchecked-example "USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ;
HELP: explain. HELP: explain.
{ $values { $values
@ -143,31 +141,35 @@ HELP: explain.
HELP: find HELP: find
{ $values { $values
{ "mdb-query" "a query" } { "selector" "a mdb-query or mdb-cursor" }
{ "cursor" "a cursor (if there are more results) or f" } { "mdb-cursor/f" "a cursor (if there are more results) or f" }
{ "result" "a sequences of objects" } { "seq" "a sequences of objects" }
} }
{ $description "executes the given query" } { $description "executes the given query" }
{ $examples { $examples
{ $example "\"mycollection\" H{ { \"name\" \"Alfred\" } } <query> find " } } ; { $unchecked-example "USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" H{ { \"name\" \"Alfred\" } } <query> find ] with-db" "" } } ;
HELP: find-one HELP: find-one
{ $values { $values
{ "mdb-query" "a query" } { "mdb-query-msg" "a query" }
{ "result" "a single object or f" } { "result/f" "a single object or f" }
} }
{ $description "Executes the query and returns one object at most" } ; { $description "Executes the query and returns one object at most" } ;
HELP: hint HELP: hint
{ $values { $values
{ "mdb-query" "a query" } { "mdb-query-msg" "a query" }
{ "index-hint" "a hint to an index" } { "index-hint" "a hint to an index" }
{ "mdb-query" "modified query object" } { "mdb-query-msg" "modified query object" }
} }
{ $description "Annotates the query with a hint to an index. " { $description "Annotates the query with a hint to an index. "
"For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } } "For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } }
{ $examples { $examples
{ $example "\"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } <query> H{ { \"name\" 1 } } hint find" } } ; { $unchecked-example "USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } <query> H{ { \"name\" 1 } } hint find ] with-db" "" } } ;
HELP: lasterror HELP: lasterror
{ $values { $values
@ -179,13 +181,15 @@ HELP: lasterror
HELP: limit HELP: limit
{ $values { $values
{ "mdb-query" "a query" } { "mdb-query-msg" "a query" }
{ "limit#" "number of objects that should be returned at most" } { "limit#" "number of objects that should be returned at most" }
{ "mdb-query" "modified query object" } { "mdb-query-msg" "modified query object" }
} }
{ $description "Limits the number of returned objects to limit#" } { $description "Limits the number of returned objects to limit#" }
{ $examples { $examples
{ $example "\"mycollection\" H{ } <query> 10 limit find" } } ; { $unchecked-example "USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" H{ } <query> 10 limit find ] with-db" "" } } ;
HELP: load-collection-list HELP: load-collection-list
{ $values { $values
@ -202,23 +206,23 @@ HELP: load-index-list
{ $description "Returns a list of all indexes that exist in the current database" } ; { $description "Returns a list of all indexes that exist in the current database" } ;
HELP: mdb-collection HELP: mdb-collection
{ $var-description "" } ; { $var-description "MongoDB collection" } ;
HELP: mdb-cursor HELP: mdb-cursor
{ $var-description "" } ; { $var-description "MongoDB cursor" } ;
HELP: mdb-error HELP: mdb-error
{ $values { $values
{ "msg" "error message" } { "msg" "error message" }
} }
{ $description "" } ; { $description "error class" } ;
HELP: r/ HELP: r/
{ $values { $values
{ "token" null } { "token" "a regexp string" }
{ "mdbregexp" null } { "mdbregexp" "a mdbregexp tuple instance" }
} }
{ $description "" } ; { $description "creates a new mdbregexp instance" } ;
HELP: save HELP: save
{ $values { $values
@ -230,53 +234,53 @@ HELP: save
HELP: save-unsafe HELP: save-unsafe
{ $values { $values
{ "collection" null } { "collection" "a collection" }
{ "object" object } { "assoc" "object" }
} }
{ $description "" } ; { $description "Save the object to the given collection without automatic error check" } ;
HELP: skip HELP: skip
{ $values { $values
{ "mdb-query" null } { "mdb-query-msg" "a query message" }
{ "skip#" null } { "skip#" "number of objects to skip" }
{ "mdb-query" null } { "mdb-query-msg" "annotated query message" }
} }
{ $description "" } ; { $description "annotates a query message with a number of objects to skip when returning the results" } ;
HELP: sort HELP: sort
{ $values { $values
{ "mdb-query" null } { "mdb-query-msg" "a query message" }
{ "quot" quotation } { "sort-quot" "a quotation with sort specifiers" }
{ "mdb-query" null } { "mdb-query-msg" "annotated query message" }
} }
{ $description "" } ; { $description "annotates the query message for sort specifiers" } ;
HELP: update HELP: update
{ $values { $values
{ "mdb-update-msg" null } { "mdb-update-msg" "a mdb-update message" }
} }
{ $description "" } ; { $description "performs an update" } ;
HELP: update-unsafe HELP: update-unsafe
{ $values { $values
{ "mdb-update-msg" null } { "mdb-update-msg" "a mdb-update message" }
} }
{ $description "" } ; { $description "performs an update without automatic error check" } ;
HELP: validate. HELP: validate.
{ $values { $values
{ "collection" null } { "collection" "collection to validate" }
} }
{ $description "" } ; { $description "validates the collection" } ;
HELP: with-db HELP: with-db
{ $values { $values
{ "mdb" null } { "mdb" "mdb instance" }
{ "quot" quotation } { "quot" "quotation to execute with the given mdb instance as context" }
} }
{ $description "" } ; { $description "executes a quotation with the given mdb instance in its context" } ;
ARTICLE: "mongodb.driver" "mongodb.driver" ARTICLE: "mongodb.driver" "MongoDB factor driver"
{ $vocab-link "mongodb.driver" } { $vocab-link "mongodb.driver" }
; ;

8
extra/mongodb/driver/driver.factor
View File

@ -162,7 +162,7 @@ PRIVATE>
: <query> ( collection assoc -- mdb-query-msg ) : <query> ( collection assoc -- mdb-query-msg )
<mdb-query-msg> ; inline <mdb-query-msg> ; inline
GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query ) GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg )
M: mdb-query-msg limit M: mdb-query-msg limit
>>return# ; inline >>return# ; inline
@ -188,7 +188,7 @@ GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
M: mdb-query-msg hint M: mdb-query-msg hint
>>hint ; >>hint ;
GENERIC: find ( mdb-query-msg/mdb-cursor -- mdb-cursor seq ) GENERIC: find ( selector -- mdb-cursor/f seq )
M: mdb-query-msg find M: mdb-query-msg find
fix-query-collection send-query ; fix-query-collection send-query ;
@ -243,7 +243,7 @@ M: assoc save
[ check-collection ] dip [ check-collection ] dip
<mdb-insert-msg> send-message-check-error ; <mdb-insert-msg> send-message-check-error ;
GENERIC: save-unsafe ( collection object -- ) GENERIC: save-unsafe ( collection assoc -- )
M: assoc save-unsafe M: assoc save-unsafe
[ check-collection ] dip [ check-collection ] dip
<mdb-insert-msg> send-message ; <mdb-insert-msg> send-message ;
@ -266,7 +266,7 @@ M: index-spec ensure-index
[ cmd-collection ] dip <mdb-query-msg> [ cmd-collection ] dip <mdb-query-msg>
find-one drop ; find-one drop ;
: <update> ( collection selector object -- update-msg ) : <update> ( collection selector object -- mdb-update-msg )
[ check-collection ] 2dip <mdb-update-msg> ; [ check-collection ] 2dip <mdb-update-msg> ;
: >upsert ( mdb-update-msg -- mdb-update-msg ) : >upsert ( mdb-update-msg -- mdb-update-msg )

2
extra/mongodb/mmm/mmm.factor
View File

@ -1,6 +1,6 @@
USING: accessors fry io io.encodings.binary io.servers.connection USING: accessors fry io io.encodings.binary io.servers.connection
io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
namespaces prettyprint tools.walker calendar calendar.format namespaces prettyprint tools.walker calendar calendar.format bson.writer.private
json.writer mongodb.operations.private mongodb.operations ; json.writer mongodb.operations.private mongodb.operations ;
IN: mongodb.mmm IN: mongodb.mmm

9
extra/mongodb/tuple/tuple.factor
View File

@ -20,7 +20,7 @@ SYNTAX: MDBTUPLE:
tuple-collection tuple-collection
[ create-collection ] [ create-collection ]
[ [ tuple-index-list ] keep [ [ tuple-index-list ] keep
'[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each '[ _ name>> swap [ name>> ] [ spec>> ] bi <index-spec> ensure-index ] each
] bi ; ] bi ;
: ensure-tables ( classes -- ) : ensure-tables ( classes -- )
@ -71,13 +71,12 @@ PRIVATE>
tuple>selector <query> ; tuple>selector <query> ;
: select-tuple ( tuple/query -- tuple/f ) : select-tuple ( tuple/query -- tuple/f )
dup mdb-query-msg? [ ] [ tuple>query ] if dup mdb-query-msg? [ tuple>query ] unless
find-one [ assoc>tuple ] [ f ] if* ; find-one [ assoc>tuple ] [ f ] if* ;
: select-tuples ( tuple/query -- cursor tuples/f ) : select-tuples ( tuple/query -- cursor tuples/f )
dup mdb-query-msg? [ ] [ tuple>query ] if dup mdb-query-msg? [ tuple>query ] unless
find [ assoc>tuple ] map ; find [ assoc>tuple ] map ;
: count-tuples ( tuple/query -- n ) : count-tuples ( tuple/query -- n )
dup mdb-query-msg? [ tuple>query ] unless dup mdb-query-msg? [ tuple>query ] unless count ;
[ collection>> ] [ query>> ] bi count ;