From: Chris Hanson Date: Sun, 27 Sep 2009 09:59:24 +0000 (-0700) Subject: Add tests for regsexp. X-Git-Tag: 20100708-Gtk~308 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=db49d6eb52ce28d568797153e8a81cc014fcb041;p=mit-scheme.git Add tests for regsexp. --- diff --git a/src/runtime/regsexp.scm b/src/runtime/regsexp.scm index 415d3bbe7..1674e7cad 100644 --- a/src/runtime/regsexp.scm +++ b/src/runtime/regsexp.scm @@ -35,7 +35,12 @@ USA. (declare (usual-integrations)) (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 (%make-compiled-regsexp insn) @@ -63,8 +68,7 @@ USA. => (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 @@ -78,17 +82,31 @@ USA. ((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)) + +;;;; Compiler rules + (define (define-rule pattern compiler) (add-boot-init! (lambda () @@ -108,8 +126,6 @@ USA. unspecific)))))) (define %compile-regsexp-rules '()) - -;;;; Compiler rules (define-rule '(ANY-CHAR) (lambda () @@ -131,6 +147,11 @@ USA. (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))) + (define-rule '(? FORM) (lambda (regsexp) (insn:? (%compile-regsexp regsexp)))) @@ -147,11 +168,6 @@ USA. (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) @@ -163,12 +179,17 @@ USA. (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 @@ -306,7 +327,7 @@ USA. (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) @@ -469,21 +490,27 @@ USA. (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) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 8993caa7b..1aa268e31 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4934,6 +4934,7 @@ USA. compile-regsexp compiled-regsexp? + condition-type:compile-regsexp error:not-compiled-regsexp guarantee-compiled-regsexp regsexp-match-input-port diff --git a/tests/runtime/test-regsexp.scm b/tests/runtime/test-regsexp.scm index e2002e2b3..e1ed9409b 100644 --- a/tests/runtime/test-regsexp.scm +++ b/tests/runtime/test-regsexp.scm @@ -31,38 +31,42 @@ USA. (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))) @@ -72,10 +76,10 @@ USA. (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) @@ -161,4 +165,178 @@ USA. (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 + )) + +(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)))) + )) + +(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 diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index 726cffb09..a3ce0705b 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -131,20 +131,25 @@ USA. (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)))) (define-syntax define-for-tests (er-macro-transformer