Skip to content

Commit

Permalink
typed words
Browse files Browse the repository at this point in the history
  • Loading branch information
@x6j8x
x6j8x committed Jun 5, 2010
1 parent 0d99a55 commit c08e046
Show file tree
Hide file tree
Showing 2 changed files with 40 additions and 42 deletions.
58 changes: 28 additions & 30 deletions extra/bson/reader/reader.factor
View file
Expand Up @@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs bson.constants calendar combinators
combinators.short-circuit io io.binary kernel math
namespaces sequences serialize strings vectors ;
namespaces sequences serialize strings vectors byte-arrays ;

FROM: io.encodings.binary => binary ;
FROM: io.streams.byte-array => with-byte-reader ;
FROM: typed => TYPED: ;

IN: bson.reader

Expand All @@ -20,7 +21,7 @@ TUPLE: state
{ scope vector }
{ elements vector } ;

: (prepare-elements) ( -- elements-vector )
TYPED: (prepare-elements) ( -- elements-vector: vector )
V{ } clone [ T_Object "" element boa swap push ] [ ] bi ; inline

: <state> ( exemplar -- state )
Expand All @@ -32,47 +33,44 @@ TUPLE: state
} cleave
(prepare-elements) >>elements ;

: get-state ( -- state )
TYPED: get-state ( -- state: state )
state get ; inline

: read-int32 ( -- int32 )
TYPED: read-int32 ( -- int32: integer )
4 read signed-le> ; inline

: read-longlong ( -- longlong )
TYPED: read-longlong ( -- longlong: integer )
8 read signed-le> ; inline

: read-double ( -- double )
TYPED: read-double ( -- double: float )
8 read le> bits>double ; inline

: read-byte-raw ( -- byte-raw )
TYPED: read-byte-raw ( -- byte-raw: byte-array )
1 read ; inline

: read-byte ( -- byte )
TYPED: read-byte ( -- byte: integer )
read-byte-raw first ; inline

: read-cstring ( -- string )
TYPED: read-cstring ( -- string: string )
"\0" read-until drop >string ; inline

: read-sized-string ( length -- string )
TYPED: read-sized-string ( length: integer -- string: string )
read 1 head-slice* >string ; inline

: push-element ( type name state -- )
TYPED: push-element ( type: integer name: string state: state -- )
[ element boa ] dip elements>> push ; inline

: pop-element ( state -- element )
TYPED: pop-element ( state: state -- element: element )
elements>> pop ; inline

: peek-scope ( state -- ht )
TYPED: peek-scope ( state: state -- ht )
scope>> last ; inline

: bson-object-data-read ( -- object )
read-int32 drop get-state
[ exemplar>> clone ] [ scope>> ] bi
[ push ] keep ; inline

: bson-binary-bytes? ( subtype -- ? )
T_Binary_Bytes = ; inline

: bson-binary-read ( -- binary )
read-int32 read-byte
{
Expand All @@ -82,14 +80,14 @@ TUPLE: state
[ drop read >string ]
} case ; inline

: bson-regexp-read ( -- mdbregexp )
TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
mdbregexp new
read-cstring >>regexp read-cstring >>options ; inline

: bson-oid-read ( -- oid )
TYPED: bson-oid-read ( -- oid: oid )
read-longlong read-int32 oid boa ; inline

: element-data-read ( type -- object )
TYPED: element-data-read ( type: integer -- object )
{
{ T_OID [ bson-oid-read ] }
{ T_String [ read-int32 read-sized-string ] }
Expand All @@ -104,50 +102,50 @@ TUPLE: state
{ T_NULL [ f ] }
} case ; inline

: bson-array? ( type -- ? )
TYPED: bson-array? ( type: integer -- ?: boolean )
T_Array = ; inline

: bson-object? ( type -- ? )
TYPED: bson-object? ( type: integer -- ?: boolean )
T_Object = ; inline

: check-object ( assoc -- object )
dup dbref-assoc? [ assoc>dbref ] when ; inline

: fix-result ( assoc type -- result )
TYPED: fix-result ( assoc type: integer -- result )
{
{ T_Array [ values ] }
{ T_Object [ check-object ] }
} case ; inline

: end-element ( type -- )
TYPED: end-element ( type: integer -- )
{ [ bson-object? ] [ bson-array? ] } 1||
[ get-state pop-element drop ] unless ; inline

