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

Let UNCASE-CHAR-SET return a regular expression as promised in the manual.

This commit is contained in:
mainzelm 2006-03-23 10:52:31 +00:00
parent bbcf682f5b
commit 8246b41681
2 changed files with 24 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
scsh/rx/parse.scm
View File

@ -220,7 +220,7 @@
(if cset? (if cset?
(if (re-char-set? re-or-cset) ; A char set or code (if (re-char-set? re-or-cset) ; A char set or code
(uncase-char-set re-or-cset) ; producing a char set. (re-char-set:cset (uncase re-or-cset))
`(,(r 'uncase) ,re-or-cset)) `(,(r 'uncase) ,re-or-cset))
(if (static-regexp? re-or-cset) ; A regexp or code (if (static-regexp? re-or-cset) ; A regexp or code
@ -291,11 +291,16 @@
(else (else
(if (every string? sre) ; A set spec -- ("wxyz"). (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)))) (if case-sensitive?
(if cset? cs (make-re-char-set cs))) (if cset?
cs
(make-re-char-set cs))
(let ((uncased-re (uncase-char-set cs)))
(if cset?
(re-char-set:cset uncased-re)
uncased-re))))
(error "Illegal SRE" sre)))))) (error "Illegal SRE" sre))))))
;; It must be a char-class name (ANY, ALPHABETIC, etc.) ;; It must be a char-class name (ANY, ALPHABETIC, etc.)
@ -375,7 +380,7 @@
(error "Unmatched range specifier" range-specs) (error "Unmatched range specifier" range-specs)
(let lp ((i (- len 1)) (cset cset)) (let lp ((i (- len 1)) (cset cset))
(if (< i 0) (if (< i 0)
(if cs? cset (uncase-char-set cset)) ; Case fold if necessary. (if cs? cset (re-char-set:cset (uncase-char-set cset))) ; Case fold if necessary.
(lp (- i 2) (lp (- i 2)
(ucs-range->char-set! (char->ascii (string-ref specs (- i 1))) (ucs-range->char-set! (char->ascii (string-ref specs (- i 1)))
(+ 1 (char->ascii (string-ref specs i))) (+ 1 (char->ascii (string-ref specs i)))

23
scsh/rx/re.scm
View File

@ -504,10 +504,10 @@
((re-char-set? re) ((re-char-set? re)
(let* ((cs (re-char-set:cset re)) (let* ((cs (re-char-set:cset re))
(new-cs (uncase-char-set cs))) ; Better not be code. (new-cs-re (uncase-char-set cs))) ; Better not be code.
(if (char-set= cs new-cs) (if (char-set= cs (re-char-set:cset new-cs-re))
(values re #f) (values re #f)
(values (make-re-char-set new-cs) #t)))) (values new-cs-re #t))))
((re-repeat? re) ((re-repeat? re)
(receive (new-body body-changed?) (recur (re-repeat:body re)) (receive (new-body body-changed?) (recur (re-repeat:body re))
@ -539,16 +539,17 @@
;;; (uncase-char-set cs) ;;; (uncase-char-set cs)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Return a char-set cs' such that cs' contains every char c in cs in both ;;; Return a regexp for char-set cs' such that cs' contains every char
;;; its upcase and downcase form. ;;; c in cs in both its upcase and downcase form.
(define (uncase-char-set cs) (define (uncase-char-set cs)
(char-set-fold (lambda (c new-cset) (make-re-char-set
(char-set-adjoin! new-cset (char-set-fold (lambda (c new-cset)
(char-downcase c) (char-set-adjoin! new-cset
(char-upcase c))) (char-downcase c)
(char-set-copy char-set:empty) (char-upcase c)))
cs)) (char-set-copy char-set:empty)
cs)))
;;; I actually make an effort to keep this a re-string ;;; I actually make an effort to keep this a re-string