From 68402e6dbb33385d5b83a12414dd9a5c077a47e1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 10 Oct 2001 04:28:49 +0000
Subject: [PATCH] The parser language developed for IMAIL has been replaced by
 the newer *PARSER facility.

---
 v7/src/imail/compile.scm       |   6 +-
 v7/src/imail/ed-ffi.scm        |   4 +-
 v7/src/imail/imail-imap.scm    |  47 ++--
 v7/src/imail/imail.pkg         |  36 +--
 v7/src/imail/imap-response.scm |  16 +-
 v7/src/imail/imap-syntax.scm   | 455 +++++++++++----------------------
 v7/src/imail/load.scm          |   4 +-
 v7/src/imail/parser.scm        | 216 ----------------
 8 files changed, 197 insertions(+), 587 deletions(-)
 delete mode 100644 v7/src/imail/parser.scm

diff --git a/v7/src/imail/compile.scm b/v7/src/imail/compile.scm
index 91c7ed9ce..51f666ebd 100644
--- a/v7/src/imail/compile.scm
+++ b/v7/src/imail/compile.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: compile.scm,v 1.13 2001/10/05 19:20:01 cph Exp $
+;;; $Id: compile.scm,v 1.14 2001/10/10 04:26:21 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -23,6 +23,7 @@
 
 (load-option 'CREF)
 (load-option 'SOS)
+(load-option '*PARSER)
 (with-working-directory-pathname (directory-pathname (current-load-pathname))
   (lambda ()
     (for-each compile-file
@@ -33,8 +34,7 @@
 		"imail-umail"
 		"imail-util"
 		"imap-response"
-		"imap-syntax"
-		"parser"))
+		"imap-syntax"))
     (for-each (let ((syntax-table
 		     (access edwin-syntax-table (->environment '(EDWIN)))))
 		(lambda (filename)
diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm
index f32b51830..eb49a7956 100644
--- a/v7/src/imail/ed-ffi.scm
+++ b/v7/src/imail/ed-ffi.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: ed-ffi.scm,v 1.15 2001/10/05 19:20:03 cph Exp $
+;;; $Id: ed-ffi.scm,v 1.16 2001/10/10 04:27:31 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -43,6 +43,4 @@
     ("imap-response"	(edwin imail imap-response)
 			system-global-syntax-table)
     ("imap-syntax"	(edwin imail imap-syntax)
-			system-global-syntax-table)
-    ("parser"		(edwin imail parser)
 			system-global-syntax-table)))
\ No newline at end of file
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 110e96c22..9375f318c 100644
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.188 2001/09/29 02:58:17 cph Exp $
+;;; $Id: imail-imap.scm,v 1.189 2001/10/10 04:26:37 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -196,28 +196,31 @@
 
 (define parse-imap-url-body
   (let ((parser
-	 (let ((//server
-		(sequence-parser (noise-parser (string-matcher "//"))
-				 (imap:server-parser #f)))
-	       (/mbox
-		(sequence-parser (noise-parser (string-matcher "/"))
-				 (optional-parser imap:parse:enc-mailbox))))
-	   (alternatives-parser
-	    (sequence-parser //server (optional-parser /mbox))
-	    /mbox
-	    imap:parse:enc-mailbox))))
+	 (let ((parse-server (imap:server-parser #f)))
+	   (*parser
+	    (alt (seq "//"
+		      parse-server
+		      (alt (seq "/" imap:parse:enc-mailbox)
+			   imap:parse:enc-mailbox
+			   (values #f)))
+		 (seq (values #f #f #f)
+		      (? "/")
+		      imap:parse:enc-mailbox))))))
     (lambda (string default-url)
-      (let ((pv (parse-string parser string)))
-	(if pv
-	    (values (or (parser-token pv 'USER-ID)
-			(imap-url-user-id default-url))
-		    (or (parser-token pv 'HOST)
-			(imap-url-host default-url))
-		    (cond ((parser-token pv 'PORT) => string->number)
-			  ((parser-token pv 'HOST) 143)
-			  (else (imap-url-port default-url)))
-		    (or (parser-token pv 'MAILBOX)
-			(imap-url-mailbox default-url)))
+      (let ((v (parser (string->parser-buffer string))))
+	(if v
+	    (let ((user-id (vector-ref v 0))
+		  (host (vector-ref v 1))
+		  (port (vector-ref v 2))
+		  (mailbox (vector-ref v 3)))
+	      (values (or user-id
+			  (imap-url-user-id default-url))
+		      (or host
+			  (imap-url-host default-url))
+		      (or port
+			  (if host 143 (imap-url-port default-url)))
+		      (or mailbox
+			  (imap-url-mailbox default-url))))
 	    (values #f #f #f #f))))))
 
 ;;;; Container heirarchy
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 9af48c6cb..dc124a5f3 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.89 2001/10/05 19:20:05 cph Exp $
+;;; $Id: imail.pkg,v 1.90 2001/10/10 04:26:26 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -24,35 +24,7 @@
 (global-definitions "../runtime/runtime")
 (global-definitions "../sos/sos")
 (global-definitions "../edwin/edwinunx")
-
-(define-package (edwin imail parser)
-  (files "parser")
-  (parent (edwin imail))
-  (export (edwin imail)
-	  *-matcher
-	  +-matcher
-	  alternatives-matcher
-	  alternatives-parser
-	  ci-string-matcher
-	  decoding-parser
-	  encapsulating-parser
-	  list-parser
-	  match-always
-	  match-never
-	  noise-parser
-	  optional-matcher
-	  optional-parser
-	  parse-always
-	  parse-never
-	  parse-string
-	  parse-substring
-	  parser-token
-	  predicated-parser
-	  rexp-matcher
-	  sequence-matcher
-	  sequence-parser
-	  simple-parser
-	  string-matcher))
+(global-definitions "../star-parser/parser")
 
 (define-package (edwin imail)
   (files "imail-util"
@@ -106,10 +78,10 @@
 	  imap:char-set:atom-char
 	  imap:char-set:tag-char
 	  imap:char-set:text-char
-	  imap:match:tag
 	  imap:parse:section
 	  imap:quoted-char?
-	  imap:quoted-special?))
+	  imap:quoted-special?
+	  imap:tag-string?))
 
 (define-package (edwin imail imap-response)
   (files "imap-response")
diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm
index ca01901f0..1b9c2ff6b 100644
--- a/v7/src/imail/imap-response.scm
+++ b/v7/src/imail/imap-response.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imap-response.scm,v 1.43 2001/02/05 18:36:08 cph Exp $
+;;; $Id: imap-response.scm,v 1.44 2001/10/10 04:26:43 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -16,7 +16,8 @@
 ;;;
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
 
 ;;;; IMAP Server Response Reader
 
@@ -33,10 +34,7 @@
 		     (discard-known-char #\space port)
 		     (cond ((string=? "*" tag)
 			    (read-untagged-response port))
-			   ((let ((end (string-length tag)))
-			      (let ((index (imap:match:tag tag 0 end)))
-				(and index
-				     (fix:= index end))))
+			   ((imap:tag-string? tag)
 			    (read-tagged-response tag port))
 			   (else
 			    (error "Malformed server response:" tag)))))))
@@ -220,10 +218,10 @@
 (define *fetch-body-part-port* #f)
 
 (define (parse-section string)
-  (let ((pv (parse-string imap:parse:section string)))
-    (if (not pv)
+  (let ((v (imap:parse:section (string->parser-buffer string))))
+    (if (not v)
 	(error:bad-range-argument string 'PARSE-SECTION))
-    (parser-token pv 'SECTION)))
+    (vector-ref v 0)))
 
 (define (parse-date-time string)
   (decoded-time->universal-time
diff --git a/v7/src/imail/imap-syntax.scm b/v7/src/imail/imap-syntax.scm
index 7670f6ce1..99467ac58 100644
--- a/v7/src/imail/imap-syntax.scm
+++ b/v7/src/imail/imap-syntax.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imap-syntax.scm,v 1.16 2000/07/05 03:25:35 cph Exp $
+;;; $Id: imap-syntax.scm,v 1.17 2001/10/10 04:26:48 cph Exp $
 ;;;
-;;; Copyright (c) 2000 Massachusetts Institute of Technology
+;;; Copyright (c) 2000, 2001 Massachusetts Institute of Technology
 ;;;
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License as
@@ -16,34 +16,13 @@
 ;;;
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
 
 ;;;; IMAP Syntax
 
 (declare (usual-integrations))
 
-(define imap:char-set:achar
-  (char-set-union url:char-set:unreserved (string->char-set "&=~")))
-
-(define imap:match:achar+
-  (rexp-matcher
-   (rexp+ (rexp-alternatives imap:char-set:achar url:rexp:escape))))
-
-(define imap:match:bchar+
-  (rexp-matcher
-   (rexp+ (rexp-alternatives (char-set-union imap:char-set:achar
-					     (string->char-set ":@/"))
-			     url:rexp:escape))))
-
-(define imap:char-set:quoted-specials
-  (char-set #\" #\\))
-
-(define (imap:quoted-special? char)
-  (char-set-member? imap:char-set:quoted-specials char))
-
-(define imap:char-set:list-wildcards
-  (char-set #\% #\*))
-
 (define imap:char-set:char
   (ascii-range->char-set #x01 #x80))
 
@@ -51,303 +30,179 @@
   (char-set-union (ascii-range->char-set #x00 #x20)
 		  (char-set #\rubout)))
 
-(define imap:char-set:atom-char
-  (char-set-difference imap:char-set:char
-		       (char-set-union (char-set #\( #\) #\{ #\space)
-				       imap:char-set:ctl
-				       imap:char-set:list-wildcards
-				       imap:char-set:quoted-specials)))
+(define imap:char-set:list-wildcards
+  (char-set #\% #\*))
 
-(define (imap:atom-char? char)
-  (char-set-member? imap:char-set:atom-char char))
+(define imap:char-set:quoted-specials
+  (char-set #\" #\\))
 
 (define imap:char-set:text-char
   (char-set-difference imap:char-set:char
 		       (char-set #\return #\linefeed)))
 
-(define imap:char-set:not-text-char
-  (char-set-invert imap:char-set:text-char))
-
-(define (imap:string-may-be-quoted? string)
-  (not (string-find-next-char-in-set string imap:char-set:not-text-char)))
-
 (define imap:char-set:quoted-char
   (char-set-difference imap:char-set:text-char
 		       imap:char-set:quoted-specials))
 
-(define (imap:quoted-char? char)
-  (char-set-member? imap:char-set:quoted-char char))
-
-(define imap:char-set:base64
-  (char-set-union char-set:alphanumeric
-		  (char-set #\+ #\/)))
+(define imap:char-set:atom-char
+  (char-set-difference imap:char-set:char
+		       (char-set-union (char-set #\( #\) #\{ #\space)
+				       imap:char-set:ctl
+				       imap:char-set:list-wildcards
+				       imap:char-set:quoted-specials)))
 
 (define imap:char-set:tag-char
   (char-set-difference imap:char-set:atom-char
 		       (char-set #\+)))
+
+(define imap:char-set:achar
+  (char-set-union url:char-set:unreserved (string->char-set "&=~")))
 
-(define imap:match:atom
-  (rexp-matcher (rexp+ imap:char-set:atom-char)))
-
-(define imap:match:text
-  (rexp-matcher (rexp+ imap:char-set:text-char)))
-
-(define imap:match:tag
-  (rexp-matcher (rexp+ imap:char-set:tag-char)))
-
-(define imap:match:base64
-  (rexp-matcher
-   (rexp-sequence
-    (rexp* imap:char-set:base64
-	   imap:char-set:base64
-	   imap:char-set:base64
-	   imap:char-set:base64)
-    (rexp-optional
-     (rexp-alternatives
-      (rexp-sequence imap:char-set:base64
-		     imap:char-set:base64
-		     "==")
-      (rexp-sequence imap:char-set:base64
-		     imap:char-set:base64
-		     imap:char-set:base64
-		     "="))))))
-
-(define imap:match:quoted-string
-  (rexp-matcher
-   (rexp-sequence "\""
-		  (rexp* (rexp-alternatives
-			  imap:char-set:quoted-char
-			  (rexp-sequence "\\" imap:char-set:quoted-specials)))
-		  "\"")))
-
-(define (imap:match:literal string start end)
-  (let ((regs (re-substring-match "{\\([0-9]+\\)}\r\n" string start end)))
-    (and regs
-	 (let ((index
-		(fix:+ (re-match-end-index 0 regs)
-		       (substring->number string
-					  (re-match-start-index 1 regs)
-					  (re-match-end-index 1 regs)))))
-	   (and (fix:<= index end)
-		index)))))
-
-(define imap:match:string
-  (alternatives-matcher imap:match:quoted-string
-			imap:match:literal))
-
-(define imap:match:astring
-  (alternatives-matcher imap:match:atom
-			imap:match:string))
-
-(define imap:match:number
-  (rexp-matcher (rexp+ char-set:numeric)))
-
-(define imap:match:nz-number
-  (rexp-matcher
-   (rexp-sequence (char-set-difference char-set:numeric (char-set #\0))
-		  (rexp* char-set:numeric))))
-
-(define imap:match:date
-  (let ((date-text
-	 (rexp-matcher
-	  (rexp-sequence
-	   (rexp-sequence (rexp-optional (char-set #\1 #\2 #\3))
-			  char-set:numeric)
-	   "-"
-	   (apply rexp-alternatives
-		  (map rexp-case-fold
-		       '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul"
-			       "Aug" "Sep" "Oct" "Nov" "Dec")))
-	   "-"
-	   (rexp-sequence char-set:numeric
-			  char-set:numeric
-			  char-set:numeric
-			  char-set:numeric)))))
-    (alternatives-matcher date-text
-			  (sequence-matcher (string-matcher "\"")
-					    date-text
-					    (string-matcher "\"")))))
+(define (imap:atom-char? char)
+  (char-set-member? imap:char-set:atom-char char))
 
-(define imap:parse:section-text
-  (alternatives-parser
-   (simple-parser (alternatives-matcher
-		   (ci-string-matcher "header")
-		   (ci-string-matcher "text"))
-		  'KEYWORD)
-   (sequence-parser
-    (simple-parser (sequence-matcher
-		    (ci-string-matcher "header.fields")
-		    (optional-matcher
-		     (ci-string-matcher ".not")))
-		   'KEYWORD)
-    (noise-parser (string-matcher " ("))
-    (predicated-parser (list-parser imap:match:astring
-				    (string-matcher " ")
-				    'HEADERS)
-		       (lambda (pv) (pair? (parser-token pv 'HEADERS))))
-    (noise-parser (string-matcher ")")))))
+(define (imap:quoted-special? char)
+  (char-set-member? imap:char-set:quoted-specials char))
 
-(define imap:parse:section
-  (encapsulating-parser
-   (alternatives-parser
-    imap:parse:section-text
-    (sequence-parser
-     (list-parser imap:match:nz-number (string-matcher ".") 'NUMBER)
-     (optional-parser
-      (noise-parser (string-matcher "."))
-      (alternatives-parser
-       imap:parse:section-text
-       (simple-parser (ci-string-matcher "mime") 'KEYWORD)))))
-   (lambda (pv)
-     (map* (let ((keyword (parser-token pv 'KEYWORD)))
-	     (if keyword
-		 (cons (intern keyword)
-		       (or (parser-token pv 'HEADERS) '()))
-		 '()))
-	   string->number
-	   (or (parser-token pv 'NUMBER) '())))
-   'SECTION))
-
-(define imap:match:set
-  (let ((range
-	 (let ((number
-		(alternatives-matcher imap:match:nz-number
-				      (string-matcher "*"))))
-	   (alternatives-matcher number
-				 (sequence-matcher number ":" number)))))
-    (sequence-matcher range
-		      (*-matcher (string-matcher ",") range))))
-
-(define imap:match:search-key
-  (let ((m
-	 (lambda (keyword . arguments)
-	   (apply sequence-matcher
-		  (ci-string-matcher keyword)
-		  (map (lambda (argument)
-			 (sequence-matcher (string-matcher " ")
-					   argument))
-		       arguments))))
-	;; Kludge: self reference.
-	(imap:match:search-key
-	 (lambda (string start end)
-	   (imap:match:search-key string start end))))
-    (alternatives-matcher
-     (m "all")
-     (m "answered")
-     (m "bcc"		imap:match:astring)
-     (m "before"	imap:match:date)
-     (m "body"		imap:match:astring)
-     (m "cc"		imap:match:astring)
-     (m "deleted")
-     (m "draft")
-     (m "flagged")
-     (m "from"		imap:match:astring)
-     (m "header"	imap:match:astring imap:match:astring)
-     (m "keyword"	imap:match:atom)
-     (m "larger"	imap:match:number)
-     (m "new")
-     (m "not"		imap:match:search-key)
-     (m "old")
-     (m "on"		imap:match:date)
-     (m "or"		imap:match:search-key imap:match:search-key)
-     (m "recent")
-     (m "seen")
-     (m "sentbefore"	imap:match:date)
-     (m "senton"	imap:match:date)
-     (m "sentsince"	imap:match:date)
-     (m "since"		imap:match:date)
-     (m "smaller"	imap:match:number)
-     (m "subject"	imap:match:astring)
-     (m "text"		imap:match:astring)
-     (m "to"		imap:match:astring)
-     (m "uid"		imap:match:set)
-     (m "unanswered")
-     (m "undeleted")
-     (m "undraft")
-     (m "unflagged")
-     (m "unkeyword"	imap:match:atom)
-     (m "unseen")
-     imap:match:set
-     (sequence-matcher (string-matcher "(")
-		       imap:match:search-key
-		       (string-matcher ")")))))
-
-(define imap:match:search-program
-  (sequence-matcher
-   (optional-matcher (ci-string-matcher "charset ")
-		     imap:match:astring
-		     (string-matcher " "))
-   imap:match:search-key))
-
-;;;; URL parser
+(define (imap:quoted-char? char)
+  (char-set-member? imap:char-set:quoted-char char))
 
-(define (url:decoding-parser match-encoded keyword)
-  (decoding-parser match-encoded
-		   url:decode-substring
-		   (simple-parser (lambda (string start end)
-				    string start
-				    end)
-				  keyword)))
+(define ((string-matching-procedure matcher) string)
+  (matcher (string->parser-buffer string)))
 
-(define (imap:server-parser allow-auth?)
-  (sequence-parser
-   (optional-parser
-    (sequence-parser
-     (let ((parse-user-id (url:decoding-parser imap:match:achar+ 'USER-ID)))
-       (if allow-auth?
-	   (let ((parse-auth
-		  (sequence-parser
-		   (noise-parser (ci-string-matcher ";auth="))
-		   (alternatives-parser
-		    (simple-parser (string-matcher "*") 'AUTH-TYPE)
-		    (url:decoding-parser imap:match:achar+ 'AUTH-TYPE)))))
-	     (alternatives-parser
-	      (sequence-parser parse-user-id
-			       (optional-parser parse-auth))
-	      (sequence-parser (optional-parser parse-user-id)
-			       parse-auth)))
-	   parse-user-id))
-     (noise-parser (string-matcher "@"))))
-   (simple-parser (rexp-matcher url:rexp:host) 'HOST)
-   (optional-parser
-    (noise-parser (string-matcher ":"))
-    (simple-parser (rexp-matcher (rexp+ char-set:numeric)) 'PORT))))
-
-(define imap:parse:server
-  (imap:server-parser #t))
+(define imap:string-may-be-quoted?
+  (string-matching-procedure
+   (*matcher (complete (* (char-set imap:char-set:text-char))))))
+
+(define imap:tag-string?
+  (string-matching-procedure
+   (*matcher (complete (+ (char-set imap:char-set:tag-char))))))
 
-(define imap:parse:mailboxlist
-  (sequence-parser
-   (optional-parser
-    (url:decoding-parser imap:match:bchar+ 'MAILBOX-LIST))
-   (noise-parser (ci-string-matcher ";type="))
-   (simple-parser (alternatives-matcher (ci-string-matcher "list")
-					(ci-string-matcher "lsub"))
-		  'LIST-TYPE)))
+(define (imap:server-parser allow-auth?)
+  (let ((parse-user/auth
+	 (if allow-auth?
+	     (let ((parse-auth
+		    (*parser
+		     (seq (noise (string-ci ";auth="))
+			  (alt (match "*")
+			       imap:parse:achar+)))))
+	       (*parser
+		(alt (seq (alt (seq imap:parse:achar+
+				    (alt parse-auth (values #f)))
+			       (seq (alt imap:parse:achar+ (values #f))
+				    parse-auth))
+			  "@")
+		     (values #f #f))))
+	     (*parser
+	      (alt (seq imap:parse:achar+ "@")
+		   (values #f))))))
+    (*parser
+     (seq parse-user/auth
+	  url:parse:hostport))))
+
+(define imap:parse:achar+
+  (*parser
+   (map url:decode-string
+	(match (+ (alt (char-set imap:char-set:achar)
+		       url:match:escape))))))
 
 (define imap:parse:enc-mailbox
-  (url:decoding-parser imap:match:bchar+ 'MAILBOX))
-
-(define imap:parse:uidvalidity
-  (sequence-parser (noise-parser (ci-string-matcher ";uidvalidity="))
-		   (simple-parser imap:match:nz-number 'UID-VALIDITY)))
-
-(define imap:parse:messagelist
-  (sequence-parser imap:parse:enc-mailbox
-		   (optional-parser
-		    (url:decoding-parser imap:match:bchar+ 'SEARCH-PROGRAM))
-		   (optional-parser imap:parse:uidvalidity)))
-
-(define imap:parse:messagepart
-  (sequence-parser imap:parse:enc-mailbox
-		   (optional-parser imap:parse:uidvalidity)
-		   (noise-parser (ci-string-matcher "/;uid="))
-		   (simple-parser imap:match:nz-number 'UID)
-		   (optional-parser
-		    (noise-parser (ci-string-matcher "/;section="))
-		    (decoding-parser imap:match:bchar+
-				     url:decode-substring
-				     imap:parse:section))))
+  (*parser
+   (map url:decode-string
+	(match (+ (alt (char-set (char-set-union imap:char-set:achar
+						 (string->char-set ":@/")))
+		       url:match:escape))))))
+
+(define imap:parse:section
+  (*parser
+   (encapsulate vector->list
+     (alt imap:parse:section-text
+	  (seq (? (seq imap:parse:nz-number
+		       (* (seq "." imap:parse:nz-number))))
+	       (? (seq "."
+		       (alt imap:parse:section-text
+			    (map intern (match (string-ci "mime")))))))))))
+
+(define imap:parse:section-text
+  (*parser
+   (alt (map intern
+	     (match (alt (string-ci "header")
+			 (string-ci "text"))))
+	(seq (map intern
+		  (match (seq (string-ci "header.fields")
+			      (? (string-ci ".not")))))
+	     " ("
+	     imap:parse:astring
+	     (* (seq " " imap:parse:astring))
+	     ")"))))
+
+(define imap:parse:nz-number
+  (*parser
+   (map string->number
+	(match (seq (char-set (char-set-difference char-set:numeric
+						   (char-set #\0)))
+		    (* (char-set char-set:numeric)))))))
+
+(define imap:parse:astring
+  (*parser (alt imap:parse:atom imap:parse:string)))
+
+(define imap:parse:atom
+  (*parser (match (+ (char-set imap:char-set:atom-char)))))
+
+(define imap:parse:string
+  (*parser (alt imap:parse:quoted-string imap:parse:literal)))
+
+(define imap:parse:quoted-string
+  (*parser
+   (seq #\"
+	(map decode-quoted-string
+	     (match (* (alt (char-set imap:char-set:quoted-char)
+			    (seq (char #\\)
+				 (char-set imap:char-set:quoted-specials))))))
+	#\")))
+
+(define (decode-quoted-string string)
+  (let ((end (string-length string)))
+    (let ((n-quotes
+	   (let loop ((start 0) (n-quotes 0))
+	     (if (fix:< start end)
+		 (let ((index (substring-find-next-char string start end #\\)))
+		   (if index
+		       (loop (fix:+ index 2) (fix:+ n-quotes 1))
+		       n-quotes))
+		 n-quotes))))
+      (let ((end* (fix:- end n-quotes)))
+	(let ((string* (make-string end*)))
+	  (let loop ((start 0) (start* 0))
+	    (if (fix:< start end)
+		(let ((index (substring-find-next-char string start end #\\)))
+		  (if index
+		      (let ((index*
+			     (substring-move! string start index
+					      string* start*)))
+			(string-set! string* index*
+				     (string-ref string (fix:+ index 1)))
+			(loop (fix:+ index 2) (fix:+ index* 1)))
+		      (substring-move! string start end string* start*)))))
+	  string*)))))
+
+(define (imap:parse:literal buffer)
+  (let ((p (get-parser-buffer-pointer buffer)))
+    (let ((v
+	   ((*parser
+	     (seq "{" (match (+ (char-set char-set:numeric))) "}\r\n"))
+	    buffer)))
+      (and v
+	   (let ((n (string->number (vector-ref v 0)))
+		 (p2 (get-parser-buffer-pointer buffer)))
+	     (let loop ((i 0))
+	       (cond ((= i n)
+		      (get-parser-buffer-tail buffer p2))
+		     ((read-parser-buffer-char buffer)
+		      (loop (+ i 1)))
+		     (else
+		      (set-parser-buffer-pointer! buffer p)
+		      #f))))))))
 
 ;;;; Mailbox-name encoding (modified UTF-7)
 
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index eec7adc87..ef010f23d 100644
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.32 2001/10/05 19:20:07 cph Exp $
+;;; $Id: load.scm,v 1.33 2001/10/10 04:27:10 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -29,4 +29,4 @@
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
       (load-package-set "imail"))))
-(add-subsystem-identification! "IMAIL" '(1 14))
\ No newline at end of file
+(add-subsystem-identification! "IMAIL" '(1 15))
\ No newline at end of file
diff --git a/v7/src/imail/parser.scm b/v7/src/imail/parser.scm
deleted file mode 100644
index b6254bf08..000000000
--- a/v7/src/imail/parser.scm
+++ /dev/null
@@ -1,216 +0,0 @@
-;;; -*-Scheme-*-
-;;;
-;;; $Id: parser.scm,v 1.4 2000/06/01 20:06:38 cph Exp $
-;;;
-;;; Copyright (c) 2000 Massachusetts Institute of Technology
-;;;
-;;; This program is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation; either version 2 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;;; Parsing support
-
-(declare (usual-integrations))
-
-;;;; Parser language
-
-;;; A parser is a procedure that accepts a substring as three
-;;; arguments and returns one of two values.  If the parser
-;;; successfully parses the substring, it returns a pair whose car is
-;;; an index into the substring indicating how much of the substring
-;;; was parsed, and whose cdr is an alist of keyword/token pairs.  If
-;;; the parser fails, it returns #F.
-
-(define (parse-string parser string)
-  (parse-substring parser string 0 (string-length string)))
-
-(define (parse-substring parser string start end)
-  (let ((pv (parser string start end)))
-    (and pv
-	 (fix:= (car pv) end)
-	 pv)))
-
-(define (parser-token parser-value keyword)
-  (let ((entry (assq keyword (cdr parser-value))))
-    (and entry
-	 (cdr entry))))
-
-(define (parse-never string start end)
-  string start end
-  #f)
-
-(define (parse-always string start end)
-  string end
-  (list start))
-
-(define (noise-parser match)
-  (lambda (string start end)
-    (let ((i (match string start end)))
-      (and i
-	   (list i)))))
-
-(define (simple-parser match keyword)
-  (lambda (string start end)
-    (let ((i (match string start end)))
-      (and i
-	   (list i (cons keyword (substring string start i)))))))
-
-(define (decoding-parser match-encoded decode parse-decoded)
-  (lambda (string start end)
-    (let ((i (match-encoded string start end)))
-      (and i
-	   (let ((string (decode string start i)))
-	     (let ((end (string-length string)))
-	       (let ((pv (parse-substring parse-decoded string 0 end)))
-		 (and pv
-		      (cons i (cdr pv))))))))))
-
-(define (encapsulating-parser parser transformer keyword)
-  (lambda (string start end)
-    (let ((pv (parser string start end)))
-      (and pv
-	   (list (car pv) (cons keyword (transformer pv)))))))
-
-(define (predicated-parser parser predicate)
-  (lambda (string start end)
-    (let ((pv (parser string start end)))
-      (and pv
-	   (predicate pv)
-	   pv))))
-
-(define (list-parser match-element match-delimiter keyword)
-  (lambda (string start end)
-    (let ((index (match-element string start end)))
-      (if index
-	  (let loop
-	      ((start index)
-	       (elements (list (substring string start index))))
-	    (let ((index (match-delimiter string start end)))
-	      (if index
-		  (let ((index* (match-element string index end)))
-		    (if index*
-			(loop index*
-			      (cons (substring string index index*) elements))
-			(list start (cons keyword (reverse! elements)))))
-		  (list start (cons keyword (reverse! elements))))))
-	  (list start (list keyword))))))
-
-(define (optional-parser . parsers)
-  (let ((parse (apply sequence-parser parsers)))
-    (lambda (string start end)
-      (or (parse string start end)
-	  (list start)))))
-
-(define (sequence-parser . parsers)
-  (if (pair? parsers)
-      (if (pair? (cdr parsers))
-	  (lambda (string start end)
-	    (let loop ((parsers parsers) (start start))
-	      (let ((pv1 ((car parsers) string start end)))
-		(and pv1
-		     (if (pair? (cdr parsers))
-			 (let ((pv2 (loop (cdr parsers) (car pv1))))
-			   (and pv2
-				(cons (car pv2) (append (cdr pv1) (cdr pv2)))))
-			 pv1)))))
-	  (car parsers))
-      parse-always))
-
-(define (alternatives-parser . parsers)
-  (if (pair? parsers)
-      (if (pair? (cdr parsers))
-	  (lambda (string start end)
-	    (let loop ((parsers parsers))
-	      (or ((car parsers) string start end)
-		  (and (pair? (cdr parsers))
-		       (loop (cdr parsers))))))
-	  (car parsers))
-      parse-never))
-
-;;;; Matcher language
-
-;;; A matcher is a procedure that accepts a substring as three
-;;; arguments and returns one of two values.  If the matcher
-;;; successfully matches the substring, it returns an index into the
-;;; substring indicating how much of the substring was matched.  If
-;;; the matcher fails, it returns #F.
-
-(define (match-never string start end)
-  string start end
-  #f)
-
-(define (match-always string start end)
-  string end
-  start)
-
-(define (rexp-matcher pattern)
-  (let ((pattern (rexp-compile pattern)))
-    (lambda (string start end)
-      (let ((regs (re-substring-match pattern string start end)))
-	(and regs
-	     (re-match-end-index 0 regs))))))
-
-(define (string-matcher pattern)
-  (let ((pl (string-length pattern)))
-    (lambda (string start end)
-      (and (substring-prefix? pattern 0 pl string start end)
-	   (fix:+ start pl)))))
-
-(define (ci-string-matcher pattern)
-  (let ((pl (string-length pattern)))
-    (lambda (string start end)
-      (and (substring-prefix-ci? pattern 0 pl string start end)
-	   (fix:+ start pl)))))
-
-(define (optional-matcher . matchers)
-  (let ((matcher (apply sequence-matcher matchers)))
-    (lambda (string start end)
-      (or (matcher string start end)
-	  start))))
-
-(define (alternatives-matcher . matchers)
-  (if (pair? matchers)
-      (if (pair? (cdr matchers))
-	  (lambda (string start end)
-	    (let loop ((matchers matchers))
-	      (or ((car matchers) string start end)
-		  (and (pair? (cdr matchers))
-		       (loop (cdr matchers))))))
-	  (car matchers))
-      match-never))
-
-(define (sequence-matcher . matchers)
-  (if (pair? matchers)
-      (if (pair? (cdr matchers))
-	  (lambda (string start end)
-	    (let loop ((matchers matchers) (start start))
-	      (let ((i ((car matchers) string start end)))
-		(and i
-		     (if (pair? (cdr matchers))
-			 (loop (cdr matchers) i)
-			 i)))))
-	  (car matchers))
-      match-always))
-
-(define (*-matcher . matchers)
-  (let ((matcher (apply sequence-matcher matchers)))
-    (lambda (string start end)
-      (let loop ((start start))
-	(let ((i (matcher string start end)))
-	  (if i
-	      (loop i)
-	      start))))))
-
-(define (+-matcher . matchers)
-  (let ((matcher (apply sequence-matcher matchers)))
-    (sequence-matcher matcher (*-matcher matcher))))
\ No newline at end of file
-- 
2.25.1