+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Interface to the gdbm database library */
-
-#include "scheme.h"
-#include "prims.h"
-#include "os.h"
-
-#ifdef HAVE_GDBM_H
-# include <gdbm.h>
-#endif
-\f
-/* Allocation Tables */
-
-struct allocation_table
-{
- void ** items;
- int length;
-};
-
-static void
-allocation_table_initialize (struct allocation_table * table)
-{
- (table -> length) = 0;
-}
-
-static unsigned int
-allocate_table_index (struct allocation_table * table, void * item)
-{
- unsigned int length = (table -> length);
- unsigned int new_length;
- void ** items = (table -> items);
- void ** new_items;
- void ** scan;
- void ** end;
- if (length == 0)
- {
- new_length = 4;
- new_items = (OS_malloc ((sizeof (void *)) * new_length));
- }
- else
- {
- scan = items;
- end = (scan + length);
- while (scan < end)
- if ((*scan++) == 0)
- {
- (*--scan) = item;
- return (scan - items);
- }
- new_length = (length * 2);
- new_items = (OS_realloc (items, ((sizeof (void *)) * new_length)));
- }
- scan = (new_items + length);
- end = (new_items + new_length);
- (*scan++) = item;
- while (scan < end)
- (*scan++) = 0;
- (table -> items) = new_items;
- (table -> length) = new_length;
- return (length);
-}
-
-static void *
-allocation_item_arg (unsigned int arg, struct allocation_table * table)
-{
- unsigned int index = (arg_ulong_index_integer (arg, (table -> length)));
- void * item = ((table -> items) [index]);
- if (item == 0)
- error_bad_range_arg (arg);
- return (item);
-}
-\f
-static struct allocation_table dbf_table;
-
-#define DBF_VAL(dbf) \
- (ulong_to_integer (allocate_table_index ((&dbf_table), ((void *) (dbf)))))
-
-#define DBF_ARG(arg) \
- ((GDBM_FILE) (allocation_item_arg ((arg), (&dbf_table))))
-
-#define GDBM_ERROR_VAL() \
- (char_pointer_to_string (gdbm_strerror (gdbm_errno)))
-
-#define VOID_GDBM_CALL(expression) \
- (((expression) == 0) ? SHARP_F : (GDBM_ERROR_VAL ()))
-
-static datum
-arg_datum (int arg)
-{
- datum d;
- CHECK_ARG (arg, STRING_P);
- (d . dptr) = (STRING_POINTER (ARG_REF (arg)));
- (d . dsize) = (STRING_LENGTH (ARG_REF (arg)));
- return (d);
-}
-
-static SCHEME_OBJECT
-datum_to_object (datum d)
-{
- if (d . dptr)
- {
- SCHEME_OBJECT result = (allocate_string (d . dsize));
- const char * scan_d = (d . dptr);
- const char * end_d = (scan_d + (d . dsize));
- char * scan_result = (STRING_POINTER (result));
- while (scan_d < end_d)
- (*scan_result++) = (*scan_d++);
- free (d . dptr);
- return (result);
- }
- else
- return (SHARP_F);
-}
-
-static void
-gdbm_fatal_error (const char * msg)
-{
- outf_error ("\ngdbm: %s\n", msg);
- outf_flush_error ();
- error_external_return ();
-}
-\f
-DEFINE_PRIMITIVE ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0)
-{
- static int initialization_done = 0;
- PRIMITIVE_HEADER (4);
- if (!initialization_done)
- {
- allocation_table_initialize (&dbf_table);
- initialization_done = 1;
- }
- {
- GDBM_FILE dbf = (gdbm_open ((STRING_ARG (1)),
- (arg_integer (2)),
- (arg_integer (3)),
- (arg_integer (4)),
- gdbm_fatal_error));
- PRIMITIVE_RETURN ((dbf == 0) ? (GDBM_ERROR_VAL ()) : (DBF_VAL (dbf)));
- }
-}
-
-DEFINE_PRIMITIVE ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- gdbm_close (DBF_ARG (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- {
- int result = (gdbm_store ((DBF_ARG (1)),
- (arg_datum (2)),
- (arg_datum (3)),
- (arg_integer (4))));
- PRIMITIVE_RETURN
- ((result < 0) ? (GDBM_ERROR_VAL ()) : (BOOLEAN_TO_OBJECT (!result)));
- }
-}
-
-DEFINE_PRIMITIVE ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (datum_to_object (gdbm_fetch ((DBF_ARG (1)), (arg_datum (2)))));
-}
-
-DEFINE_PRIMITIVE ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT (gdbm_exists ((DBF_ARG (1)), (arg_datum (2)))));
-}
-\f
-DEFINE_PRIMITIVE ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (((gdbm_delete ((DBF_ARG (1)), (arg_datum (2)))) == 0)
- ? SHARP_T
- : (gdbm_errno == GDBM_ITEM_NOT_FOUND)
- ? SHARP_F
- : (GDBM_ERROR_VAL ()));
-}
-
-DEFINE_PRIMITIVE ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (datum_to_object (gdbm_firstkey (DBF_ARG (1))));
-}
-
-DEFINE_PRIMITIVE ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (datum_to_object (gdbm_nextkey ((DBF_ARG (1)), (arg_datum (2)))));
-}
-
-DEFINE_PRIMITIVE ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (VOID_GDBM_CALL (gdbm_reorganize (DBF_ARG (1))));
-}
-
-DEFINE_PRIMITIVE ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- gdbm_sync (DBF_ARG (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (char_pointer_to_string (gdbm_version));
-}
-
-DEFINE_PRIMITIVE ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- int value = (arg_integer (3));
- PRIMITIVE_RETURN
- (VOID_GDBM_CALL (gdbm_setopt ((DBF_ARG (1)),
- (arg_integer (2)),
- (&value),
- (sizeof (int)))));
- }
-}
-
-#ifdef COMPILE_AS_MODULE
-
-char *
-dload_initialize_file (void)
-{
- declare_primitive ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0);
- declare_primitive ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0);
- declare_primitive ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0);
- declare_primitive ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0);
- declare_primitive ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0);
- declare_primitive ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0);
- declare_primitive ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0);
- declare_primitive ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0);
- declare_primitive ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0);
- declare_primitive ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0);
- declare_primitive ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0);
- declare_primitive ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0);
- return ("#prgdbm");
-}
-
-#endif /* COMPILE_AS_MODULE */
(declare (usual-integrations))
\f
-(define gdbm-initialized? #f)
-(define gdbf-finalizer)
+;;; Access to the gdbm library is now accomplished with the FFI
+;;; rather than a microcode module. The bindings in this package are
+;;; linked to those in the (gdbm) package after the plugin is loaded.
-(define (gdbm-available?)
- (load-library-object-file "prgdbm" #f)
- (and (implemented-primitive-procedure? (ucode-primitive gdbm-open 4))
- (begin
- (if (not gdbm-initialized?)
- (begin
- (set! gdbf-finalizer
- (make-gc-finalizer (ucode-primitive gdbm-close 1)
- gdbf?
- gdbf-descriptor
- set-gdbf-descriptor!))
- (set! gdbm-initialized? #t)))
- #t)))
-
-;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
-;; create the database.
-(define gdbm_reader 0) ;A reader.
-(define gdbm_writer 1) ;A writer.
-(define gdbm_wrcreat 2) ;A writer. Create the db if needed.
-(define gdbm_newdb 3) ;A writer. Always create a new db.
-(define gdbm_fast 16) ;Write fast! => No fsyncs.
-
-(define (gdbm-open filename block-size flags mode)
- (if (not (gdbm-available?))
- (error "This Scheme system was built without gdbm support."))
- (let ((filename (->namestring (merge-pathnames filename))))
- (without-interruption
- (lambda ()
- (add-to-gc-finalizer!
- gdbf-finalizer
- (make-gdbf (gdbm-error ((ucode-primitive gdbm-open 4)
- filename block-size flags mode))
- filename))))))
-
-(define (gdbm-close gdbf)
- (if (not (gdbf? gdbf))
- (error:wrong-type-argument gdbf "gdbm handle" 'gdbm-close))
- (remove-from-gc-finalizer! gdbf-finalizer gdbf))
-
-;; Parameters to gdbm_store for simple insertion or replacement in the
-;; case that the key is already in the database.
-(define gdbm_insert 0) ;Never replace old data with new.
-(define gdbm_replace 1) ;Always replace old data with new.
-
-(define (gdbm-store gdbf key datum flags)
- (gdbm-error
- ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'gdbm-store)
- key datum flags)))
-
-(define (gdbm-fetch gdbf key)
- ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'gdbm-fetch) key))
-
-(define (gdbm-exists? gdbf key)
- ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'gdbm-exists?) key))
-
-(define (gdbm-delete gdbf key)
- (gdbm-error
- ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'gdbm-delete) key)))
-
-(define (gdbm-firstkey gdbf)
- ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'gdbm-firstkey)))
+(define linked? #f)
-(define (gdbm-nextkey gdbf key)
- ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'gdbm-nextkey) key))
-
-(define (gdbm-reorganize gdbf)
- (gdbm-error
- ((ucode-primitive gdbm-reorganize 1)
- (guarantee-gdbf gdbf 'gdbm-reorganize))))
-
-(define (gdbm-sync gdbf)
- ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'gdbm-sync)))
-
-(define (gdbm-version)
- ((ucode-primitive gdbm-version 0)))
-
-;; Parameters to gdbm_setopt, specifing the type of operation to perform.
-(define gdbm_cachesize 1) ;Set the cache size.
-(define gdbm_fastmode 2) ;Toggle fast mode.
-
-(define (gdbm-setopt gdbf opt val)
- (gdbm-error
- ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'gdbm-setopt)
- opt val)))
-
-(define-structure (gdbf
- (print-procedure (standard-print-method 'gdbf
- (lambda (gdbf)
- (list (gdbf-filename gdbf))))))
- descriptor
- (filename #f read-only #t))
-
-(define (guarantee-gdbf gdbf procedure)
- (if (gdbf? gdbf)
- (or (gdbf-descriptor gdbf) (error:bad-range-argument gdbf procedure))
- (error:wrong-type-argument gdbf "gdbm handle" procedure)))
-
-(define (gdbm-error object)
- (if (string? object) (error "gdbm error:" object))
- object)
\ No newline at end of file
+(define (gdbm-available?)
+ (and (plugin-available? "gdbm")
+ (or linked?
+ (begin
+ (load-option 'gdbm)
+ (link!)
+ #t))))
+
+(define (link!)
+ (for-each
+ (let ((runtime (->environment '(runtime gdbm)))
+ (gdbm (->environment '(gdbm))))
+ (lambda (name)
+ (environment-link-name runtime gdbm name)))
+ names)
+ (set! linked? #t))
+
+(define names
+ '(gdbm-close
+ gdbm-delete
+ gdbm-exists?
+ gdbm-fetch
+ gdbm-firstkey
+ gdbm-nextkey
+ gdbm-open
+ gdbm-reorganize
+ gdbm-setopt
+ gdbm-store
+ gdbm-sync
+ gdbm-version
+ gdbm_cachesize
+ gdbm_fast
+ gdbm_fastmode
+ gdbm_insert
+ gdbm_newdb
+ gdbm_reader
+ gdbm_replace
+ gdbm_wrcreat
+ gdbm_writer))
+
+(define gdbm-close)
+(define gdbm-delete)
+(define gdbm-exists?)
+(define gdbm-fetch)
+(define gdbm-firstkey)
+(define gdbm-nextkey)
+(define gdbm-open)
+(define gdbm-reorganize)
+(define gdbm-setopt)
+(define gdbm-store)
+(define gdbm-sync)
+(define gdbm-version)
+(define gdbm_cachesize)
+(define gdbm_fast)
+(define gdbm_fastmode)
+(define gdbm_insert)
+(define gdbm_newdb)
+(define gdbm_reader)
+(define gdbm_replace)
+(define gdbm_wrcreat)
+(define gdbm_writer)
\ No newline at end of file
projects / mit-scheme.git / commitdiff