build: Resurrect --with-cheating.
[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 #include "mes/lib.h"
22 #include "mes/mes.h"
23
24 #include <assert.h>
25 #include <string.h>
26
27 int
28 hash_cstring (char const *s, long size)
29 {
30   int hash = s[0] * 37;
31   if (s[0] && s[1])
32     hash = hash + s[1] * 43;
33   assert (size);
34   hash = hash % size;
35   return hash;
36 }
37
38 int
39 hashq_ (SCM x, long size)
40 {
41   if (TYPE (x) == TSPECIAL || TYPE (x) == TSYMBOL)
42     return hash_cstring (CSTRING (x), size);    // FIXME: hash x directly
43   error (cell_symbol_system_error, cons (MAKE_STRING0 ("hashq_: not a symbol"), x));
44 }
45
46 int
47 hash_ (SCM x, long size)
48 {
49   if (TYPE (x) == TSTRING)
50     return hash_cstring (CSTRING (x), size);
51   assert (0);
52   return hashq_ (x, size);
53 }
54
55 SCM
56 hashq (SCM x, SCM size)
57 {
58   assert (0);
59   return MAKE_NUMBER (hashq_ (x, VALUE (size)));
60 }
61
62 SCM
63 hash (SCM x, SCM size)
64 {
65   assert (0);
66   return MAKE_NUMBER (hash_ (x, VALUE (size)));
67 }
68
69 SCM
70 hashq_get_handle (SCM table, SCM key, SCM dflt)
71 {
72   long size = VALUE (struct_ref_ (table, 3));
73   unsigned hash = hashq_ (key, size);
74   SCM buckets = struct_ref_ (table, 4);
75   SCM bucket = vector_ref_ (buckets, hash);
76   SCM x = cell_f;
77   if (TYPE (dflt) == TPAIR)
78     x = CAR (dflt);
79   if (TYPE (bucket) == TPAIR)
80     x = assq (key, bucket);
81   return x;
82 }
83
84 SCM
85 hashq_ref (SCM table, SCM key, SCM dflt)
86 {
87 #if defined (INLINE)
88   SCM x = hashq_get_handle (table, key, dflt);
89 #else
90   long size = VALUE (struct_ref_ (table, 3));
91   unsigned hash = hashq_ (key, size);
92   SCM buckets = struct_ref_ (table, 4);
93   SCM bucket = vector_ref_ (buckets, hash);
94   SCM x = cell_f;
95   if (TYPE (dflt) == TPAIR)
96     x = CAR (dflt);
97   if (TYPE (bucket) == TPAIR)
98     x = assq (key, bucket);
99 #endif
100   if (x != cell_f)
101     x = CDR (x);
102   return x;
103 }
104
105 SCM
106 hash_ref (SCM table, SCM key, SCM dflt)
107 {
108   long size = VALUE (struct_ref_ (table, 3));
109   unsigned hash = hash_ (key, size);
110   SCM buckets = struct_ref_ (table, 4);
111   SCM bucket = vector_ref_ (buckets, hash);
112   SCM x = cell_f;
113   if (TYPE (dflt) == TPAIR)
114     x = CAR (dflt);
115   if (TYPE (bucket) == TPAIR)
116     {
117       x = assoc (key, bucket);
118       if (x != cell_f)
119         x = CDR (x);
120     }
121   return x;
122 }
123
124 #if defined (INLINE)
125 #error INLINE
126 SCM
127 hash_set_x_ (SCM table, unsigned hash, SCM key, SCM value)
128 {
129   SCM buckets = struct_ref_ (table, 4);
130   SCM bucket = vector_ref_ (buckets, hash);
131   if (TYPE (bucket) != TPAIR)
132     bucket = cell_nil;
133   bucket = acons (key, value, bucket);
134   vector_set_x_ (buckets, hash, bucket);
135   return value;
136 }
137 #endif
138
139 SCM
140 hashq_set_x (SCM table, SCM key, SCM value)
141 {
142   long size = VALUE (struct_ref_ (table, 3));
143   unsigned hash = hashq_ (key, size);
144 #if defined (INLINE)
145   return hash_set_x_ (table, hash, key, value);
146 #else
147   SCM buckets = struct_ref_ (table, 4);
148   SCM bucket = vector_ref_ (buckets, hash);
149   if (TYPE (bucket) != TPAIR)
150     bucket = cell_nil;
151   bucket = acons (key, value, bucket);
152   vector_set_x_ (buckets, hash, bucket);
153   return value;
154 #endif
155 }
156
157 SCM
158 hash_set_x (SCM table, SCM key, SCM value)
159 {
160   long size = VALUE (struct_ref_ (table, 3));
161   unsigned hash = hash_ (key, size);
162 #if defined (INLINE)
163   return hash_set_x_ (table, hash, key, value);
164 #else
165   SCM buckets = struct_ref_ (table, 4);
166   SCM bucket = vector_ref_ (buckets, hash);
167   if (TYPE (bucket) != TPAIR)
168     bucket = cell_nil;
169   bucket = acons (key, value, bucket);
170   vector_set_x_ (buckets, hash, bucket);
171   return value;
172 #endif
173 }
174
175 SCM
176 hash_table_printer (SCM table)
177 {
178   fdputs ("#<", __stdout);
179   display_ (struct_ref_ (table, 2));
180   fdputc (' ', __stdout);
181   fdputs ("size: ", __stdout);
182   display_ (struct_ref_ (table, 3));
183   fdputc (' ', __stdout);
184   SCM buckets = struct_ref_ (table, 4);
185   fdputs ("buckets: ", __stdout);
186   for (int i = 0; i < LENGTH (buckets); i++)
187     {
188       SCM e = vector_ref_ (buckets, i);
189       if (e != cell_unspecified)
190         {
191           fdputc ('[', __stdout);
192           while (TYPE (e) == TPAIR)
193             {
194               write_ (CAAR (e));
195               e = CDR (e);
196               if (TYPE (e) == TPAIR)
197                 fdputc (' ', __stdout);
198             }
199           fdputs ("]\n  ", __stdout);
200         }
201     }
202   fdputc ('>', __stdout);
203 }
204
205 SCM
206 make_hashq_type ()              ///((internal))
207 {
208   SCM record_type = cell_symbol_record_type;    // FIXME
209   SCM fields = cell_nil;
210   fields = cons (cell_symbol_buckets, fields);
211   fields = cons (cell_symbol_size, fields);
212   fields = cons (fields, cell_nil);
213   fields = cons (cell_symbol_hashq_table, fields);
214   return make_struct (record_type, fields, cell_unspecified);
215 }
216
217 SCM
218 make_hash_table_ (long size)
219 {
220   if (!size)
221     size = 100;
222   SCM hashq_type = make_hashq_type ();
223
224   SCM buckets = make_vector__ (size);
225   SCM values = cell_nil;
226   values = cons (buckets, values);
227   values = cons (MAKE_NUMBER (size), values);
228   values = cons (cell_symbol_hashq_table, values);
229   //FIXME: symbol/printer return make_struct (hashq_type, values, cstring_to_symbol ("hash-table-printer");
230   return make_struct (hashq_type, values, cell_unspecified);
231 }
232
233 SCM
234 make_hash_table (SCM x)
235 {
236   long size = 0;
237   if (TYPE (x) == TPAIR)
238     {
239       assert (TYPE (x) == TNUMBER);
240       size = VALUE (x);
241     }
242   return make_hash_table_ (size);
243 }