reverse forms implemented

3 files changed, 100 insertions, 32 deletions

diff --git a/modules/language/python/module/re/compile.scm b/modules/language/python/module/re/compile.scm
index e0b415b..9c4dfd3 100644
--- a/modules/language/python/module/re/compile.scm
+++ b/modules/language/python/module/re/compile.scm
@@ -1,11 +1,14 @@
 (define-module (language python module re compile)
   #:use-module (language python module re parser)
+  #:use-module (language python module re flags)
   #:use-module (language python list)
   #:use-module (language python string)
   #:use-module ((parser stis-parser) #:select
 		((parse . stisparse) <p-lambda> <p-cc> .. f-nl! f-nl
-		 f-tag! f-tag f-seq f-or f-or! f-and f-true g* g+ gmn ng* ng+ ngmn
-		 g? ng? f-test! f-eof f-not! f-prev f-not f-out f-rev *whitespace*
+		 f-tag! f-tag f-seq f-or f-or! f-and f-true g* g+ gmn ng* ng+
+                 ngmn f-reg! f-and!
+		 g? ng? f-test! f-eof f-not! f-prev f-not f-out f-rev
+                 *whitespace*
 		 f-nm f-pos))
   
   #:use-module (parser stis-parser macros)
@@ -25,6 +28,19 @@
     (.. c2 (f c))
     (<p-cc> (wrap L c2))))
 
