--- /dev/null
+# 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
+# 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.
+
+MIT_SCHEME_EXE = mit-scheme
+EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+
+build: gdbm-shim.so gdbm-types.bin gdbm-const.bin
+ echo "(compile-bundle)" | $(EXE)
+
+check:
+ echo '(load "check")' | $(EXE)
+
+install: build
+ echo "(install-bundle)" | $(EXE) -- *.com *.bci *.pkd make.scm
+ echo '(install-shim "gdbm")' | $(EXE)
+
+clean:
+ rm -f gdbm-const.scm gdbm-const gdbm-const.c gdbm-shim.c
+ rm -f gdbm-*.crf gdbm-*.fre gdbm-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci
+ rm -f *.moc *.fni *-init.c *-init.h *-init.o
+ rm -f gdbm-check.db
+
+gdbm-shim.so: gdbm-shim.o gdbm-adapter.o
+ echo "(link-shim)" | $(EXE) -- -o $@ $^ -lgdbm
+
+gdbm-adapter.o: gdbm-adapter.c gdbm-shim.h
+ echo '(compile-shim)' | $(EXE) -- -c $<
+
+gdbm-shim.o: gdbm-shim.c gdbm-shim.h
+ echo '(compile-shim)' | $(EXE) -- -c $<
+
+gdbm-shim.c gdbm-const.c gdbm-types.bin: gdbm-shim.h gdbm.cdecl
+ echo '(generate-shim "gdbm" "#include \"gdbm-shim.h\"")' | $(EXE)
+
+gdbm-const.bin: gdbm-const.scm
+ echo '(sf "gdbm-const")' | $(EXE)
+
+gdbm-const.scm: gdbm-const
+ ./gdbm-const
+
+gdbm-const: gdbm-const.o
+ $(CC) $(LDFLAGS) -o $@ $^
+
+gdbm-const.o: gdbm-const.c gdbm-shim.h
+ $(CC) $(CFLAGS) -c $<
+
+.PHONY: build install clean
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the GDBM adapter.
+
+(load "make")
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (load "gdbm-check" (->environment '(gdbm)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Compile the GDBM adapter
+
+(fluid-let ((load/suppress-loading-message? #t))
+ (load-option 'CREF)
+ (load-option 'FFI))
+
+(compile-system "gdbm" (directory-pathname (current-load-pathname)))
\ No newline at end of file
--- /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 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 <mit-scheme.h>
+#include "gdbm-shim.h"
+
+extern char *
+alloc_gdbm_key (gdbm_args * args, int size)
+{
+ char * bytes;
+
+ if (size <= args->key_allocation)
+ {
+ bytes = args->key.dptr;
+ }
+ else
+ {
+ if (args->key.dptr != NULL)
+ free (args->key.dptr);
+ bytes = args->key.dptr = malloc (size);
+ args->key_allocation = size;
+ }
+ args->key.dsize = size;
+ return (bytes);
+}
+
+extern char *
+alloc_gdbm_content (gdbm_args * args, int size)
+{
+ char * bytes;
+
+ if (size <= args->content_allocation)
+ bytes = args->content.dptr;
+ else
+ {
+ if (args->content.dptr != NULL)
+ free (args->content.dptr);
+ bytes = args->content.dptr = malloc (size);
+ args->content_allocation = size;
+ }
+ args->content.dsize = size;
+ return (bytes);
+}
+
+extern char *
+get_gdbm_version (void)
+{
+ return (gdbm_version);
+}
+
+static void
+fatal_error (const char * msg)
+{
+ outf_error ("\ngdbm: %s\n", msg);
+ outf_flush_error ();
+ error_external_return ();
+}
+
+extern gdbm_args *
+do_gdbm_open (char * name, int block_size, int read_write, int mode)
+{
+ gdbm_args *args = (gdbm_args *) malloc (sizeof (gdbm_args));
+ if (!args) return (args);
+
+ args->key.dsize = 0;
+ args->key.dptr = NULL;
+ args->key_allocation = 0;
+ args->content.dsize = 0;
+ args->content.dptr = NULL;
+ args->content_allocation = 0;
+ args->gdbm_errno = 0;
+ args->sys_errno = 0;
+ args->dbf = gdbm_open (name, block_size, read_write, mode, &fatal_error);
+
+ if (args->dbf == NULL)
+ {
+ args->gdbm_errno = gdbm_errno;
+ args->sys_errno = errno;
+ }
+ return (args);
+}
+
+extern void
+do_gdbm_close (gdbm_args * args)
+{
+ gdbm_close (args->dbf);
+ if (args->key.dptr != NULL)
+ free (args->key.dptr);
+ if (args->content.dptr != NULL)
+ free (args->content.dptr);
+ free (args);
+}
+
+extern int
+do_gdbm_store (gdbm_args * args, int flag)
+{
+ int ret = gdbm_store (args->dbf, args->key, args->content, flag);
+ if (ret == -1)
+ {
+ args->gdbm_errno = gdbm_errno;
+ args->sys_errno = errno;
+ }
+ return (ret);
+}
+
+extern void
+do_gdbm_fetch (gdbm_args * args)
+{
+ if (args->content.dptr != NULL)
+ free (args->content.dptr);
+ args->content = gdbm_fetch (args->dbf, args->key);
+ args->content_allocation = args->content.dsize;
+}
+
+extern int
+do_gdbm_exists (gdbm_args * args)
+{
+ return (gdbm_exists (args->dbf, args->key));
+}
+
+extern int
+do_gdbm_delete (gdbm_args * args)
+{
+ return (gdbm_delete (args->dbf, args->key));
+}
+
+extern void
+do_gdbm_firstkey (gdbm_args * args)
+{
+ if (args->key.dptr != NULL)
+ free (args->key.dptr);
+ args->key = gdbm_firstkey (args->dbf);
+ if (args->key.dptr != NULL)
+ args->key_allocation = args->key.dsize;
+ else
+ args->key_allocation = 0;
+}
+
+extern int
+do_gdbm_nextkey (gdbm_args * args)
+{
+ datum next = gdbm_nextkey (args->dbf, args->key);
+ if (next.dptr == NULL)
+ return (1);
+ if (args->key.dptr != NULL)
+ free (args->key.dptr);
+ args->key = next;
+ args->key_allocation = next.dsize;
+ return (0);
+}
+
+extern int
+do_gdbm_reorganize (gdbm_args * args)
+{
+ int ret = gdbm_reorganize (args->dbf);
+ if (ret)
+ {
+ args->gdbm_errno = gdbm_errno;
+ args->sys_errno = errno;
+ }
+ return (ret);
+}
+
+extern void
+do_gdbm_sync (gdbm_args * args)
+{
+ gdbm_sync (args->dbf);
+}
+
+extern int
+do_gdbm_setopt (gdbm_args * args, int option, int value)
+{
+ int ret = gdbm_setopt (args->dbf, option, &value, sizeof (int));
+ if (ret)
+ {
+ args->gdbm_errno = gdbm_errno;
+ args->sys_errno = errno;
+ }
+ return (ret);
+}
--- /dev/null
+#| -*-Scheme-*-
+
+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 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.
+
+|#
+
+;;;; Test the GDBM adapter.
+
+(if (not (gdbm-available?))
+ (warn "gdbm adapter not found")
+ (let ((filename.db "gdbm-check.db"))
+ (ignore-errors (lambda () (delete-file filename.db)))
+ (let ((dbf (gdbm-open filename.db 0 GDBM_WRCREAT #o660)))
+ ;; Must be set before first store.
+ (gdbm-setopt dbf GDBM_CACHESIZE 101)
+
+ (gdbm-store dbf "Silly String" "Testing 1 2 3." GDBM_REPLACE)
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-store dbf "NullString" "" GDBM_INSERT)))))
+ (error "storing null content did not signal"))
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-store dbf "" "NullString" GDBM_INSERT)))))
+ (error "storing null key did not signal"))
+ (if (not (eq? #t (gdbm-store dbf "Silly String" "Ahoy!" GDBM_REPLACE)))
+ (error "replace produced wrong indication"))
+ (if (not (eq? #f (gdbm-store dbf "Silly String" "Oy!" GDBM_INSERT)))
+ (error "double insert produced no indication"))
+
+ (gdbm-setopt dbf GDBM_SYNCMODE 1)
+
+ (let ((content (gdbm-fetch dbf "Silly String")))
+ (if (not (string=? "Ahoy!" content))
+ (error "fetched:" content)))
+ (let ((content (gdbm-fetch dbf "Missing String")))
+ (if (not (eq? #f content))
+ (error "missing fetched:" content)))
+
+ (if (gdbm-exists? dbf "Missing String")
+ (error "exists"))
+ (if (not (gdbm-exists? dbf "Silly String"))
+ (error "not exists"))
+
+ (gdbm-delete dbf "Silly String")
+ (if (gdbm-exists? dbf "Silly String")
+ (error "not deleted"))
+ (if (gdbm-delete dbf "Missing String")
+ (error "deleted"))
+
+ (let ((k (gdbm-firstkey dbf)))
+ (if k
+ (error "empty database returned a firstkey:" k)))
+ (gdbm-store dbf "AString" "Testing 1 2 3." GDBM_INSERT)
+ (gdbm-store dbf "ASecondString" "Testing 1 2 3." GDBM_REPLACE)
+ (gdbm-store dbf "AThirdString" "Testing 1 2 3." GDBM_INSERT)
+ #;(let ((keys (sort (gdbm-keys dbf) string<?)))
+ (if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
+ (error "keys:" keys)))
+
+ (gdbm-reorganize dbf)
+ (gdbm-sync dbf)
+ (gdbm-setopt dbf 'SYNCMODE #f)
+ (gdbm-version)
+ (gdbm-close dbf))
+
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-open "notfound.db" 0 GDBM_READER 0)))))
+ (error "opened a nonexistent database file:" gdbf))
+ (let ((dbf2 (gdbm-open filename.db 0 GDBM_READER 0)))
+ (let ((keys (sort (gdbm-keys dbf2) string<?)))
+ (if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
+ (error "bogus keys:" keys))
+ (map (lambda (key)
+ (if (not (string=? "Testing 1 2 3." (gdbm-fetch dbf2 key)))
+ (error "bogus content:" key)))
+ keys))
+ (gdbm-close dbf2))))
\ No newline at end of file
--- /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 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 <stdlib.h>
+#include <errno.h>
+#include <string.h>
+#include <gdbm.h>
+
+typedef struct gdbm_args {
+ GDBM_FILE dbf;
+ gdbm_error gdbm_errno;
+ int sys_errno;
+ datum key, content;
+ int key_allocation, content_allocation;
+} gdbm_args;
+
+extern char * alloc_gdbm_key (gdbm_args * args, int size);
+extern char * alloc_gdbm_content (gdbm_args * args, int size);
+
+extern gdbm_args * do_gdbm_open (char * name,
+ int block_size, int read_write, int mode);
+extern void do_gdbm_close (gdbm_args * args);
+extern int do_gdbm_store (gdbm_args * args, int flag);
+extern void do_gdbm_fetch (gdbm_args * args);
+extern int do_gdbm_exists (gdbm_args * args);
+extern int do_gdbm_delete (gdbm_args * args);
+extern void do_gdbm_firstkey (gdbm_args * args);
+extern int do_gdbm_nextkey (gdbm_args * args);
+extern int do_gdbm_reorganize (gdbm_args * args);
+extern void do_gdbm_sync (gdbm_args * args);
+extern int do_gdbm_setopt (gdbm_args * args, int option, int value);
+extern char * get_gdbm_version (void);
--- /dev/null
+#| -*-Scheme-*-
+
+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 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.
+
+|#
+
+;;;; C declarations for gdbm-shim.so.
+\f
+;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who
+;; can create the database.
+(enum (GDBM_READER) ;; A reader.
+ (GDBM_WRITER) ;; A writer.
+ (GDBM_WRCREAT) ;; A writer. Create the db if needed.
+ (GDBM_NEWDB) ;; A writer. Always create a new db.
+ (GDBM_FAST) ;; Write fast! => No fsyncs. OBSOLETE.
+ (GDBM_SYNC) ;; Sync operations to the disk.
+ (GDBM_NOLOCK)) ;; Don't do file locking operations.
+
+;; Parameters to gdbm_store for simple insertion or replacement in the
+;; case that the key is already in the database.
+(enum (GDBM_INSERT) ;; Never replace old data with new.
+ (GDBM_REPLACE)) ;; Always replace old data with new.
+
+;; Parameters to gdbm_setopt, specifing the type of operation to perform.
+(enum (GDBM_CACHESIZE) ;; Set the cache size.
+ (GDBM_FASTMODE) ;; Toggle fast mode. OBSOLETE.
+ (GDBM_SYNCMODE) ;; Turn on or off sync operations.
+ (GDBM_CENTFREE) ;; Keep all free blocks in the header.
+ (GDBM_COALESCEBLKS)) ;; Attempt to coalesce free blocks.
+
+(typedef datum
+ (struct
+ (dptr (* char))
+ (dsize int)))
+
+(typedef gdbm_args
+ (struct
+ (dbf GDBM_FILE)
+ (gdbm_errno int)
+ (sys_errno int)
+ (key datum)
+ (content datum)))
+
+(typedef GDBM_FILE (* dummy))
+
+(extern (* char) alloc_gdbm_key (args (* gdbm_args)) (size int))
+(extern (* char) alloc_gdbm_content (args (* gdbm_args)) (size int))
+
+(extern (* gdbm_args) do_gdbm_open
+ (name (* char)) (block_size int) (read_write int) (mode int))
+(extern void do_gdbm_close (args (* gdbm_args)))
+(extern int do_gdbm_store (args (* gdbm_args)) (flag int))
+(extern void do_gdbm_fetch (args (* gdbm_args)))
+(extern int do_gdbm_exists (args (* gdbm_args)))
+(extern int do_gdbm_delete (args (* gdbm_args)))
+(extern void do_gdbm_firstkey (args (* gdbm_args)))
+(extern int do_gdbm_nextkey (args (* gdbm_args)))
+(extern int do_gdbm_reorganize (args (* gdbm_args)))
+(extern void do_gdbm_sync (args (* gdbm_args)))
+(extern (* char) gdbm_strerror (errnum int))
+(extern (* char) strerror (errnum int))
+(extern int do_gdbm_setopt (args (* gdbm_args)) (option int) (value int))
+(extern (* char) get_gdbm_version)
+
+(enum (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_OPT_ALREADY_SET)
+ (GDBM_OPT_ILLEGAL))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+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 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.
+
+|#
+
+(global-definitions runtime/)
+
+(define-package (gdbm)
+ (files "gdbm")
+ (parent ())
+ (initialization (initialize-package!))
+ ;; You'll have to import these from (gdbm). They are currently
+ ;; bound in () by exports from (runtime gdbm).
+ #;(export #f
+ gdbm-available?
+ 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))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+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 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.
+
+|#
+
+;;;; gdbm Database Library Interface
+;;; package: (gdbm)
+
+(declare (usual-integrations)
+ (integrate-external))
+\f
+(C-include "gdbm")
+
+(define (gdbm-available?)
+ (let ((path (ignore-errors (lambda ()
+ (system-library-pathname "gdbm-shim.so")))))
+ (and (pathname? path)
+ (file-loadable? path))))
+
+;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
+;; create the database.
+(define GDBM_READER (C-enum "GDBM_READER")) ;A reader.
+(define GDBM_WRITER (C-enum "GDBM_WRITER")) ;A writer.
+(define GDBM_WRCREAT(C-enum "GDBM_WRCREAT")) ;A writer. Create the db if needed.
+(define GDBM_NEWDB (C-enum "GDBM_NEWDB")) ;A writer. Always create a new db.
+(define GDBM_FAST (C-enum "GDBM_FAST")) ;Write fast! => No fsyncs.
+
+(define (gdbm-open filename block-size flags mode)
+ (guarantee-integer block-size 'GDBM-OPEN)
+ (guarantee-integer mode 'GDBM-OPEN)
+ (let ((args (make-alien '|gdbm_args|))
+ (flagsnum (guarantee-gdbm-open-flags flags)))
+ (let ((gdbf (make-gdbf args (make-thread-mutex) filename)))
+ (if (not (gdbm-available?))
+ (error "GDBM support is not installed."))
+ (add-open-gdbf-cleanup gdbf)
+ (with-gdbf-locked
+ gdbf
+ (lambda ()
+ (C-call "do_gdbm_open" args filename block-size flagsnum mode)
+ (if (alien-null? args)
+ (error "gdbm_open failed: malloc failed")
+ (if (alien-null? (C-> args "gdbm_args dbf"))
+ (gdbm-error gdbf "gdbm_open")))))
+ gdbf)))
+
+(define (guarantee-gdbm-open-flags flags)
+ (define (flag->number flag)
+ (case flag
+ ((READER) (C-enum "GDBM_READER"))
+ ((WRITER) (C-enum "GDBM_WRITER"))
+ ((WRCREAT) (C-enum "GDBM_WRCREAT"))
+ ((NEWDB) (C-enum "GDBM_NEWDB"))
+ ((FAST) (C-enum "GDBM_FAST"))
+ (else (error:wrong-type-argument flags "gdbm-open flags" 'GDBM-OPEN))))
+ (cond ((integer? flags) flags)
+ ((symbol? flags) (flag->number flags))
+ ((list-of-type? flags symbol?)
+ (reduce + 0 (map flag->number flags)))
+ (else (error:wrong-type-argument flags "gdbm-open flags" 'GDBM-OPEN))))
+
+(define (gdbm-close gdbf)
+ (guarantee-gdbf gdbf 'GDBM-CLOSE)
+ (with-gdbf-locked
+ gdbf
+ (lambda ()
+ (let ((args (gdbf-args gdbf)))
+ (if (not (alien-null? args))
+ (begin
+ (C-call "do_gdbm_close" args)
+ (alien-null! args)
+ (remove-open-gdbf-cleanup gdbf))))
+ unspecific)))
+
+;; Parameters to gdbm_store for simple insertion or replacement in the
+;; case that the key is already in the database.
+(define GDBM_INSERT (C-enum "GDBM_INSERT")) ;Never replace old data.
+(define GDBM_REPLACE (C-enum "GDBM_REPLACE")) ;Always replace old data.
+
+(define (gdbm-store gdbf key content flag)
+ (guarantee-gdbf gdbf 'GDBM-STORE)
+ (guarantee-nonnull-string key 'GDBM-STORE)
+ (guarantee-nonnull-string content 'GDBM-STORE)
+ (let ((flagnum (cond ((= flag GDBM_INSERT) flag)
+ ((= flag GDBM_REPLACE) flag)
+ ((eq? flag 'INSERT) (C-enum "GDBM_INSERT"))
+ ((eq? flag 'REPLACE) (C-enum "GDBM_REPLACE"))
+ (else (error:wrong-type-argument flag "gdbm-store flag"
+ 'GDBM-STORE)))))
+ (with-gdbf-locked-open
+ gdbf 'GDBM-STORE
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (gdbf-args-put-content! args content)
+ (let ((ret (C-call "do_gdbm_store" args flagnum)))
+ (cond ((fix:zero? ret) #t)
+ ((fix:< 0 ret) #f)
+ (else (gdbm-error gdbf "gdbm_store"))))))))
+
+(define (gdbm-fetch gdbf key)
+ (guarantee-gdbf gdbf 'GDBM-FETCH)
+ (guarantee-nonnull-string key 'GDBM-FETCH)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-FETCH
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (C-call "do_gdbm_fetch" args)
+ (gdbf-args-get-content args))))
+
+(define (gdbm-exists? gdbf key)
+ (guarantee-gdbf gdbf 'GDBM-EXISTS?)
+ (guarantee-nonnull-string key 'GDBM-EXISTS?)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-EXISTS
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (not (zero? (C-call "do_gdbm_exists" args))))))
+
+(define (gdbm-delete gdbf key)
+ (guarantee-gdbf gdbf 'GDBM-DELETE)
+ (guarantee-nonnull-string key 'GDBM-DELETE)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-DELETE
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (zero? (C-call "do_gdbm_delete" (gdbf-args gdbf))))))
+
+(define (gdbm-keys gdbf)
+ (guarantee-gdbf gdbf 'GDBM-KEYS)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-KEYS
+ (lambda (args)
+ (C-call "do_gdbm_firstkey" args)
+ (let ((key (gdbf-args-get-key args)))
+ (if (not key)
+ '()
+ (let loop ((keys (list key)))
+ (if (zero? (C-call "do_gdbm_nextkey" args))
+ (loop (cons (gdbf-args-get-key args) keys))
+ keys)))))))
+
+(define (gdbm-firstkey gdbf)
+ (guarantee-gdbf gdbf 'GDBM-FIRSTKEY)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-FIRSTKEY
+ (lambda (args)
+ (C-call "do_gdbm_firstkey" args)
+ (gdbf-args-get-key args))))
+
+(define (gdbm-nextkey gdbf key)
+ ;; Returns #f if KEY is not (or no longer) in the database. Use
+ ;; gdbm-keys to read a complete list despite deletes. Gdbm-keys
+ ;; also avoids copying the keys back for gdbm_nextkey.
+ (guarantee-gdbf gdbf 'GDBM-NEXTKEY)
+ (guarantee-nonnull-string key 'GDBM-NEXTKEY)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-NEXTKEY
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (if (zero? (C-call "do_gdbm_nextkey" args))
+ (gdbf-args-get-key args)
+ #f))))
+
+(define (gdbm-reorganize gdbf)
+ (guarantee-gdbf gdbf 'GDBM-REORGANIZE)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-REORGANIZE
+ (lambda (args)
+ (if (not (zero? (C-call "do_gdbm_reorganize" args)))
+ (gdbm-error gdbf "gdbm_reorganize")))))
+
+(define (gdbm-sync gdbf)
+ (guarantee-gdbf gdbf 'GDBM-SYNC)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-SYNC
+ (lambda (args)
+ (C-call "do_gdbm_sync" args))))
+
+(define (gdbm-strerror errno)
+ (guarantee-fixnum errno 'GDBM-STRERROR)
+ (c-peek-cstring (C-call "gdbm_strerror" (make-alien '(* char)) errno)))
+
+(define (strerror errno)
+ (guarantee-fixnum errno 'STRERROR)
+ (c-peek-cstring (C-call "strerror" (make-alien '(* char)) errno)))
+
+;; Parameters to gdbm_setopt, specifing the type of operation to perform.
+(define GDBM_CACHESIZE (C-enum "GDBM_CACHESIZE")) ;Set the cache size.
+(define GDBM_SYNCMODE (C-enum "GDBM_SYNCMODE")) ;Toggle fast mode.
+
+(define (gdbm-setopt gdbf opt val)
+ (guarantee-gdbf gdbf 'GDBM-SETOPT)
+ (let* ((optnum
+ (cond ((eq? opt 'SYNCMODE) (C-enum "GDBM_SYNCMODE"))
+ ((eq? opt 'CACHESIZE) (C-enum "GDBM_CACHESIZE"))
+ ((and (number? opt) (= opt GDBM_SYNCMODE)) opt)
+ ((and (number? opt) (= opt GDBM_CACHESIZE)) opt)
+ (else (error:wrong-type-argument opt "option" 'GDBM-SETOPT))))
+ (valnum
+ (cond ((= optnum GDBM_SYNCMODE)
+ (cond ((not val) 0)
+ ((eq? val #t) 1)
+ ((zero? val) val)
+ ((= val 1) val)
+ (else (error:wrong-type-argument val "SYNCMODE boolean"
+ 'GDBM-SETOPT))))
+ ((= optnum GDBM_CACHESIZE)
+ (guarantee-integer val 'GDBM-SETOPT)
+ val))))
+ (with-gdbf-locked-open
+ gdbf 'GDBM-SETOPT
+ (lambda (args)
+ (if (not (zero? (C-call "do_gdbm_setopt" args optnum valnum)))
+ (gdbm-error gdbf "gdbm_setopt"))))))
+
+(define (gdbm-version)
+ (c-peek-cstring (C-call "get_gdbm_version" (make-alien '(* char)))))
+
+(define (guarantee-nonnull-string obj procedure)
+ (if (or (not (string? obj)) (string-null? obj))
+ (error:wrong-type-argument obj "non-null string" procedure)))
+\f
+(define-structure (gdbf (constructor make-gdbf)
+ (print-procedure
+ (standard-unparser-method
+ 'GDBF
+ (lambda (gdbf port)
+ (write-char #\space port)
+ (write (gdbf-filename gdbf) port)))))
+ ;; Note that communicating through this malloced-per-GDBM_FILE
+ ;; helper struct assumes there are no callbacks possible during gdbm
+ ;; operations (via which this procedure could be called multiple
+ ;; times [requiring a malloc per operation]). The per-gdbf lock is
+ ;; probably already be poised to deadlock any thread trying it.
+ (args #f read-only #t)
+ (mutex #f read-only #t)
+ (filename #f read-only #t))
+
+(define (guarantee-gdbf gdbf procedure)
+ (if (gdbf? gdbf)
+ (or (not (alien-null? (gdbf-args gdbf)))
+ (error:bad-range-argument gdbf procedure))
+ (error:wrong-type-argument gdbf "gdbm handle" procedure)))
+
+(define-integrable (with-gdbf-locked gdbf thunk)
+ (with-thread-mutex-locked (gdbf-mutex gdbf) thunk))
+
+(define (with-gdbf-locked-open gdbf operator receiver)
+ (with-thread-mutex-locked
+ (gdbf-mutex gdbf)
+ (lambda ()
+ (let ((args (gdbf-args gdbf)))
+ (if (alien-null? args)
+ (error (string-append (symbol-name operator) " failed: closed")))
+ (receiver args)))))
+
+(define (gdbm-error gdbf msg)
+ (let ((args (gdbf-args gdbf)))
+ (error (string-append msg " failed:")
+ (gdbm-strerror (C-> args "gdbm_args gdbm_errno"))
+ (strerror (C-> args "gdbm_args sys_errno")))))
+
+(define (gdbf-args-put-key! args key)
+ (let ((size (string-length key))
+ (dptr (make-alien '(* char))))
+ (if (< size 1)
+ (error "empty key:" key))
+ (C-call "alloc_gdbm_key" dptr args size)
+ (if (alien-null? dptr)
+ (error "gdbf-args-put-key!: malloc failed" key))
+ (c-poke-bytes dptr 0 size key 0)))
+
+(define (gdbf-args-put-content! args content)
+ (let ((size (string-length content))
+ (dptr (make-alien '(* char))))
+ (if (< size 1)
+ (error "empty content:" content))
+ (C-call "alloc_gdbm_content" dptr args size)
+ (if (alien-null? dptr)
+ (error "gdbf-args-put-content!: malloc failed" size))
+ (c-poke-bytes dptr 0 size content 0)))
+
+(define (gdbf-args-get-key args)
+ (let ((data (C-> args "gdbm_args key dptr")))
+ (if (alien-null? data)
+ #f
+ (let* ((size (C-> args "gdbm_args key dsize"))
+ (string (string-allocate size)))
+ (c-peek-bytes data 0 size string 0)
+ string))))
+
+(define (gdbf-args-get-content args)
+ (let ((data (C-> args "gdbm_args content dptr")))
+ (if (alien-null? data)
+ #f
+ (let* ((size (C-> args "gdbm_args content dsize"))
+ (string (string-allocate size)))
+ (c-peek-bytes data 0 size string 0)
+ string))))
+
+(define open-gdbfs '())
+(define open-gdbfs-mutex)
+
+(define (add-open-gdbf-cleanup gdbf)
+ (with-thread-mutex-locked
+ open-gdbfs-mutex
+ (lambda ()
+ (set! open-gdbfs (cons (weak-cons gdbf (gdbf-args gdbf))
+ open-gdbfs)))))
+
+(define (remove-open-gdbf-cleanup gdbf)
+ (with-thread-mutex-locked
+ open-gdbfs-mutex
+ (lambda ()
+ (let ((entry (weak-assq gdbf open-gdbfs)))
+ (if entry
+ (set! open-gdbfs (delq! entry open-gdbfs)))))))
+
+(define (weak-assq obj alist)
+ (let loop ((alist alist))
+ (if (null? alist) #f
+ (let* ((entry (car alist))
+ (key (weak-car entry)))
+ (if (eq? obj key) entry
+ (loop (cdr alist)))))))
+
+(define (cleanup-open-gdbfs)
+ (if (not (thread-mutex-owner open-gdbfs-mutex))
+ (let loop ((entries open-gdbfs)
+ (prev #f))
+ (if (pair? entries)
+ (let ((entry (car entries))
+ (next (cdr entries)))
+ (if (weak-pair/car? entry)
+ (loop next entries)
+ (let ((args (weak-cdr entry)))
+ (if prev
+ (set-cdr! prev next)
+ (set! open-gdbfs next))
+ (if (not (alien-null? args))
+ (begin
+ (C-call "do_gdbm_close" args)
+ (alien-null! args)))
+ (loop next prev))))))))
+
+(define (initialize-package!)
+ (set! open-gdbfs-mutex (make-thread-mutex))
+ (set! open-gdbfs '())
+ (add-gc-daemon! cleanup-open-gdbfs))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Load the GDBM option.
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load-package-set "gdbm")))
+
+(add-subsystem-identification! "GDBM2" '(0 1))
\ No newline at end of file
projects / mit-scheme.git / commitdiff