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