flags regex directives support

1 files changed, 94 insertions, 6 deletions

diff --git a/modules/language/python/module/re/compile.scm b/modules/language/python/module/re/compile.scm
index e259e3b..927f833 100644
--- a/modules/language/python/module/re/compile.scm
+++ b/modules/language/python/module/re/compile.scm
@@ -17,9 +17,9 @@
 
 (define-syntax-rule (<pp-lambda> (a b) . code)
   (<p-lambda> (d)
-    (let ((a (car   d))
-	  (b (cadr  d)))
-      . code)))
+     (let ((a (car   d))
+           (b (cadr  d)))
+       . code)))
 
 (define wrap list)
 
@@ -28,6 +28,38 @@
     (.. c2 (f c))
     (<p-cc> (wrap L c2))))
 
+(define (f-flags a b f)
+  (<p-lambda> (c)
+     (let* ((flags (fluid-ref *flags*))
+            (newfl (logand (logior a flags) (lognot b)))
+            (p     P)
+            (cc    CC))
+       (<with-bind>
+        ((P   (lambda ()
+                (fluid-set! *flags* flags)
+                (p)))
+         (CC  (lambda (s p)
+                (let ((pp (lambda ()
+                            (fluid-set! *flags* newfl)
+                            (p))))
+                  (fluid-set! *flags* flags)
+                  (cc s pp)))))
+        (<code> (fluid-set! *flags* newfl))
+        (.. c2 (f c))
+        (<p-cc> c2)))))
+
+(define (f-flags2 a b)
+  (<p-lambda> (c)
+     (let* ((flags (fluid-ref *flags*))
+            (newfl (logand (logior a flags) (lognot b)))
+            (p     P))
+       (<with-bind>
+        ((P   (lambda ()
+                       (fluid-set! *flags* flags)
+                       (p))))
+        (<code> (fluid-set! *flags* newfl))
+        (<p-cc> c)))))
+  
 (define startline
   (<pp-lambda> (L c)
      (when (= N 0)
@@ -150,6 +182,10 @@
      (list #:?P< n (reverse-form f)))
     ((#:?: f)
      (reverse-form f))
+    ((#:flags a b f)
+     (list #:flags a b (reverse-form f)))
+    ((#:flags2 a)
+     (list #:flags2 a))
     ((#:?P= name)
      (#:?P=-rev name))
     ((#:?P=-rev name)
@@ -158,8 +194,10 @@
      (list #:if name (reverse-form yes) (reverse-form no)))
     ((#:?=  f) (list #:?= (reverse-form f)))
     ((#:?!  f) (list #:?= (reverse-form f)))
-    ((#:?<= f) f)
-    ((#:?<! f) (#:not f))
+    ((#:?<= f) (list #:?<=-rev f))
+    ((#:?<! f) (list #:?<!-rev f))
+    ((#:?<=-rev f) (list #:?<= f))
+    ((#:?<!-rev f) (list #:?<! f))
     ((#:not f) (list #:not (reverse-form f)))
     (#:$   #:^)
     (#:^   #:$)
@@ -254,7 +292,46 @@
     (hash-set! (fluid-ref groupindex) n i)
     (fluid-set! groups (+ i 1))
     (cons n i)))
-   
+
+(define (mask-on a b)
+  (let lp ((l (string->list a)) (f 0))
+    (match l
+      ((#\a . l)
+       (lp l (logior f ASCII)))
+      ((#\i . l)
+       (lp l (logior f IGNORECASE)))
+      ((#\L . l)
+       (lp l (logior f LOCALE)))
+      ((#\m . l)
+       (lp l (logior f MULTILINE)))
+      ((#\s . l)
+       (lp l (logior f DOTALL)))
+      ((#\x . l)
+       (lp l (logior f VERBOSE)))
+      ((_ . l)
+       (lp l f))
+      (()
+       f))))
+
+(define (mask-off a b)
+  (let lp ((l (string->list b)) (f (if (member #\u (string->list a))
+                                       ASCII
+                                       0)))
+    (match l
+      ((#\i . l)
+       (lp l (logior f IGNORECASE)))
+      ((#\m . l)
+       (lp l (logior f MULTILINE)))
+      ((#\s . l)
+       (lp l (logior f DOTALL)))
+      ((#\x . l)
+       (lp l (logior f VERBOSE)))
+      ((_ . l)
+       (lp l f))
+      (()
+       f))))
+      
+      
 (define (compile x)
   (match x
     ((#:or x)
@@ -280,6 +357,9 @@
     ((#:?<= f) (gt (compile (reverse-form f))))
     ((#:?<! f) (f-seq (f-not (f-seq f-rev (compile (reverse-form f))))
                       f-true))
+    ((#:?<=-rev f) (gt (compile f)))
+    ((#:?<!-rev f) (f-seq (f-not (f-seq f-rev (compile f)))
+                      f-true))
     ((#:not f) (f-and (f-not (compile f)) f-true))
     ((#:?if name yes no)
      (f-or (f-seq (incant name) yes)
@@ -302,7 +382,15 @@
             (f-and
              dotall
              (fw f-nl!))))
+    ((#:flags a b f)
+     (let ((maskon  (mask-on  a b))
+           (maskoff (mask-off a b)))
+       (f-flags maskon maskoff (compile f))))
     
+    ((#:flags2 a)
+     (let ((maskon  (mask-on  a ""))
+           (maskoff (mask-off a "")))
+       (f-flags2 maskon maskoff)))
     ((#:op  x #:* ) (g*   (compile x)    ))
     ((#:op  x #:+ ) (g+   (compile x)    ))
     ((#:op  x (#:rep  m n)) (gmn   (compile x) m n))