More fitting the SRE system into the scsh upgrade; should have been
committed with previous commit of the rest of the sources in the
rx directory.
-Olin
This commit is contained in:
shivers
parent
96d9b0e068
commit
2413f9c763
|
|
@ -144,18 +144,18 @@
|
|||
|
||||
(define-interface re-folders-interface
|
||||
(export
|
||||
(regexp-foldl (proc (:value (proc (:exact-integer :value :value) :value)
|
||||
:value
|
||||
:string
|
||||
&opt (proc (:exact-integer :value) :value)
|
||||
:exact-integer)
|
||||
:value))
|
||||
(regexp-foldr (proc (:value (proc (:value :exact-integer :value) :value)
|
||||
:value
|
||||
:string
|
||||
&opt (proc (:exact-integer :value) :value)
|
||||
:exact-integer)
|
||||
:value))
|
||||
(regexp-fold (proc (:value (proc (:exact-integer :value :value) :value)
|
||||
:value
|
||||
:string
|
||||
&opt (proc (:exact-integer :value) :value)
|
||||
:exact-integer)
|
||||
:value))
|
||||
(regexp-fold (proc (:value (proc (:value :exact-integer :value) :value)
|
||||
:value
|
||||
:string
|
||||
&opt (proc (:exact-integer :value) :value)
|
||||
:exact-integer)
|
||||
:value))
|
||||
(regexp-for-each (proc (:value (proc (:value) :unspecific)
|
||||
:string &opt :exact-integer)
|
||||
:unspecific))))
|
||||
|
|
@ -199,7 +199,7 @@
|
|||
char-set-package
|
||||
error-package
|
||||
ascii
|
||||
string-lib ; string-foldl
|
||||
string-lib ; string-fold
|
||||
scheme)
|
||||
(files re-low re simp re-high
|
||||
parse posixstr spencer re-syntax)
|
||||
|
|
@ -225,7 +225,7 @@
|
|||
conditionals
|
||||
re-level-0
|
||||
char-set-package
|
||||
scsh-utilities ; foldl
|
||||
scsh-utilities ; fold
|
||||
error-package
|
||||
ascii
|
||||
scheme)
|
||||
|
|
@ -264,7 +264,7 @@
|
|||
(define-structure re-subst re-subst-interface
|
||||
(open re-level-0
|
||||
re-match-internals
|
||||
scsh-utilities ; foldl & some string utilities that need to be moved.
|
||||
scsh-utilities ; fold & some string utilities that need to be moved.
|
||||
scsh-level-0 ; write-string
|
||||
string-lib ; string-copy!
|
||||
scheme)
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
|
||||
;;; Imports:
|
||||
;;; ? for COND, and SWITCHQ conditional form.
|
||||
;;; every?
|
||||
;;; every
|
||||
|
||||
;;; This code is much hairier than it would otherwise be because of the
|
||||
;;; the presence of ,<exp> forms, which put a static/dynamic duality over
|
||||
|
|
@ -53,8 +53,8 @@
|
|||
;;; in the form of embedded code in some of the regexp's fields?
|
||||
|
||||
(define (static-regexp? re)
|
||||
(? ((re-seq? re) (every? static-regexp? (re-seq:elts re)))
|
||||
((re-choice? re) (every? static-regexp? (re-choice:elts re)))
|
||||
(? ((re-seq? re) (every static-regexp? (re-seq:elts re)))
|
||||
((re-choice? re) (every static-regexp? (re-choice:elts re)))
|
||||
|
||||
((re-char-set? re) (char-set? (re-char-set:cset re))) ; Might be code.
|
||||
|
||||
|
|
@ -267,7 +267,7 @@
|
|||
(posix-string->regexp (cadr sre))
|
||||
(error "Illegal (posix-string ...) SRE body." sre)))
|
||||
|
||||
(else (if (every? string? sre) ; A set spec -- ("wxyz").
|
||||
(else (if (every string? sre) ; A set spec -- ("wxyz").
|
||||
(let* ((cs (apply char-set-union
|
||||
(map string->char-set sre)))
|
||||
(cs (if case-sensitive? cs (uncase-char-set cs))))
|
||||
|
|
@ -615,9 +615,9 @@
|
|||
(receive (loose ranges) (char-set->in-pair cset)
|
||||
(values (apply string loose)
|
||||
(apply string
|
||||
(foldr (lambda (r lis)
|
||||
`(,(car r) ,(cdr r) . ,lis))
|
||||
'() ranges)))))))
|
||||
(fold-right (lambda (r lis)
|
||||
`(,(car r) ,(cdr r) . ,lis))
|
||||
'() ranges)))))))
|
||||
(receive (cs+ rp+) (->sexp-pair cset)
|
||||
(receive (cs- rp-) (->sexp-pair (char-set-invert cset))
|
||||
(if (< (+ (string-length cs-) (string-length rp-))
|
||||
|
|
|
|||
|
|
@ -324,21 +324,21 @@
|
|||
(if (zero? len)
|
||||
(values "()" 0 1 '#()) ; Special case ""
|
||||
|
||||
(let* ((len2 (string-foldl (lambda (c len) ; Length of answer str
|
||||
(+ len (if (char-set-contains? specials c) 2 1)))
|
||||
0 s))
|
||||
(let* ((len2 (string-fold (lambda (c len) ; Length of answer str
|
||||
(+ len (if (char-set-contains? specials c) 2 1)))
|
||||
0 s))
|
||||
(s2 (make-string len2))) ; Answer string
|
||||
|
||||
;; Copy the chars over to S2.
|
||||
(string-foldl (lambda (c i)
|
||||
;; Write char C at index I, return the next index.
|
||||
(let ((i (cond ((char-set-contains? specials c)
|
||||
(string-set! s2 i #\\)
|
||||
(+ i 1))
|
||||
(else i))))
|
||||
(string-set! s2 i c)
|
||||
(+ i 1)))
|
||||
0 s)
|
||||
(string-fold (lambda (c i)
|
||||
;; Write char C at index I, return the next index.
|
||||
(let ((i (cond ((char-set-contains? specials c)
|
||||
(string-set! s2 i #\\)
|
||||
(+ i 1))
|
||||
(else i))))
|
||||
(string-set! s2 i c)
|
||||
(+ i 1)))
|
||||
0 s)
|
||||
(values s2 (if (= len 1) 1 2)
|
||||
0 '#())))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
;;; Regexp "fold" combinators -*- scheme -*-
|
||||
;;; Copyright (c) 1998 by Olin Shivers.
|
||||
|
||||
;;; REGEXP-FOLDL re kons knil s [finish start] -> value
|
||||
;;; REGEXP-FOLDR re kons knil s [finish start] -> value
|
||||
;;; REGEXP-FOLD re kons knil s [finish start] -> value
|
||||
;;; REGEXP-FOLD-RIGHT re kons knil s [finish start] -> value
|
||||
;;; REGEXP-FOR-EACH re proc s [start] -> unspecific
|
||||
|
||||
;;; Non-R4RS imports: let-optionals :optional error ?
|
||||
|
||||
;;; regexp-foldl re kons knil s [finish start] -> value
|
||||
;;; regexp-fold re kons knil s [finish start] -> value
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; The following definition is a bit unwieldy, but the intuition is
|
||||
;;; simple: this procedure uses the regexp RE to divide up string S into
|
||||
|
|
@ -17,7 +17,7 @@
|
|||
;;; Search from START (defaulting to 0) for a match to RE; call
|
||||
;;; this match M. Let I be the index of the end of the match
|
||||
;;; (that is, (match:end M 0)). Loop as follows:
|
||||
;;; (regexp-foldl re kons (kons START M knil) s finish I)
|
||||
;;; (regexp-fold re kons (kons START M knil) s finish I)
|
||||
;;; If there is no match, return instead
|
||||
;;; (finish START knil)
|
||||
;;; FINISH defaults to (lambda (i knil) knil)
|
||||
|
|
@ -38,23 +38,23 @@
|
|||
;;; where Ji is the index of the start of NMi, MTCHi is a match value
|
||||
;;; describing Mi, and Q is the index of the beginning of NMlast.
|
||||
|
||||
(define (regexp-foldl re kons knil s . maybe-finish+start)
|
||||
(define (regexp-fold re kons knil s . maybe-finish+start)
|
||||
(let-optionals maybe-finish+start ((finish (lambda (i x) x))
|
||||
(start 0))
|
||||
(if (> start (string-length s))
|
||||
(error "Illegal START parameter"
|
||||
regexp-foldl re kons knil s finish start))
|
||||
regexp-fold re kons knil s finish start))
|
||||
(let lp ((i start) (val knil))
|
||||
(? ((regexp-search re s i) =>
|
||||
(lambda (m)
|
||||
(let ((next-i (match:end m 0)))
|
||||
(if (= next-i (match:start m 0))
|
||||
(error "An empty-string regexp match has put regexp-foldl into an infinite loop."
|
||||
(error "An empty-string regexp match has put regexp-fold into an infinite loop."
|
||||
re s start next-i)
|
||||
(lp next-i (kons i m val))))))
|
||||
(else (finish i val))))))
|
||||
|
||||
;;; regexp-foldr re kons knil s [finish start] -> value
|
||||
;;; regexp-fold-right re kons knil s [finish start] -> value
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This procedure repeatedly matches regexp RE across string S.
|
||||
;;; This divides S up into a sequence of matching/non-matching chunks:
|
||||
|
|
@ -72,11 +72,11 @@
|
|||
;;; operation by handling the initial chunk of non-matching text (NM0, above).
|
||||
;;; FINISH defaults to (lambda (i knil) knil)
|
||||
|
||||
(define (regexp-foldr re kons knil s . maybe-finish+start)
|
||||
(define (regexp-fold-right re kons knil s . maybe-finish+start)
|
||||
(let-optionals maybe-finish+start ((finish (lambda (i x) x))
|
||||
(start 0))
|
||||
(if (> start (string-length s))
|
||||
(error "Illegal START parameter" regexp-foldr re kons knil s
|
||||
(error "Illegal START parameter" regexp-fold-right re kons knil s
|
||||
finish start))
|
||||
|
||||
(? ((regexp-search re s start) =>
|
||||
|
|
@ -87,7 +87,7 @@
|
|||
(lambda (m)
|
||||
(let ((i (match:start m 0)))
|
||||
(if (= i (match:end m 0))
|
||||
(error "An empty-string regexp match has put regexp-foldr into an infinite loop."
|
||||
(error "An empty-string regexp match has put regexp-fold-right into an infinite loop."
|
||||
re s start i)
|
||||
(kons last-m i (recur m))))))
|
||||
(else (kons last-m (string-length s) knil)))))))
|
||||
|
|
|
|||
|
|
@ -34,20 +34,20 @@
|
|||
|
||||
;; Here's the string case. Make two passes -- one to
|
||||
;; compute the length of the target string, one to fill it in.
|
||||
(let* ((len (foldl (lambda (item i)
|
||||
(+ i (if (string? item) (string-length item)
|
||||
(receive (si ei) (range item) (- ei si)))))
|
||||
0 items))
|
||||
(let* ((len (fold (lambda (item i)
|
||||
(+ i (if (string? item) (string-length item)
|
||||
(receive (si ei) (range item) (- ei si)))))
|
||||
0 items))
|
||||
(ans (make-string len)))
|
||||
|
||||
(foldl (lambda (item index)
|
||||
(cond ((string? item)
|
||||
(string-copy! ans index item)
|
||||
(+ index (string-length item)))
|
||||
(else (receive (si ei) (range item)
|
||||
(string-copy! ans index str si ei)
|
||||
(+ index (- ei si))))))
|
||||
0 items)
|
||||
(fold (lambda (item index)
|
||||
(cond ((string? item)
|
||||
(string-copy! ans index item)
|
||||
(+ index (string-length item)))
|
||||
(else (receive (si ei) (range item)
|
||||
(string-copy! ans index str si ei)
|
||||
(+ index (- ei si))))))
|
||||
0 items)
|
||||
ans))))
|
||||
|
||||
|
||||
|
|
@ -62,9 +62,9 @@
|
|||
(else (error "Illegal substitution item."
|
||||
item
|
||||
regexp-substitute/global)))))
|
||||
(num-posts (foldl (lambda (item count)
|
||||
(+ count (if (eq? item 'post) 1 0)))
|
||||
0 items)))
|
||||
(num-posts (fold (lambda (item count)
|
||||
(+ count (if (eq? item 'post) 1 0)))
|
||||
0 items)))
|
||||
|
||||
(if (and port (< num-posts 2))
|
||||
|
||||
|
|
@ -108,30 +108,30 @@
|
|||
(s (vector-ref sv 0))
|
||||
(e (vector-ref ev 0))
|
||||
(empty? (= s e)))
|
||||
(foldl (lambda (item pieces)
|
||||
(cond ((string? item)
|
||||
(cons item pieces))
|
||||
(fold (lambda (item pieces)
|
||||
(cond ((string? item)
|
||||
(cons item pieces))
|
||||
|
||||
((procedure? item)
|
||||
(cons (item match) pieces))
|
||||
((procedure? item)
|
||||
(cons (item match) pieces))
|
||||
|
||||
((eq? 'post0 item)
|
||||
(if (and empty? (< s str-len))
|
||||
(cons (string (string-ref str s))
|
||||
pieces)
|
||||
pieces))
|
||||
((eq? 'post0 item)
|
||||
(if (and empty? (< s str-len))
|
||||
(cons (string (string-ref str s))
|
||||
pieces)
|
||||
pieces))
|
||||
|
||||
((eq? 'post item)
|
||||
(if (not cached-post)
|
||||
(set! cached-post
|
||||
(recur (if empty? (+ e 1) e))))
|
||||
(append cached-post pieces))
|
||||
((eq? 'post item)
|
||||
(if (not cached-post)
|
||||
(set! cached-post
|
||||
(recur (if empty? (+ e 1) e))))
|
||||
(append cached-post pieces))
|
||||
|
||||
(else (receive (si ei)
|
||||
(range start sv ev item)
|
||||
(cons (substring str si ei)
|
||||
pieces)))))
|
||||
'() items))
|
||||
(else (receive (si ei)
|
||||
(range start sv ev item)
|
||||
(cons (substring str si ei)
|
||||
pieces)))))
|
||||
'() items))
|
||||
|
||||
;; No match. Return str[start,end].
|
||||
(list (if (zero? start) str
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
(or (string? exp) ; "foo"
|
||||
(and (pair? exp)
|
||||
(let ((head (car exp)))
|
||||
(or (every? string? exp) ; ("aeiou")
|
||||
(or (every string? exp) ; ("aeiou")
|
||||
(kw? head '*) ; (* re ...)
|
||||
(kw? head '+) ; (+ re ...)
|
||||
(kw? head '?) ; (? re ...)
|
||||
|
|
|
|||
|
|
@ -89,8 +89,8 @@
|
|||
|
||||
(define (make-re-seq res)
|
||||
(%make-re-seq res
|
||||
(foldl (lambda (re sm-count) (+ (re-tsm re) sm-count))
|
||||
0 res)))
|
||||
(fold (lambda (re sm-count) (+ (re-tsm re) sm-count))
|
||||
0 res)))
|
||||
|
||||
;;; Slightly smart sequence constructor:
|
||||
;;; - Flattens nested sequences
|
||||
|
|
@ -135,8 +135,8 @@
|
|||
|
||||
(define (make-re-choice res)
|
||||
(%make-re-choice res
|
||||
(foldl (lambda (re sm-count) (+ (re-tsm re) sm-count))
|
||||
0 res)))
|
||||
(fold (lambda (re sm-count) (+ (re-tsm re) sm-count))
|
||||
0 res)))
|
||||
|
||||
;;; Slightly smart choice constructor:
|
||||
;;; - Flattens nested choices
|
||||
|
|
@ -160,7 +160,7 @@
|
|||
(else (cons re tail))))
|
||||
'()))))
|
||||
;; If all elts are char-class re's, fold them together.
|
||||
(if (every? static-char-class? res)
|
||||
(if (every static-char-class? res)
|
||||
(let ((cset (apply char-set-union
|
||||
(map (lambda (elt)
|
||||
(if (re-char-set? elt)
|
||||
|
|
@ -540,11 +540,11 @@
|
|||
|
||||
(define (uncase-string s)
|
||||
;; SEQ is a list of chars and doubleton char-sets.
|
||||
(let* ((seq (string-foldr (lambda (c lis)
|
||||
(cons (? ((char-lower-case? c) (char-set c (char-upcase c)))
|
||||
((char-upper-case? c) (char-set c (char-downcase c)))
|
||||
(else c))
|
||||
lis))
|
||||
(let* ((seq (string-fold-right (lambda (c lis)
|
||||
(cons (? ((char-lower-case? c) (char-set c (char-upcase c)))
|
||||
((char-upper-case? c) (char-set c (char-downcase c)))
|
||||
(else c))
|
||||
lis))
|
||||
'() s))
|
||||
|
||||
;; Coalesce adjacent chars together into a string.
|
||||
|
|
|
|||
|
|
@ -26,14 +26,14 @@
|
|||
|
||||
(define (spec->char-set in? loose ranges)
|
||||
(let ((doit (lambda (loose ranges)
|
||||
(foldl (lambda (r cset)
|
||||
(let ((from (char->ascii (car r)))
|
||||
(to (char->ascii (cdr r))))
|
||||
(do ((i from (+ i 1))
|
||||
(cs cset (char-set-adjoin! cs (ascii->char i))))
|
||||
((> i to) cs))))
|
||||
(string->char-set loose)
|
||||
ranges))))
|
||||
(fold (lambda (r cset)
|
||||
(let ((from (char->ascii (car r)))
|
||||
(to (char->ascii (cdr r))))
|
||||
(do ((i from (+ i 1))
|
||||
(cs cset (char-set-adjoin! cs (ascii->char i))))
|
||||
((> i to) cs))))
|
||||
(string->char-set loose)
|
||||
ranges))))
|
||||
(if in?
|
||||
(doit loose ranges)
|
||||
(char-set-invert! (doit loose ranges)))))
|
||||
|
|
|
|||
|
|
@ -388,8 +388,8 @@
|
|||
|
||||
(define (has-live-submatches? re)
|
||||
(or (re-submatch? re)
|
||||
(? ((re-seq? re) (every? has-live-submatches? (re-seq:elts re)))
|
||||
((re-choice? re) (every? has-live-submatches? (re-choice:elts re)))
|
||||
(? ((re-seq? re) (every has-live-submatches? (re-seq:elts re)))
|
||||
((re-choice? re) (every has-live-submatches? (re-choice:elts re)))
|
||||
((re-repeat? re) (has-live-submatches? (re-repeat:body re)))
|
||||
((re-dsm? re) (has-live-submatches? (re-dsm:body re)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue