mes: Switch to srfi-9 based on structs.
[mes.git] / 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 }