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

gdbm: switch back to simpler error handling scheme

db4
Dmitry Shubin 2010-06-26 22:06:35 +04:00
parent cb361af8b4
commit 09dbdaae77
2 changed files with 37 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
extra/gdbm/ffi/ffi.factor
View File

@ -50,7 +50,29 @@ FUNCTION: int gdbm_exists ( GDBM_FILE dbf, datum key ) ;
FUNCTION: int gdbm_setopt ( GDBM_FILE dbf, int option, int* value, int size ) ; FUNCTION: int gdbm_setopt ( GDBM_FILE dbf, int option, int* value, int size ) ;
FUNCTION: int gdbm_fdesc ( GDBM_FILE dbf ) ; FUNCTION: int gdbm_fdesc ( GDBM_FILE dbf ) ;
TYPEDEF: int gdbm_error ENUM: gdbm-error
C-GLOBAL: gdbm_error gdbm_errno gdbm-no-error
gdbm-malloc-error
gdbm-block-size-error
gdbm-file-open-error
gdbm-file-write-error
gdbm-file-seek-error
gdbm-file-read-error
gdbm-bad-magic-number
gdbm-empty-database
gdbm-cant-be-reader
gdbm-cant-be-writer
gdbm-reader-cant-delete
gdbm-reader-cant-store
gdbm-reader-cant-reorganize
gdbm-unknown-update
gdbm-item-not-found
gdbm-reorganize-failed
gdbm-cannot-replace
gdbm-illegal-data
gdbm-option-already-set
gdbm-illegal-option ;
FUNCTION: c-string gdbm_strerror ( gdbm_error errno ) ; C-GLOBAL: gdbm-error gdbm_errno
FUNCTION: c-string gdbm_strerror ( gdbm-error errno ) ;

75
extra/gdbm/gdbm.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2010 Dmitry Shubin. ! Copyright (C) 2010 Dmitry Shubin.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.destructors assocs USING: accessors alien.c-types alien.data alien.destructors
biassocs classes.struct combinators destructors gdbm.ffi io.backend classes.struct combinators destructors gdbm.ffi io.backend kernel libc
kernel libc literals locals math namespaces sequences serialize literals locals math namespaces sequences serialize strings ;
strings ;
IN: gdbm IN: gdbm
TUPLE: gdbm TUPLE: gdbm
@ -12,59 +11,13 @@ TUPLE: gdbm
{ flags integer initial: $ GDBM_WRCREAT } { flags integer initial: $ GDBM_WRCREAT }
{ mode integer initial: OCT: 644 } ; { mode integer initial: OCT: 644 } ;
SINGLETONS:
gdbm-no-error gdbm-malloc-error
gdbm-block-size-error gdbm-file-open-error
gdbm-file-write-error gdbm-file-seek-error
gdbm-file-read-error gdbm-bad-magic-number
gdbm-empty-database gdbm-cant-be-reader
gdbm-cant-be-writer gdbm-reader-cant-delete
gdbm-reader-cant-store gdbm-reader-cant-reorganize
gdbm-unknown-update gdbm-item-not-found
gdbm-reorganize-failed gdbm-cannot-replace
gdbm-illegal-data gdbm-option-already-set
gdbm-illegal-option ;
ERROR: gdbm-unknown-error error ;
<PRIVATE <PRIVATE
: error-table ( -- table ) : gdbm-throw ( -- * ) gdbm_errno throw ;
{
{ 0 gdbm-no-error }
{ 1 gdbm-malloc-error }
{ 2 gdbm-block-size-error }
{ 3 gdbm-file-open-error }
{ 4 gdbm-file-write-error }
{ 5 gdbm-file-seek-error }
{ 6 gdbm-file-read-error }
{ 7 gdbm-bad-magic-number }
{ 8 gdbm-empty-database }
{ 9 gdbm-cant-be-reader }
{ 10 gdbm-cant-be-writer }
{ 11 gdbm-reader-cant-delete }
{ 12 gdbm-reader-cant-store }
{ 13 gdbm-reader-cant-reorganize }
{ 14 gdbm-unknown-update }
{ 15 gdbm-item-not-found }
{ 16 gdbm-reorganize-failed }
{ 17 gdbm-cannot-replace }
{ 18 gdbm-illegal-data }
{ 19 gdbm-option-already-set }
{ 20 gdbm-illegal-option }
} >biassoc ;
: error>code ( error -- code )
dup error-table value-at [ ] [ gdbm-unknown-error ] ?if ;
: code>error ( code -- error ) error-table at ;
: gdbm-throw ( -- * ) gdbm_errno code>error throw ;
: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ; : check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
SYMBOL: current-dbf SYMBOL: current-dbf
: dbf ( -- dbf ) current-dbf get ; : dbf ( -- dbf ) current-dbf get ;
@ -91,10 +44,17 @@ DESTRUCTOR: gdbm-close
gdbm_store check-error gdbm_store check-error
] with-destructors ; ] with-destructors ;
:: (gdbm-setopt) ( option value -- )
[
int heap-size dup malloc &free :> ( size ptr )
value ptr 0 int set-alien-value
dbf option ptr size gdbm_setopt check-error
] with-destructors ;
PRIVATE> PRIVATE>
: gdbm-error-message ( error -- msg ) error>code gdbm_strerror ; ALIAS: gdbm-error-message gdbm_strerror
: 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 ;
@ -126,17 +86,6 @@ PRIVATE>
[ dbf swap object>datum gdbm_exists c-bool> ] [ dbf swap object>datum gdbm_exists c-bool> ]
with-destructors ; with-destructors ;
<PRIVATE
:: (gdbm-setopt) ( option value -- )
[
int heap-size dup malloc &free :> ( size ptr )
value ptr 0 int set-alien-value
dbf option ptr size gdbm_setopt check-error
] with-destructors ;
PRIVATE>
: gdbm-setopt ( option value -- ) : gdbm-setopt ( option value -- )
over GDBM_CACHESIZE = [ >c-bool ] unless (gdbm-setopt) ; over GDBM_CACHESIZE = [ >c-bool ] unless (gdbm-setopt) ;