diff options
Diffstat (limited to 'modules/language/python/module/re/compile.scm')
| -rw-r--r-- | modules/language/python/module/re/compile.scm | 257 |
1 files changed, 257 insertions, 0 deletions
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))) + |