andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Delay bracket expression errors in patterns. 

* gash/pattern.scm (parse-matching-bracket-expression): Do not
report errors until a full bracket expression has been parsed.
* tests/unit/pattern.scm: Add test.
This commit is contained in:
Timothy Sample 2019-08-27 08:58:50 -04:00
parent 3c7693ece6
commit b41ae32106
2 changed files with 25 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
gash/pattern.scm
View File

@ -83,42 +83,48 @@
(define* (parse-matching-bracket-expression s #:optional (start 0)
(end (string-length s)))
(let loop ((i start) (acc '()))
(let loop ((i start) (acc '()) (errors '()))
(match (and (< i end) (string-ref s i))
(#f (values #f 0))
(#\] (if (= i start)
(loop (1+ i) (cons #\] acc))
(values (list->char-set acc) (1+ (- i start)))))
(loop (1+ i) (cons #\] acc) errors)
(match errors
(() (values (list->char-set acc) (1+ (- i start))))
(_ (throw (last errors))))))
(#\[ (match (and (< (1+ i) end) (string-ref s (1+ i)))
(#\. (receive (result length)
(parse-collating-symbol s (+ i 2) end)
(if result
(throw 'pattern-collating-symbol)
(loop (1+ i) (cons #\[ acc)))))
(loop (+ i length 1) acc
(cons 'pattern-collating-symbol errors))
(loop (1+ i) (cons #\[ acc) errors))))
(#\= (receive (result length)
(parse-equivalence-class s (+ i 2) end)
(if result
(throw 'pattern-equivalence-class)
(loop (1+ i) (cons #\[ acc)))))
(loop (+ i length 1) acc
(cons 'pattern-equivalence-class errors))
(loop (1+ i) (cons #\[ acc) errors))))
(#\: (receive (result length)
(parse-character-class s (+ i 2) end)
(if result
(throw 'pattern-character-class)
(loop (1+ i) (cons #\[ acc)))))
(_ (loop (1+ i) (cons #\[ acc)))))
(loop (+ i length 1) acc
(cons 'pattern-character-class errors))
(loop (1+ i) (cons #\[ acc) errors))))
(_ (loop (1+ i) (cons #\[ acc) errors))))
(#\- (if (or (= i start)
(and (< (1+ i) end) (char=? (string-ref s (1+ i)) #\])))
(loop (1+ i) (cons #\- acc))
(loop (1+ i) (cons #\- acc) errors)
(let ((alpha (and (pair? acc) (car acc)))
;; XXX: Escaped range end?
(omega (and (< (1+ i) end) (string-ref s (1+ i)))))
(match (character-range alpha omega)
(#f (throw 'pattern-range-expression))
(chrs (loop (+ i 2) (append chrs acc)))))))
(#f (loop (+ i 2) acc
(cons 'pattern-range-expression errors)))
(chrs (loop (+ i 2) (append chrs acc) errors))))))
(#\\ (if (< (1+ i) end)
(loop (+ i 2) (cons (string-ref s (1+ i)) acc))
(loop (1+ i) acc)))
(chr (loop (1+ i) (cons chr acc))))))
(loop (+ i 2) (cons (string-ref s (1+ i)) acc) errors)
(loop (1+ i) acc errors)))
(chr (loop (1+ i) (cons chr acc) errors)))))
(define* (parse-bracket-expression s #:optional (start 0)
(end (string-length s)))

3
tests/unit/pattern.scm
View File

@ -126,6 +126,9 @@
(test-assert "Matches with allowed character ranges"
(pattern-match? (parse-pattern "[a-z][A-Z][0-9]") "mJ2"))
(test-assert "Allows bad ranges in not-quite bracket expressions"
(pattern-plain? (parse-pattern "[]-foo")))
;;; Asterisks