Implement FOR-ALL-CHARS-IN-STRING? and FOR-ANY-CHAR-IN-STRING?.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 80e0e06fc85d343f8734cb51518e61ada10fdc42..bcf86f1d866fbf7cde047fc8c19f1e9b88fddce6 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.587 2006/07/20 17:09:44 riastradh Exp $
+$Id: runtime.pkg,v 14.588 2006/07/27 00:00:06 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -4788,6 +4788,7 @@ USA.
          alphabet->char-set
          alphabet->code-points
          alphabet->string
+         alphabet-predicate
          alphabet?
          call-with-wide-output-string
          char-in-alphabet?
@@ -4806,6 +4807,8 @@ USA.
          error:not-well-formed-code-point-list
          error:not-wide-char
          error:not-wide-string
+         for-all-chars-in-string?
+         for-any-char-in-string?
          guarantee-8-bit-alphabet
          guarantee-alphabet
          guarantee-unicode-code-point

diff --git a/v7/src/runtime/unicode.scm b/v7/src/runtime/unicode.scm
index d670f6b9c7fb7ae547a5a6d86ffdd5b067e90d37..decbcf0f67bf52a66a9143f8eb42825b80e340d6 100644 (file)
--- a/v7/src/runtime/unicode.scm
+++ b/v7/src/runtime/unicode.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unicode.scm,v 1.26 2006/03/07 19:56:25 cph Exp $
+$Id: unicode.scm,v 1.27 2006/07/27 00:00:13 cph Exp $
 
 Copyright 2001,2003,2004,2005 Massachusetts Institute of Technology
 
@@ -1145,6 +1145,45 @@ USA.
 (define-integrable (%valid-trailer? n)
   (fix:= #x80 (fix:and #xC0 n)))
 \f
+;;;; Per-character combination predicates
+
+(define (for-all-chars-in-string? predicate string #!optional start end coding)
+  (let ((port (open-string string start end coding 'FOR-ALL-CHARS-IN-STRING?)))
+    (let loop ()
+      (let ((char (read-char port)))
+       (cond ((eof-object? char) #t)
+             ((predicate char) (loop))
+             (else #f))))))
+
+(define (for-any-char-in-string? predicate string #!optional start end coding)
+  (let ((port (open-string string start end coding 'FOR-ANY-CHAR-IN-STRING?)))
+    (let loop ()
+      (let ((char (read-char port)))
+       (cond ((eof-object? char) #f)
+             ((predicate char) #t)
+             (else (loop)))))))
+
+(define (open-string string start end coding caller)
+  (cond ((string? string)
+        (let ((port (open-input-string string start end)))
+          (if (not (default-object? coding))
+              (port/set-coding port coding))
+          port))
+       ((wide-string? string)
+        (if (not (default-object? coding))
+            (error "Coding not allowed with wide strings:" coding))
+        (open-wide-input-string string start end))
+       (else
+        (error:wrong-type-argument string "string" caller))))
+
+(define (alphabet-predicate alphabet)
+  (cond ((alphabet? alphabet)
+        (lambda (char) (char-in-alphabet? char alphabet)))
+       ((char-set? alphabet)
+        (lambda (char) (char-set-member? alphabet char)))
+       (else
+        (error:not-alphabet alphabet 'ALPHABET-PREDICATE))))
+\f
 ;;;; Wide string ports
 
 (define open-wide-output-string)