From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 27 Jul 2006 00:00:13 +0000 (+0000)
Subject: Implement FOR-ALL-CHARS-IN-STRING? and FOR-ANY-CHAR-IN-STRING?.
X-Git-Tag: 20090517-FFI~978
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3c9d183a37e52862d3ae7a697ec1df64e2eb3bfe;p=mit-scheme.git

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 80e0e06fc..bcf86f1d8 100644
--- 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 d670f6b9c..decbcf0f6 100644
--- 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)))
 
+;;;; 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))))
+
 ;;;; Wide string ports
 
 (define open-wide-output-string)