2018-10-15 12:36:19 +01:00
|
|
|
/* -*-comment-start: "//";comment-end:""-*-
|
|
|
|
* GNU Mes --- Maxwell Equations of Software
|
|
|
|
* Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
|
|
*
|
|
|
|
* This file is part of GNU Mes.
|
|
|
|
*
|
|
|
|
* GNU Mes is free software; you can redistribute it and/or modify it
|
|
|
|
* under the terms of the GNU General Public License as published by
|
|
|
|
* the Free Software Foundation; either version 3 of the License, or (at
|
|
|
|
* your option) any later version.
|
|
|
|
*
|
|
|
|
* GNU Mes is distributed in the hope that it will be useful, but
|
|
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
* GNU General Public License for more details.
|
|
|
|
*
|
|
|
|
* You should have received a copy of the GNU General Public License
|
|
|
|
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
*/
|
|
|
|
|
2019-03-02 13:36:22 +00:00
|
|
|
#include "mes/lib.h"
|
|
|
|
#include "mes/mes.h"
|
|
|
|
|
|
|
|
#include <assert.h>
|
|
|
|
#include <string.h>
|
2018-10-15 12:36:19 +01:00
|
|
|
|
|
|
|
int
|
2019-02-16 11:27:42 +00:00
|
|
|
hash_cstring (char const *s, long size)
|
2018-10-15 12:36:19 +01:00
|
|
|
{
|
2018-11-11 15:25:36 +00:00
|
|
|
int hash = s[0] * 37;
|
|
|
|
if (s[0] && s[1])
|
|
|
|
hash = hash + s[1] * 43;
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
assert (size);
|
|
|
|
hash = hash % size;
|
|
|
|
return hash;
|
2018-10-15 12:36:19 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
int
|
|
|
|
hashq_ (SCM x, long size)
|
|
|
|
{
|
2019-02-16 11:27:42 +00:00
|
|
|
if (TYPE (x) == TSPECIAL || TYPE (x) == TSYMBOL)
|
|
|
|
return hash_cstring (CSTRING (x), size); // FIXME: hash x directly
|
2018-11-11 15:25:36 +00:00
|
|
|
error (cell_symbol_system_error, cons (MAKE_STRING0 ("hashq_: not a symbol"), x));
|
2018-10-15 12:36:19 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
int
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
hash_ (SCM x, long size)
|
|
|
|
{
|
|
|
|
if (TYPE (x) == TSTRING)
|
2018-11-11 15:25:36 +00:00
|
|
|
return hash_cstring (CSTRING (x), size);
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
assert (0);
|
|
|
|
return hashq_ (x, size);
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
2018-10-15 12:36:19 +01:00
|
|
|
hashq (SCM x, SCM size)
|
|
|
|
{
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
assert (0);
|
|
|
|
return MAKE_NUMBER (hashq_ (x, VALUE (size)));
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
hash (SCM x, SCM size)
|
|
|
|
{
|
|
|
|
assert (0);
|
|
|
|
return MAKE_NUMBER (hash_ (x, VALUE (size)));
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
hashq_get_handle (SCM table, SCM key, SCM dflt)
|
|
|
|
{
|
|
|
|
long size = VALUE (struct_ref_ (table, 3));
|
|
|
|
unsigned hash = hashq_ (key, size);
|
|
|
|
SCM buckets = struct_ref_ (table, 4);
|
|
|
|
SCM bucket = vector_ref_ (buckets, hash);
|
|
|
|
SCM x = cell_f;
|
|
|
|
if (TYPE (dflt) == TPAIR)
|
|
|
|
x = CAR (dflt);
|
|
|
|
if (TYPE (bucket) == TPAIR)
|
|
|
|
x = assq (key, bucket);
|
|
|
|
return x;
|
2018-10-15 12:36:19 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
hashq_ref (SCM table, SCM key, SCM dflt)
|
|
|
|
{
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
#if defined (INLINE)
|
|
|
|
SCM x = hashq_get_handle (table, key, dflt);
|
|
|
|
#else
|
|
|
|
long size = VALUE (struct_ref_ (table, 3));
|
|
|
|
unsigned hash = hashq_ (key, size);
|
2018-10-15 19:42:10 +01:00
|
|
|
SCM buckets = struct_ref_ (table, 4);
|
2018-10-15 14:45:41 +01:00
|
|
|
SCM bucket = vector_ref_ (buckets, hash);
|
2018-10-15 12:36:19 +01:00
|
|
|
SCM x = cell_f;
|
|
|
|
if (TYPE (dflt) == TPAIR)
|
|
|
|
x = CAR (dflt);
|
|
|
|
if (TYPE (bucket) == TPAIR)
|
|
|
|
x = assq (key, bucket);
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
#endif
|
|
|
|
if (x != cell_f)
|
|
|
|
x = CDR (x);
|
2018-10-15 12:36:19 +01:00
|
|
|
return x;
|
|
|
|
}
|
|
|
|
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
SCM
|
|
|
|
hash_ref (SCM table, SCM key, SCM dflt)
|
|
|
|
{
|
|
|
|
long size = VALUE (struct_ref_ (table, 3));
|
|
|
|
unsigned hash = hash_ (key, size);
|
|
|
|
SCM buckets = struct_ref_ (table, 4);
|
|
|
|
SCM bucket = vector_ref_ (buckets, hash);
|
|
|
|
SCM x = cell_f;
|
|
|
|
if (TYPE (dflt) == TPAIR)
|
|
|
|
x = CAR (dflt);
|
|
|
|
if (TYPE (bucket) == TPAIR)
|
|
|
|
{
|
|
|
|
x = assoc (key, bucket);
|
|
|
|
if (x != cell_f)
|
|
|
|
x = CDR (x);
|
|
|
|
}
|
|
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
|
|
#if defined (INLINE)
|
|
|
|
#error INLINE
|
|
|
|
SCM
|
|
|
|
hash_set_x_ (SCM table, unsigned hash, SCM key, SCM value)
|
|
|
|
{
|
|
|
|
SCM buckets = struct_ref_ (table, 4);
|
|
|
|
SCM bucket = vector_ref_ (buckets, hash);
|
|
|
|
if (TYPE (bucket) != TPAIR)
|
|
|
|
bucket = cell_nil;
|
|
|
|
bucket = acons (key, value, bucket);
|
|
|
|
vector_set_x_ (buckets, hash, bucket);
|
|
|
|
return value;
|
|
|
|
}
|
|
|
|
#endif
|
|
|
|
|
2018-10-15 12:36:19 +01:00
|
|
|
SCM
|
|
|
|
hashq_set_x (SCM table, SCM key, SCM value)
|
|
|
|
{
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
long size = VALUE (struct_ref_ (table, 3));
|
|
|
|
unsigned hash = hashq_ (key, size);
|
|
|
|
#if defined (INLINE)
|
|
|
|
return hash_set_x_ (table, hash, key, value);
|
|
|
|
#else
|
|
|
|
SCM buckets = struct_ref_ (table, 4);
|
|
|
|
SCM bucket = vector_ref_ (buckets, hash);
|
|
|
|
if (TYPE (bucket) != TPAIR)
|
|
|
|
bucket = cell_nil;
|
|
|
|
bucket = acons (key, value, bucket);
|
|
|
|
vector_set_x_ (buckets, hash, bucket);
|
|
|
|
return value;
|
|
|
|
#endif
|
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
hash_set_x (SCM table, SCM key, SCM value)
|
|
|
|
{
|
|
|
|
long size = VALUE (struct_ref_ (table, 3));
|
|
|
|
unsigned hash = hash_ (key, size);
|
|
|
|
#if defined (INLINE)
|
|
|
|
return hash_set_x_ (table, hash, key, value);
|
|
|
|
#else
|
2018-10-15 19:42:10 +01:00
|
|
|
SCM buckets = struct_ref_ (table, 4);
|
2018-10-15 14:45:41 +01:00
|
|
|
SCM bucket = vector_ref_ (buckets, hash);
|
2018-10-15 12:36:19 +01:00
|
|
|
if (TYPE (bucket) != TPAIR)
|
|
|
|
bucket = cell_nil;
|
|
|
|
bucket = acons (key, value, bucket);
|
2018-10-15 14:45:41 +01:00
|
|
|
vector_set_x_ (buckets, hash, bucket);
|
2018-10-15 12:36:19 +01:00
|
|
|
return value;
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
#endif
|
2018-10-15 12:36:19 +01:00
|
|
|
}
|
|
|
|
|
2018-10-15 14:45:41 +01:00
|
|
|
SCM
|
|
|
|
hash_table_printer (SCM table)
|
|
|
|
{
|
2019-02-16 11:27:42 +00:00
|
|
|
fdputs ("#<", __stdout);
|
|
|
|
display_ (struct_ref_ (table, 2));
|
|
|
|
fdputc (' ', __stdout);
|
|
|
|
fdputs ("size: ", __stdout);
|
|
|
|
display_ (struct_ref_ (table, 3));
|
|
|
|
fdputc (' ', __stdout);
|
2018-10-15 19:42:10 +01:00
|
|
|
SCM buckets = struct_ref_ (table, 4);
|
2019-01-05 11:35:18 +00:00
|
|
|
fdputs ("buckets: ", __stdout);
|
2019-02-16 11:27:42 +00:00
|
|
|
for (int i = 0; i < LENGTH (buckets); i++)
|
2018-10-15 14:45:41 +01:00
|
|
|
{
|
|
|
|
SCM e = vector_ref_ (buckets, i);
|
|
|
|
if (e != cell_unspecified)
|
|
|
|
{
|
2019-01-05 11:35:18 +00:00
|
|
|
fdputc ('[', __stdout);
|
2018-10-15 14:45:41 +01:00
|
|
|
while (TYPE (e) == TPAIR)
|
|
|
|
{
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
write_ (CAAR (e));
|
2018-10-15 14:45:41 +01:00
|
|
|
e = CDR (e);
|
|
|
|
if (TYPE (e) == TPAIR)
|
2019-01-05 11:35:18 +00:00
|
|
|
fdputc (' ', __stdout);
|
2018-10-15 14:45:41 +01:00
|
|
|
}
|
2019-01-05 11:35:18 +00:00
|
|
|
fdputs ("]\n ", __stdout);
|
2018-10-15 14:45:41 +01:00
|
|
|
}
|
|
|
|
}
|
2019-01-05 11:35:18 +00:00
|
|
|
fdputc ('>', __stdout);
|
2018-10-15 14:45:41 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
2019-02-16 11:27:42 +00:00
|
|
|
make_hashq_type () ///((internal))
|
2018-10-15 14:45:41 +01:00
|
|
|
{
|
2019-02-16 11:27:42 +00:00
|
|
|
SCM record_type = cell_symbol_record_type; // FIXME
|
2018-10-15 14:45:41 +01:00
|
|
|
SCM fields = cell_nil;
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
fields = cons (cell_symbol_buckets, fields);
|
|
|
|
fields = cons (cell_symbol_size, fields);
|
2018-10-15 15:57:00 +01:00
|
|
|
fields = cons (fields, cell_nil);
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
fields = cons (cell_symbol_hashq_table, fields);
|
2018-10-15 19:42:10 +01:00
|
|
|
return make_struct (record_type, fields, cell_unspecified);
|
2018-10-15 14:45:41 +01:00
|
|
|
}
|
|
|
|
|
2018-10-15 12:36:19 +01:00
|
|
|
SCM
|
|
|
|
make_hash_table_ (long size)
|
|
|
|
{
|
|
|
|
if (!size)
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
size = 100;
|
2018-10-15 19:42:10 +01:00
|
|
|
SCM hashq_type = make_hashq_type ();
|
|
|
|
|
2018-10-15 14:45:41 +01:00
|
|
|
SCM buckets = make_vector__ (size);
|
|
|
|
SCM values = cell_nil;
|
|
|
|
values = cons (buckets, values);
|
|
|
|
values = cons (MAKE_NUMBER (size), values);
|
core: Add hashq_get_handle, hash, hash_ref, hash_set_x.
* src/mes.c (scm_symbol_hashq_table, scm_symbol_record_type,
scm_symbol_module, scm_symbol_buckets, scm_symbol_size): New symbols.
Update users.
* src/hash.c (hash_list_of_char): Rename from hashq_. Respect size,
update callers.
(hashq_, hash_ hash, hashq_get_handle, hash_ref, hash_set_x_,
hash_set_x): New function.
(hashq_ref): Do not return handle. Update callers.
2018-10-18 06:55:28 +01:00
|
|
|
values = cons (cell_symbol_hashq_table, values);
|
core: Remove struct definitions for builtins, drop snarfing.
After making a change to the list of builtin functions, run
cat src/*.i
and move the into
src/mes.c:mes_builtins ()
and, or also after changing the list of fixed symbols in src/mes.c:mes_symbols (), do
cat src/*.h > src/builtins.h
* build-aux/build.sh.in: Remove snarfing.
* build-aux/bootstrap.sh.in: Likewise.
* mes/module/mes/display.mes (display):
* mes/module/mes/type-0.mes (cell:type-alist): Remove <cell:function>.
(function?, builtin?): Remove.
* src/builtins.h: New file.
* src/mes.c (TFUNCTION): Remove.
(struct function): Remove.
(apply_builtin): Rewrite from call.
(mes_builtins): Rewrite.
(init_builtin, make_builtin_type, make_builtin, builtin_name,
builtin_arity, builtin, builtin_p, builtin_printer): New function.
2018-12-21 08:55:16 +00:00
|
|
|
//FIXME: symbol/printer return make_struct (hashq_type, values, cstring_to_symbol ("hash-table-printer");
|
|
|
|
return make_struct (hashq_type, values, cell_unspecified);
|
2018-10-15 12:36:19 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
SCM
|
|
|
|
make_hash_table (SCM x)
|
|
|
|
{
|
|
|
|
long size = 0;
|
|
|
|
if (TYPE (x) == TPAIR)
|
|
|
|
{
|
|
|
|
assert (TYPE (x) == TNUMBER);
|
|
|
|
size = VALUE (x);
|
|
|
|
}
|
|
|
|
return make_hash_table_ (size);
|
|
|
|
}
|