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