(declare (usual-integrations))
\f
(define (compile-regsexp regsexp)
- (%make-compiled-regsexp ((%compile-regsexp regsexp) %top-level-success)))
+ (bind-condition-handler (list condition-type:error)
+ (lambda (condition)
+ (signal-compile-error regsexp condition))
+ (lambda ()
+ (%make-compiled-regsexp
+ ((%compile-regsexp regsexp) %top-level-success)))))
(define-record-type <compiled-regsexp>
(%make-compiled-regsexp insn)
=> (lambda (rule)
(apply (cdr rule) (cdr regsexp))))
(else
- (error:wrong-type-argument regsexp "regular s-expression"
- 'COMPILE-REGSEXP))))
+ (error "Ill-formed regular s-expression:" regsexp))))
(define (%compile-char-set items)
(scalar-values->alphabet
((string? item)
(map char->integer (string->list item)))
(else
- (error:wrong-type-argument item "char-set item"
- 'COMPILE-REGSEXP))))
+ (error "Ill-formed char-set item:" item))))
items)))
(define (%compile-group-key key)
(if (not (or (fix:fixnum? key)
(unicode-char? key)
(symbol? key)))
- (error:wrong-type-argument key "regsexp group key" 'COMPILE-REGSEXP))
+ (error "Ill-formed regsexp group key:" key))
key)
+(define condition-type:compile-regsexp
+ (make-condition-type 'COMPILE-REGSEXP condition-type:error
+ '(PATTERN CAUSE)
+ (lambda (condition port)
+ (write (access-condition condition 'PATTERN) port)
+ (write-string ": " port)
+ (write-condition-report (access-condition condition 'CAUSE) port))))
+
+(define signal-compile-error
+ (condition-signaller condition-type:compile-regsexp
+ '(PATTERN CAUSE)
+ standard-error-handler))
+\f
+;;;; Compiler rules
+
(define (define-rule pattern compiler)
(add-boot-init!
(lambda ()
unspecific))))))
(define %compile-regsexp-rules '())
-\f
-;;;; Compiler rules
(define-rule '(ANY-CHAR)
(lambda ()
(lambda items
(insn:inverse-char-set (%compile-char-set items))))
+(define-rule '(LINE-START) (lambda () (insn:line-start)))
+(define-rule '(LINE-END) (lambda () (insn:line-end)))
+(define-rule '(STRING-START) (lambda () (insn:string-start)))
+(define-rule '(STRING-END) (lambda () (insn:string-end)))
+\f
(define-rule '(? FORM)
(lambda (regsexp)
(insn:? (%compile-regsexp regsexp))))
(lambda (regsexp)
(insn:*? (%compile-regsexp regsexp))))
-(define-rule '(LINE-START) (lambda () (insn:line-start)))
-(define-rule '(LINE-END) (lambda () (insn:line-end)))
-(define-rule '(STRING-START) (lambda () (insn:string-start)))
-(define-rule '(STRING-END) (lambda () (insn:string-end)))
-
(define-rule '(REPEAT> DATUM DATUM FORM)
(lambda (n m regsexp)
(check-repeat-args n m)
(insn:repeat< n m (%compile-regsexp regsexp))))
(define (check-repeat-args n m)
+ (if (not n)
+ (error "Repeat lower limit may not be #F"))
+ (if (not (exact-nonnegative-integer? n))
+ (error "Repeat limit must be non-negative integer:" n))
(guarantee-exact-nonnegative-integer n 'COMPILE-REGSEXP)
(if m
(begin
- (guarantee-exact-nonnegative-integer m 'COMPILE-REGSEXP)
+ (if (not (exact-nonnegative-integer? m))
+ (error "Repeat limit must be non-negative integer:" m))
(if (not (<= n m))
- (error:bad-range-argument m 'COMPILE-REGSEXP)))))
+ (error "Repeat upper limit greater than lower limit:" n m)))))
(define-rule '(ALT * FORM)
(lambda regsexps
(define (insn:group-ref key)
(lambda (succeed)
(lambda (position groups fail)
- ((%find-group succeed key groups) position groups fail))))
+ (((%find-group key groups) succeed) position groups fail))))
(define (insn:seq insns)
(lambda (succeed)
(cons (list key (cadr p) position)
(delq p groups))))
-(define (%find-group succeed key groups)
+(define (%find-group key groups)
(let ((p (assq key groups)))
(if (not p)
- (error "No group with this key:" key))
- (if (null? (cddr p))
- (error "Reference to group appears before group's end:" key))
- (insn:chars succeed (%group-chars (cadr p) (caddr p)))))
+ ;; This can happen with (* (GROUP ...)), but in other cases it
+ ;; would be an error.
+ (insn:always-succeed)
+ (begin
+ (if (null? (cddr p))
+ (error "Reference to group appears before group's end:" key))
+ (insn:chars (%group-chars (cadr p) (caddr p)))))))
(define (%group-chars start-position end-position)
(let ((same? (%position-type-same? (%get-position-type start-position))))
(let loop ((position start-position) (chars '()))
- (if (same? start-position end-position)
+ (if (same? position end-position)
(reverse! chars)
- (loop (next-position position)
- (cons (next-char position) chars))))))
+ (let ((char (next-char position)))
+ (if (not char)
+ (error "Failure of SAME? predicate"))
+ (loop (next-position position)
+ (cons char chars)))))))
(define (%convert-groups groups)
(map (lambda (g)
<compiled-regsexp>
compile-regsexp
compiled-regsexp?
+ condition-type:compile-regsexp
error:not-compiled-regsexp
guarantee-compiled-regsexp
regsexp-match-input-port
(regsexp-match-string (compile-regsexp pattern) string))
(define ((match-string-test pattern string expected))
- (assert-equal (match-string pattern string)
- expected
- 'EXPRESSION `(match-string ',pattern ,string)))
+ (let ((result (ignore-errors (lambda () (match-string pattern string)))))
+ (if (condition? result)
+ (if (and (eq? expected 'PATTERN-ERROR)
+ (condition-of-type? result condition-type:compile-regsexp))
+ #f
+ (signal-condition condition))
+ (assert-equal result
+ expected
+ 'EXPRESSION `(match-string ',pattern ,string)))))
(define (match-strings-test pattern entries)
(map (lambda (p)
- (match-string-test pattern (car p) (cadr p)))
+ (if (string? p)
+ (match-string-test pattern p (list (string-length p)))
+ (match-string-test pattern
+ (car p)
+ (if (exact-nonnegative-integer? (cadr p))
+ (cdr p)
+ (cadr p)))))
entries))
-(define (no-groups-test pattern entries)
- (match-strings-test pattern
- (map (lambda (p)
- (list (car p)
- (and (cadr p)
- (list (cadr p)))))
- entries)))
-
(define-test 'any-char
- (no-groups-test '(any-char)
- '(("" #f)
- ("a" 1)
- ("b" 1)
- ("\n" #f))))
+ (match-strings-test '(any-char)
+ '(("" #f)
+ ("a" 1)
+ ("b" 1)
+ ("\n" #f))))
(define-test '*any-char
- (no-groups-test '(* (any-char))
- '(("" 0)
- ("a" 1)
- ("ab" 2)
- ("abc" 3)
- ("ab\n" 2)
- ("a\nb" 1))))
+ (match-strings-test '(* (any-char))
+ '(("" 0)
+ ("a" 1)
+ ("ab" 2)
+ ("abc" 3)
+ ("ab\n" 2)
+ ("a\nb" 1))))
(define-test 'simple-seq
(match-string-test '(seq "a" "b") "ab" '(2)))
(lambda (indices . patterns)
(map (let ((strings '("" "a" "b" "ab" "ba" "aab")))
(lambda (pattern)
- (no-groups-test pattern
- (map list
- strings
- indices))))
+ (match-strings-test pattern
+ (map list
+ strings
+ indices))))
patterns))))
(list
(equivalents '(0 0 0 0 0 0)
(match-string-test '(seq (group foo (*? "a")) "ab") "aab" '(3 (foo 0 1)))
(match-string-test '(seq (group foo (*? "a")) "aab") "aab" '(3 (foo 0 0)))
- ))
\ No newline at end of file
+ ))
+\f
+(define-test 'palindromes
+ (list
+ (match-strings-test '(seq (group a (any-char))
+ (group b (any-char))
+ (any-char)
+ (group-ref b)
+ (group-ref a))
+ '(("radar" 5 (b 1 2) (a 0 1))))
+ (match-strings-test '(seq (string-start)
+ (group 1 (? (any-char)))
+ (group 2 (? (any-char)))
+ (group 3 (? (any-char)))
+ (group 4 (? (any-char)))
+ (group 5 (? (any-char)))
+ (group 6 (? (any-char)))
+ (group 7 (? (any-char)))
+ (group 8 (? (any-char)))
+ (group 9 (? (any-char)))
+ (? (any-char))
+ (group-ref 9)
+ (group-ref 8)
+ (group-ref 7)
+ (group-ref 6)
+ (group-ref 5)
+ (group-ref 4)
+ (group-ref 3)
+ (group-ref 2)
+ (group-ref 1)
+ (string-end))
+ '(("civic" 5
+ (9 2 2) (8 2 2) (7 2 2) (6 2 2) (5 2 2)
+ (4 2 2) (3 2 2) (2 1 2) (1 0 1))
+ ("abba" 4
+ (9 2 2) (8 2 2) (7 2 2) (6 2 2) (5 2 2)
+ (4 2 2) (3 2 2) (2 1 2) (1 0 1))))
+ (match-strings-test '(seq (string-start)
+ (group 1 (?? (any-char)))
+ (group 2 (?? (any-char)))
+ (group 3 (?? (any-char)))
+ (group 4 (?? (any-char)))
+ (group 5 (?? (any-char)))
+ (group 6 (?? (any-char)))
+ (group 7 (?? (any-char)))
+ (group 8 (?? (any-char)))
+ (group 9 (?? (any-char)))
+ (?? (any-char))
+ (group-ref 9)
+ (group-ref 8)
+ (group-ref 7)
+ (group-ref 6)
+ (group-ref 5)
+ (group-ref 4)
+ (group-ref 3)
+ (group-ref 2)
+ (group-ref 1)
+ (string-end))
+ '(("civic" 5
+ (9 1 2) (8 0 1) (7 0 0) (6 0 0) (5 0 0)
+ (4 0 0) (3 0 0) (2 0 0) (1 0 0))
+ ("abba" 4
+ (9 1 2) (8 0 1) (7 0 0) (6 0 0) (5 0 0)
+ (4 0 0) (3 0 0) (2 0 0) (1 0 0))))
+ ))
+\f
+(define-test 'grep-bre
+ (map (lambda (entry)
+ (match-strings-test (car entry) (cdr entry)))
+ '(((seq "a" (seq "b") "c")
+ "abc")
+ ((seq "a" (seq) "b")
+ "ab")
+ ((seq (* "a")
+ (seq (string-start)
+ "b"
+ (string-end))
+ (* "c"))
+ "b")
+ ((seq)
+ ("abc" 0))
+ ((seq "a"
+ (group x (* "b"))
+ "c"
+ (group-ref x)
+ "d")
+ ("abbcbd" #f)
+ ("abbcbbd" 7 (x 1 3))
+ ("abbcbbbd" #f))
+ ((seq (string-start)
+ (group x (any-char))
+ (group-ref x))
+ ("abc" #f))
+ ((seq "a"
+ (* (seq (group x (char-set "bc"))
+ (group-ref x)))
+ "d")
+ ("abbccd" 6 (x 3 4) (x 1 2))
+ ("abbcbd" #f))
+ ((seq "a"
+ (* (seq (* (group x "b"))
+ (group-ref x)))
+ "d")
+ ("abbbd" 5 (x 2 3) (x 1 2)))
+ ((seq (group x "a")
+ (group-ref x)
+ "bcd")
+ ("aabcd" 5 (x 0 1)))
+ ((seq (group x "a")
+ (group-ref x)
+ "b"
+ (* "c")
+ "d")
+ ("aabcd" 5 (x 0 1))
+ ("aabd" 4 (x 0 1))
+ ("aabcccd" 7 (x 0 1)))
+ ((seq (group x "a")
+ (group-ref x)
+ "b"
+ (* "c")
+ (char-set "ce")
+ "d")
+ ("aabcccd" 7 (x 0 1)))
+ ((seq (string-start)
+ (group x "a")
+ (group-ref x)
+ "b"
+ (* "c")
+ "cd"
+ (string-end))
+ ("aabcccd" 7 (x 0 1)))
+ ((seq (repeat> 1 1 "a") "b")
+ "ab")
+ ((seq (repeat> 1 #f "a") "b")
+ "ab")
+ ((seq (repeat> 1 2 "a") "b")
+ "aab")
+ ((seq "a" (repeat> 0 0 "b") "c")
+ "ac"
+ ("abc" #f))
+ ((seq "a" (repeat> 0 1 "b") "c")
+ "ac"
+ "abc"
+ ("abbc" #f))
+ ((seq "a" (repeat> 0 3 "b") "c")
+ "ac"
+ "abc"
+ "abbc"
+ "abbbc"
+ ("abbbbc" #f))
+ ((seq "a" (repeat> 1 0 "b") "c")
+ ("ac" pattern-error))
+ ((seq "a" (repeat> #f 1 "b") "c")
+ ("ac" pattern-error))
+ ((seq "a" (repeat> 1 1 "b") "c")
+ ("ac" #f)
+ "abc")
+ ((seq "a" (repeat> 1 3 "b") "c")
+ ("ac" #f)
+ "abc")
+ ((seq "a" (repeat> 2 2 "b") "c")
+ ("abc" #f)
+ "abbc")
+ ((seq "a" (repeat> 2 4 "b") "c")
+ ("abcabbc" #f))
+ ((seq "a"
+ (? (group x "b"))
+ "c"
+ (group-ref x)
+ "d")
+ "acd")
+ ((seq (repeat> 0 1 "-")
+ (+ (char-set "0123456789"))
+ (string-end))
+ "-5"))))
\ No newline at end of file
(write-object-property tag p port)))
(define (report-failure failure port)
- (let ((result (failure-feature 'RESULT failure)))
- (if result
- (begin
- (write-string "value" port)
- (let ((expr (failure-property 'EXPRESSION failure)))
- (if expr
- (write-expr-property "of" expr port)))
- (write-feature "was" result port)
- (let ((expectation (failure-feature 'EXPECTATION failure)))
- (if expectation
- (write-feature "but expected" expectation port))))
- (write-string (or (failure-property 'DESCRIPTION failure)
- "failed for an unknown reason")
- port))))
+ (cond ((failure-property 'CONDITION failure)
+ => (lambda (p)
+ (write-string "failed with error: " port)
+ (write-condition-report (cdr p) port)))
+ ((failure-feature 'RESULT failure)
+ => (lambda (result)
+ (write-string "value" port)
+ (let ((expr (failure-property 'EXPRESSION failure)))
+ (if expr
+ (write-expr-property "of" expr port)))
+ (write-feature "was" result port)
+ (let ((expectation (failure-feature 'EXPECTATION failure)))
+ (if expectation
+ (write-feature "but expected" expectation port)))))
+ ((failure-property 'DESCRIPTION failure)
+ => (lambda (p)
+ (write-string (cdr p) port)))
+ (else
+ (error "Ill-formed failure:" failure))))
\f
(define-syntax define-for-tests
(er-macro-transformer
projects / mit-scheme.git / commitdiff