~ chicken-core (master) 5760e2dc26dcc5cc24a3d09b6042e3acfb49251c

commit 5760e2dc26dcc5cc24a3d09b6042e3acfb49251c
Author:     felix <bunny351@gmail.com>
AuthorDate: Mon May 17 11:55:42 2010 +0200
Commit:     felix <bunny351@gmail.com>
CommitDate: Mon May 17 11:55:42 2010 +0200

    cache precompiled regular expressions

diff --git a/regex.scm b/regex.scm
index 3494781c..f0d7783b 100644
--- a/regex.scm
+++ b/regex.scm
@@ -61,6 +61,44 @@
 
 (define-record regexp x)
 
+(define-syntax (build-cache x r c)
+  ;; (build-cache N ARG FAIL) 
+  (let* ((n (cadr x))
+	 (n2 (* n 2))
+	 (arg (caddr x))
+	 (fail (cadddr x))
+	 (%cache (r 'cache))
+	 (%index (r 'index))
+	 (%arg (r 'arg))
+	 (%let (r 'let))
+	 (%let* (r 'let*))
+	 (%if (r 'if))
+	 (%fx+ (r 'fx+))
+	 (%fxmod (r 'fxmod))
+	 (%equal? (r 'equal?))
+	 (%quote (r 'quote))
+	 (%tmp (r 'tmp))
+	 (%begin (r 'begin))
+	 (cache (make-vector (add1 n2) #f)))
+    (vector-set! cache n2 0)
+    `(,%let* ((,%cache (,%quote ,cache))
+	      (,%arg ,arg))
+	     ,(let fold ((i 0))
+		(if (>= i n)
+		    ;; this should be thread-safe: a context-switch can only
+		    ;; happen before this code and in the call to FAIL.
+		    `(,%let ((,%tmp ,fail)
+			     (,%index (##sys#slot ,%cache ,n2)))
+			    (##sys#setslot ,%cache ,%index ,%arg)
+			    (##sys#setslot ,%cache (,%fx+ ,%index 1) ,%tmp)
+			    (##sys#setislot 
+			     ,%cache ,n2
+			     (##core#inline "C_u_fixnum_modulo" (,%fx+ ,%index 2) ,n2))
+			    ,%tmp)
+		    `(,%if (,%equal? (##sys#slot ,%cache ,(* i 2)) ,%arg)
+			   (##sys#slot ,%cache ,(add1 (* i 2)))
+			   ,(fold (add1 i))))))))
+
 (define (regexp pat #!optional caseless extended utf8)
   (if (regexp? pat)
       pat
@@ -77,7 +115,10 @@
 (define (unregexp x)
   (cond ((regexp? x) (regexp-x x))
 	((irregex? x) x)
-	(else (irregex x))))
+	(else
+	 (build-cache
+	  5 x
+	  (irregex x)))))
 
 
 ;;; Basic `regexp' operations