: (>state<) ( -- state scope element )
TYPED: (>state<) ( -- state: state scope: vector element: element )
get-state [ ] [ scope>> ] [ pop-element ] tri ; inline

: (prepare-result) ( scope element -- result )
TYPED: (prepare-result) ( scope: vector element: element -- result )
[ pop ] [ type>> ] bi* fix-result ; inline

: bson-eoo-element-read ( -- cont? )
: bson-eoo-element-read ( -- cont?: boolean )
(>state<)
[ (prepare-result) ] [ ] [ drop empty? ] 2tri
[ 2drop >>result drop f ]
[ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline

: (prepare-object) ( type -- object )
TYPED: (prepare-object) ( type: integer -- object )
[ element-data-read ] [ end-element ] bi ; inline

: (read-object) ( type name state -- )
TYPED: (read-object) ( type: integer name: string state: state -- )
[ (prepare-object) ] 2dip
peek-scope set-at ; inline

: bson-not-eoo-element-read ( type -- cont? )
TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean )
read-cstring get-state
[ push-element ]
[ (read-object) t ] 3bi ; inline

: (element-read) ( type -- cont? )
TYPED: (element-read) ( type: integer -- cont?: boolean )
dup T_EOO >
[ bson-not-eoo-element-read ]
[ drop bson-eoo-element-read ] if ; inline
Expand Down
24 changes: 12 additions & 12 deletions extra/bson/writer/writer.factor
View file
Expand Up @@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs bson.constants byte-arrays
calendar combinators.short-circuit fry hashtables io io.binary
kernel linked-assocs literals math math.parser namespaces
kernel linked-assocs literals math math.parser namespaces byte-vectors
quotations sequences serialize strings vectors dlists alien.accessors ;
FROM: words => word? word ;
FROM: typed => TYPED: ;
Expand All @@ -17,7 +17,7 @@ CONSTANT: INT64-SIZE 8

PRIVATE>

: with-length ( quot: ( -- ) -- bytes-written start-index )
TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
[ output-stream get [ length ] [ ] bi ] dip
call length swap [ - ] keep ; inline

Expand All @@ -33,26 +33,26 @@ PRIVATE>

<PRIVATE

: write-int32 ( int -- ) INT32-SIZE >le write ; inline
TYPED: write-int32 ( int: integer -- ) INT32-SIZE >le write ; inline

: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
TYPED: write-double ( real: float -- ) double>bits INT64-SIZE >le write ; inline

: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
TYPED: write-cstring ( string: string -- ) B{ } like write 0 write1 ; inline

: write-longlong ( object -- ) INT64-SIZE >le write ; inline

: write-eoo ( -- ) T_EOO write1 ; inline

: write-header ( name object type -- object )
TYPED: write-header ( name: string object type: integer -- object )
write1 [ write-cstring ] dip ; inline

DEFER: write-pair

: write-byte-array ( binary -- )
TYPED: write-byte-array ( binary: byte-array -- )
[ length write-int32 ]
[ T_Binary_Bytes write1 write ] bi ; inline

: write-mdbregexp ( regexp -- )
TYPED: write-mdbregexp ( regexp: mdbregexp -- )
[ regexp>> write-cstring ]
[ options>> write-cstring ] bi ; inline

Expand Down Expand Up @@ -94,7 +94,7 @@ TYPED: write-string ( string: string -- )
TYPED: write-boolean ( bool: boolean -- )
[ 1 write1 ] [ 0 write1 ] if ; inline

: write-pair ( name obj -- )
TYPED: write-pair ( name: string obj -- )
{
{
[ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
Expand Down Expand Up @@ -143,12 +143,12 @@ TYPED: write-boolean ( bool: boolean -- )

PRIVATE>

TYPED: assoc>bv ( assoc: hashtables -- byte-vector )
TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
[ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline

TYPED: assoc>stream ( assoc: hashtables -- )
write-assoc ; inline

: mdb-special-value? ( value -- ? )
TYPED: mdb-special-value? ( value -- ?: boolean )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
[ oid? ] [ byte-array? ] } 1|| ; inline
[ oid? ] [ byte-array? ] } 1|| ; inline

0 comments on commit c08e046

Please sign in to comment.