~ chicken-core (chicken-5) c393a88afd508bd69a104be6d9e65ee3162016ed
commit c393a88afd508bd69a104be6d9e65ee3162016ed
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 30 22:44:37 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jul 30 22:44:37 2010 +0200
lifted irregex-core.scm to 0.8.2
diff --git a/irregex-core.scm b/irregex-core.scm
index 4f5f410c..4b8189ed 100644
--- a/irregex-core.scm
+++ b/irregex-core.scm
@@ -31,6 +31,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; History
;;
+;; 0.8.2: 2010/07/30 - (...)? submatch extraction fix and alternate
+;; named submatches from Peter Bex
;; 0.8.1: 2010/03/09 - backtracking irregex-match fix and other small fixes
;; 0.8.0: 2010/01/20 - optimizing DFA compilation, adding SRE escapes
;; inside PCREs, adding utility SREs
@@ -424,22 +426,30 @@
(define (char-alphanumeric? c)
(or (char-alphabetic? c) (char-numeric? c)))
-(define (%substring=? a b start1 start2 len)
- (let lp ((i 0))
- (cond ((>= i len)
- #t)
- ((char=? (string-ref a (+ start1 i)) (string-ref b (+ start2 i)))
- (lp (+ i 1)))
- (else
- #f))))
+(cond-expand
+ (building-chicken
+ (define-alias fast-substring=? %substring=?))
+ (else
+ (define (%substring=? a b start1 start2 len)
+ (let lp ((i 0))
+ (cond ((>= i len)
+ #t)
+ ((char=? (string-ref a (+ start1 i)) (string-ref b (+ start2 i)))
+ (lp (+ i 1)))
+ (else
+ #f))))))
;; SRFI-13 extracts
-(define (%%string-copy! to tstart from fstart fend)
- (do ((i fstart (+ i 1))
- (j tstart (+ j 1)))
- ((>= i fend))
- (string-set! to j (string-ref from i))))
+(cond-expand
+ (building-chicken
+ (define-alias fast-string-copy %%string-copy!))
+ (else
+ (define (%%string-copy! to tstart from fstart fend)
+ (do ((i fstart (+ i 1))
+ (j tstart (+ j 1)))
+ ((>= i fend))
+ (string-set! to j (string-ref from i))))))
(define (string-cat-reverse string-list)
(string-cat-reverse/aux
@@ -3057,8 +3067,13 @@
((?)
(let ((match-once (lp (sre-sequence (cdr sre)) n #t)))
(lambda (cnk start i end j matches)
- (match-once cnk start i end j matches)
- #t)))
+ (cond
+ ((match-once cnk start i end j matches)
+ #t)
+ (else
+ (match-vector-set! matches tmp-end-src-offset start)
+ (match-vector-set! matches tmp-end-index-offset i)
+ #t)))))
(($ submatch => submatch-named)
(let ((match-one
(lp (sre-sequence (if (memq (car sre) '($ submatch))
diff --git a/irregex.scm b/irregex.scm
index afa0c0ce..58f56e41 100644
--- a/irregex.scm
+++ b/irregex.scm
@@ -122,6 +122,12 @@
(##sys#slot ,%cache ,(add1 (* i 2)))
,(fold (add1 i))))))))
+(define-inline (fast-string-copy! to tstart from fstart fend)
+ (##core#inline "C_substring_copy" from to fstart fend tstart))
+
+(define-inline (fast-substring=? a b start1 start2 len)
+ (##core#inline "C_substring_compare" a b start1 start2 len))
+
(include "irregex-core.scm")
(define ##sys#glob->regexp
@@ -164,4 +170,4 @@
(else
(loop2 (cdr rest) (cons (car rest) s))))))
(else (cons c (loop rest (memq c '(#\\ #\/))))))))))))
- (if sre? sre (regexp sre))))))
+ (if sre? sre (irregex sre))))))
diff --git a/setup-download.scm b/setup-download.scm
index f080b5a7..3508eb2f 100644
--- a/setup-download.scm
+++ b/setup-download.scm
@@ -42,6 +42,8 @@
(define-constant +default-tcp-connect-timeout+ 10000) ; 10 seconds
(define-constant +default-tcp-read/write-timeout+ 20000) ; 20 seconds
+ (define-constant +url-regex+ "(http://)?([^/:]+)(:([^:/]+))?(/.+)")
+
(tcp-connect-timeout +default-tcp-connect-timeout+)
(tcp-read-timeout +default-tcp-read/write-timeout+)
(tcp-write-timeout +default-tcp-read/write-timeout+)
@@ -172,7 +174,7 @@
(conc dir #\/ egg ".meta"))
(define (deconstruct-url url)
- (let ([m (irregex-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url)])
+ (let ([m (irregex-match +url-regex+ url)])
(values
(if m (irregex-match-substring m 2) url)
(if (and m (irregex-match-substring m 3))
diff --git a/tests/re-tests.txt b/tests/re-tests.txt
index e8698569..3b7bf976 100644
--- a/tests/re-tests.txt
+++ b/tests/re-tests.txt
@@ -104,6 +104,9 @@ a[bcd]*dcdcde adcdcde y & adcdcde
a[bcd]+dcdcde adcdcde n - -
(ab|a)b*c abc y &-\1 abc-ab
((a)(b)c)(d) abcd y \1-\2-\3-\4 abc-a-b-d
+((a)(b)?c)(d) abcd y \1-\2-\3-\4 abc-a-b-d
+((a)(b)?c)(d) acd y \1-\2-\3-\4 ac-a--d
+((aa)(bb)?cc)(dd) aaccdd y \1-\2-\3-\4 aacc-aa--dd
[ -~]* abc y & abc
[ -~ -~]* abc y & abc
[ -~ -~ -~]* abc y & abc
diff --git a/tweaks.scm b/tweaks.scm
index 7a44082a..43041395 100644
--- a/tweaks.scm
+++ b/tweaks.scm
@@ -30,16 +30,13 @@
(cond-expand
- (debugbuild
- (declare
- (fixnum)
- (disable-interrupts) ))
- (else
- (declare
- (disable-interrupts)
- (no-bound-checks)
- (no-procedure-checks)
- (no-argc-checks))))
+ ((not debugbuild)
+ (declare
+ (disable-interrupts)
+ (no-bound-checks)
+ (no-procedure-checks)
+ (no-argc-checks)))
+ (else))
(define-inline (node? x) (##sys#structure? x 'node))
(define-inline (make-node c p s) (##sys#make-structure 'node c p s))
Trap