1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Interface to the gdbm database library */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "os.h"
32
33 #ifdef HAVE_GDBM_H
34 # include <gdbm.h>
35 #endif
36
37 /* Allocation Tables */
38
39 struct allocation_table
40 {
41 void ** items;
42 int length;
43 };
44
45 static void
allocation_table_initialize(struct allocation_table * table)46 allocation_table_initialize (struct allocation_table * table)
47 {
48 (table -> length) = 0;
49 }
50
51 static unsigned int
allocate_table_index(struct allocation_table * table,void * item)52 allocate_table_index (struct allocation_table * table, void * item)
53 {
54 unsigned int length = (table -> length);
55 unsigned int new_length;
56 void ** items = (table -> items);
57 void ** new_items;
58 void ** scan;
59 void ** end;
60 if (length == 0)
61 {
62 new_length = 4;
63 new_items = (OS_malloc ((sizeof (void *)) * new_length));
64 }
65 else
66 {
67 scan = items;
68 end = (scan + length);
69 while (scan < end)
70 if ((*scan++) == 0)
71 {
72 (*--scan) = item;
73 return (scan - items);
74 }
75 new_length = (length * 2);
76 new_items = (OS_realloc (items, ((sizeof (void *)) * new_length)));
77 }
78 scan = (new_items + length);
79 end = (new_items + new_length);
80 (*scan++) = item;
81 while (scan < end)
82 (*scan++) = 0;
83 (table -> items) = new_items;
84 (table -> length) = new_length;
85 return (length);
86 }
87
88 static void *
allocation_item_arg(unsigned int arg,struct allocation_table * table)89 allocation_item_arg (unsigned int arg, struct allocation_table * table)
90 {
91 unsigned int index = (arg_ulong_index_integer (arg, (table -> length)));
92 void * item = ((table -> items) [index]);
93 if (item == 0)
94 error_bad_range_arg (arg);
95 return (item);
96 }
97
98 static struct allocation_table dbf_table;
99
100 #define DBF_VAL(dbf) \
101 (ulong_to_integer (allocate_table_index ((&dbf_table), ((void *) (dbf)))))
102
103 #define DBF_ARG(arg) \
104 ((GDBM_FILE) (allocation_item_arg ((arg), (&dbf_table))))
105
106 #define GDBM_ERROR_VAL() \
107 (char_pointer_to_string (gdbm_strerror (gdbm_errno)))
108
109 #define VOID_GDBM_CALL(expression) \
110 (((expression) == 0) ? SHARP_F : (GDBM_ERROR_VAL ()))
111
112 static datum
arg_datum(int arg)113 arg_datum (int arg)
114 {
115 datum d;
116 CHECK_ARG (arg, STRING_P);
117 (d . dptr) = (STRING_POINTER (ARG_REF (arg)));
118 (d . dsize) = (STRING_LENGTH (ARG_REF (arg)));
119 return (d);
120 }
121
122 static SCHEME_OBJECT
datum_to_object(datum d)123 datum_to_object (datum d)
124 {
125 if (d . dptr)
126 {
127 SCHEME_OBJECT result = (allocate_string (d . dsize));
128 const char * scan_d = (d . dptr);
129 const char * end_d = (scan_d + (d . dsize));
130 char * scan_result = (STRING_POINTER (result));
131 while (scan_d < end_d)
132 (*scan_result++) = (*scan_d++);
133 free (d . dptr);
134 return (result);
135 }
136 else
137 return (SHARP_F);
138 }
139
140 static void
gdbm_fatal_error(const char * msg)141 gdbm_fatal_error (const char * msg)
142 {
143 outf_error ("\ngdbm: %s\n", msg);
144 outf_flush_error ();
145 error_external_return ();
146 }
147
148 DEFINE_PRIMITIVE ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0)
149 {
150 static int initialization_done = 0;
151 PRIMITIVE_HEADER (4);
152 if (!initialization_done)
153 {
154 allocation_table_initialize (&dbf_table);
155 initialization_done = 1;
156 }
157 {
158 GDBM_FILE dbf = (gdbm_open ((STRING_ARG (1)),
159 (arg_integer (2)),
160 (arg_integer (3)),
161 (arg_integer (4)),
162 gdbm_fatal_error));
163 PRIMITIVE_RETURN ((dbf == 0) ? (GDBM_ERROR_VAL ()) : (DBF_VAL (dbf)));
164 }
165 }
166
167 DEFINE_PRIMITIVE ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0)
168 {
169 PRIMITIVE_HEADER (1);
170 gdbm_close (DBF_ARG (1));
171 PRIMITIVE_RETURN (UNSPECIFIC);
172 }
173
174 DEFINE_PRIMITIVE ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0)
175 {
176 PRIMITIVE_HEADER (4);
177 {
178 int result = (gdbm_store ((DBF_ARG (1)),
179 (arg_datum (2)),
180 (arg_datum (3)),
181 (arg_integer (4))));
182 PRIMITIVE_RETURN
183 ((result < 0) ? (GDBM_ERROR_VAL ()) : (BOOLEAN_TO_OBJECT (!result)));
184 }
185 }
186
187 DEFINE_PRIMITIVE ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0)
188 {
189 PRIMITIVE_HEADER (2);
190 PRIMITIVE_RETURN
191 (datum_to_object (gdbm_fetch ((DBF_ARG (1)), (arg_datum (2)))));
192 }
193
194 DEFINE_PRIMITIVE ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0)
195 {
196 PRIMITIVE_HEADER (2);
197 PRIMITIVE_RETURN
198 (BOOLEAN_TO_OBJECT (gdbm_exists ((DBF_ARG (1)), (arg_datum (2)))));
199 }
200
201 DEFINE_PRIMITIVE ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0)
202 {
203 PRIMITIVE_HEADER (2);
204 PRIMITIVE_RETURN
205 (((gdbm_delete ((DBF_ARG (1)), (arg_datum (2)))) == 0)
206 ? SHARP_T
207 : (gdbm_errno == GDBM_ITEM_NOT_FOUND)
208 ? SHARP_F
209 : (GDBM_ERROR_VAL ()));
210 }
211
212 DEFINE_PRIMITIVE ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0)
213 {
214 PRIMITIVE_HEADER (1);
215 PRIMITIVE_RETURN (datum_to_object (gdbm_firstkey (DBF_ARG (1))));
216 }
217
218 DEFINE_PRIMITIVE ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0)
219 {
220 PRIMITIVE_HEADER (2);
221 PRIMITIVE_RETURN
222 (datum_to_object (gdbm_nextkey ((DBF_ARG (1)), (arg_datum (2)))));
223 }
224
225 DEFINE_PRIMITIVE ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0)
226 {
227 PRIMITIVE_HEADER (1);
228 PRIMITIVE_RETURN (VOID_GDBM_CALL (gdbm_reorganize (DBF_ARG (1))));
229 }
230
231 DEFINE_PRIMITIVE ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0)
232 {
233 PRIMITIVE_HEADER (1);
234 gdbm_sync (DBF_ARG (1));
235 PRIMITIVE_RETURN (UNSPECIFIC);
236 }
237
238 DEFINE_PRIMITIVE ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0)
239 {
240 PRIMITIVE_HEADER (0);
241 PRIMITIVE_RETURN (char_pointer_to_string (gdbm_version));
242 }
243
244 DEFINE_PRIMITIVE ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0)
245 {
246 PRIMITIVE_HEADER (3);
247 {
248 int value = (arg_integer (3));
249 PRIMITIVE_RETURN
250 (VOID_GDBM_CALL (gdbm_setopt ((DBF_ARG (1)),
251 (arg_integer (2)),
252 (&value),
253 (sizeof (int)))));
254 }
255 }
256
257 #ifdef COMPILE_AS_MODULE
258
259 char *
dload_initialize_file(void)260 dload_initialize_file (void)
261 {
262 declare_primitive ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0);
263 declare_primitive ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0);
264 declare_primitive ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0);
265 declare_primitive ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0);
266 declare_primitive ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0);
267 declare_primitive ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0);
268 declare_primitive ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0);
269 declare_primitive ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0);
270 declare_primitive ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0);
271 declare_primitive ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0);
272 declare_primitive ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0);
273 declare_primitive ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0);
274 return ("#prgdbm");
275 }
276
277 #endif /* COMPILE_AS_MODULE */
278