summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guimb/scm/sieve.scm.in1006
1 files changed, 1006 insertions, 0 deletions
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))))
+
+
+
+
+

Return to:

Send suggestions and report system problems to the System administrator.