source: project/release/4/gdbm/gdbm.scm @ 15656

Last change on this file since 15656 was 15656, checked in by Alex Shinn, 10 years ago

gdbm for chicken 4

File size: 4.2 KB
Line 
1;;;; gdbm.scm -- GNU DBM bindings for Chicken
2;;
3;; Copyright (c) 2005 Alex Shinn
4;; All rights reserved.
5;;
6;; BSD-style license: http://www.debian.org/misc/bsd.license
7(module gdbm
8
9( gdbm-open gdbm-close gdbm-store gdbm-fetch gdbm-delete gdbm-exists
10  gdbm-first-key gdbm-next-key gdbm-fold
11  GDBM_READER GDBM_WRITER GDBM_WRCREAT GDBM_NEWDB GDBM_SYNC GDBM_NOLOCK
12  GDBM_INSERT GDBM_REPLACE)
13
14(import scheme)
15(import chicken)
16(import foreign)
17
18(declare
19 (fixnum-arithmetic)
20 (usual-integrations)
21 )
22
23(declare
24  (foreign-declare #<<EOF
25#include <gdbm.h>
26
27#define copy_string_result(ptr, len, str)     (C_memcpy(C_c_string(str), (char *)C_block_item(ptr, 0), C_unfix(len)), C_SCHEME_UNDEFINED)
28#define free_ptr(ptr)     (C_free((char *)C_block_item(ptr, 0)), C_SCHEME_UNDEFINED)
29EOF
30) )
31
32;; gdbm-open flags
33(define-foreign-variable GDBM_READER_ int "GDBM_READER")
34(define-foreign-variable GDBM_WRITER_ int "GDBM_WRITER")
35(define-foreign-variable GDBM_WRCREAT_ int "GDBM_WRCREAT")
36(define-foreign-variable GDBM_NEWDB_ int "GDBM_NEWDB")
37(define-foreign-variable GDBM_SYNC_ int "GDBM_SYNC")
38(define-foreign-variable GDBM_NOLOCK_ int "GDBM_NOLOCK")
39
40(define GDBM_READER GDBM_READER_)
41(define GDBM_WRITER GDBM_WRITER_)
42(define GDBM_WRCREAT GDBM_WRCREAT_)
43(define GDBM_NEWDB GDBM_NEWDB_)
44(define GDBM_SYNC GDBM_SYNC_)
45(define GDBM_NOLOCK GDBM_NOLOCK_)
46
47;; gdbm-store flags
48(define-foreign-variable GDBM_INSERT_ int "GDBM_INSERT")
49(define-foreign-variable GDBM_REPLACE_ int "GDBM_REPLACE")
50
51(define GDBM_INSERT GDBM_INSERT_)
52(define GDBM_REPLACE GDBM_REPLACE_)
53
54(define %gdbm-open
55  (foreign-lambda* c-pointer ((c-string file) (int block_size) (int flags) (int mode))
56    "GDBM_FILE result = gdbm_open(file, block_size, flags, mode, NULL);"
57    "return(result);"))
58
59(define (gdbm-open file . o)
60  (let-optionals* o ((block-size #f)
61                     (flags #f)
62                     (mode #o644))
63    (%gdbm-open file (or block-size 512) (or flags 2) mode)))
64
65(define gdbm-close
66  (foreign-lambda* void ((c-pointer dbf))
67    "gdbm_close((GDBM_FILE) dbf);"))
68
69(define %gdbm-store
70  (foreign-lambda* int ((c-pointer dbf) (pointer kptr) (int ksize)
71                        (pointer vptr) (int vsize) (int flag))
72    "datum dkey = {kptr, ksize};"
73    "datum dvalue = {vptr, vsize};"
74    "return(gdbm_store((GDBM_FILE) dbf, dkey, dvalue, flag));"))
75
76(define (gdbm-store dbf key value . o)
77  (%gdbm-store dbf key (string-length key) value (string-length value)
78               (if (pair? o) (car o) 1)))
79
80(define %gdbm-delete
81  (foreign-lambda* void ((c-pointer dbf) (pointer kptr) (int ksize))
82    "datum dkey = {kptr, ksize};"
83    "gdbm_delete((GDBM_FILE) dbf, dkey);"))
84
85(define (gdbm-delete dbf key)
86  (%gdbm-delete dbf key (string-length key)))
87
88(define %gdbm-fetch
89  (foreign-safe-lambda* scheme-object ((c-pointer dbf) (pointer kptr) (int ksize))
90    "datum dkey = {kptr, ksize};"
91    "datum result = gdbm_fetch((GDBM_FILE) dbf, dkey);"
92    "return(make_string_with_len(result.dptr, result.dsize));"))
93
94(define (gdbm-fetch dbf key)
95  (%gdbm-fetch dbf key (string-length key)))
96
97(define %gdbm-exists
98  (foreign-lambda* bool ((c-pointer dbf) (pointer kptr) (int ksize))
99    "datum dkey = {kptr, ksize};"
100    "int result = gdbm_exists((GDBM_FILE) dbf, dkey);"
101    "return(result);"))
102
103(define (gdbm-exists dbf key)
104  (%gdbm-exists dbf key (string-length key)))
105
106(define gdbm-first-key
107  (foreign-safe-lambda* scheme-object ((c-pointer dbf))
108    "datum result = gdbm_firstkey((GDBM_FILE) dbf);"
109    "return(make_string_with_len(result.dptr, result.dsize));"))
110
111(define %gdbm-next-key
112  (foreign-safe-lambda* scheme-object ((c-pointer dbf) (pointer kptr) (int ksize))
113    "datum dkey = {kptr, ksize};"
114    "datum result = gdbm_nextkey((GDBM_FILE) dbf, dkey);"
115    "return(make_string_with_len(result.dptr, result.dsize));"))
116
117(define (gdbm-next-key dbf key)
118  (%gdbm-next-key dbf key (string-length key)))
119
120(define (gdbm-fold dbf kons knil)
121  (let lp ((key (gdbm-first-key dbf)) (acc knil))
122    (if (not key)
123      acc
124      (let ((val (gdbm-fetch dbf key)))
125        (lp (gdbm-next-key dbf key) (kons key val acc))))))
126
127(define-external (make_string_with_len (c-pointer ptr) (int len)) scheme-object
128  (and ptr
129       (let ([str (make-string len)])
130         (##core#inline "copy_string_result" ptr len str)
131         (##core#inline "free_ptr" ptr)
132         str) ) ) )
Note: See TracBrowser for help on using the repository browser.