more tests

scsh/test/pattern-matching-test.scm

@@ -13,35 +13,147 @@
 
 (define eq-match?
   (lambda (m1 m2)
+    (if (equal? m1 #f)
+	(not m2)
 	(and (= (match:start m1)
 		(match:start m2))
 	     (= (match:end m1)
 		(match:end m2))
 	     (equal? (match:substring m1)
-		 (match:substring m2)))))
+		     (match:substring m2))))))
 
-;; *** tests ***
+(define matches-same-signs?
+  (lambda (re1 re2)
+    (let loop ((i 0))
+      (if (= 256 i)
+	  #t
+	  (let ((str (list->string (list (ascii->char i)))))
+	    (if (eq-match? (string-match re1 str)
+			   (string-match re2 str))
+		(loop (+ i 1))
+		#f))))))
+
+
+;; *** help-strings *** 
+
+(define all-signs-string
+  (let loop ((i 0))
+    (if (= i 256)
+	""
+	(string-append (list->string (list (ascii->char i)))
+		       (loop (+ i 1))))))
 
 (define test-string "Dieser Test-String wurde am 29.07.2004 um 5:23PM erstellt.\na aa aaa aaaa\nab aabb aaabbb\naba abba abbba\n1 12 123 1234\nyyyyyyyyyy\n")
-(define nul-string (list->string (list (ascii->char 0) (ascii->char 0))))
+
-(define newln-string "\n\n")
+
+;; *** tests ***
 
 (add-test! 'no-match-test 'pattern-matching
   (lambda ()
     (not (string-match (rx "xxx") test-string))))
 
-(add-test! 'simple-string-match 'pattern-matching
+(add-test! 'various-forms-of-non-vowels 'pattern-matching
   (lambda ()
-	     (eq-match? (string-match (rx (- alpha ("aeiouAEIOU"))) test-string)
+    (and (eq-match? (string-match (rx (- alpha ("aeiouAEIOU"))) test-string)
-			(string-match (rx (- (/"azAZ") ("aeiouAEIOU"))) test-string))))
+		    (string-match (rx (- (/"azAZ") ("aeiouAEIOU"))) test-string))
+	 (eq-match? (string-match (rx (- (/"azAZ") ("aeiouAEIOU"))) test-string)
+		    (string-match (rx (- alpha ("aeiou") ("AEIOU"))) test-string))
+	 (eq-match? (string-match (rx (- alpha ("aeiou") ("AEIOU"))) test-string)
+		    (string-match (rx (w/nocase (- alpha ("aeiou")))) test-string))
+	 (eq-match? (string-match (rx (w/nocase (- alpha ("aeiou")))) test-string)
+		    (string-match (rx (w/nocase (- (/ "az") ("aeiou")))) test-string)))))
 
-(add-test! 'simple-string-regexp 'pattern-matching
+(add-test! '|-test 'pattern-matching
+  (lambda ()
+    (eq-match? (string-match (rx (| upper ("aeiou") digit)) "xxx A yyy")
+	       (string-match (rx (| (/ "AZ09") ("aeiou"))) "xxx A yyy"))
+    (eq-match? (string-match (rx (| upper ("aeiou") digit)) "xxx a yyy")
+	       (string-match (rx (| (/ "AZ09") ("aeiou"))) "xxx a yyy"))
+    (eq-match? (string-match (rx (| upper ("aeiou") digit)) "xxx 6 yyy")
+	       (string-match (rx (| (/ "AZ09") ("aeiou"))) "xxx 6 yyy"))))
+
+(add-test! 'comma-seperated-list-of-REs 'pattern-matching
+  (lambda () 
+    (let ((csl (lambda (re)
+		 (rx (| ""
+			(: ,re
+			   (* ", " ,re)))))))
+      (string-match (csl (rx (| "John" "Paul" "George" "Ringo")))
+		    "George, Ringo, Paul, John"))))
+
+(add-test! 'repetition-test 'pattern-matching
+  (lambda ()
+    (and (equal? "caaadadr"
+		  (match:substring (string-match (rx (: "c" (+ (| "a" "d")) "r"))
+						 "(caaadadr ...")))
+	 (equal? "caaadadr"
+		  (match:substring (string-match (rx (: "c" (+ ("ad")) "r"))
+						 "(caaadadr ...")))
+	 (equal? "caaadadr"
+		  (match:substring (string-match (rx (: "c" (** 1 6 ("ad")) "r"))
+						 "(caaadadr ...")))
+	 (not (string-match (rx (: "c" (** 1 4 ("ad")) "r"))
+						 "(caaadadr ...")))))
+
+(add-test! 'special-cases-test 'pattern-matching
+  (lambda ()
+    (and (matches-same-signs? (rx any) (rx (~)))
+	 (not (string-match (rx (|)) all-signs-string)))))
+
+
+
+;XXX something is wrong with this
+;(add-test! 're-vs-@re-submatch-test 'pattern-matching
+;  (lambda ()
+;    (let* ((f (lambda ()
+;		(rx (submatch "sub-f1")
+;		    (submatch "sub-f2"))))
+;	   (re (rx (submatch (* "foo"))
+;		   (submatch (? "bar"))
+;		   ,(f)
+;		   (submatch "baz")))
+;	   (match1 (string-match ,re "foofoobarsub-f1sub-f2baz"))
+;	   (match2 (string-match ,@re "foofoobarsub-f1sub-f2baz")))
+;      (and (...)))))
+
+(add-test! 'posix-string-test 'pattern-matching
+  (lambda ()
+    (and (string-match (rx (posix-string "[aeiou]+|x*|y{3,5}"))
+		       "a")
+	 (string-match (rx (posix-string "[aeiou]+|x*|y{3,5}"))
+		       "x")
+	 (string-match (rx (posix-string "[aeiou]+|x*|y{3,5}"))
+		       "")
+	 (string-match (rx (posix-string "[aeiou]+|x*|y{3,5}"))
+		       "yyyy"))))
+
+(add-test! 'dsm-test 'pattern-matching
+  (lambda ()
+    (and (equal? "hello"
+		 (match:substring (string-match (rx (dsm 1 0 (submatch "hello")))
+						"bla hello bla")
+				  2))
+	 (not (match:substring (string-match (rx (dsm 1 0 (submatch "hello")))
+						"bla hello bla")
+				  1))
+	 (equal? "hello"
+		 (match:substring (string-match (rx (dsm 2 0 (submatch "hello")))
+						"bla hello bla")
+				  3))
+	 (not (match:substring (string-match (rx (dsm 2 0 (submatch "hello")))
+						"bla hello bla")
+				  1))
+	 (not (match:substring (string-match (rx (dsm 2 0 (submatch "hello")))
+						"bla hello bla")
+				  2)))))
+
+(add-test! 'string-regexp 'pattern-matching
   (lambda ()
     (and (equal? "erstellt."
 		 (match:substring (string-match (rx "erstellt.") test-string)))
 	 (not (string-match (rx "Erstellt.") test-string)))))
 
-(add-test! 'simple-character-set 'pattern-matching
+(add-test! 'character-set 'pattern-matching
   (lambda ()
     (eq-match? (string-match (rx ("abcde")) test-string)
 	       (string-match (rx ("edcba")) test-string))))
@@ -191,11 +303,15 @@
 	  (you 2))
       (and (equal? "feeding the goose"
 		   (match:substring (string-match (rx (: "feeding the "
-								  ,(if (> me 1) "geese" "goose")))
+							 ,(if (> me 1) 
+							      "geese" 
+							      "goose")))
 						  str)))
 	   (equal? "feeding the geese"
 		   (match:substring (string-match (rx (: "feeding the "
-								  ,(if (> you 1) "geese" "goose")))
+							 ,(if (> you 1) 
+							      "geese" 
+							      "goose")))
 						  str)))))))
 
 (add-test! 'dynamic-re-test-2 'pattern-matching
@@ -208,10 +324,12 @@
 			   "30"
 			   "31")))))
       (and (equal? "on Mar 14"
-			    (match:substring (string-match (rx (: "on " ,date)) "it was on Mar 14 ...")))
+		   (match:substring (string-match (rx (: "on " ,date)) 
+						  "it was on Mar 14 ...")))
 	   
 	   (equal? "on May 31"
-			    (match:substring (string-match (rx (: "on " ,date)) "it was on May 31 ...")))))))
+		   (match:substring (string-match (rx (: "on " ,date)) 
+						  "it was on May 31 ...")))))))
 
 (add-test! 'regexp?-test 'pattern-matching
   (lambda ()
@@ -257,7 +375,8 @@
 				      (lambda (m)
 					(let ((mon (vector-ref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
 								  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
-									(- (string->number (match:substring m 1)) 1)))
+							       (- (string->number (match:substring m 1)) 
+								  1)))
 					      (day (match:substring m 2))
 					      (year (match:substring m 3)))
 					  (string-append mon " " day ", 19" year)))
