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

30
scsh/rx/packages.scm
View File

@ -144,18 +144,18 @@
(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)
:exact-integer) :exact-integer)
:value)) :value))
(regexp-for-each (proc (:value (proc (:value) :unspecific) (regexp-for-each (proc (:value (proc (:value) :unspecific)
:string &opt :exact-integer) :string &opt :exact-integer)
:unspecific)))) :unspecific))))
@ -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)

14
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,9 +615,9 @@
(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)
(receive (cs- rp-) (->sexp-pair (char-set-invert cset)) (receive (cs- rp-) (->sexp-pair (char-set-invert cset))
(if (< (+ (string-length cs-) (string-length rp-)) (if (< (+ (string-length cs-) (string-length rp-))

24
scsh/rx/posixstr.scm
View File

@ -324,21 +324,21 @@
(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 #\\)
(+ i 1)) (+ i 1))
(else i)))) (else i))))
(string-set! s2 i c) (string-set! s2 i c)
(+ i 1))) (+ i 1)))
0 s) 0 s)
(values s2 (if (= len 1) 1 2) (values s2 (if (= len 1) 1 2)
0 '#()))))))) 0 '#())))))))

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)))))))

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

@ -34,20 +34,20 @@
;; 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)))
(else (receive (si ei) (range item) (else (receive (si ei) (range item)
(string-copy! ans index str si ei) (string-copy! ans index str si ei)
(+ index (- ei si)))))) (+ index (- ei si))))))
0 items) 0 items)
ans)))) ans))))
@ -62,9 +62,9 @@
(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)))
(if (and port (< num-posts 2)) (if (and port (< num-posts 2))
@ -108,30 +108,30 @@
(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))
((procedure? item) ((procedure? item)
(cons (item match) pieces)) (cons (item match) pieces))
((eq? 'post0 item) ((eq? 'post0 item)
(if (and empty? (< s str-len)) (if (and empty? (< s str-len))
(cons (string (string-ref str s)) (cons (string (string-ref str s))
pieces) pieces)
pieces)) pieces))
((eq? 'post item) ((eq? 'post item)
(if (not cached-post) (if (not cached-post)
(set! cached-post (set! cached-post
(recur (if empty? (+ e 1) e)))) (recur (if empty? (+ e 1) e))))
(append cached-post pieces)) (append cached-post pieces))
(else (receive (si ei) (else (receive (si ei)
(range start sv ev item) (range start sv ev item)
(cons (substring str si ei) (cons (substring str si ei)
pieces))))) pieces)))))
'() items)) '() items))
;; No match. Return str[start,end]. ;; No match. Return str[start,end].
(list (if (zero? start) str (list (if (zero? start) str

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 ...)

20
scsh/rx/re.scm
View File

@ -89,8 +89,8 @@
(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:
;;; - Flattens nested sequences ;;; - Flattens nested sequences
@ -135,8 +135,8 @@
(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:
;;; - Flattens nested choices ;;; - Flattens nested choices
@ -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,11 +540,11 @@
(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))
lis)) lis))
'() s)) '() s))
;; Coalesce adjacent chars together into a string. ;; Coalesce adjacent chars together into a string.

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

@ -26,14 +26,14 @@
(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))
(cs cset (char-set-adjoin! cs (ascii->char i)))) (cs cset (char-set-adjoin! cs (ascii->char i))))
((> i to) cs)))) ((> i to) cs))))
(string->char-set loose) (string->char-set loose)
ranges)))) ranges))))
(if in? (if in?
(doit loose ranges) (doit loose ranges)
(char-set-invert! (doit loose ranges))))) (char-set-invert! (doit loose ranges)))))

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)))