src/hash.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * GNU Mes --- Maxwell Equations of Software
   3  * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   4  *
   5  * This file is part of GNU Mes.
   6  *
   7  * GNU Mes is free software; you can redistribute it and/or modify it
   8  * under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3 of the License, or (at
  10  * your option) any later version.
  11  *
  12  * GNU Mes 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
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  19  */
  20
  21 SCM make_vector__ (long k);
  22 SCM vector_ref_ (SCM x, long i);
  23 SCM vector_set_x_ (SCM x, long i, SCM e);
  24
  25 int
  26 char_hash (int c)
  27 {
  28   if (c >= 'a' && c <= 'z')
  29     return c - 'a';
  30   return 27;
  31 }
  32
  33 int
  34 hashq_ (SCM x, long size)
  35 {
  36   int hash = char_hash (VALUE (CAR (STRING (x)))) * 27;
  37   if (TYPE (CDR (STRING (x))) == TPAIR)
  38     hash = hash + char_hash (VALUE (CADR (STRING (x))));
  39   else
  40     hash = hash + char_hash (0);
  41   assert (hash <= 756);
  42   return hash;
  43 }
  44
  45 int
  46 hashq (SCM x, SCM size)
  47 {
  48   return hashq_ (x, VALUE (size));
  49 }
  50
  51 SCM
  52 hashq_ref (SCM table, SCM key, SCM dflt)
  53 {
  54   unsigned hash = hashq_ (key, 0);
  55   SCM buckets = struct_ref_ (table, 4);
  56   SCM bucket = vector_ref_ (buckets, hash);
  57   SCM x = cell_f;
  58   if (TYPE (dflt) == TPAIR)
  59     x = CAR (dflt);
  60   if (TYPE (bucket) == TPAIR)
  61     x = assq (key, bucket);
  62   return x;
  63 }
  64
  65 SCM
  66 hashq_set_x (SCM table, SCM key, SCM value)
  67 {
  68   unsigned hash = hashq_ (key, 0);
  69   SCM buckets = struct_ref_ (table, 4);
  70   SCM bucket = vector_ref_ (buckets, hash);
  71   if (TYPE (bucket) != TPAIR)
  72     bucket = cell_nil;
  73   bucket = acons (key, value, bucket);
  74   vector_set_x_ (buckets, hash, bucket);
  75   return value;
  76 }
  77
  78 SCM
  79 hash_table_printer (SCM table)
  80 {
  81   fdputs ("#<", g_stdout); display_ (struct_ref_ (table, 2)); fdputc (' ', g_stdout);
  82   fdputs ("size: ", g_stdout); display_ (struct_ref_ (table, 3)); fdputc (' ', g_stdout);
  83   SCM buckets = struct_ref_ (table, 4);
  84   fdputs ("buckets: ", g_stdout);
  85   for (int i=0; i<LENGTH (buckets); i++)
  86     {
  87       SCM e = vector_ref_ (buckets, i);
  88       if (e != cell_unspecified)
  89         {
  90           fdputc ('[', g_stdout);
  91           while (TYPE (e) == TPAIR)
  92             {
  93               display_ (CAAR (e));
  94               e = CDR (e);
  95               if (TYPE (e) == TPAIR)
  96                 fdputc (' ', g_stdout);
  97             }
  98           fdputs ("]\n  ", g_stdout);
  99         }
 100     }
 101   fdputc ('>', g_stdout);
 102 }
 103
 104 SCM
 105 make_hashq_type () ///((internal))
 106 {
 107   SCM record_type_name = cstring_to_symbol ("<record-type>");
 108   SCM record_type = record_type_name; // FIXME
 109   SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
 110   SCM fields = cell_nil;
 111   fields = cons (cstring_to_symbol ("buckets"), fields);
 112   fields = cons (cstring_to_symbol ("size"), fields);
 113   fields = cons (fields, cell_nil);
 114   fields = cons (hashq_type_name, fields);
 115   return make_struct (record_type, fields, cell_unspecified);
 116 }
 117
 118 SCM
 119 make_hash_table_ (long size)
 120 {
 121   if (!size)
 122     size = 30 * 27;
 123   SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
 124   SCM record_type_name = cstring_to_symbol ("<record-type>");
 125   //SCM hashq_type = hashq_type_name; // FIXME
 126   SCM hashq_type = make_hashq_type ();
 127
 128   SCM buckets = make_vector__ (size);
 129   SCM values = cell_nil;
 130   values = cons (buckets, values);
 131   values = cons (MAKE_NUMBER (size), values);
 132   values = cons (hashq_type_name, values);
 133   return make_struct (hashq_type, values, cell_hash_table_printer);
 134 }
 135
 136 SCM
 137 make_hash_table (SCM x)
 138 {
 139   long size = 0;
 140   if (TYPE (x) == TPAIR)
 141     {
 142       assert (TYPE (x) == TNUMBER);
 143       size = VALUE (x);
 144     }
 145   return make_hash_table_ (size);
 146 }