From 52050ed71c65d480a86528446d31c0ae7209e06d Mon Sep 17 00:00:00 2001
From: Sergey Poznyakoff <gray@gnu.org.ua>
Date: Sun, 1 Sep 2002 21:58:38 +0000
Subject: Added to the repository.

---
 guimb/scm/sieve.scm.in | 1006 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 1006 insertions(+)
 create mode 100644 guimb/scm/sieve.scm.in

diff --git a/guimb/scm/sieve.scm.in b/guimb/scm/sieve.scm.in
new file mode 100644
index 000000000..edbba129f
--- /dev/null
+++ b/guimb/scm/sieve.scm.in
@@ -0,0 +1,1006 @@
+#! %BINDIR%/guimb --source
+!#
+;;;; GNU mailutils - a suite of utilities for electronic mail
+;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
+;;;;
+;;;; 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, 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.  
+;;;;
+
+;;;; This is a Sieve to Scheme translator.
+;;;;
+;;;; To convert a sieve script into equivalent Scheme program, executable
+;;;; by guimb, run:
+;;;;
+;;;;  guile -s sieve.scm --file <sieve-script-name> --output <output-file-name>
+;;;;
+;;;; To compile and execute a sieve script upon a mailbox, run:
+;;;;
+;;;;  guimb -f sieve.scm -{ --file <sieve-script-name> -} --mailbox ~/mbox
+
+(define sieve-debug 0)
+(define sieve-parser #t)
+(define sieve-libdir "%LIBDIR%")
+(define sieve-load-files '())
+
+(define error-count 0)
+(define current-token #f)
+(define putback-list '())
+(define input-port #f)
+(define input-file "")
+(define input-line-number 0)
+(define input-line "")
+(define input-index 0)
+(define input-length 0)
+(define nesting-level 0)
+(define recovery-line-number -1)
+(define recovery-index -1)
+
+(define (DEBUG level . rest)
+  (if (>= sieve-debug level)
+      (begin
+	(display "DEBUG(")
+	(display level)
+	(display "):")
+	(for-each (lambda (x)
+		    (display x))
+		  rest)
+	(newline))))
+
+;;;; Lexical scanner
+(define (delimiter? c)
+  (or (member c (list #\[ #\] #\{ #\} #\, #\; #\( #\)))
+      (char-whitespace? c)))
+
+(define (lex-error . rest)
+  (set! error-count (1+ error-count))
+  (display input-file)
+  (display ":")
+  (display input-line-number)
+  (display ": ")
+  (for-each (lambda (x)
+	      (display x))
+	    rest)
+  (newline)
+  #t)
+
+(define (syntax-error . rest)
+  (set! error-count (1+ error-count))
+  (display input-file)
+  (display ":")
+  (display input-line-number)
+  (display ": ")
+  (for-each (lambda (x)
+	      (display x))
+	    rest)
+  (newline)
+  (throw 'syntax-error))
+
+
+;;; If current input position points to end of line or to a start of
+;;; # comment, return #f. Otherwise return cons whose car contains
+;;; token type and cdr contains token itself (string). 
+(define (next-token)
+  (let ((start (do ((i input-index (1+ i)))
+		   ((or (>= i input-length)
+			(not (char-whitespace? (string-ref input-line i))))
+		    i))))
+;    (DEBUG 100 "START " start ": " (substring input-line start)) 
+    (if (< start input-length)
+	(let ((char (string-ref input-line start)))
+	  (DEBUG 100 "CHAR " char)
+	  (case char
+	    ((#\#)
+	     (set! input-index input-length)
+	     #f)
+	    ((#\[ #\] #\{ #\} #\( #\) #\, #\;)
+	     (set! input-index (1+ start))
+	     (cons 'delimiter char))
+	    ((#\")
+	     (let ((end (do ((end (1+ start) (1+ end)))
+			    ((or (>= end input-length)
+				 (char=? (string-ref input-line end) #\"))
+			     end))))
+	       (if (>= end input-length)
+		   (lex-error "Unterminated string constant"))
+		  (set! input-index (1+ end))
+		  (cons 'string (substring input-line (1+ start) end))))
+	    (else
+	     (DEBUG 100 "MATCH else")
+	     (cond
+	      ((and (char=? (string-ref input-line start) #\/)
+		    (< (1+ start) input-length)
+		    (char=? (string-ref input-line (1+ start)) #\*))
+	       (set! input-index (+ start 2))
+	       (cons 'bracket-comment "/*"))
+	      ((char-numeric? char)
+	       (let* ((end (do ((end start (1+ end)))
+			       ((or
+				 (>= end (1- input-length))
+				 (not (char-numeric?
+				       (string-ref input-line end))))
+				 end)))
+		      (num (string->number (substring input-line start end))) 
+		      (q (string-ref input-line end))
+		      (k 1))
+		 (case q
+		   ((#\K)
+		    (set! end (1+ end))
+		    (set! k 1024))
+		   ((#\M)
+		    (set! end (1+ end))
+		    (set! k 1048576))
+		   ((#\G)
+		    (set! end (1+ end))
+		    (set! k 1073741824))
+		   (else
+		    (cond
+		     ((char-numeric? q) 
+		      (set! end (1+ end)))
+		     ((not (delimiter? q))
+		      (lex-error "Unknown qualifier (" q ")")))))
+		 (set! input-index end)
+		 (cons 'number (* num k))))
+	      (else
+	       (let ((end (do ((end start (1+ end)))
+			      ((or (>= end input-length)
+				   (delimiter? (string-ref input-line end)))
+			       end))))
+		 (DEBUG 100 "END " end)
+		 (set! input-index end)
+		 (cond
+		  ((char=? char #\:)
+		   (cons 'tag (substring input-line (1+ start) end)))
+		  (else
+		   (cons 'identifier (substring input-line start end))))))))))
+	#f)))
+
+(define (end-of-line?)
+  (do ((i input-index (1+ i)))
+      ((or (>= i input-length)
+	   (not (char-whitespace? (string-ref input-line i))))
+       (>= i input-length))))
+
+(define (read-input-line port)
+  (set! input-line (read-line port))
+  (if (not (eof-object? input-line))
+      (begin
+	(set! input-line-number (1+ input-line-number))
+	(set! input-length (string-length input-line))
+	(set! input-index 0)))
+  input-line)
+
+(define (next-token-from-port port)
+  (let ((tok (or (next-token)
+		 (begin
+		   (DEBUG 100 "2nd")
+		   (set! input-line (read-line port))
+		   (if (not (eof-object? input-line))
+		       (begin
+                         (set! input-line-number (1+ input-line-number))
+			 (set! input-length (string-length input-line))
+			 (set! input-index 0)
+			 (next-token))
+		       input-line)))))
+    (cond
+     ((or (not tok) (eof-object? tok))
+      tok)
+     ((and (eq? (car tok) 'identifier)
+	   (string=? (cdr tok) "text:")
+	   (end-of-line?))
+      (let ((text "")
+	    (string-start input-line-number))
+	(do ((line (read-line port) (read-line port)))
+	    ((or (and
+		  (eof-object? line)
+		  (lex-error
+		   "Unexpected end of file in multiline string started on line "
+		   string-start)
+		  (throw 'end-of-file))
+		 (let ((len (string-length line)))
+		   (and (> len 0)
+			(char=? (string-ref line 0) #\.)
+			(do ((i 1 (1+ i)))
+			    ((or (>= i len)
+				 (not
+				  (char-whitespace?
+				   (string-ref line i))))
+			     (>= i len))))))
+	     #f)
+          (set! input-line-number (1+ input-line-number))
+	  (if (and (not (string-null? line))
+                   (char=? (string-ref line 0) #\.)
+		   (char=? (string-ref line 1) #\.))
+	      (set! line (make-shared-substring line 1)))
+	  (set! text (string-append text "\n" line)))
+	(set! input-length 0)
+	(set! input-index 0)
+	(cons 'string text)))
+     ((eq? (car tok) 'bracket-comment)
+      (let ((comment-start input-line-number))
+	(set! input-length (- input-length input-index))
+	   (if (> input-length 0)
+	       (begin
+		 (set! input-line
+		       (substring input-line input-index input-length))
+		 (set! input-index 0))
+	       (read-input-line port))
+	   (do ()
+	       ((> input-index 0) #f)
+	     (cond
+	      ((eof-object? input-line)
+	       (lex-error
+		"Unexpected end of file in comment started on line "
+		comment-start)
+	       (throw 'end-of-file))
+	      (else
+	       (let ((t (string-index input-line #\*)))
+		 (if (and t
+			  (< (1+ t) input-length)
+			  (char=? (string-ref input-line (1+ t)) #\/))
+		     (set! input-index (+ t 2))
+		     (read-input-line port))))))))
+     (else
+	tok))))
+
+(define (delimiter token c)
+  (and (pair? token)
+       (eq? (car token) 'delimiter)
+       (char=? (cdr token) c)))
+
+(define (identifier token c)
+  (and (eq? (car token) 'identifier)
+       (string=? (cdr token) c)))
+
+(define (putback-token)
+  (set! putback-list (append (list current-token)
+			     putback-list)))
+
+(define (read-token)
+  (cond
+   ((not (null? putback-list))
+    (set! current-token (car putback-list))
+    (set! putback-list (cdr putback-list)))
+   (else
+    (set! current-token (do ((token (next-token-from-port input-port)
+				    (next-token-from-port input-port)))
+			    (token token)))))
+  current-token)
+
+(define (require-semicolon . read)
+  (if (null? read)
+      (read-token))
+  (if (or (eof-object? current-token)
+	  (not (delimiter current-token #\;)))
+      (syntax-error "Missing ;")
+      current-token))
+
+(define (require-tag . read)
+  (if (null? read)
+      (read-token))
+  (cond
+   ((eof-object? current-token)
+    (syntax-error "Expected tag but found " current-token))
+   ((not (eq? (car current-token) 'tag))
+    (syntax-error "Expected tag but found " (car current-token))))
+  current-token)
+
+(define (require-string . read)
+  (if (null? read)
+      (read-token))
+  (cond
+   ((eof-object? current-token)
+    (syntax-error "Expected string but found " current-token))
+   ((not (eq? (car current-token) 'string))
+    (syntax-error "Expected string but found " (car current-token))))
+  current-token)
+
+(define (require-number . read)
+  (if (null? read)
+      (read-token))
+  (cond
+   ((eof-object? current-token)
+    (syntax-error "Expected number but found " current-token))
+   ((not (eq? (car current-token) 'number))
+    (syntax-error "Expected number but found " (car current-token))))
+  current-token)
+
+(define (require-string-list . read)
+  (if (null? read)
+      (read-token))
+  (cond
+   ((eof-object? current-token)
+    (syntax-error "Expected string-list but found " current-token))
+   ((eq? (car current-token) 'string)
+    (list 'string-list (cdr current-token)))
+   ((not (eq? (car current-token) 'delimiter))
+    (syntax-error "Expected string-list but found " (car current-token)))
+   ((char=? (cdr current-token) #\[)
+    (do ((slist '())
+	 (token (read-token) (read-token)))
+	((if (not (eq? (car token) 'string))
+	     (begin
+	       (syntax-error "Expected string but found " (car token))
+	       #t)
+	     (begin
+	       (set! slist (append slist (list (cdr token))))
+	       (read-token)
+	       (cond
+		((eof-object? current-token)
+		 (syntax-error "Unexpected end of file in string list")
+		 #t) ;; break;
+		((eq? (car current-token) 'delimiter)
+		 (cond
+		  ((char=? (cdr current-token) #\,) #f) ;; continue
+		  ((char=? (cdr current-token) #\]) #t) ;; break
+		  (else
+		   (lex-error "Expected ',' or ']' but found "
+			      (cdr current-token))
+		   #t)))
+		(else
+		 (lex-error "Expected delimiter but found "
+			    (car current-token))
+		 #t))))
+	 (cons 'string-list slist))))
+   (else
+    (syntax-error "Expected '[' but found " (car current-token)))))
+  
+(define (require-identifier . read)
+  (if (null? read)
+      (read-token))
+  (cond
+   ((eof-object? current-token)
+    (syntax-error "1. Expected identifier but found " current-token))
+   ((not (eq? (car current-token) 'identifier))
+    (syntax-error "2. Expected identifier but found " (car current-token))))
+  current-token)
+
+;;;;
+
+(define (sieve-syntax-table-lookup table name)
+    (call-with-current-continuation
+        (lambda (exit)
+	  (for-each (lambda (x)
+		      (if (string=? (car x) name)
+			  (exit (cdr x))))
+		    table)
+	  #f)))
+
+;;;; Comparators
+
+;;; Each entry is (list COMP-NAME COMP-FUNCTION)
+(define sieve-comparator-table '())
+
+(define (sieve-find-comparator name)
+  (sieve-syntax-table-lookup sieve-comparator-table name))
+
+(define (sieve-register-comparator name function)
+  (if (not (or (eq? function #f)
+	       (eq? function #t)
+	       (procedure? function)))
+      (lex-error "sieve-register-comparator: bad type for function"
+	          function))
+  (set! sieve-comparator-table
+	(append sieve-comparator-table (list
+					(cons name function)))))
+      
+
+;;;; Command parsers
+
+;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)
+;;; OPT-ARG-LIST is a list of optional arguments (aka keywords, tags).
+;;; It consists of conses: (cons TAG-NAME FLAG) where FLAG is #t
+;;; if the tag requires an argument (e.g. :comparator <comp-name>),
+;;; and is #f otherwise.
+;;; REQ-ARG-LIST is a list of required (positional) arguments. It
+;;; is a list of argument types.
+(define sieve-test-table '())
+
+(define (sieve-find-test name)
+  (sieve-syntax-table-lookup sieve-test-table name))
+
+(define (sieve-register-test name function opt-arg-list req-arg-list)
+  (cond
+   ((not (list? opt-arg-list))
+    (lex-error "sieve-register-test: opt-arg-list must be a list"))
+   ((not (list? req-arg-list))
+    (lex-error "sieve-register-test: req-arg-list must be a list"))
+   ((not (or (eq? function #f)
+	     (eq? function #t)
+	     (procedure? function)))
+    (lex-error "sieve-register-test: bad type for function" function))
+   (else
+    (set! sieve-test-table
+	  (append sieve-test-table
+		  (list
+		   (list name function opt-arg-list req-arg-list)))))))
+   
+
+;;; arguments = *argument [test / test-list]
+;;; argument = string-list / number / tag
+
+(define (sieve-parse-arguments tag-gram)
+  (do ((opt-list '())   ;; List of optional arguments (tags)
+       (arg-list '())   ;; List of positional arguments
+       (last-tag #f)    ;; Description of the last tag from tag-gram
+       (state 'opt)     ;; 'opt when scanning optional arguments,
+                        ;; 'arg when scanning positional arguments
+       (token (read-token) (read-token))) ;; Obtain next token
+      ((cond
+	((eof-object? token)
+	 (syntax-error "Expected argument but found " token))
+	((eq? (car token) 'tag)
+	 (if (not (eq? state 'opt))
+	     (syntax-error "Misplaced tag: :" (cdr token)))
+	 (set! last-tag (assoc (cdr token) tag-gram))
+	 (if (not last-tag)
+	     (syntax-error
+	      "Tag :" (cdr token) " is not allowed in this context"))
+	 (set! opt-list (append opt-list (list token)))
+	 #f)
+	((or (eq? (car token) 'number)
+	     (eq? (car token) 'string))
+	 (cond
+	  ((and (eq? state 'opt) (pair? last-tag))
+	   (cond
+	    ((cdr last-tag)
+	     (if (not (eq? (cdr last-tag) (car token)))
+		 (syntax-error
+		  "Tag :" (car last-tag) " takes " (cdr last-tag) " argument"))
+	     (cond
+	      ((string=? (car last-tag) "comparator")
+	       (let ((comp (sieve-find-comparator (cdr token))))
+		 (if (not comp)
+		     (syntax-error "Undefined comparator: " (cdr token)))
+		 (set-cdr! token comp))))
+	     (set! opt-list (append opt-list (list token)))
+	     (set! last-tag #f))
+	    (else
+	     (set! state 'arg)
+	     (set! arg-list (append arg-list (list token))))))
+	  (else
+	   (set! arg-list (append arg-list (list token)))))
+	 #f)
+	((delimiter token #\[) ;;FIXME: tags are not allowed to take
+	                       ;;string-list arguments. 
+	 (set! state 'arg)
+	 (putback-token)
+	 (set! arg-list (append arg-list
+				(list (require-string-list))))
+	 #f)
+	(else
+	 #t)) 
+       (cons opt-list arg-list))))
+
+;;; test-list = "(" test *("," test) ")"
+(define (sieve-parse-test-list)
+  (do ((token (sieve-parse-test) (sieve-parse-test)))
+      ((cond
+	((delimiter token #\))
+	 #t) ;; break;
+	((delimiter token #\,)
+	 #f) ;; continue
+	((eof-object? token)
+	 (syntax-error "Unexpected end of file in test-list")
+	 #t) ;; break
+	(else
+	 (syntax-error "Expected ',' or ')' but found " (cdr token))
+	 #t)) ;; break
+       (read-token))))
+	
+;;; test = identifier arguments
+(define (sieve-parse-test)
+  (let ((ident (require-identifier)))
+    (sieve-exp-begin)
+    (cond
+     ((string=? (cdr ident) "not")
+      (sieve-exp-append 'not)
+      (sieve-parse-test))
+     (else
+      (read-token)
+      (cond
+       ((eof-object? current-token)
+	(syntax-error "Unexpected end of file in conditional"))
+       ((delimiter current-token #\()
+	(cond
+	 ((string=? (cdr ident) "allof")
+	  (sieve-exp-append 'and))
+	 ((string=? (cdr ident) "anyof")
+	  (sieve-exp-append 'or))
+	 (else
+	  (syntax-error "Unexpected '('")))
+	(sieve-parse-test-list))
+       ((delimiter current-token #\)))
+       (else
+	(let ((test (sieve-find-test (cdr ident))))
+	  (if (not test)
+	      (syntax-error "Unknown test name: " (cdr ident)))
+	  (putback-token)
+	  (let ((arg-list (sieve-parse-arguments (car (cdr test)))))
+	    (sieve-exp-append (car test))
+	    ;; Process positional arguments
+	    (do ((expect (car (cdr (cdr test))) (cdr expect))
+		 (argl (cdr arg-list) (cdr argl))
+		 (n 1 (1+ n)))
+		((cond
+		  ((null? expect)
+		   (if (not (null? argl))
+		       (syntax-error
+			"Too many positional arguments for " ident
+			" (bailed out at " (car argl) ")"))
+		   #t)
+		  ((null? argl)
+		   (if (not (null? expect))
+		       (syntax-error
+			"Too few positional arguments for " ident))
+		   #t)
+		  (else #f)) #f)
+		(let ((expect-type (car expect))
+		      (arg (car argl)))
+		  (cond
+		   ((and (eq? expect-type 'string-list)
+			 (eq? (car arg) 'string))
+		    ;; Coerce string to string-list
+		    (sieve-exp-append (list 'list (cdr arg))))
+		   ((eq? expect-type (car arg))
+		    (if (eq? expect-type 'string-list)
+			(sieve-exp-append (append (list 'list) (cdr arg)))
+			(sieve-exp-append (cdr arg))))
+		   (else
+		    (syntax-error
+		     "Type mismatch in argument " n " to " (cdr ident)
+		     "; expected " expect-type ", but got " (car arg))))))
+	    ;; Process optional arguments (tags).
+	    ;; They have already been tested 
+	    (for-each
+	     (lambda (tag)
+	       (sieve-exp-append (if (eq? (car tag) 'tag)
+				     (string->symbol
+				      (string-append "#:" (cdr tag)))
+				   (cdr tag))))
+	     (car arg-list))
+	    ))))))
+    (sieve-exp-finish))
+  current-token)
+
+(define (sieve-parse-block . read)
+  (if (not (null? read))
+      (read-token))
+  (if (delimiter current-token #\{)
+      (begin
+	(set! nesting-level (1+ nesting-level))
+	(do ((token (read-token) (read-token)))
+	    ((cond
+	      ((eof-object? token)
+	       (syntax-error "Unexpected end of file in block")
+	       #t)
+	      ((delimiter token #\})
+	       #t)
+	      (else
+	       (putback-token)
+	       (sieve-parse-command)
+	       #f))) #f)
+	(set! nesting-level (1- nesting-level)))
+      (require-semicolon 'dont-read)))
+
+;;; if <test1: test> <block1: block>
+(define (sieve-parse-if-internal)
+  (DEBUG 10 "sieve-parse-if-internal" current-token)
+  (sieve-exp-begin)
+  
+  (sieve-parse-test)
+  
+  (sieve-parse-block)
+  (sieve-exp-finish)
+  
+  (read-token)
+  (cond
+   ((eof-object? current-token) )
+   ((identifier current-token "elsif")
+    (sieve-parse-if-internal))
+   ((identifier current-token "else")
+    (sieve-exp-begin 'else)
+    (sieve-parse-block 'read)
+    (sieve-exp-finish))
+   (else
+    (putback-token))))
+
+(define (sieve-parse-if)
+  (sieve-exp-begin 'cond)
+  (sieve-parse-if-internal)
+  (sieve-exp-finish))
+
+(define (sieve-parse-else)
+  (syntax-error "else without if"))
+
+(define (sieve-parse-elsif)
+  (syntax-error "elsif without if"))
+
+;;; require <capabilities: string-list>
+(define (sieve-parse-require)
+  (for-each
+   (lambda (capability)
+     (if (not
+	  (cond
+	   ((and
+	     (>= (string-length capability) 5)
+	     (string=? (make-shared-substring capability 0 5) "test-"))
+	    (sieve-find-test (make-shared-substring capability 5)))
+	   ((and
+	     (>= (string-length capability) 11)
+	     (string=? (make-shared-substring capability 0 11) "comparator-"))
+	    (sieve-find-comparator (make-shared-substring capability 11)))
+	   (else
+	    (sieve-find-action capability))))
+	 (let ((name (string-append sieve-libdir
+				    "/" capability ".scm")))
+	   (set! sieve-load-files (append sieve-load-files (list name)))
+	   (catch #t
+		  (lambda ()
+		    (load name))
+		  (lambda args
+		    (lex-error "Can't load required capability "
+			       capability)
+		    args)))))
+   (cdr (require-string-list)))
+  (require-semicolon))
+
+;;; stop
+(define (sieve-parse-stop)
+  (sieve-exp-begin sieve-stop)
+  (sieve-exp-finish)
+  (require-semicolon))
+
+;;; Actions
+
+;;; Each entry is: (list ACTION-NAME FUNCTION ARG-LIST)
+;;; ARG-LIST is a list of argument types
+(define sieve-action-table '())
+
+(define (sieve-find-action name)
+  (sieve-syntax-table-lookup sieve-action-table name))
+
+(define (sieve-register-action name proc . arg-list)
+  (if (not (sieve-find-action name))
+      (set! sieve-action-table (append sieve-action-table
+				       (list
+					(append
+					 (list name proc) arg-list))))))
+
+(define (sieve-parse-action)
+  (let* ((name (cdr current-token))
+	 (descr (sieve-find-action name)))
+    (cond
+     (descr
+      (if (car descr)
+	  (sieve-exp-begin (car descr)))
+      (do ((arg (cdr descr) (cdr arg)))
+	  ((null? arg) #f)
+	(read-token)
+	(case (car arg)
+	  ((string)
+	   (require-string 'dont-read))
+	  ((string-list)
+	   (require-string-list 'dont-read))
+	  ((number)
+	   (require-number 'dont-read))
+	  ((tag)
+	   (require-tag 'dont-read))
+	  (else
+	   (syntax-error "Malformed table entry for " name " :" (car arg))))
+	(if (car descr)
+	    (sieve-exp-append (cdr current-token))))
+      (require-semicolon)
+      (if (car descr)
+	  (sieve-exp-finish)))
+     (else
+      (syntax-error "Unknown identifier: " name)))))
+
+;;;; Parser
+
+(define (sieve-parse-command)
+  (DEBUG 10 "sieve-parse-command" current-token)
+  (catch 'syntax-error
+   (lambda ()
+     (read-token)
+     (cond
+      ((or (not current-token)
+	   (eof-object? current-token))) ;; Skip comments and #<eof>
+      ((eq? (car current-token) 'identifier)
+       ;; Process a command
+       (let ((elt (assoc (string->symbol (cdr current-token))
+			 (list
+			  (cons 'if sieve-parse-if)
+			  (cons 'elsif sieve-parse-elsif)
+			  (cons 'else sieve-parse-else)
+		          (cons 'require sieve-parse-require)
+		          (cons 'stop sieve-parse-stop)))))
+	 (if (not elt)
+	     (sieve-parse-action)
+	     (apply (cdr elt) '()))))
+      (else
+       (syntax-error "3. Expected identifier but found "
+		     (cdr current-token)))))
+   (lambda args
+     ;; Error recovery: skip until we find a ';' or '}'.
+     (if (and (= input-line-number recovery-line-number)
+	      (= input-index recovery-index))
+	 (begin
+	   (lex-error "ERROR RECOVERY: Skipping to end of file")
+	   (throw 'end-of-file)))
+     (set! recovery-line-number input-line-number)
+     (set! recovery-index input-index)
+
+     (if (or (delimiter current-token #\})
+	     (delimiter current-token #\;))
+	 (read-token))
+     (DEBUG 50 "ERROR RECOVERY at " current-token)
+     (do ((token current-token (read-token)))
+	 ((cond
+	   ((eof-object? token)
+	    (throw 'end-of-file))
+	   ((delimiter token #\;)
+	    #t)
+	   ((delimiter token #\})
+	    (cond
+	     ((> nesting-level 0)
+	      (putback-token)
+	      #t)
+	     (else
+	      #f)))
+	   ((delimiter token #\{)
+	    (sieve-skip-block)
+	    (putback-token)
+	    #f)
+	   (else
+	    #f)) #f))
+     (DEBUG 50 "ERROR RECOVERY FINISHED AT " current-token)))
+  current-token)
+
+(define (sieve-skip-block)
+  (do ((token (read-token) (read-token)))
+      ((cond
+	((eof-object? token)
+	 (throw 'end-of-file))
+	((delimiter token #\{)
+	 (sieve-skip-block)
+	 #f)
+	((delimiter token #\})
+	 #t)
+	(else
+	 #f)) #f)))
+
+(define (sieve-parse-from-port port)
+  (set! input-port port)
+  (do ((token (sieve-parse-command) (sieve-parse-command)))
+      ((eof-object? token) #f)) )
+
+(define (sieve-parse filename)
+  (if (file-exists? filename)
+      (catch 'end-of-file 
+        (lambda ()
+	  (set! error-count 0)
+	  (set! current-token #f)
+	  (set! input-file filename)
+	  (set! input-line-number 0)
+	  (set! putback-list '())
+	  (call-with-input-file filename sieve-parse-from-port))
+	(lambda args args))))
+
+;;;; Code generator
+
+(define sieve-exp '())  ;; Expression currently being built
+(define sieve-exp-stack '())
+(define sieve-code-list '())  ;; Resulting scheme code
+
+(define (sieve-exp-begin . exp)
+  (set! sieve-exp-stack (append (list sieve-exp) sieve-exp-stack))
+  (set! sieve-exp exp))
+
+(define (sieve-exp-append exp)
+  (set! sieve-exp (append sieve-exp (list exp))))
+
+(define (sieve-exp-finish)
+  (set! sieve-exp (append (car sieve-exp-stack) (list sieve-exp)))
+  (set! sieve-exp-stack (cdr sieve-exp-stack)))
+
+(define (sieve-code-begin)
+  (set! sieve-exp-stack '())
+  (set! sieve-exp '()))
+
+(define (sieve-code-finish)
+  (if (not (null? sieve-exp))
+      (set! sieve-code-list (append sieve-code-list sieve-exp (list #t)))))
+
+;;; Print the program
+
+(define (sieve-code-print-list exp . opt-port)
+  (let ((port (if (null? opt-port)
+		  (current-output-port)
+		(car opt-port))))
+    (display "(" port)
+    (for-each
+     (lambda (x)
+       (cond
+	((procedure? x)
+	 (display (procedure-name x) port))
+	((list? x)
+	 (sieve-code-print-list x port))
+	(else
+	 (write x port)))
+       (display " " port))
+     exp)
+    (display ")" port)))
+
+;;; Save the program
+
+(define (sieve-save-program outfile)
+  (call-with-output-file
+   outfile
+   (lambda (port)
+     (display "#! /home/gray/mailutils/guimb/guimb --source\n!#\n" port)
+     (display (string-append
+	       ";;;; A Guile mailbox parser made from " filename) port)
+     (newline port) 
+     (display ";;;; by sieve.scm, GNU mailutils (0.0.9)" port)
+     (newline port)
+     
+     (display "(define sieve-parser #f)" port)
+     (newline port)
+     (display (string-append
+	       "(define sieve-source \"" filename "\")") port)
+     (newline port)
+     
+     (display (string-append
+	       "(load \"" sieve-libdir "/sieve-core.scm\")") port)
+     (newline port)
+     (for-each
+      (lambda (file)
+	(display (string-append
+		  "(load \"" file "\")") port)
+	(newline port))
+      sieve-load-files)
+     (sieve-code-print-list sieve-code-list port)
+     (newline port)
+     (display "(sieve-main)" port))))
+     
+;;;; Main
+
+(define filename #f)
+(define output #f)
+
+(define (sieve-usage)
+  (display "usage: sieve.scm [OPTIONS]\n")
+  (display "GNU sieve.scm -- compile a Sieve program into Scheme code\n")
+  (display "Options are:\n")
+  (display "   -f, --file FILENAME      Set input file name\n")
+  (display "   -o, --output FILENAME    Set output file name\n")
+  (display "   -L, --lib-dir DIRNAME    Set sieve library directory name\n")
+  (display "   -d, --debug LEVEL        Set debugging level\n")
+  (exit 0))
+
+(define (sieve-expand-filename name)
+  (let ((index (string-index name #\%)))
+    (if (or (not index) (= index (string-length name)))
+	name
+      (let ((ch (string-ref name (1+ index))))
+	(string-append
+	 (make-shared-substring name 0 index)
+	 (case ch
+	   ((#\%)
+	    "%")
+	   ((#\u)
+	    user-name)
+	   ((#\h)
+	    (passwd:dir (getpwnam user-name)))
+	   (else
+	    (make-shared-substring name index 2)))
+	 (sieve-expand-filename
+	  (make-shared-substring name (+ index 2))))))))
+
+;;; Parse command line 
+
+(use-modules (ice-9 getopt-long))
+(define grammar
+  `((file   (single-char #\f)
+            (value #t))
+    (output (single-char #\o)
+	    (value #t))
+    (debug  (single-char #\d)
+	    (value #t))
+    (lib-dir (single-char #\L)
+	     (value #t))
+    (help   (single-char #\h))))
+
+(define program-name (car (command-line)))
+
+(for-each
+ (lambda (x)
+   (cond
+    ((pair? x)
+     (case (car x)
+       ((debug)
+	(set! sieve-debug (string->number (cdr x))))
+       ((file)
+	(set! filename (cdr x)))
+       ((lib-dir)
+	(set! sieve-libdir (cdr x)))
+       ((output)
+	(set! output (cdr x)))
+       ((help)
+	(sieve-usage))))))
+ (getopt-long (command-line) grammar))
+
+(if (not filename)
+    (begin
+     (display program-name)
+     (display ": missing input filename")
+     (newline)
+     (sieve-usage)))
+
+(define guimb? (string->obarray-symbol #f "mu-mailbox-open" #t))
+
+(if (and guimb? (string? user-name))
+    (set! filename (sieve-expand-filename filename)))
+
+(if (not (file-exists? filename))
+    (begin
+      (display (string-append
+		program-name
+		": Input file " filename " does not exist."))
+      (newline)
+      (exit 0)))
+	
+(if (not sieve-libdir)
+    (set! sieve-libdir
+	    (let ((myname (car (command-line))))
+	      (if (not (char=? (string-ref myname 0) #\/))
+		  (set! myname (string-append (getcwd) "/" myname)))
+	      (let ((slash (string-rindex myname #\/)))
+		(substring myname 0 slash)))))
+
+(load (string-append sieve-libdir "/sieve-core.scm"))
+
+(sieve-exp-append 'define)
+(sieve-exp-append (list 'sieve-process-message))
+(sieve-parse filename)
+(sieve-code-finish)
+
+(cond
+ ((> error-count 0)
+  (display error-count)
+  (display " errors.")
+  (newline)
+  (exit 1))
+ (output
+  (sieve-save-program output))
+ ((not guimb?)
+  (display program-name)
+  (display ": Either use guimb to compile and execute the script")
+  (newline)
+  (display "or use --output option to save the Scheme program.")
+  (newline)
+  (exit 1))
+ (else
+  (let ((temp-file (tmpnam))
+	(saved-umask (umask #o077)))
+    (sieve-save-program temp-file)
+    (load temp-file)
+    (delete-file temp-file)	
+    (umask saved-umask))))
+
+
+
+
+
-- 
cgit v1.2.1