@@ -268,7 +387,8 @@
     (let ((kill-matches (lambda (re s)
 			  (regexp-substitute/global #f re s 'pre 'post))))
       (equal? " will disappear, also  and "
-		       (kill-matches (rx (| "Windows" "tcl" "Intel")) "Windows will disappear, also tcl and Intel")))))
+	      (kill-matches (rx (| "Windows" "tcl" "Intel")) 
+			    "Windows will disappear, also tcl and Intel")))))
 
 (add-test! 'regexp-fold-right-test 'pattern-matching
   (lambda ()
@@ -288,12 +408,118 @@
 		       (whole-date month day year)
 		       (string-append whole-date "\nmonth: " month "\nday: " day "\nyear: " year)))))
 
+(add-test! 'if-match-test 'pattern-matching
+  (lambda ()
+    (and (if-match (regexp-search (rx (submatch (+ digit)) "/"
+				      (submatch (+ digit)) "/"
+				      (submatch (+ digit)))
+				  "here comes a date: 3/1/79")
+		   (whole-date month day year)
+		   (and (equal? month "3")
+			(equal? day "1")
+			(equal? year "79"))
+		   #f)
+	 (if-match (regexp-search (rx (submatch (+ digit)) "/"
+				      (submatch (+ digit)) "/"
+				      (submatch (+ digit)))
+				  "here comes a date: 3|1|79")
+		   (whole-date month day year)
+		   (and (equal? month "3")
+			(equal? day "1")
+			(equal? year "79"))
+		   #t))))
+
+(add-test! 'match-cond-test 'pattern-matching
+  (lambda ()
+    (let ((m "")
+	  (d "")
+	  (y ""))
+      (and (match-cond ((regexp-search (rx (submatch (+ digit)) "/"
+					   (submatch (+ digit)) "/"
+					   (submatch (+ digit)))
+				       "here comes a date: 3/1/79")
+			(whole-date month day year)
+			(begin (set! m month)
+			       (set! d day)
+			       (set! y year)))
+		       (test (equal? m "3")
+			     #t)
+		       (else #f))
+	   (match-cond ((regexp-search (rx (submatch (+ digit)) "/"
+					   (submatch (+ digit)) "/"
+					 (submatch (+ digit)))
+				       "here comes a date: 4/1/79")
+			(whole-date month day year)
+			(begin (set! m month)
+			       (set! d day)
+			       (set! y year)))
+		       (test (equal? m "3")
+			     #t)
+		       (test (if (equal? m "4")
+				 m
+				 d) =>
+				 (lambda (month)
+				   (equal? month "4")))			       
+		       (else #f))
+	   (match-cond ((regexp-search (rx (submatch (+ digit)) "/"
+					   (submatch (+ digit)) "/"
+					   (submatch (+ digit)))
+				       "here comes a date: 5/1/79")
+			(whole-date month day year)
+			(begin (set! m month)
+			       (set! d day)
+			       (set! y year)))
+		       (test (equal? m "3")
+			     #t)
+		       (test (if (equal? m "4")
+				 m
+				 d) =>
+				 (lambda (month)
+				   (equal? month "4")))			       
+		       (else #t))))))
+
+(add-test! 'flush-submatches-test 'pattern-matching
+  (lambda ()
+    (let ((re (rx (submatch "foo")
+		  (submatch "bar"))))
+      (and (= 2
+	      (re-seq:tsm re))
+	   (= 0
+	      (re-seq:tsm (flush-submatches re)))
+	   (equal? "foobar"
+		   (match:substring (string-match (flush-submatches re)
+						  "foobar")))))))
+
+(add-test! 'uncase-test 'pattern-matching
+  (lambda ()
+    (equal? "FoO"
+	    (match:substring (string-match (uncase (rx "foo"))
+					   "FoO")))))
+
+;; XXX no idea how to test simplify-regexp
+
+
+
+;; XXX perhaps only a mistake in the manual - it says: 
+;; uncase-char-set was of the type: cset -> re
+;; in fact it is of the type: cset -> cset
+(add-test! 'uncase-char-set-test 'patern-matching 
+  (lambda ()
+    (equal? "B"
+	    (match:substring (string-match (uncase-char-set (list->char-set (list #\a #\b #\c)))
+					   "dDBb")))))
+
+(add-test! 'uncase-string-test 'pattern-matching
+  (lambda ()
+    (equal? "FoO"
+	    (match:substring (string-match (uncase-string "foo")
+					   "FoO")))))
 (add-test! 'sre->regexp-test 'pattern-matching
   (lambda ()
     (regexp? (sre->regexp '(: "Christoph " (? "F. ") "Hetz")))))
 
 
- 
+;; XXX
 ;;Warning: wrong number of arguments
 ;;         (re-seq (re-string "Pete ") (re-repeat 1 #f (re-string "Sz")) (re-string "ilagyi"))
 ;;         (procedure wants: (:value))
@@ -307,7 +533,3 @@
 ;						 (re-repeat 1 #f (re-string "Sz"))
 ;						 (re-string "ilagyi")))))))
 
-
-
-
-

scsh/test/read-delimited-strings.scm

@@ -328,13 +328,43 @@
 
 ;; ===============================================================================================
 
-(add-test! 'read-delimited!-with-char-set-test 'read-delimited-strings
+
+;; XXX read-delimited! and %read-delimited! are confusing bugy
+;(add-test! 'read-delimited!-with-char-set-test 'read-delimited-strings
+;	   (lambda ()
+;	     (let ((buf "                              "))
+;	       ((lambda (in-port)
+;		  (read-delimited! (list->char-set (list #\a #\b #\1))
+;				   buf
+;				   in-port)
+;		  (equal? "zeile a                       "
+;			  buf))
+;		(make-string-input-port "zeile a1 nix\nzeile b1 x2\nzeile c1 wieder nix\n")))))
+
+
+;; ====================================================================================================
+
+(add-test! 'skip-char-set-wiht-charset-test 'read-delimited-strings
   (lambda ()
-	     (let ((buf "                              "))
+    (= 6
-	       ((lambda (in-port)
+       (skip-char-set (list->char-set (list #\a #\b #\c))
-		  (read-delimited! (list->char-set (list #\a #\b #\1))
+		      (make-string-input-port "abccbaxxx")))))
-				   buf
+
-				   in-port)
+
-		  (equal? "zeile a                       "
+(add-test! 'skip-char-set-wiht-string-test 'read-delimited-strings
-			  buf))
+  (lambda ()
-		(make-string-input-port "zeile a1 nix\nzeile b1 x2\nzeile c1 wieder nix\n")))))
+    (= 6
+       (skip-char-set "abc"
+		      (make-string-input-port "abccbaxxx")))))
+
+(add-test! 'skip-char-set-wiht-character-test 'read-delimited-strings
+  (lambda ()
+    (= 6
+       (skip-char-set #\a
+		      (make-string-input-port "aaaaaaxxx")))))
+
+(add-test! 'skip-char-set-wiht-character-predicate-test 'read-delimited-strings
+  (lambda ()
+    (= 6
+       (skip-char-set char-digit?
+		      (make-string-input-port "123456xxx")))))