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