From bf35763d00bed87133880d9435d0014fd98ab7e5 Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Fri, 13 Jul 2018 15:19:03 +0200
Subject: missing files

---
 modules/language/python/module/re/compile.scm | 257 ++++++++++++++++++++++++++
 modules/language/python/module/re/flags.scm   |  25 +++
 modules/language/python/module/re/parser.scm  |  63 +++++++
 3 files changed, 345 insertions(+)
 create mode 100644 modules/language/python/module/re/compile.scm
 create mode 100644 modules/language/python/module/re/flags.scm
 create mode 100644 modules/language/python/module/re/parser.scm

(limited to 'modules/language/python/module/re')

diff --git a/modules/language/python/module/re/compile.scm b/modules/language/python/module/re/compile.scm
new file mode 100644
index 0000000..6ed7162
--- /dev/null
+++ b/modules/language/python/module/re/compile.scm
@@ -0,0 +1,257 @@
+(define-module (language python module re compile)
+  #:use-module (language python module re parser)
+  #: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-nm f-pos))
+  
+  #:use-module (parser stis-parser macros)
+  #:use-module (ice-9 match)
+  #:export (compile-reg test-reg parse))
+
+(define-syntax-rule (<pp-lambda> (a b) . code)
+  (<p-lambda> (d)
+    (let ((a (car   d))
+	  (b (cadr  d)))
+      . code)))
+
+(define wrap list)
+
+(define (fw f)
+  (<pp-lambda> (L c)
+    (.. c2 (f c))
+    (<p-cc> (wrap L c2))))
+
+(define-syntax-rule (group f)
+  (let ()
+    (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
+    (let ((I  (new-group))
+	  (ff f))
+      (<pp-lambda> (L c)
+	(let ((e -1)
+	      (s -1))
+         (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e)))(list L c))) 
+	 (let* ((L (car c2))
+		(L (cons (cons I (list (strit c (cadr c2)) s e)) L)))
+	   (<p-cc> (wrap L (cadr c2)))))))))
+
+(define-syntax-rule (group-name f name)
+  (let ()
+    (define-syntax-rule (mac s) (lambda (x n m) (set! s x)))
+    (let* ((n  (new-name name))
+	   (ff f))
+      (<pp-lambda> (L c)
+       (let ((e -1)
+	     (s -1))	 
+	 (.. c2 ((f-seq (f-pos (mac s)) ff (f-pos (mac e))) (list L c))) 
+	 (let* ((L  (car  c2))
+		(c2 (cadr c2))
+		(L  (cons (cons n (list (strit c c2) s e)) L)))
+	   (<p-cc> (wrap L c2))))))))
+
+(define (strit u v)
+  (let lp ((v v) (r '()))
+    (if (eq? u v)
+	(list->string r)
+	(lp (cdr v) (cons (car v) r)))))
+
+(define (incant name)
+  (<p-lambda> (c)
+    (let* ((L (cadr c))
+	   (r (if (number? name)
+		  (let lp ((l L))
+		    (define (f x u l)
+		      (if (= x name)
+			  u
+			  (lp l)))
+		    
+		    (match l
+		      (((x . u) . l)
+		       (if (pair? x)
+			   (f (cdr x) (car u) l)
+			   (f x       (car u) l)))
+		      (() (error (+ "could not incant " name)))))
+		  (let lp ((l L))
+		    (define (f x u l)
+		      (if (equal? x name)
+			  u
+			  (lp l)))
+		    
+		    (match l
+		      (((x . u) . l)
+		       (if (pair? x)
+			   (f (car x) u l)
+			   (f x       u l)))
+		      (() (error (+ "could not incant " name))))))))
+		  	   
+		       
+			
+      (if r
+          (<and> (.. ((fw (f-tag! r)) c)))
+          (<code> (error "group is not existing in the history"))))))
+
+(define (incant-rev name)
+  (<p-lambda> (c)
+    (let* ((L (cadr c))
+	   (r (assoc name L)))
+      (if r
+          (<and> (.. ((f-tag (reverse (cdr r))) c)))
+          (<code> (error "group is not existing in the history"))))))
+
+(define (reverse-form x)
+  (match x
+    ((#:or x)
+     (reverse-form x))
+    ((#:or . l)
+     (cons #:or (map reverse-form l)))
+    ((#:sub f)
+     (list #:group (reverse-form f)))
+    ((#:?P< f n)
+     (list #:?P< (reverse-form f) n))
+    ((#:?: f)
+     (reverse-form f))
+    ((#:?P= name)
+     (#:?P=-rev name))
+    ((#:?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)))
+
+(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!)
+      ("t"  (f-tag! "\t"))
+      ("r"  (f-tag! "\r"))
+      ("a"  (f-tag! "\a"))
+      ("v"  (f-tag! "\v"))
+      ("f"  (f-tag! "\f"))
+      ("A"  (f-nm 0 1))
+      ("b"  (f-or! (f-and (f-prev 1 (f-not f-w)) f-w f-true)
+		   (f-and (f-prev 1 f-w) (f-not f-w) f-true)))
+      ("B"  (f-or! (f-and (f-prev 1 (f-not f-w)) (f-not f-w) f-true)
+		   (f-and (f-prev 1 f-w) f-w f-true)))
+      ("d"  f-d)
+      ("D"  (f-not! f-d))
+      ("w"  f-w)
+      ("W"  (f-not! f-w))
+      ("s"  f-s)
+      ("S"  (f-not! f-s))
+      ("Z"  f-eof)
+      (x    (f-tag! x))))
+
+(define groups     (make-fluid 0))
+(define groupindex (make-fluid 0))
+(define (init)
+  (fluid-set! groups     1)
+  (fluid-set! groupindex (make-hash-table)))
+(define (new-group)
+  (let ((i (fluid-ref groups)))
+    (fluid-set! groups (+ i 1))
+    i))
+(define (new-name n)
+  (let ((i (fluid-ref groups)))
+    (hash-set! (fluid-ref groupindex) n i)
+    (fluid-set! groups (+ i 1))
+    (cons n i)))
+   
+(define (compile x)
+  (match x
+    ((#:or x)
+     (compile x))
+    ((#:or . l)     
+     (apply f-or (map compile l)))
+    ((#:seq x)
+     (compile x))
+    ((#:seq . l)
+     (apply f-seq (map compile l)))
+    ((#:sub f)
+     (group (compile f)))
+    ((#:?P< n f)
+     (group-name (compile f) n))
+    ((#:?: f)
+     (compile f))
+    ((#:?P= name)
+     (incant name))
+    ((#:?P=-rev name)
+     (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))
+    ((#:?if name yes no)
+     (f-or (f-seq (incant name) yes)
+           no))
+    ((#:?if-rev name yes no)
+     (f-or (f-seq yes (incant-rev name))
+           no))
+    (#:$  f-eof)
+    (#:^  (f-nm 0 1))
+    ((#:op  x #:* ) (g*   (compile x)    ))
+    ((#:op  x #:+ ) (g+   (compile x)    ))
+    ((#:op  x (#:rep  m n)) (gmn   (compile x) m n))
+    ((#:op  x (#:rep  m  )) (gmn   (compile x) m m))
+    ((#:op  x (#:rep? m n)) (ngmn  (compile x) m n))
+    ((#:op  x (#:rep? m  )) (ngmn  (compile x) m m))
+    ((#:op  x #:? ) (g?   (compile x)    ))
+    ((#:op  x #:*?) (ng*  (compile x)    ))
+    ((#:op  x #:+?) (ng+  (compile x)    ))
+    ((#:op  x #:??) (ng?  (compile x)    ))
+    ((#:ch (#:class x))
+     (fw (get-class x)))
+    ((#:ch x)
+     (fw (f-tag! x)))
+    ((#:bracket not ch ...)
+     (let ((f (apply f-or!
+                     (map (lambda (x)
+                            (match x
+			      ((#:ch (#:class ch))
+                               (get-class ch))
+                              ((#:ch ch)
+                               (f-tag! ch)))) ch))))
+       
+       (if not
+           (f-not! f)
+           f)))))
+
+(define (maybe-add-nk x)
+   (if (equal? (pylist-ref x (- (len x) 1)) "\n")
+       (+ x "\n")
+       x))
+      
+(define (compile-reg x)
+  (init)
+  (let ((p (f-seq (f-out '(() ())) (compile (parse-reg x)))))
+    (list p (fluid-ref groups) (fluid-ref groupindex))))
+
+(define (test-reg y x)
+  (with-fluids ((*whitespace* f-true))
+    (stisparse (maybe-add-nk y)  (car (compile-reg x)))))
+
+(define (parse y x)
+  (with-fluids ((*whitespace* f-true))
+    (stisparse (maybe-add-nk y) x)))
+
diff --git a/modules/language/python/module/re/flags.scm b/modules/language/python/module/re/flags.scm
new file mode 100644
index 0000000..527bb09
--- /dev/null
+++ b/modules/language/python/module/re/flags.scm
@@ -0,0 +1,25 @@
+(define-module (language python module re flags)
+  #:export (set-flags get-flags
+		      A ASCII DEBUG I IGNORECASE L LOCALE M MULTILINE X VERBOSE))
+
+(define *flags* (make-fluid 0))
+(define (set-flags x) (fluid-set! *flags* x))
+(define (get-flags)   (fluid-ref *flags*))
+
+(define A          1)
+(define ASCII      A)
+
+(define DEBUG      2)
+
+(define I          4)
+(define IGNORECASE I)
+
+(define L          8)
+(define LOCALE     L)
+
+(define M          16)
+(define MULTILINE  M)
+
+(define X          32)
+(define VERBOSE    X)
+
diff --git a/modules/language/python/module/re/parser.scm b/modules/language/python/module/re/parser.scm
new file mode 100644
index 0000000..eae4b3f
--- /dev/null
+++ b/modules/language/python/module/re/parser.scm
@@ -0,0 +1,63 @@
+(define-module (language python module re parser)
+  #:use-module (parser stis-parser)
+  #:export(parse-reg e-matcher))
+
+(define-syntax-rule (mk n tag str) (define n (f-seq tag (f-tag str))))
+(mk f-. #:dot  ".")
+(mk f-^ #:^    "^")
+(mk f-$ #:$    "$")
+(mk q*  #:*    "*")
+(mk q?  #:?    "?")
+(mk q+  #:+    "+")
+(mk q*? #:*?   "*?")
+(mk q?? #:??   "??")
+(mk q+? #:+?   "+?")
+
+(define subexpr (f-list #:sub
+                        (f-seq (f-tag "(")  (Ds ee) (f-tag ")"))))
+
+(define f-back
+  (f-or (f-list #:class (mk-token (f-reg! "[AZbBdDsSwntr]")))
+        (mk-token (f-reg "."))))
+
+(define anongroup (f-list #:?:  "(?:" (Ds ee) ")"))
+(define namegroup (f-list #:?P< "(?P<" (mk-token (f+ (f-not! (f-reg "[> ]")))) ">" (Ds ee) ")"))
+(define (ch not)
+  (f-list #:ch
+          (f-or! (f-seq (f-char #\\) f-back)
+                 (mk-token (f-not! not)))))
+(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 repn?   (f-list #:rep? "{" number "}" "?"))
+(define repnm?  (f-list #:rep? "{" number "," number "}" "?"))
+(define repn    (f-list #:rep  "{" number "}"))
+(define repnm   (f-list #:rep  "{" number "," number "}"))
+
+(define lookh   (f-list #:?= "(?=" (Ds ee) ")"))
+(define lookh!  (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))
+(define choice
+  (f-cons #:bracket
+          (f-or!
+           (f-seq "[^]" (f-out (list (list #:ch (f-out #f) "^"))))
+           (f-cons*
+            (f-tag "[")
+            (f-if (f-tag "^") (f-out #t) (f-out #f))
+            bbody))))
+
+
+(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 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 )))
+(define ee     (f-cons* #:or line (ff* (f-seq f-bar line))))
+
+(define (parse-reg str) (parse str ee))
+
+(define e-matcher ee)
-- 
cgit v1.2.3