summaryrefslogtreecommitdiff
path: root/guimb
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2002-09-01 21:58:00 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2002-09-01 21:58:00 +0000
commitea0789609523b0f6ae0831a76f9a8abedd9f13b8 (patch)
tree066e4f159ddfbf2b7c60372c5bae09c5ed5c2aae /guimb
parent6f4ac93e89b67648ba20ff3d6cdc6b2e98f40d0a (diff)
downloadmailutils-ea0789609523b0f6ae0831a76f9a8abedd9f13b8.tar.gz
mailutils-ea0789609523b0f6ae0831a76f9a8abedd9f13b8.tar.bz2
Generated from sieve.scm.in
Diffstat (limited to 'guimb')
-rw-r--r--guimb/scm/sieve.scm1003
1 files changed, 0 insertions, 1003 deletions
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))))
-
-
-
-
-

Return to:

Send suggestions and report system problems to the System administrator.