[Guile-commits] GNU Guile branch, master, updated. release_1-9-2-7-gf59cf99

[Michael Gran]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=f59cf9981a84515b56359c5af56d7e787ad4d474

The branch, master has been updated
       via  f59cf9981a84515b56359c5af56d7e787ad4d474 (commit)
       via  8ef6962953d8377ce2157f4edd5ba469169728ba (commit)
       via  3dd11c9b130f54895efced104043022ea4609879 (commit)
      from  7f171dbfa04ee80ae5486e5eab637dce9c1d640a (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit f59cf9981a84515b56359c5af56d7e787ad4d474
Author: Michael Gran <address@hidden>
Date:   Tue Aug 18 21:14:56 2009 -0700

    Avoid double-casts of stringbuf
    
    Conversion from char to scm_t_wchar require an intermediate cast to
    unsigned char.  By changing the return type of SCM_STRINGBUF_INLINE_CHARS
    to unsigned char *, doublecasts in the code can be avoided.  Also,
    some clarification of return types.
    
    * libguile/strings.c (STRINGBUF_OUTLINE_CHARS)
    (STRINGBUF_INLINE_CHARS): now returns unsigned char *; all callers changed.

commit 8ef6962953d8377ce2157f4edd5ba469169728ba
Author: Michael Gran <address@hidden>
Date:   Tue Aug 18 21:13:38 2009 -0700

    Avoid compilation warnings in SCM_MAKE_CHAR
    
    * libguile/chars.h (SCM_MAKE_CHAR): change inequality

commit 3dd11c9b130f54895efced104043022ea4609879
Author: Michael Gran <address@hidden>
Date:   Tue Aug 18 19:42:38 2009 -0700

    Benchmarks for common character and string procedures
    
    * benchmark-suite/benchmarks/chars.bm: new benchmarks
    
    * benchmark-suite/benchmarks/srfi-13.bm: new benchmarks

-----------------------------------------------------------------------

Summary of changes:
 benchmark-suite/benchmarks/chars.bm   |   57 +++++++
 benchmark-suite/benchmarks/srfi-13.bm |  291 +++++++++++++++++++++++++++++++++
 libguile/chars.h                      |   12 +-
 libguile/strings.c                    |   22 ++--
 4 files changed, 368 insertions(+), 14 deletions(-)
 create mode 100644 benchmark-suite/benchmarks/chars.bm
 create mode 100644 benchmark-suite/benchmarks/srfi-13.bm

diff --git a/benchmark-suite/benchmarks/chars.bm 
b/benchmark-suite/benchmarks/chars.bm
new file mode 100644
index 0000000..dc6ad94
--- /dev/null
+++ b/benchmark-suite/benchmarks/chars.bm
@@ -0,0 +1,57 @@
+;;; -*- mode: scheme; coding: latin-1; -*-
+;;; chars.bm
+;;;
+;;; Copyright (C) 2009  Free Software Foundation, Inc.
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 3, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this software; see the file COPYING.LESSER.  If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks chars)
+  :use-module (benchmark-suite lib))
+
+
+(with-benchmark-prefix "chars"
+                       
+  (benchmark "char" 1000000
+     #\a)
+
+  (benchmark "octal" 1000000
+     #\123)
+
+  (benchmark "char? eq" 1000000
+    (char? #\a))
+
+  (benchmark "char=?" 1000000
+    (char=? #\a #\a))
+
+  (benchmark "char<?" 1000000
+    (char=? #\a #\a))
+
+  (benchmark "char-ci=?" 1000000
+    (char=? #\a #\a))
+
+  (benchmark "char-ci<? " 1000000
+    (char=? #\a #\a))
+
+  (benchmark "char->integer" 1000000
+    (char->integer #\a))
+
+  (benchmark "char-alphabetic?" 1000000
+    (char-upcase #\a))
+
+  (benchmark "char-numeric?" 1000000
+    (char-upcase #\a)))
+
diff --git a/benchmark-suite/benchmarks/srfi-13.bm 
b/benchmark-suite/benchmarks/srfi-13.bm
new file mode 100644
index 0000000..a8187d5
--- /dev/null
+++ b/benchmark-suite/benchmarks/srfi-13.bm
@@ -0,0 +1,291 @@
+;;; -*- mode: scheme; coding: latin-1; -*-
+;;; srfi-13.bm
+;;;
+;;; Copyright (C) 2009  Free Software Foundation, Inc.
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 3, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this software; see the file COPYING.LESSER.  If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks strings)
+  :use-module (benchmark-suite lib))
+
+(seed->random-state 1)
+
+(define short-string "Hi")
+(define medium-string 
+"ARMA virumque cano, Troiae qui primus ab oris
+Italiam, fato profugus, Laviniaque venit")
+(define long-string
+  (string-tabulate 
+   (lambda (n) (integer->char (+ 32 (random 90)))) 
+   1000))
+
+(define short-chlist (string->list short-string))
+(define medium-chlist (string->list medium-string))
+(define long-chlist (string->list long-string))
+
+(define str1 (string-copy short-string))
+(define str2 (string-copy medium-string))
+(define str3 (string-copy long-string))
+
+
+(with-benchmark-prefix "strings"
+
+  (with-benchmark-prefix "predicates"
+
+    (benchmark "string?" 250000
+      (string? short-string)
+      (string? medium-string)
+      (string? long-string))
+
+    (benchmark "null?" 390000
+      (string-null? short-string)
+      (string-null? medium-string)
+      (string-null? long-string))
+    
+    (benchmark "any" 22000
+      (string-any #\a short-string)
+      (string-any #\a medium-string)
+      (string-any #\a long-string))
+
+    (benchmark "every" 22000
+      (string-every #\a short-string)
+      (string-every #\a medium-string)
+      (string-every #\a long-string)))
+
+  (with-benchmark-prefix "constructors"
+
+    (benchmark "string" 2000
+      (apply string short-chlist)         
+      (apply string medium-chlist)
+      (apply string long-chlist))
+
+    (benchmark "list->" 2500
+      (list->string short-chlist)
+      (list->string medium-chlist)
+      (list->string long-chlist))
+
+    (benchmark "reverse-list->" 2000
+      (reverse-list->string short-chlist)
+      (reverse-list->string medium-chlist)
+      (reverse-list->string long-chlist))
+
+    (benchmark "make" 20000
+      (make-string 250 #\x))
+
+    (benchmark "tabulate" 16000
+      (string-tabulate integer->char 250))
+
+    (benchmark "join" 5000
+      (string-join (list short-string medium-string long-string) "|" 'suffix)))
+
+  (with-benchmark-prefix "list/string"
+    (benchmark "->list" 3300
+      (string->list short-string)
+      (string->list medium-string)
+      (string->list long-string))
+
+    (benchmark "split" 20000
+      (string-split short-string #\a)
+      (string-split medium-string #\a)
+      (string-split long-string #\a)))
+
+  (with-benchmark-prefix "selection"
+
+    (benchmark "ref" 300
+      (let loop ((k 0))
+        (if (< k (string-length short-string))
+            (begin
+              (string-ref short-string k)
+              (loop (+ k 1)))))
+      (let loop ((k 0))
+        (if (< k (string-length medium-string))
+            (begin
+              (string-ref medium-string k)
+              (loop (+ k 1)))))
+      (let loop ((k 0))
+        (if (< k (string-length long-string))
+            (begin
+              (string-ref long-string k)
+              (loop (+ k 1))))))
+
+    (benchmark "copy" 20000
+      (string-copy short-string)
+      (string-copy medium-string)
+      (string-copy long-string)
+      (substring/copy short-string 0 1)
+      (substring/copy medium-string 10 20)
+      (substring/copy long-string 100 200))
+
+    (benchmark "pad" 20000
+      (string-pad short-string 100)
+      (string-pad medium-string 100)
+      (string-pad long-string 100))
+
+    (benchmark "trim trim-right trim-both" 20000
+      (string-trim short-string char-alphabetic?)
+      (string-trim medium-string char-alphabetic?)
+      (string-trim long-string char-alphabetic?)
+      (string-trim-right short-string char-alphabetic?)
+      (string-trim-right medium-string char-alphabetic?)
+      (string-trim-right long-string char-alphabetic?)
+      (string-trim-both short-string char-alphabetic?)
+      (string-trim-both medium-string char-alphabetic?)
+      (string-trim-both long-string char-alphabetic?)))
+
+  (with-benchmark-prefix "modification"
+
+    (set! str1 (string-copy short-string))                         
+    (set! str2 (string-copy medium-string))   
+    (set! str3 (string-copy long-string))
+
+    (benchmark "set!" 300
+      (let loop ((k 1))
+        (if (< k (string-length short-string))
+            (begin
+              (string-set! str1 k #\x)
+              (loop (+ k 1)))))
+      (let loop ((k 20))
+        (if (< k (string-length medium-string))
+            (begin
+              (string-set! str2 k #\x)
+              (loop (+ k 1)))))
+      (let loop ((k 900))
+        (if (< k (string-length long-string))
+            (begin
+              (string-set! str3 k #\x)
+              (loop (+ k 1))))))
+
+    (set! str1 (string-copy short-string))                         
+    (set! str2 (string-copy medium-string))   
+    (set! str3 (string-copy long-string))
+
+    (benchmark "sub-move!" 20000
+      (substring-move! short-string 0 2 str2 10)
+      (substring-move! medium-string 10 20 str3 20))
+
+    (set! str1 (string-copy short-string))                         
+    (set! str2 (string-copy medium-string))   
+    (set! str3 (string-copy long-string))
+
+    (benchmark "fill!" 20000
+      (string-fill! str1 #\y 0 1)
+      (string-fill! str2 #\y 10 20)
+      (string-fill! str3 #\y 20 30))
+
+  (with-benchmark-prefix "comparison"
+
+    (benchmark "compare compare-ci" 20000
+      (string-compare short-string medium-string string<? string=? string>?)  
+      (string-compare long-string medium-string string<? string=? string>?)
+      (string-compare short-string medium-string string<? string=? string>?)  
+      (string-compare long-string medium-string string<? string=? string>?))
+  
+    (benchmark "hash hash-ci" 20000
+      (string-hash short-string)
+      (string-hash medium-string)
+      (string-hash long-string)
+      (string-hash short-string)
+      (string-hash medium-string)
+      (string-hash long-string))))
+  
+  (with-benchmark-prefix "searching" 20000
+
+    (benchmark "prefix-length suffix-length" 1000
+      (string-prefix-length short-string 
+                            (string-append short-string medium-string))
+      (string-prefix-length long-string 
+                            (string-append long-string medium-string))
+      (string-suffix-length short-string
+                            (string-append long-string medium-string))
+      (string-suffix-length long-string
+                            (string-append long-string medium-string))
+      (string-prefix-length-ci short-string 
+                            (string-append short-string medium-string))
+      (string-prefix-length-ci long-string 
+                            (string-append long-string medium-string))
+      (string-suffix-length-ci short-string
+                            (string-append long-string medium-string))
+      (string-suffix-length-ci long-string
+                            (string-append long-string medium-string)))
+
+    (benchmark "prefix? suffix?" 1000
+      (string-prefix? short-string 
+                            (string-append short-string medium-string))
+      (string-prefix? long-string 
+                            (string-append long-string medium-string))
+      (string-suffix? short-string
+                            (string-append long-string medium-string))
+      (string-suffix? long-string
+                            (string-append long-string medium-string))
+      (string-prefix? short-string 
+                            (string-append short-string medium-string))
+      (string-prefix? long-string 
+                            (string-append long-string medium-string))
+      (string-suffix? short-string
+                            (string-append long-string medium-string))
+      (string-suffix? long-string
+                            (string-append long-string medium-string)))
+
+    (benchmark "index index-right rindex" 10000
+      (string-index short-string #\T)
+      (string-index medium-string #\T)
+      (string-index long-string #\T)
+      (string-index-right short-string #\T)
+      (string-index-right medium-string #\T)
+      (string-index-right long-string #\T)
+      (string-rindex short-string #\T)
+      (string-rindex medium-string #\T)
+      (string-rindex long-string #\T))
+
+    (benchmark "skip skip-right?" 10000
+      (string-skip short-string char-alphabetic?)
+      (string-skip medium-string char-alphabetic?)
+      (string-skip long-string char-alphabetic?)
+      (string-skip-right short-string char-alphabetic?)
+      (string-skip-right medium-string char-alphabetic?)
+      (string-skip-right long-string char-alphabetic?))
+
+    (benchmark "count" 3000
+      (string-count short-string char-alphabetic?)
+      (string-count medium-string char-alphabetic?)
+      (string-count long-string char-alphabetic?))
+    
+    (benchmark "contains contains-ci" 10000
+      (string-contains short-string short-string)
+      (string-contains medium-string (substring medium-string 10 15))
+      (string-contains long-string (substring long-string 100 130))
+      (string-contains-ci short-string short-string)
+      (string-contains-ci medium-string (substring medium-string 10 15))
+      (string-contains-ci long-string (substring long-string 100 130)))
+
+    (set! str1 (string-copy short-string))                         
+    (set! str2 (string-copy medium-string))   
+    (set! str3 (string-copy long-string))
+
+    (benchmark "upcase downcase upcase! downcase!" 500
+      (string-upcase short-string)
+      (string-upcase medium-string)
+      (string-upcase long-string)
+      (string-downcase short-string)
+      (string-downcase medium-string)
+      (string-downcase long-string)
+      (string-upcase! str1 0 1)
+      (string-upcase! str2 10 20)
+      (string-upcase! str3 100 130)
+      (string-downcase! str1 0 1)
+      (string-downcase! str2 10 20)
+      (string-downcase! str3 100 130))))
\ No newline at end of file
diff --git a/libguile/chars.h b/libguile/chars.h
index 51adc21..f75aead 100644
--- a/libguile/chars.h
+++ b/libguile/chars.h
@@ -32,9 +32,15 @@
 #define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
 #define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))
 
-#define SCM_MAKE_CHAR(x)                                               \
-  ((scm_t_int32) (x) < 0                                               \
-   ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char)   \
+/* SCM_MAKE_CHAR maps signed chars (-128 to 127) and unsigned chars (0
+   to 255) to Latin-1 codepoints (0 to 255) while allowing higher
+   codepoints (256 to 1114111) to pass through unchanged.
+
+   This macro evaluates x twice, which may lead to side effects if not
+   used properly. */
+#define SCM_MAKE_CHAR(x)                                                \
+  ((x) <= 1                                                             \
+   ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char)    \
    : SCM_MAKE_ITAG8 ((scm_t_bits) (x), scm_tc8_char))
 
 #define SCM_CODEPOINT_MAX (0x10ffff)
diff --git a/libguile/strings.c b/libguile/strings.c
index 03fb4b4..d28f5ad 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -87,16 +87,16 @@
 #define STRINGBUF_INLINE(buf)   (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
 #define STRINGBUF_WIDE(buf)     (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
 
-#define STRINGBUF_OUTLINE_CHARS(buf)   ((char *)SCM_CELL_WORD_1(buf))
+#define STRINGBUF_OUTLINE_CHARS(buf)   ((unsigned char *) SCM_CELL_WORD_1(buf))
 #define STRINGBUF_OUTLINE_LENGTH(buf)  (SCM_CELL_WORD_2(buf))
-#define STRINGBUF_INLINE_CHARS(buf)    ((char *)SCM_CELL_OBJECT_LOC(buf,1))
+#define STRINGBUF_INLINE_CHARS(buf)    ((unsigned char *) 
SCM_CELL_OBJECT_LOC(buf,1))
 #define STRINGBUF_INLINE_LENGTH(buf)   (((size_t)SCM_CELL_WORD_0(buf))>>16)
 
 #define STRINGBUF_CHARS(buf)  (STRINGBUF_INLINE (buf) \
                                ? STRINGBUF_INLINE_CHARS (buf) \
                                : STRINGBUF_OUTLINE_CHARS (buf))
 
-#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *)SCM_CELL_WORD_1(buf))
+#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) SCM_CELL_WORD_1(buf))
 #define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
                                ? STRINGBUF_INLINE_LENGTH (buf) \
                                : STRINGBUF_OUTLINE_LENGTH (buf))
@@ -213,7 +213,7 @@ widen_stringbuf (SCM buf)
       mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
       for (i = 0; i < len; i++)
         mem[i] =
-          (scm_t_wchar) (unsigned char) STRINGBUF_INLINE_CHARS (buf)[i];
+          (scm_t_wchar) STRINGBUF_INLINE_CHARS (buf)[i];
       mem[len] = 0;
 
       SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_INLINE);
@@ -228,7 +228,7 @@ widen_stringbuf (SCM buf)
       mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
       for (i = 0; i < len; i++)
         mem[i] =
-          (scm_t_wchar) (unsigned char) STRINGBUF_OUTLINE_CHARS (buf)[i];
+          (scm_t_wchar) STRINGBUF_OUTLINE_CHARS (buf)[i];
       mem[len] = 0;
 
       scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), len + 1, "string");
@@ -280,7 +280,7 @@ scm_i_make_string (size_t len, char **charsp)
   SCM buf = make_stringbuf (len);
   SCM res;
   if (charsp)
-    *charsp = STRINGBUF_CHARS (buf);
+    *charsp = (char *) STRINGBUF_CHARS (buf);
   res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
                         (scm_t_bits)0, (scm_t_bits) len);
   return res;
@@ -468,7 +468,7 @@ scm_i_string_chars (SCM str)
   size_t start;
   get_str_buf_start (&str, &buf, &start);
   if (scm_i_is_narrow_string (str))
-    return STRINGBUF_CHARS (buf) + start;
+    return (const char *) STRINGBUF_CHARS (buf) + start;
   else
     scm_misc_error (NULL, "Invalid read access of chars of wide string: ~s",
                     scm_list_1 (str));
@@ -485,7 +485,7 @@ scm_i_string_wide_chars (SCM str)
 
   get_str_buf_start (&str, &buf, &start);
   if (!scm_i_is_narrow_string (str))
-    return STRINGBUF_WIDE_CHARS (buf) + start;
+    return (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf) + start;
   else
     scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s",
                     scm_list_1 (str));
@@ -550,7 +550,7 @@ scm_i_string_writable_chars (SCM str)
 
   get_str_buf_start (&str, &buf, &start);
   if (scm_i_is_narrow_string (str))
-    return STRINGBUF_CHARS (buf) + start;
+    return (char *) STRINGBUF_CHARS (buf) + start;
   else
     scm_misc_error (NULL, "Invalid write access of chars of wide string: ~s",
                     scm_list_1 (str));
@@ -724,7 +724,7 @@ scm_i_symbol_chars (SCM sym)
 
   buf = SYMBOL_STRINGBUF (sym);
   if (!STRINGBUF_WIDE (buf))
-    return STRINGBUF_CHARS (buf);
+    return (const char *) STRINGBUF_CHARS (buf);
   else
     scm_misc_error (NULL, "Invalid access of chars of a wide symbol ~S",
                     scm_list_1 (sym));
@@ -739,7 +739,7 @@ scm_i_symbol_wide_chars (SCM sym)
 
   buf = SYMBOL_STRINGBUF (sym);
   if (STRINGBUF_WIDE (buf))
-    return STRINGBUF_WIDE_CHARS (buf);
+    return (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf);
   else
     scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S",
                     scm_list_1 (sym));


hooks/post-receive
-- 
GNU Guile