yet further improvements

svn: r8553

collects/scheme/private/string.ss

@@ -84,31 +84,31 @@
                             (and p (subbytes s (- (car p) drop) (- (cdr p) drop))))
                           (cdr m))))))))
 
-  ;; Helper function for the regexp functions below.
+  ;; Helper macro for the regexp functions below.
-  (define-syntax make-regexp-loop
+  (define-syntax regexp-loop
     (syntax-rules ()
-      [(make-regexp-loop
+      [(regexp-loop name loop start end rx string
-        name rx string success-k port-success-k failure-k port-failure-k
+        success-k port-success-k failure-k port-failure-k
         need-leftover? peek?)
        (let ([len (cond [(string? string) (string-length string)]
                         [(bytes?  string) (bytes-length  string)]
                         [else #f])])
          (if peek?
            (unless (input-port? string)
-             (raise-type-error name "input port" string))
+             (raise-type-error 'name "input port" string))
            (unless (or len (input-port? string))
-             (raise-type-error name "string, byte string or input port" string)))
+             (raise-type-error
-         (lambda (acc start end)
+              'name "string, byte string or input port" string)))
          (unless (and (number? start) (exact? start) (integer? start)
                       (start . >= . 0))
-             (raise-type-error name "non-negative exact integer" start))
+           (raise-type-error 'name "non-negative exact integer" start))
          (unless (or (not end)
                      (and (number? end) (exact? end) (integer? end)
                           (end . >= . 0)))
-             (raise-type-error name "non-negative exact integer or false" end))
+           (raise-type-error 'name "non-negative exact integer or false" end))
          (unless (or (input-port? string) (and len (start . <= . len)))
            (raise-mismatch-error
-              name
+            'name
             (format "starting offset index out of range [0,~a]: " len)
             start))
          (unless (or (not end)
@@ -116,10 +116,11 @@
                           (or (input-port? string)
                               (and len (end . <= . len)))))
            (raise-mismatch-error
-              name
+            'name
             (format "ending offset index out of range [~a,~a]: " start len)
             end))
-
+         (reverse
+          (let loop ([acc '()] [start start] [end end])
             (when (and (positive? start) (input-port? string) need-leftover?)
               ;; Skip start chars:
               (let ([s (make-bytes 4096)])
@@ -129,7 +130,7 @@
                               s string 0 (min (- start n) 4096))])
                       (unless (eof-object? m) (loop (+ n m))))))))
 
-           (if (and (input-port? string) port-success-k)
+            (if (and port-success-k (input-port? string))
               ;; Input port match, get string
               (let ([discarded 0]
                     [leftover-port (and need-leftover? (open-output-bytes))])
@@ -172,17 +173,15 @@
                   (let ([match-start (caar match)]
                         [match-end (cdar match)])
                     (if (= match-start match-end)
-                     (error name
+                      (error 'name
                              "pattern matched a zero-length substring: ~e" rx)
                       (success-k acc start end match-start match-end)))
-                 (failure-k acc start end))))))]))
+                  (failure-k acc start end)))))))]))
 
   ;; Returns all the positions at which the pattern matched.
   (define (regexp-match-positions* pattern string [start 0] [end #f])
     (define rx (bstring->regexp 'regexp-match-positions* pattern))
-    (define loop
+    (regexp-loop regexp-match-positions* loop start end rx string
-      (make-regexp-loop
-       'regexp-match-positions* rx string
      ;; success-k:
      (lambda (acc start end match-start match-end)
        (let ([acc (cons (cons match-start match-end) acc)])
@@ -202,14 +201,11 @@
      #f
      #f
      #f))
-    (reverse (loop '() start end)))
 
   ;; Returns all the positions at which the pattern matched.
   (define (regexp-match-peek-positions* pattern string [start 0] [end #f])
     (define rx (bstring->regexp 'regexp-match-peek-positions* pattern))
-    (define loop
+    (regexp-loop regexp-match-peek-positions* loop start end rx string
-      (make-regexp-loop
-       'regexp-match-peek-positions* rx string
      ;; success-k:
      (lambda (acc start end match-start match-end)
        (loop (cons (cons match-start match-end) acc) match-end end))
@@ -221,7 +217,6 @@
      #f
      #f
      #t))
-    (reverse (loop '() start end)))
 
   ;; Splits a string into a list by removing any piece which matches
   ;; the pattern.
@@ -231,9 +226,7 @@
                   (string->bytes/utf-8 string (char->integer #\?))
                   string))
     (define sub (if (bytes? buf) subbytes substring))
-    (define loop
+    (regexp-loop regexp-split loop start end rx buf
-      (make-regexp-loop
-       'regexp-split rx buf
      ;; success-k:
      (lambda (acc start end match-start match-end)
        (loop (cons (sub buf start match-start) acc) match-end end))
@@ -247,7 +240,6 @@
      (lambda (acc leftover) (cons leftover acc))
      #t
      #f))
-    (reverse (loop '() start end)))
 
   ;; Returns all the matches for the pattern in the string.
   (define (regexp-match* pattern string [start 0] [end #f])
@@ -256,9 +248,7 @@
                   (string->bytes/utf-8 string (char->integer #\?))
                   string))
     (define sub (if (bytes? buf) subbytes substring))
-    (define loop
+    (regexp-loop regexp-match* loop start end rx buf
-      (make-regexp-loop
-       'regexp-match* rx buf
      ;; success-k:
      (lambda (acc start end match-start match-end)
        (loop (cons (sub buf match-start match-end) acc) match-end end))
@@ -271,7 +261,6 @@
      (lambda (acc leftover) acc)
      #f
      #f))
-    (reverse (loop '() start end)))
 
   (define (regexp-match-exact? p s)
     (let ([m (regexp-match-positions p s)])