scsh-conservatory
/
scsh-0.5
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 1999-07-11 20:41:27 +00:00
parent 96d9b0e068
commit 2413f9c763
9 changed files with 101 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
scsh/rx/packages.scm
View File

@ -144,13 +144,13 @@
(define-interface re-folders-interface (define-interface re-folders-interface
(export (export
(regexp-foldl (proc (:value (proc (:exact-integer :value :value) :value) (regexp-fold (proc (:value (proc (:exact-integer :value :value) :value)
:value :value
:string :string
&opt (proc (:exact-integer :value) :value) &opt (proc (:exact-integer :value) :value)
:exact-integer) :exact-integer)
:value)) :value))
(regexp-foldr (proc (:value (proc (:value :exact-integer :value) :value) (regexp-fold (proc (:value (proc (:value :exact-integer :value) :value)
:value :value
:string :string
&opt (proc (:exact-integer :value) :value) &opt (proc (:exact-integer :value) :value)
@ -199,7 +199,7 @@
char-set-package char-set-package
error-package error-package
ascii ascii
string-lib ; string-foldl string-lib ; string-fold
scheme) scheme)
(files re-low re simp re-high (files re-low re simp re-high
parse posixstr spencer re-syntax) parse posixstr spencer re-syntax)
@ -225,7 +225,7 @@
conditionals conditionals
re-level-0 re-level-0
char-set-package char-set-package
scsh-utilities ; foldl scsh-utilities ; fold
error-package error-package
ascii ascii
scheme) scheme)
@ -264,7 +264,7 @@
(define-structure re-subst re-subst-interface (define-structure re-subst re-subst-interface
(open re-level-0 (open re-level-0
re-match-internals 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 scsh-level-0 ; write-string
string-lib ; string-copy! string-lib ; string-copy!
scheme) scheme)

10
scsh/rx/parse.scm
View File

@ -25,7 +25,7 @@
;;; Imports: ;;; Imports:
;;; ? for COND, and SWITCHQ conditional form. ;;; ? for COND, and SWITCHQ conditional form.
;;; every? ;;; every
;;; This code is much hairier than it would otherwise be because of the ;;; 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 ;;; 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? ;;; in the form of embedded code in some of the regexp's fields?
(define (static-regexp? re) (define (static-regexp? re)
(? ((re-seq? re) (every? static-regexp? (re-seq:elts re))) (? ((re-seq? re) (every static-regexp? (re-seq:elts re)))
((re-choice? re) (every? static-regexp? (re-choice: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. ((re-char-set? re) (char-set? (re-char-set:cset re))) ; Might be code.
@ -267,7 +267,7 @@
(posix-string->regexp (cadr sre)) (posix-string->regexp (cadr sre))
(error "Illegal (posix-string ...) SRE body." 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 (let* ((cs (apply char-set-union
(map string->char-set sre))) (map string->char-set sre)))
(cs (if case-sensitive? cs (uncase-char-set cs)))) (cs (if case-sensitive? cs (uncase-char-set cs))))
@ -615,7 +615,7 @@
(receive (loose ranges) (char-set->in-pair cset) (receive (loose ranges) (char-set->in-pair cset)
(values (apply string loose) (values (apply string loose)
(apply string (apply string
(foldr (lambda (r lis) (fold-right (lambda (r lis)
`(,(car r) ,(cdr r) . ,lis)) `(,(car r) ,(cdr r) . ,lis))
'() ranges))))))) '() ranges)))))))
(receive (cs+ rp+) (->sexp-pair cset) (receive (cs+ rp+) (->sexp-pair cset)

4
scsh/rx/posixstr.scm
View File

@ -324,13 +324,13 @@
(if (zero? len) (if (zero? len)
(values "()" 0 1 '#()) ; Special case "" (values "()" 0 1 '#()) ; Special case ""
(let* ((len2 (string-foldl (lambda (c len) ; Length of answer str (let* ((len2 (string-fold (lambda (c len) ; Length of answer str
(+ len (if (char-set-contains? specials c) 2 1))) (+ len (if (char-set-contains? specials c) 2 1)))
0 s)) 0 s))
(s2 (make-string len2))) ; Answer string (s2 (make-string len2))) ; Answer string
;; Copy the chars over to S2. ;; Copy the chars over to S2.
(string-foldl (lambda (c i) (string-fold (lambda (c i)
;; Write char C at index I, return the next index. ;; Write char C at index I, return the next index.
(let ((i (cond ((char-set-contains? specials c) (let ((i (cond ((char-set-contains? specials c)
(string-set! s2 i #\\) (string-set! s2 i #\\)

22
scsh/rx/re-fold.scm
View File

@ -1,13 +1,13 @@
;;; Regexp "fold" combinators -*- scheme -*- ;;; Regexp "fold" combinators -*- scheme -*-
;;; Copyright (c) 1998 by Olin Shivers. ;;; Copyright (c) 1998 by Olin Shivers.
;;; REGEXP-FOLDL re kons knil s [finish start] -> value ;;; REGEXP-FOLD re kons knil s [finish start] -> value
;;; REGEXP-FOLDR 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 ;;; REGEXP-FOR-EACH re proc s [start] -> unspecific
;;; Non-R4RS imports: let-optionals :optional error ? ;;; 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 ;;; The following definition is a bit unwieldy, but the intuition is
;;; simple: this procedure uses the regexp RE to divide up string S into ;;; 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 ;;; 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 ;;; this match M. Let I be the index of the end of the match
;;; (that is, (match:end M 0)). Loop as follows: ;;; (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 ;;; If there is no match, return instead
;;; (finish START knil) ;;; (finish START knil)
;;; FINISH defaults to (lambda (i knil) 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 ;;; 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. ;;; 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)) (let-optionals maybe-finish+start ((finish (lambda (i x) x))
(start 0)) (start 0))
(if (> start (string-length s)) (if (> start (string-length s))
(error "Illegal START parameter" (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)) (let lp ((i start) (val knil))
(? ((regexp-search re s i) => (? ((regexp-search re s i) =>
(lambda (m) (lambda (m)
(let ((next-i (match:end m 0))) (let ((next-i (match:end m 0)))
(if (= next-i (match:start 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) re s start next-i)
(lp next-i (kons i m val)))))) (lp next-i (kons i m val))))))
(else (finish i 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 procedure repeatedly matches regexp RE across string S.
;;; This divides S up into a sequence of matching/non-matching chunks: ;;; 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). ;;; operation by handling the initial chunk of non-matching text (NM0, above).
;;; FINISH defaults to (lambda (i knil) knil) ;;; 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)) (let-optionals maybe-finish+start ((finish (lambda (i x) x))
(start 0)) (start 0))
(if (> start (string-length s)) (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)) finish start))
(? ((regexp-search re s start) => (? ((regexp-search re s start) =>
@ -87,7 +87,7 @@
(lambda (m) (lambda (m)
(let ((i (match:start m 0))) (let ((i (match:start m 0)))
(if (= i (match:end 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) re s start i)
(kons last-m i (recur m)))))) (kons last-m i (recur m))))))
(else (kons last-m (string-length s) knil))))))) (else (kons last-m (string-length s) knil)))))))

8
scsh/rx/re-subst.scm
View File

@ -34,13 +34,13 @@
;; Here's the string case. Make two passes -- one to ;; Here's the string case. Make two passes -- one to
;; compute the length of the target string, one to fill it in. ;; compute the length of the target string, one to fill it in.
(let* ((len (foldl (lambda (item i) (let* ((len (fold (lambda (item i)
(+ i (if (string? item) (string-length item) (+ i (if (string? item) (string-length item)
(receive (si ei) (range item) (- ei si))))) (receive (si ei) (range item) (- ei si)))))
0 items)) 0 items))
(ans (make-string len))) (ans (make-string len)))
(foldl (lambda (item index) (fold (lambda (item index)
(cond ((string? item) (cond ((string? item)
(string-copy! ans index item) (string-copy! ans index item)
(+ index (string-length item))) (+ index (string-length item)))
@ -62,7 +62,7 @@
(else (error "Illegal substitution item." (else (error "Illegal substitution item."
item item
regexp-substitute/global))))) regexp-substitute/global)))))
(num-posts (foldl (lambda (item count) (num-posts (fold (lambda (item count)
(+ count (if (eq? item 'post) 1 0))) (+ count (if (eq? item 'post) 1 0)))
0 items))) 0 items)))
@ -108,7 +108,7 @@
(s (vector-ref sv 0)) (s (vector-ref sv 0))
(e (vector-ref ev 0)) (e (vector-ref ev 0))
(empty? (= s e))) (empty? (= s e)))
(foldl (lambda (item pieces) (fold (lambda (item pieces)
(cond ((string? item) (cond ((string? item)
(cons item pieces)) (cons item pieces))

2
scsh/rx/re-syntax.scm
View File

@ -11,7 +11,7 @@
(or (string? exp) ; "foo" (or (string? exp) ; "foo"
(and (pair? exp) (and (pair? exp)
(let ((head (car exp))) (let ((head (car exp)))
(or (every? string? exp) ; ("aeiou") (or (every string? exp) ; ("aeiou")
(kw? head '*) ; (* re ...) (kw? head '*) ; (* re ...)
(kw? head '+) ; (+ re ...) (kw? head '+) ; (+ re ...)
(kw? head '?) ; (? re ...) (kw? head '?) ; (? re ...)

8
scsh/rx/re.scm
View File

@ -89,7 +89,7 @@
(define (make-re-seq res) (define (make-re-seq res)
(%make-re-seq res (%make-re-seq res
(foldl (lambda (re sm-count) (+ (re-tsm re) sm-count)) (fold (lambda (re sm-count) (+ (re-tsm re) sm-count))
0 res))) 0 res)))
;;; Slightly smart sequence constructor: ;;; Slightly smart sequence constructor:
@ -135,7 +135,7 @@
(define (make-re-choice res) (define (make-re-choice res)
(%make-re-choice res (%make-re-choice res
(foldl (lambda (re sm-count) (+ (re-tsm re) sm-count)) (fold (lambda (re sm-count) (+ (re-tsm re) sm-count))
0 res))) 0 res)))
;;; Slightly smart choice constructor: ;;; Slightly smart choice constructor:
@ -160,7 +160,7 @@
(else (cons re tail)))) (else (cons re tail))))
'())))) '()))))
;; If all elts are char-class re's, fold them together. ;; 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 (let ((cset (apply char-set-union
(map (lambda (elt) (map (lambda (elt)
(if (re-char-set? elt) (if (re-char-set? elt)
@ -540,7 +540,7 @@
(define (uncase-string s) (define (uncase-string s)
;; SEQ is a list of chars and doubleton char-sets. ;; SEQ is a list of chars and doubleton char-sets.
(let* ((seq (string-foldr (lambda (c lis) (let* ((seq (string-fold-right (lambda (c lis)
(cons (? ((char-lower-case? c) (char-set c (char-upcase c))) (cons (? ((char-lower-case? c) (char-set c (char-upcase c)))
((char-upper-case? c) (char-set c (char-downcase c))) ((char-upper-case? c) (char-set c (char-downcase c)))
(else c)) (else c))

2
scsh/rx/rx-lib.scm
View File

@ -26,7 +26,7 @@
(define (spec->char-set in? loose ranges) (define (spec->char-set in? loose ranges)
(let ((doit (lambda (loose ranges) (let ((doit (lambda (loose ranges)
(foldl (lambda (r cset) (fold (lambda (r cset)
(let ((from (char->ascii (car r))) (let ((from (char->ascii (car r)))
(to (char->ascii (cdr r)))) (to (char->ascii (cdr r))))
(do ((i from (+ i 1)) (do ((i from (+ i 1))

4
scsh/rx/simp.scm
View File

@ -388,8 +388,8 @@
(define (has-live-submatches? re) (define (has-live-submatches? re)
(or (re-submatch? re) (or (re-submatch? re)
(? ((re-seq? re) (every? has-live-submatches? (re-seq: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-choice? re) (every has-live-submatches? (re-choice:elts re)))
((re-repeat? re) (has-live-submatches? (re-repeat:body re))) ((re-repeat? re) (has-live-submatches? (re-repeat:body re)))
((re-dsm? re) (has-live-submatches? (re-dsm:body re))) ((re-dsm? re) (has-live-submatches? (re-dsm:body re)))