flags regex directives support

2 files changed, 109 insertions, 9 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))
diff --git a/modules/language/python/module/re/parser.scm b/modules/language/python/module/re/parser.scm
index 45a7a5c..144d974 100644
--- a/modules/language/python/module/re/parser.scm
+++ b/modules/language/python/module/re/parser.scm
@@ -29,7 +29,9 @@
 (define number (mk-token (f+ (f-reg! "[0-9]")) string->number))
 (define incant (f-list #:?P= "(?P=" (f-or! number
 					   (mk-token (f+ (f-not! (f-reg "[) ]"))))) ")"))
-(define coment  (f-seq "(?#" (f* (f-not (f-tag ")"))) ")"))
+(define coment  (f-and
+                 (f-seq "(?#" (f* (f-not (f-tag ")"))) ")")
+                 f-true))
 (define repn?   (f-list #:rep? "{" number "}" "?"))
 (define repnm?  (f-list #:rep? "{" number "," number "}" "?"))
 (define repn    (f-list #:rep  "{" number "}"))
@@ -40,7 +42,17 @@
 
 (define rev     (f-list #:?<= "(?<=" (Ds ee) ")"))
 (define rev!    (f-list #:?<! "(?<!" (Ds ee) ")"))
-
+(define flags   (f-list #:flags "(?"
+                        (mk-token (f* (f-reg! "[aiLmsux]")))
+                        (f-or!
+                         (f-seq "-" (mk-token (f+ (f-reg! "[imsx]"))))
+                         (f-out ""))
+                        ":"
+                        (Ds ee) ")"))
+(define flags2  (f-list #:flags2 "(?"
+                        (mk-token (f* (f-reg! "[aiLmsux]")))
+                        ")"))
+                         
 (define bbody (f-cons (ch (f-reg "[\\]")) (ff* (ch (f-reg "[]\\]")))))
 
 (define (f-if a b c) (f-or! (f-seq a b) c))
@@ -56,7 +68,7 @@
 
 (define f-bar  (f-tag "|"))
 (define qq     (ch (f-reg "[][?+|*.$^()\\]")))
-(define atom   (f-or qq f-. choice subexpr anongroup namegroup incant coment lookh lookh! rev rev! f-^ f-$))
+(define atom   (f-or qq f-. flags2 flags choice subexpr anongroup namegroup incant coment lookh lookh! rev rev! f-^ f-$))
 (define spec   (f-list #:op atom (f-or! q+? q?? q*? q* q? q+ repn? repnm? repn repnm)))
 (define aatom  (f-or! spec atom))
 (define line   (f-cons* #:seq aatom (ff* aatom )))