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

gdbm: code cleanup

db4
Dmitry Shubin 2010-06-14 00:37:40 +04:00
parent 4378948e47
commit 01a62e25eb
1 changed files with 39 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
extra/gdbm/gdbm.factor
View File

@ -5,6 +5,33 @@ classes.struct combinators destructors gdbm.ffi io.backend kernel libc
literals math namespaces sequences serialize strings ; literals math namespaces sequences serialize strings ;
IN: gdbm IN: gdbm
TUPLE: gdbm
{ name string }
{ block-size integer }
{ flags integer initial: $ GDBM_WRCREAT }
{ mode integer initial: OCT: 644 } ;
ERROR: gdbm-error errno msg ;
<PRIVATE
: gdbm-throw ( -- * ) gdbm_errno dup gdbm_strerror gdbm-error ;
: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
SYMBOL: current-dbf
: dbf ( -- dbf ) current-dbf get ;
: gdbm-open ( gdbm -- dbf )
{
[ name>> normalize-path ]
[ block-size>> ] [ flags>> ] [ mode>> ]
} cleave f gdbm_open [ gdbm-throw ] unless* ;
DESTRUCTOR: gdbm-close
: object>datum ( obj -- datum ) : object>datum ( obj -- datum )
object>bytes [ malloc-byte-array &free ] [ length ] bi object>bytes [ malloc-byte-array &free ] [ length ] bi
datum <struct-boa> ; datum <struct-boa> ;
@ -13,60 +40,36 @@ IN: gdbm
[ dptr>> ] [ dsize>> ] bi over [ dptr>> ] [ dsize>> ] bi over
[ memory>byte-array bytes>object t ] [ drop f ] if ; [ memory>byte-array bytes>object t ] [ drop f ] if ;
SYMBOL: current-dbf
: dbf ( -- dbf ) current-dbf get ;
TUPLE: gdbm
{ name string }
{ block-size integer }
{ flags integer initial: $ GDBM_WRCREAT }
{ mode integer initial: OCT: 644 } ;
DESTRUCTOR: gdbm-close
ERROR: gdbm-error errno msg ;
: gdbm-throw ( -- * ) gdbm_errno dup gdbm_strerror gdbm-error ;
: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
: gdbm-open ( gdbm -- dbf )
{
[ name>> normalize-path ]
[ block-size>> ] [ flags>> ] [ mode>> ]
} cleave f gdbm_open [ gdbm-throw ] unless* ;
: gdbm-store ( key content flag -- ) : gdbm-store ( key content flag -- )
[ [
{ [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
gdbm_store check-error gdbm_store check-error
] with-destructors ; ] with-destructors ;
PRIVATE>
: gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ; : gdbm-replace ( key content -- ) GDBM_REPLACE gdbm-store ;
: gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ; : gdbm-insert ( key content -- ) GDBM_INSERT gdbm-store ;
: gdbm-fetch* ( key -- content ? )
[ dbf swap object>datum gdbm_fetch datum>object* ]
with-destructors ;
: gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
: gdbm-delete ( key -- ) : gdbm-delete ( key -- )
[ dbf swap object>datum gdbm_delete check-error ] [ dbf swap object>datum gdbm_delete check-error ]
with-destructors ; with-destructors ;
: gdbm-firstkey* ( -- key ? ) : gdbm-fetch* ( key -- content ? )
[ dbf swap object>datum gdbm_fetch datum>object* ]
with-destructors ;
: gdbm-first-key* ( -- key ? )
[ dbf gdbm_firstkey datum>object* ] with-destructors ; [ dbf gdbm_firstkey datum>object* ] with-destructors ;
: gdbm-firstkey ( -- key/f ) gdbm-firstkey* drop ; : gdbm-next-key* ( key -- key ? )
: gdbm-nextkey* ( key -- key ? )
[ dbf swap object>datum gdbm_nextkey datum>object* ] [ dbf swap object>datum gdbm_nextkey datum>object* ]
with-destructors ; with-destructors ;
: gdbm-nextkey ( key -- key/f ) gdbm-nextkey* drop ; : gdbm-fetch ( key -- content/f ) gdbm-fetch* drop ;
: gdbm-first-key ( -- key/f ) gdbm-first-key* drop ;
: gdbm-next-key ( key -- key/f ) gdbm-next-key* drop ;
: gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ; : gdbm-reorganize ( -- ) dbf gdbm_reorganize check-error ;