From ea0789609523b0f6ae0831a76f9a8abedd9f13b8 Mon Sep 17 00:00:00 2001
From: Sergey Poznyakoff <gray@gnu.org.ua>
Date: Sun, 1 Sep 2002 21:58:00 +0000
Subject: Generated from sieve.scm.in

---
 guimb/scm/sieve.scm | 1003 ---------------------------------------------------
 1 file changed, 1003 deletions(-)
 delete mode 100644 guimb/scm/sieve.scm

diff --git a/guimb/scm/sieve.scm b/guimb/scm/sieve.scm
deleted file mode 100644
index 64ead17dc..000000000
--- a/guimb/scm/sieve.scm
+++ /dev/null
@@ -1,1003 +0,0 @@
-;;;; 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 #f)
-(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 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
-		    (if (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))
-    (begin
-     (set! filename (sieve-expand-filename filename))
-     (if (not (file-exists? filename))
-	 (exit 0)))
-  (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