patches by Ludovic Courtès for symbol generation.

7 files changed, 188 insertions, 35 deletions

diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog
index a64e4361f..d2a6dfa21 100644
--- a/doc/ref/ChangeLog
+++ b/doc/ref/ChangeLog
@@ -1,3 +1,10 @@
+
+2005-12-19  Ludovic Courtès  <ludovic.courtes@laas.fr>
+
+        * api-data.texi (Operations Related to Symbols):
+        Documented `scm_take_locale_symbol ()'.
+
+	
 2005-12-15  Kevin Ryde  <user42@zip.com.au>
 
 	* api-evaluation.texi (Fly Evaluation): Add scm_call_4, suggested by
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 042af4521..99cd43a3e 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -4551,6 +4551,16 @@ terminated; for @code{scm_from_locale_symboln} the length of @var{name} is
 specified explicitly by @var{len}.
 @end deffn
 
+@deftypefn  {C Function} SCM scm_take_locale_symbol (char *str)
+@deftypefnx {C Function} SCM scm_take_locale_symboln (char *str, size_t len)
+Like @code{scm_from_locale_symbol} and @code{scm_from_locale_symboln},
+respectively, but also frees @var{str} with @code{free} eventually.
+Thus, you can use this function when you would free @var{str} anyway
+immediately after creating the Scheme string.  In certain cases, Guile
+can then use @var{str} directly as its internal representation.
+@end deftypefn
+
+
 Finally, some applications, especially those that generate new Scheme
 code dynamically, need to generate symbols for use in the generated
 code.  The @code{gensym} primitive meets this need:
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index e7f6572a3..c0bdbcf44 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,24 @@
+2005-12-19  Ludovic Courtès  <ludovic.courtes@laas.fr>
+
+        * strings.c (scm_i_take_stringbufn): New.
+        (scm_i_c_take_symbol): New.
+        (scm_take_locale_stringn): Use `scm_i_take_stringbufn ()'.
+
+        * strings.h (scm_i_c_take_symbol): New.
+        (scm_i_take_stringbufn): New.
+
+        * symbols.c  (lookup_interned_symbol): New function.
+        (scm_i_c_mem2symbol): New function.
+        (scm_i_mem2symbol): Use `lookup_symbol ()'.
+        (scm_from_locale_symbol): Use `scm_i_c_mem2symbol ()'.  This avoids
+        creating a new Scheme string.
+        (scm_from_locale_symboln): Likewise.
+        (scm_take_locale_symbol): New.
+        (scm_take_locale_symboln): New.
+
+        * symbols.h (scm_take_locale_symbol): New.
+        (scm_take_locale_symboln): New.
+
 2006-01-18  Han-Wen Nienhuys  <hanwen@xs4all.nl>
 
 	* gc-card.c ("sweep_card"): don't count scm_tc_free_cell for
diff --git a/libguile/strings.c b/libguile/strings.c
index 9a2656b80..fd6be5065 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -122,6 +122,17 @@ make_stringbuf (size_t len)
     }
 }
 
+/* Return a new stringbuf whose underlying storage consists of the LEN octets
+   pointed to by STR.  */
+SCM_C_INLINE SCM
+scm_i_take_stringbufn (char *str, size_t len)
+{
+  scm_gc_register_collectable_memory (str, len, "stringbuf");
+
+  return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
+			  (scm_t_bits) len, (scm_t_bits) 0);
+}
+
 SCM
 scm_i_stringbuf_mark (SCM buf)
 {
@@ -412,6 +423,29 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
 			  (scm_t_bits) hash, SCM_UNPACK (props));
 }
 
