struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
+struct scm scm_symbol_hashq_table = {TSYMBOL, "<hashq-table>",0};
+struct scm scm_symbol_record_type = {TSYMBOL, "<record-type>",0};
+struct scm scm_symbol_module = {TSYMBOL, "<module>",0};
+struct scm scm_symbol_buckets = {TSYMBOL, "buckets",0};
+struct scm scm_symbol_size = {TSYMBOL, "size",0};
+
struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
return a != cell_nil ? CAR (a) : cell_f;
}
+SCM
+assoc_string (SCM x, SCM a) ///(internal))
+{
+ while (a != cell_nil && list_of_char_equal_p (STRING (x), STRING (CAAR (a))) == cell_f)
+ a = CDR (a);
+ return a != cell_nil ? CAR (a) : cell_f;
+}
+
+SCM
+assoc (SCM x, SCM a)
+{
+ if (TYPE (x) == TSTRING)
+ return assoc_string (x, a);
+ while (a != cell_nil && equal2_p (x, CAAR (a)) == cell_f)
+ a = CDR (a);
+ return a != cell_nil ? CAR (a) : cell_f;
+}
+
SCM
set_car_x (SCM x, SCM e)
{
SCM vector_set_x_ (SCM x, long i, SCM e);
int
-char_hash (int c)
+hash_list_of_char (SCM lst, long size)
{
- if (c >= 'a' && c <= 'z')
- return c - 'a';
- return 27;
+ int hash = VALUE (CAR (lst)) * 37;
+ if (TYPE (CDR (lst)) == TPAIR && TYPE (CADR (lst)) == TCHAR)
+ hash = hash + VALUE (CADR (lst)) * 43;
+ assert (size);
+ hash = hash % size;
+ return hash;
}
int
hashq_ (SCM x, long size)
{
- int hash = char_hash (VALUE (CAR (STRING (x)))) * 27;
- if (TYPE (CDR (STRING (x))) == TPAIR)
- hash = hash + char_hash (VALUE (CADR (STRING (x))));
- else
- hash = hash + char_hash (0);
- assert (hash <= 756);
- return hash;
+ if (TYPE (x) == TSPECIAL
+ || TYPE (x) == TSYMBOL)
+ return hash_list_of_char (STRING (x), size); // FIXME: hash x directly
+ error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list ("hashq_: not a symbol")), x));
}
int
+hash_ (SCM x, long size)
+{
+ if (TYPE (x) == TSTRING)
+ return hash_list_of_char (STRING (x), size);
+ assert (0);
+ return hashq_ (x, size);
+}
+
+SCM
hashq (SCM x, SCM size)
{
- return hashq_ (x, VALUE (size));
+ 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;
}
SCM
hashq_ref (SCM table, SCM key, SCM dflt)
{
- unsigned hash = hashq_ (key, 0);
+#if defined (INLINE)
+ SCM x = hashq_get_handle (table, key, dflt);
+#else
+ 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;
x = CAR (dflt);
if (TYPE (bucket) == TPAIR)
x = assq (key, bucket);
+#endif
+ if (x != cell_f)
+ x = CDR (x);
return x;
}
+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
+
SCM
hashq_set_x (SCM table, SCM key, SCM value)
{
- unsigned hash = hashq_ (key, 0);
+ 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
SCM buckets = struct_ref_ (table, 4);
SCM bucket = vector_ref_ (buckets, hash);
if (TYPE (bucket) != TPAIR)
bucket = acons (key, value, bucket);
vector_set_x_ (buckets, hash, bucket);
return value;
+#endif
}
SCM
fdputc ('[', g_stdout);
while (TYPE (e) == TPAIR)
{
- display_ (CAAR (e));
+ write_ (CAAR (e));
e = CDR (e);
if (TYPE (e) == TPAIR)
fdputc (' ', g_stdout);
SCM
make_hashq_type () ///((internal))
{
- SCM record_type_name = cstring_to_symbol ("<record-type>");
- SCM record_type = record_type_name; // FIXME
- SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
+ SCM record_type = cell_symbol_record_type; // FIXME
SCM fields = cell_nil;
- fields = cons (cstring_to_symbol ("buckets"), fields);
- fields = cons (cstring_to_symbol ("size"), fields);
+ fields = cons (cell_symbol_buckets, fields);
+ fields = cons (cell_symbol_size, fields);
fields = cons (fields, cell_nil);
- fields = cons (hashq_type_name, fields);
+ fields = cons (cell_symbol_hashq_table, fields);
return make_struct (record_type, fields, cell_unspecified);
}
make_hash_table_ (long size)
{
if (!size)
- size = 30 * 27;
- SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
- SCM record_type_name = cstring_to_symbol ("<record-type>");
- //SCM hashq_type = hashq_type_name; // FIXME
+ size = 100;
SCM hashq_type = make_hashq_type ();
SCM buckets = make_vector__ (size);
SCM values = cell_nil;
values = cons (buckets, values);
values = cons (MAKE_NUMBER (size), values);
- values = cons (hashq_type_name, values);
+ values = cons (cell_symbol_hashq_table, values);
return make_struct (hashq_type, values, cell_hash_table_printer);
}
#if POSIX
long ARENA_SIZE = 100000000;
#else
-long ARENA_SIZE = 200000; // 32b: 2MiB, 64b: 4 MiB
+long ARENA_SIZE = 300000; // 32b: 3MiB, 64b: 6 MiB
#endif
long MAX_ARENA_SIZE = 100000000;
long STACK_SIZE = 20000;
struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
+struct scm scm_symbol_hashq_table = {TSYMBOL, "<hashq-table>",0};
+struct scm scm_symbol_record_type = {TSYMBOL, "<record-type>",0};
+struct scm scm_symbol_module = {TSYMBOL, "<module>",0};
+struct scm scm_symbol_buckets = {TSYMBOL, "buckets",0};
+struct scm scm_symbol_size = {TSYMBOL, "size",0};
+
struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
SCM
macro_ref (SCM table, SCM name) ///((internal))
{
- return hashq_ref (table, name, cell_nil);
+ if (TYPE (name) == TSYMBOL)
+ return hashq_get_handle (table, name, cell_nil);
+ return cell_f;
}
SCM
g_free++;
g_cells[cell_symbol_unbound_variable] = scm_symbol_unbound_variable;
+g_free++;
+g_cells[cell_symbol_hashq_table] = scm_symbol_hashq_table;
+
+g_free++;
+g_cells[cell_symbol_record_type] = scm_symbol_record_type;
+
+g_free++;
+g_cells[cell_symbol_module] = scm_symbol_module;
+
+g_free++;
+g_cells[cell_symbol_buckets] = scm_symbol_buckets;
+
+g_free++;
+g_cells[cell_symbol_size] = scm_symbol_size;
+
g_free++;
g_cells[cell_symbol_argv] = scm_symbol_argv;
g_cells[cell_symbol_wrong_number_of_args].car = cstring_to_list (scm_symbol_wrong_number_of_args.name);
g_cells[cell_symbol_wrong_type_arg].car = cstring_to_list (scm_symbol_wrong_type_arg.name);
g_cells[cell_symbol_unbound_variable].car = cstring_to_list (scm_symbol_unbound_variable.name);
+g_cells[cell_symbol_hashq_table].car = cstring_to_list (scm_symbol_hashq_table.name);
+g_cells[cell_symbol_record_type].car = cstring_to_list (scm_symbol_record_type.name);
+g_cells[cell_symbol_module].car = cstring_to_list (scm_symbol_module.name);
+g_cells[cell_symbol_buckets].car = cstring_to_list (scm_symbol_buckets.name);
+g_cells[cell_symbol_size].car = cstring_to_list (scm_symbol_size.name);
g_cells[cell_symbol_argv].car = cstring_to_list (scm_symbol_argv.name);
g_cells[cell_symbol_mes_prefix].car = cstring_to_list (scm_symbol_mes_prefix.name);
g_cells[cell_symbol_mes_version].car = cstring_to_list (scm_symbol_mes_version.name);
SCM
make_module_type () ///(internal))
{
- SCM record_type_name = cstring_to_symbol ("<record-type>");
- SCM record_type = record_type_name; // FIXME
- SCM module_type_name = cstring_to_symbol ("<module>");
+ SCM record_type = cell_symbol_record_type; // FIXME
SCM fields = cell_nil;
fields = cons (cstring_to_symbol ("globals"), fields);
fields = cons (cstring_to_symbol ("locals"), fields);
fields = cons (cstring_to_symbol ("name"), fields);
fields = cons (fields, cell_nil);
- fields = cons (module_type_name, fields);
+ fields = cons (cell_symbol_module, fields);
return make_struct (record_type, fields, cell_unspecified);
}
SCM
make_initial_module (SCM a) ///((internal))
{
- SCM module_type_name = cstring_to_symbol ("<module>");
- // SCM module_type = module_type_name; //FIXME
SCM module_type = make_module_type ();
- a = acons (module_type_name, module_type, a);
+ a = acons (cell_symbol_module, module_type, a);
SCM hashq_type = make_hashq_type ();
- SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
- a = acons (hashq_type_name, hashq_type, a);
+ a = acons (cell_symbol_hashq_table, hashq_type, a);
SCM name = cons (cstring_to_symbol ("boot"), cell_nil);
SCM globals = make_hash_table_ (0);
values = cons (globals, values);
values = cons (locals, values);
values = cons (name, values);
- values = cons (module_type_name, values);
+ values = cons (cell_symbol_module, values);
SCM module = make_struct (module_type, values, cell_module_printer);
r0 = cell_nil;
r0 = cons (CADR (a), r0);
{
if (g_debug > 3)
{
- eputs ("entry="); display_error_ (CAR (a)); eputs ("\n");
+ eputs ("entry="); write_error_ (CAR (a)); eputs ("\n");
}
module_define_x (module, CAAR (a), CDAR (a));
a = CDR (a);
{
module = m0;
SCM globals = struct_ref_ (module, 5);
- x = hashq_ref (globals, name, cell_f);
+ x = hashq_get_handle (globals, name, cell_f);
}
return x;
}