From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 18 Apr 2000 21:30:42 +0000 (+0000)
Subject: Move parser support into separate file.
X-Git-Tag: 20090517-FFI~4008
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=642eacbe2a8463848ff23a9c88874d694c01fb83;p=mit-scheme.git

Move parser support into separate file.
---

diff --git a/v7/src/imail/parser.scm b/v7/src/imail/parser.scm
new file mode 100644
index 000000000..3076e7a0e
--- /dev/null
+++ b/v7/src/imail/parser.scm
@@ -0,0 +1,178 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: parser.scm,v 1.1 2000/04/18 21:30:42 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 (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 match-decoded keyword)
+  (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 ((j (match-decoded string 0 end)))
+		 (and j
+		      (fix:= j end)
+		      (list i (cons keyword (substring string 0 j)))))))))))
+
+(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