+(define (gt f)
+  (<pp-lambda> (L c)
+    (let ((x #f))
+    (<or>           
+     (<and>
+      (.. c* (f-rev '()))
+      (.. c2 (f (list L '())))
+      (<code> (set! x c2))
+      <fail>)
+     (when x
+       (<p-cc> (wrap (car x) c)))))))
+
+
 (define-syntax-rule (group f)
   (let ()
     (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
@@ -107,10 +123,14 @@
      (reverse-form x))
     ((#:or . l)
      (cons #:or (map reverse-form l)))
+    ((#:seq x)
+     (reverse-form x))
+    ((#:seq . l)
+     (cons #:seq (reverse (map reverse-form l))))
     ((#:sub f)
      (list #:group (reverse-form f)))
-    ((#:?P< f n)
-     (list #:?P< (reverse-form f) n))
+    ((#:?P< n f)
+     (list #:?P< n (reverse-form f)))
     ((#:?: f)
      (reverse-form f))
     ((#:?P= name)
@@ -118,29 +138,59 @@
     ((#:?P=-rev name)
      (#:?P= name))
     ((#:?if name yes no)
-     (list #:?if-rev name (reverse-form yes) (reverse-form no)))
-    ((#:?if-rev name yes no)
-     (list #:?if name (reverse-form yes) (reverse-form no)))
-    ((#:?=  f    ) (list #:?=  (reverse-form f)))
-    ((#:?!  f    ) (list #:?!  (reverse-form f)))
-    ((#:?<= f    ) (list #:?<= f))
-    ((#:?<! f    ) (list #:?<! f))
-    ((#:*   x    ) (list #:*   (reverse-form x)))
-    ((#:+   x    ) (list #:+   (reverse-form x)))
-    ((#:mn  x m n) (list #:mn  (reverse-form x) m n))
-    ((#:?   x    ) (list #:?   (reverse-form x)))
-    ((#:*?  x    ) (list #:*?  (reverse-form x)))
-    ((#:+?  x    ) (list #:+?  (reverse-form x)))
-    ((#:??  x    ) (list #:??  (reverse-form x)))
-    ((:mn?  x m n) (list #:mn? (reverse-form x) m n))
-    ((#:ch  x    ) (list #:ch  x))
-    ((#:bracket . l) (cons #:bracket l))
-    ((x . l) (map reverse-form (cons x l)))
-    (x x)))
+     (list #:if name (reverse-form yes) (reverse-form no)))
+    ((#:?=  f) (list #:?= (reverse-form f)))
+    ((#:?!  f) (list #:?= (reverse-form f)))
+    ((#:?<= f) f)
+    ((#:?<! f) (#:not f))
+    ((#:not f) (list #:not (reverse-form f)))
+    (#:$  #:^)
+    (#:^  #:$)
+    ((#:op  x #:* ) (list #:op  (reverse-form x) #:*)) 
+    ((#:op  x #:+ ) (list #:op  (reverse-form x) #:+)) 
+    ((#:op  x (#:rep  m n)) (list #:op  (reverse-form x) (#:rep  m n)))
+    ((#:op  x (#:rep  m  )) (list #:op  (reverse-form x) (#:rep  m)))
+    ((#:op  x (#:rep? m n)) (list #:op  (reverse-form x) (#:rep?  m n)))
+    ((#:op  x (#:rep? m  )) (list #:op  (reverse-form x) (#:rep?  m)))
+    ((#:op  x #:? ) (list #:op  (reverse-form x) #:?)) 
+    ((#:op  x #:*?) (list #:op  (reverse-form x) #:*?)) 
+    ((#:op  x #:+?) (list #:op  (reverse-form x) #:+?)) 
+    ((#:op  x #:??) (list #:op  (reverse-form x) #:??)) 
+    ((and a (#:ch (#:class x))) a)
+    ((and a (#:ch x)) a)
+    ((and a (#:bracket not ch ...)) a)))
+
+    
+(define f-w
+  (f-or! (f-test! (lambda (x)
+                    (let ((x (fluid-ref *flags*)))
+                      (and
+                       (= (logand x ASCII) 0)
+                       (or (char-numeric? x)
+                           (char-alphabetic? x))))))
+                                  
+         (f-tag  "_")
+         (f-reg! "a-zA-Z0-9")))
+         
+(define f-d
+  (f-or!
+   (f-test! (lambda (x)
+              (let ((x (fluid-ref *flags*)))
+                (and
+                 (= (logand x ASCII) 0)
+                 (char-numeric? x)))))
+   (f-reg! "0-9")))
+
+(define f-s
+  (f-or!
+   (f-test!
+    (lambda (x)
+      (let ((fl (fluid-ref *flags*)))
+        (and
+         (= (logand fl ASCII) 0)
+         (char-whitespace? x)))))
+   (f-reg! "[\n\r \t\f\v]")))
 
-(define f-w (f-test! (lambda (x) (or (char-numeric? x) (char-alphabetic? x) (eq? x #\_)))))
-(define f-d (f-test! (lambda (x) (or (char-numeric? x)))))
-(define f-s (f-test! (lambda (x) (or (char-whitespace? x)))))
 (define (get-class tag)
    (match tag
       ("n"  f-nl!)
@@ -208,8 +258,10 @@
      (incant-rev name))
     ((#:?=  f) (f-and (compile f) f-true))
     ((#:?!  f) (f-and (f-not (compile f)) f-true))
-    ((#:?<= f) (f-and (f-seq f-rev (compile (reverse-form f))) f-true))
-    ((#:?<! f) (f-and (f-seq f-rev (f-not (compile (reverse-form f)))) f-true))
+    ((#:?<= f) (gt (compile (reverse-form f))))
+    ((#:?<! f) (f-seq (f-not (f-seq f-rev (compile (reverse-form f))))
+                      f-true))
+    ((#:not f) (f-and (f-not (compile f)) f-true))
     ((#:?if name yes no)
      (f-or (f-seq (incant name) yes)
            no))
@@ -231,7 +283,18 @@
     ((#:ch (#:class x))
      (fw (get-class x)))
     ((#:ch x)
-     (fw (f-tag! x)))
+     (let ((chx (string-ref x 0)))
+       (fw
+        (f-test! (lambda (ch)
+                   (let ((y (fluid-ref *flags*)))
+                     (if (= 0 (logand y IGNORECASE))
+                         (eq? ch chx)
+                         (if (= 0 (logand y ASCII))
+                             (eq? (char-upcase chx) (char-upcase ch))
+                             (if (and (< (char->integer ch)  128)
+                                      (< (char->integer chx) 128))
+                                 (eq? (char-upcase chx) (char-upcase ch))
+                                 (eq? chx ch))))))))))
     ((#:bracket not ch ...)
      (let ((f (apply f-or!
                      (map (lambda (x)
@@ -239,7 +302,8 @@
 			      ((#:ch (#:class ch))
                                (get-class ch))
                               ((#:ch ch)
-                               (f-tag! ch)))) ch))))
+                               (compile (list #:ch ch)))))
+                          ch))))
        
        (if not
            (f-not! f)
diff --git a/modules/language/python/module/re/flags.scm b/modules/language/python/module/re/flags.scm
index 527bb09..4db839a 100644
--- a/modules/language/python/module/re/flags.scm
+++ b/modules/language/python/module/re/flags.scm
@@ -1,5 +1,5 @@
 (define-module (language python module re flags)
-  #:export (set-flags get-flags
+  #:export (set-flags get-flags *flags*
 		      A ASCII DEBUG I IGNORECASE L LOCALE M MULTILINE X VERBOSE))
 
 (define *flags* (make-fluid 0))
diff --git a/modules/language/python/module/re/parser.scm b/modules/language/python/module/re/parser.scm
index eae4b3f..a7210d1 100644
--- a/modules/language/python/module/re/parser.scm
+++ b/modules/language/python/module/re/parser.scm
@@ -37,6 +37,10 @@
 
 (define lookh   (f-list #:?= "(?=" (Ds ee) ")"))
 (define lookh!  (f-list #:?! "(?!" (Ds ee) ")"))
+
+(define rev     (f-list #:?<= "(?<=" (Ds ee) ")"))
+(define rev!    (f-list #:?<! "(?<!" (Ds ee) ")"))
+
 (define bbody (f-cons (ch (f-reg "[\\]")) (ff* (ch (f-reg "[]\\]")))))
 
 (define (f-if a b c) (f-or! (f-seq a b) c))
@@ -52,7 +56,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! f-^ f-$))
+(define atom   (f-or qq f-. 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 )))