[Guile-commits] GNU Guile branch, master, updated. v2.1.0-162-ga62b5c3

[Andy Wingo]

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=a62b5c3d5431cf68d94af5397116ca38f7d15840

The branch, master has been updated
       via  a62b5c3d5431cf68d94af5397116ca38f7d15840 (commit)
       via  4df9e5eb0f2cbdcd36cb2a50214f79a16816accf (commit)
      from  8ebd06c64bbb68343b30b82efffd7eed3b22b456 (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 a62b5c3d5431cf68d94af5397116ca38f7d15840
Author: Andy Wingo <address@hidden>
Date:   Wed Mar 7 13:34:06 2012 +0100

    call-with-{input,output}-string implemented in scheme
    
    * module/ice-9/boot-9.scm (call-with-input-string)
      (call-with-output-string): Implement in Scheme.
    
    * libguile/strports.c (scm_call_with_output_string):
      (scm_call_with_input_string): Dispatch to Scheme.

commit 4df9e5eb0f2cbdcd36cb2a50214f79a16816accf
Author: Andy Wingo <address@hidden>
Date:   Wed Mar 7 12:39:30 2012 +0100

    micro-optimizations to string-trim-both, and to (web http)
    
    * libguile/srfi-13.c (scm_string_trim, scm_string_trim_right)
      (scm_string_trim_both): Take the whitespace fast-path if the char_pred
      is scm_char_set_whitespace.
    
    * module/web/http.scm (read-header, split-and-trim, parse-quality-list):
      (parse-param-component, parse-credentials, "Content-Type"):
      (read-request-line, read-response-line): Use char-set:whitespace
      instead of char-whitespace?.  It avoids recursing into the VM.

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

Summary of changes:
 libguile/srfi-13.c      |   11 +++++++----
 libguile/strports.c     |   36 ++++++++++++++----------------------
 module/ice-9/boot-9.scm |   14 ++++++++++++++
 module/web/http.scm     |   46 +++++++++++++++++++++-------------------------
 4 files changed, 56 insertions(+), 51 deletions(-)

diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index 75feae3..2834553 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -1,6 +1,6 @@
 /* srfi-13.c --- SRFI-13 procedures for Guile
  *
- * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software 
Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 Free 
Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -719,7 +719,8 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
   MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              3, start, cstart,
                              4, end, cend);
-  if (SCM_UNBNDP (char_pred))
+  if (SCM_UNBNDP (char_pred)
+      || scm_is_eq (char_pred, scm_char_set_whitespace))
     {
       while (cstart < cend)
        {
@@ -794,7 +795,8 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 
3, 0,
   MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              3, start, cstart,
                              4, end, cend);
-  if (SCM_UNBNDP (char_pred))
+  if (SCM_UNBNDP (char_pred)
+      || scm_is_eq (char_pred, scm_char_set_whitespace))
     {
       while (cstart < cend)
        {
@@ -869,7 +871,8 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 
0,
   MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              3, start, cstart,
                              4, end, cend);
-  if (SCM_UNBNDP (char_pred))
+  if (SCM_UNBNDP (char_pred)
+      || scm_is_eq (char_pred, scm_char_set_whitespace))
     {
       while (cstart < cend)
        {
diff --git a/libguile/strports.c b/libguile/strports.c
index c8cce35..7b51a8c 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -354,35 +354,27 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 
0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, 
-           (SCM proc),
-           "Calls the one-argument procedure @var{proc} with a newly created 
output\n"
-           "port.  When the function returns, the string composed of the 
characters\n"
-           "written into the port is returned.")
-#define FUNC_NAME s_scm_call_with_output_string
+SCM
+scm_call_with_output_string (SCM proc)
 {
-  SCM p;
+  static SCM var = SCM_BOOL_F;
 
-  p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-                    SCM_OPN | SCM_WRTNG,
-                     FUNC_NAME);
-  scm_call_1 (proc, p);
+  if (scm_is_false (var))
+    var = scm_c_private_lookup ("guile", "call-with-output-string");
 
-  return scm_get_output_string (p);
+  return scm_call_1 (scm_variable_ref (var), proc);
 }
-#undef FUNC_NAME
 
-SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0,
-           (SCM string, SCM proc),
-           "Calls the one-argument procedure @var{proc} with a newly\n"
-           "created input port from which @var{string}'s contents may be\n"
-           "read.  The value yielded by the @var{proc} is returned.")
-#define FUNC_NAME s_scm_call_with_input_string
+SCM
+scm_call_with_input_string (SCM string, SCM proc)
 {
-  SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME);
-  return scm_call_1 (proc, p);
+  static SCM var = SCM_BOOL_F;
+
+  if (scm_is_false (var))
+    var = scm_c_private_lookup ("guile", "call-with-input-string");
+
+  return scm_call_2 (scm_variable_ref (var), string, proc);
 }
-#undef FUNC_NAME
 
 SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0,
            (SCM str),
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8fbddd0..1630461 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1456,6 +1456,12 @@ procedures, their behavior is implementation dependent."
   (call-with-output-file file
    (lambda (p) (with-error-to-port p thunk))))
 
+(define (call-with-input-string string proc)
+  "Calls the one-argument procedure @var{proc} with a newly created
+input port from which @var{string}'s contents may be read.  The value
+yielded by the @var{proc} is returned."
+  (proc (open-input-string string)))
+
 (define (with-input-from-string string thunk)
   "THUNK must be a procedure of no arguments.
 The test of STRING  is opened for
@@ -1468,6 +1474,14 @@ procedures, their behavior is implementation dependent."
   (call-with-input-string string
    (lambda (p) (with-input-from-port p thunk))))
 
+(define (call-with-output-string proc)
+  "Calls the one-argument procedure @var{proc} with a newly created output
+port.  When the function returns, the string composed of the characters
+written into the port is returned."
+  (let ((port (open-output-string)))
+    (proc port)
+    (get-output-string port)))
+
 (define (with-output-to-string thunk)
   "Calls THUNK and returns its output as a string."
   (call-with-output-string
diff --git a/module/web/http.scm b/module/web/http.scm
index c15bc3e..10c5fcf 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
 ;;; HTTP messages
 
-;; Copyright (C)  2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -185,7 +185,7 @@ body was reached (i.e., a blank line)."
             sym
             (read-continuation-line
              port
-             (string-trim-both line char-whitespace? (1+ delim)))))))))
+             (string-trim-both line char-set:whitespace (1+ delim)))))))))
 
 (define (parse-header sym val)
   "Parse @var{val}, a string, with the parser registered for the header
@@ -277,7 +277,7 @@ ordered alist."
   (let lp ((i start))
     (if (< i end)
         (let* ((idx (string-index str delim i end))
-               (tok (string-trim-both str char-whitespace? i (or idx end))))
+               (tok (string-trim-both str char-set:whitespace i (or idx end))))
           (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
         '())))
 
@@ -420,13 +420,13 @@ ordered alist."
          (cond
           ((string-rindex part #\;)
            => (lambda (idx)
-                (let ((qpart (string-trim-both part char-whitespace? (1+ 
idx))))
+                (let ((qpart (string-trim-both part char-set:whitespace (1+ 
idx))))
                   (if (string-prefix? "q=" qpart)
                       (cons (parse-quality qpart 2)
-                            (string-trim-both part char-whitespace? 0 idx))
+                            (string-trim-both part char-set:whitespace 0 idx))
                       (bad-header-component 'quality qpart)))))
           (else
-           (cons 1000 (string-trim-both part char-whitespace?)))))
+           (cons 1000 (string-trim-both part char-set:whitespace)))))
        (string-split str #\,)))
 
 (define (validate-quality-list l)
@@ -541,15 +541,15 @@ ordered alist."
 ;; param-component = token [ "=" (token | quoted-string) ] \
 ;;    *(";" token [ "=" (token | quoted-string) ])
 ;;
+(define param-delimiters (char-set #\, #\; #\=))
+(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;))
 (define* (parse-param-component str #:optional
                                 (val-parser default-val-parser)
                                 (start 0) (end (string-length str)))
   (let lp ((i start) (out '()))
     (if (not (< i end))
         (values (reverse! out) end)
-        (let ((delim (string-index str
-                                   (lambda (c) (memq c '(#\, #\; #\=)))
-                                   i)))
+        (let ((delim (string-index str param-delimiters i)))
           (let ((k (string->symbol
                     (substring str i (trim-whitespace str i (or delim end)))))
                 (delimc (and delim (string-ref str delim))))
@@ -561,13 +561,8 @@ ordered alist."
                        (if (and (< i end) (eqv? (string-ref str i) #\"))
                            (parse-qstring str i end #:incremental? #t)
                            (let ((delim
-                                  (or (string-index
-                                       str
-                                       (lambda (c)
-                                         (or (eqv? c #\;)
-                                             (eqv? c #\,)
-                                             (char-whitespace? c)))
-                                       i end)
+                                  (or (string-index str param-value-delimiters
+                                                    i end)
                                       end)))
                              (values (substring str i delim)
                                      delim)))))
@@ -853,7 +848,7 @@ ordered alist."
 (define* (parse-credentials str #:optional (val-parser default-val-parser)
                             (start 0) (end (string-length str)))
   (let* ((start (skip-whitespace str start end))
-         (delim (or (string-index str char-whitespace? start end) end)))
+         (delim (or (string-index str char-set:whitespace start end) end)))
     (if (= start end)
         (bad-header-component 'authorization str))
     (let ((scheme (string->symbol
@@ -1038,8 +1033,8 @@ not have to have a scheme or host name.  The result is a 
URI object."
   "Read the first line of an HTTP request from @var{port}, returning
 three values: the method, the URI, and the version."
   (let* ((line (read-line* port))
-         (d0 (string-index line char-whitespace?)) ; "delimiter zero"
-         (d1 (string-rindex line char-whitespace?)))
+         (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+         (d1 (string-rindex line char-set:whitespace)))
     (if (and d0 d1 (< d0 d1))
         (values (parse-http-method line 0 d0)
                 (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
@@ -1100,14 +1095,14 @@ three values: the method, the URI, and the version."
 three values: the HTTP version, the response code, and the \"reason
 phrase\"."
   (let* ((line (read-line* port))
-         (d0 (string-index line char-whitespace?)) ; "delimiter zero"
-         (d1 (and d0 (string-index line char-whitespace?
+         (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+         (d1 (and d0 (string-index line char-set:whitespace
                                    (skip-whitespace line d0)))))
     (if (and d0 d1)
         (values (parse-http-version line 0 d0)
                 (parse-non-negative-integer line (skip-whitespace line d0 d1)
                                             d1)
-                (string-trim-both line char-whitespace? d1))
+                (string-trim-both line char-set:whitespace d1))
         (bad-response "Bad Response-Line: ~s" line))))
 
 (define (write-response-line version code reason-phrase port)
@@ -1488,9 +1483,10 @@ phrase\"."
             (map (lambda (x)
                    (let ((eq (string-index x #\=)))
                      (if (and eq (= eq (string-rindex x #\=)))
-                         (cons (string->symbol
-                                (string-trim x char-whitespace? 0 eq))
-                               (string-trim-right x char-whitespace? (1+ eq)))
+                         (cons
+                          (string->symbol
+                           (string-trim x char-set:whitespace 0 eq))
+                          (string-trim-right x char-set:whitespace (1+ eq)))
                          (bad-header 'content-type str))))
                  (cdr parts)))))
   (lambda (val)


hooks/post-receive
-- 
GNU Guile