+SCM
+scm_i_c_make_symbol (const char *name, size_t len,
+		     scm_t_bits flags, unsigned long hash, SCM props)
+{
+  SCM buf = make_stringbuf (len);
+  memcpy (STRINGBUF_CHARS (buf), name, len);
+
+  return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
+			  (scm_t_bits) hash, SCM_UNPACK (props));
+}
+
+/* Return a new symbol that uses the LEN bytes pointed to by NAME as its
+   underlying storage.  */
+SCM
+scm_i_c_take_symbol (char *name, size_t len,
+		     scm_t_bits flags, unsigned long hash, SCM props)
+{
+  SCM buf = scm_i_take_stringbufn (name, len);
+
+  return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
+			  (scm_t_bits) hash, SCM_UNPACK (props));
+}
+
 size_t
 scm_i_symbol_length (SCM sym)
 {
@@ -842,12 +876,10 @@ scm_take_locale_stringn (char *str, size_t len)
       str[len] = '\0';
     }
 
-  buf = scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
-                         (scm_t_bits) len, (scm_t_bits) 0);
+  buf = scm_i_take_stringbufn (str, len);
   res = scm_double_cell (STRING_TAG,
                          SCM_UNPACK (buf),
                          (scm_t_bits) 0, (scm_t_bits) len);
-  scm_gc_register_collectable_memory (str, len+1, "string");
   return res;
 }
 
diff --git a/libguile/strings.h b/libguile/strings.h
index a2ec51ae9..a8a7af670 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -124,6 +124,12 @@ SCM_API void scm_i_string_stop_writing (void);
 
 SCM_API SCM scm_i_make_symbol (SCM name, scm_t_bits flags, 
 			       unsigned long hash, SCM props);
+SCM_API SCM
+scm_i_c_make_symbol (const char *name, size_t len,
+		     scm_t_bits flags, unsigned long hash, SCM props);
+SCM_API SCM
+scm_i_c_take_symbol (char *name, size_t len,
+		     scm_t_bits flags, unsigned long hash, SCM props);
 SCM_API const char *scm_i_symbol_chars (SCM sym);
 SCM_API size_t scm_i_symbol_length (SCM sym);
 SCM_API SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);
@@ -144,6 +150,7 @@ SCM_API void scm_i_free_string_pointers (char **pointers);
 SCM_API void scm_i_get_substring_spec (size_t len,
 				       SCM start, size_t *cstart,
 				       SCM end, size_t *cend);
+SCM_API SCM scm_i_take_stringbufn (char *str, size_t len);
 
 /* deprecated stuff */
 
diff --git a/libguile/symbols.c b/libguile/symbols.c
index a60ab9355..314dcb79e 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -85,43 +85,79 @@ scm_i_hash_symbol (SCM obj, unsigned long n, void *closure)
 }
 
 static SCM
-scm_i_mem2symbol (SCM str)
+lookup_interned_symbol (const char *name, size_t len,
+			unsigned long raw_hash)
 {
-  const char *name = scm_i_string_chars (str);
-  size_t len = scm_i_string_length (str);
+  /* Try to find the symbol in the symbols table */
+  SCM l;
+  unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
+
+  for (l = SCM_HASHTABLE_BUCKET (symbols, hash);
+       !scm_is_null (l);
+       l = SCM_CDR (l))
+    {
+      SCM sym = SCM_CAAR (l);
+      if (scm_i_symbol_hash (sym) == raw_hash
+	  && scm_i_symbol_length (sym) == len)
+	{
+	  const char *chrs = scm_i_symbol_chars (sym);
+	  size_t i = len;
+
+	  while (i != 0)
+	    {
+	      --i;
+	      if (name[i] != chrs[i])
+		goto next_symbol;
+	    }
+
+	  return sym;
+	}
+    next_symbol:
+      ;
+    }
+
+  return SCM_BOOL_F;
+}
 
