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.

diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c
index 9da6de983c5bda16856f2f70caccd218a4112c9c..b8909658a1cb144d28ce9023d47e24d60483cb9c 100644 (file)
--- a/scaffold/mini-mes.c
+++ b/scaffold/mini-mes.c
@@ -134,6 +134,12 @@ struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0}
 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};
@@ -646,6 +652,24 @@ assq (SCM x, SCM a)
   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)
 {

diff --git a/src/hash.c b/src/hash.c
index 6ddae79adace858bfb1d667b26f5e5045a78f06d..f2dee09c8857073c292fa1e86d18e7bcfcf5c23c 100644 (file)
--- a/src/hash.c
+++ b/src/hash.c
@@ -23,35 +23,71 @@ SCM vector_ref_ (SCM x, long i);
 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;
@@ -59,13 +95,72 @@ hashq_ref (SCM table, SCM key, SCM dflt)
     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)
@@ -73,6 +168,7 @@ hashq_set_x (SCM table, SCM key, SCM value)
   bucket = acons (key, value, bucket);
   vector_set_x_ (buckets, hash, bucket);
   return value;
+#endif
 }
 
 SCM
@@ -90,7 +186,7 @@ hash_table_printer (SCM table)
           fdputc ('[', g_stdout);
           while (TYPE (e) == TPAIR)
             {
-              display_ (CAAR (e));
+              write_ (CAAR (e));
               e = CDR (e);
               if (TYPE (e) == TPAIR)
                 fdputc (' ', g_stdout);
@@ -104,14 +200,12 @@ hash_table_printer (SCM table)
 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);
 }
 
@@ -119,17 +213,14 @@ SCM
 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);
 }
 

diff --git a/src/mes.c b/src/mes.c
index f4f8686d3e2f337d435477788a9e7073e9f3c227..625d432a183412b0313b2f3a34e5ac8936052838 100644 (file)
--- a/src/mes.c
+++ b/src/mes.c
@@ -28,7 +28,7 @@
 #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;
@@ -200,6 +200,12 @@ struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0}
 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};
@@ -930,7 +936,9 @@ make_variable_ (SCM var) ///((internal))
 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
@@ -1836,6 +1844,21 @@ g_cells[cell_symbol_wrong_type_arg] = scm_symbol_wrong_type_arg;
 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;
 
@@ -2034,6 +2057,11 @@ g_cells[cell_symbol_system_error].car = cstring_to_list (scm_symbol_system_error
 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);

diff --git a/src/module.c b/src/module.c
index c0b737403bb7357744ad5fa69422bb7a5e34d1b2..484b121b0e38a3699144fc03890307c493f94c42 100644 (file)
--- a/src/module.c
+++ b/src/module.c
@@ -24,29 +24,24 @@ SCM struct_set_x_ (SCM x, long i, SCM e);
 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);
@@ -56,7 +51,7 @@ make_initial_module (SCM a) ///((internal))
   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);
@@ -66,7 +61,7 @@ make_initial_module (SCM a) ///((internal))
     {
       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);
@@ -98,7 +93,7 @@ module_variable (SCM module, SCM name)
     {
       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;
 }