From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 27 Jul 2008 04:24:26 +0000 (+0000)
Subject: Change mime-type parsing to use parser language; export the relevant
X-Git-Tag: 20090517-FFI~262
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3a6885c19c22c9ae3f3657bfae1642a09a4281f4;p=mit-scheme.git

Change mime-type parsing to use parser language; export the relevant
matchers and parsers.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index cf4962f75..f01271450 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.654 2008/07/26 22:53:55 cph Exp $
+$Id: runtime.pkg,v 14.655 2008/07/27 04:24:13 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -472,6 +472,8 @@ USA.
 	  init-file-specifier?
 	  make-directory
 	  make-mime-type
+	  matcher:mime-token
+	  matcher:mime-type
 	  mime-token-string?
 	  mime-token?
 	  mime-type->string
@@ -481,6 +483,8 @@ USA.
 	  mime-type?
 	  open-input-init-file
 	  open-output-init-file
+	  parser:mime-token
+	  parser:mime-type
 	  pathname-mime-type
 	  pathname-type->mime-type
 	  rename-file
diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index ce9526d7b..a0afa4f6d 100644
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.44 2008/07/26 22:51:29 cph Exp $
+$Id: sfile.scm,v 14.45 2008/07/27 04:24:26 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -334,26 +334,17 @@ USA.
 		 "/"
 		 (symbol-name (mime-type/subtype mime-type))))
 
-(define (string->mime-type string)
-  (guarantee-mime-type-string string 'STRING->MIME-TYPE)
-  (let ((slash (string-find-next-char string #\/)))
-    (%make-mime-type (intern (string-head string slash))
-		     (intern (string-tail string (fix:+ slash 1))))))
+(define (string->mime-type string #!optional start end)
+  (vector-ref (or (*parse-string parser:mime-type string start end)
+		  (error:not-mime-type-string string 'STRING->MIME-TYPE))
+	      0))
 
 (define (mime-type-string? object)
   (and (string? object)
        (string-is-mime-type? object)))
 
 (define (string-is-mime-type? string #!optional start end)
-  (let ((start (if (default-object? start) 0 start))
-	(end (if (default-object? end) (string-length string) end)))
-    (let ((i (check-mime-token-syntax string start end)))
-      (and (fix:> i 0)
-	   (fix:< i end)
-	   (char=? (string-ref string i) #\/)
-	   (fix:< (fix:+ i 1) end)
-	   (fix:= end (check-mime-token-syntax string (fix:+ i 1) end))
-	   i))))
+  (*match-string matcher:mime-type string start end))
 
 (define (mime-token? object)
   (and (interned-symbol? object)
@@ -364,17 +355,23 @@ USA.
        (string-is-mime-token? object)))
 
 (define (string-is-mime-token? string #!optional start end)
-  (let ((start (if (default-object? start) 0 start))
-	(end (if (default-object? end) (string-length string) end)))
-    (fix:= end (check-mime-token-syntax string start end))))
-
-(define (check-mime-token-syntax string start end)
-  (let loop ((i start))
-    (if (fix:< i end)
-	(if (char-set-member? char-set:mime-token (string-ref string i))
-	    (loop (fix:+ i 1))
-	    i)
-	end)))
+  (*match-string matcher:mime-token string start end))
+
+(define parser:mime-type
+  (*parser
+   (encapsulate (lambda (v)
+		  (%make-mime-type (vector-ref v 0)
+				   (vector-ref v 1)))
+     (seq parser:mime-token "/" parser:mime-token))))
+
+(define matcher:mime-type
+  (*matcher (seq matcher:mime-token "/" matcher:mime-token)))
+
+(define parser:mime-token
+  (*parser (map intern (match matcher:mime-token))))
+
+(define matcher:mime-token
+  (*matcher (* (char-set char-set:mime-token))))
 
 (define-guarantee mime-type "MIME type")
 (define-guarantee mime-type-string "MIME type string")