+static SCM
+scm_i_c_mem2symbol (const char *name, size_t len)
+{
+  SCM symbol;
   size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
   size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
 
+  symbol = lookup_interned_symbol (name, len, raw_hash);
+  if (symbol != SCM_BOOL_F)
+    return symbol;
+
   {
-    /* Try to find the symbol in the symbols table */
-
-    SCM l;
-
-    for (l = SCM_HASHTABLE_BUCKET (symbols, hash);
-	 !scm_is_null (l);
-	 l = SCM_CDR (l))
-      {
-	SCM sym = SCM_CAAR (l);
-	if (scm_i_symbol_hash (sym) == raw_hash
-	    && scm_i_symbol_length (sym) == len)
-	  {
-	    const char *chrs = scm_i_symbol_chars (sym);
-	    size_t i = len;
-
-	    while (i != 0)
-	      {
-		--i;
-		if (name[i] != chrs[i])
-		  goto next_symbol;
-	      }
-
-	    return sym;
-	  }
-      next_symbol:
-	;
-      }
+    /* The symbol was not found - create it. */
+    SCM symbol = scm_i_c_make_symbol (name, len, 0, raw_hash,
+				      scm_cons (SCM_BOOL_F, SCM_EOL));
+
+    SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash);
+    SCM cell = scm_cons (symbol, SCM_UNDEFINED);
+    SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot));
+    SCM_HASHTABLE_INCREMENT (symbols);
+    if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols))
+      scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol");
+
+    return symbol;
   }
+}
+
+static SCM
+scm_i_mem2symbol (SCM str)
+{
+  SCM symbol;
+  const char *name = scm_i_string_chars (str);
+  size_t len = scm_i_string_length (str);
+  size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
+  size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
+
+  symbol = lookup_interned_symbol (name, len, raw_hash);
+  if (symbol != SCM_BOOL_F)
+    return symbol;
 
   {
     /* The symbol was not found - create it. */
@@ -139,6 +175,7 @@ scm_i_mem2symbol (SCM str)
   }
 }
 
+
 static SCM
 scm_i_mem2uninterned_symbol (SCM str)
 {
@@ -348,13 +385,50 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
 SCM
 scm_from_locale_symbol (const char *sym)
 {
-  return scm_string_to_symbol (scm_from_locale_string (sym));
+  return scm_i_c_mem2symbol (sym, strlen (sym));
 }
 
 SCM
 scm_from_locale_symboln (const char *sym, size_t len)
 {
-  return scm_string_to_symbol (scm_from_locale_stringn (sym, len));
+  return scm_i_c_mem2symbol (sym, len);
+}
+
+SCM
+scm_take_locale_symboln (char *sym, size_t len)
+{
+  SCM res;
+  unsigned long raw_hash;
+
+  if (len == (size_t)-1)
+    len = strlen (sym);
+  else
+    {
+      /* Ensure STR is null terminated.  A realloc for 1 extra byte should
+         often be satisfied from the alignment padding after the block, with
+         no actual data movement.  */
+      sym = scm_realloc (sym, len+1);
+      sym[len] = '\0';
+    }
+
+  raw_hash = scm_string_hash ((unsigned char *)sym, len);
+  res = lookup_interned_symbol (sym, len, raw_hash);
+  if (res != SCM_BOOL_F)
+    {
+      free (sym);
+      return res;
+    }
+
+  res = scm_i_c_take_symbol (sym, len, 0, raw_hash,
+			     scm_cons (SCM_BOOL_F, SCM_EOL));
+
+  return res;
+}
+
+SCM
+scm_take_locale_symbol (char *sym)
+{
+  return scm_take_locale_symboln (sym, (size_t)-1);
 }
 
 void
diff --git a/libguile/symbols.h b/libguile/symbols.h
index eadff545a..35b327f08 100644
--- a/libguile/symbols.h
+++ b/libguile/symbols.h
@@ -56,6 +56,8 @@ SCM_API SCM scm_gensym (SCM prefix);
 
 SCM_API SCM scm_from_locale_symbol (const char *str);
 SCM_API SCM scm_from_locale_symboln (const char *str, size_t len);
+SCM_API SCM scm_take_locale_symbol (char *sym);
+SCM_API SCM scm_take_locale_symboln (char *sym, size_t len);
 
 /* internal functions. */