summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-03-07 12:39:30 +0100
committerAndy Wingo <wingo@pobox.com>2012-03-07 13:04:53 +0100
commit4df9e5eb0f2cbdcd36cb2a50214f79a16816accf (patch)
tree8fd43abca4d105e39b32f72040ef213ad9e73c9b
parent8ebd06c64bbb68343b30b82efffd7eed3b22b456 (diff)
downloadguile-4df9e5eb0f2cbdcd36cb2a50214f79a16816accf.tar.gz
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.
-rw-r--r--libguile/srfi-13.c11
-rw-r--r--module/web/http.scm46
2 files changed, 28 insertions, 29 deletions
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index 75feae3b2..28345532e 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/module/web/http.scm b/module/web/http.scm
index c15bc3ed7..10c5fcf77 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)