Cleaned up the source.

-#! %BINDIR%/guimb --source
+#! %GUILE_BINDIR%/guile -s
 # Emacs, its -*- scheme -*-
 # Emacs, its -*- scheme -*-
 !#
 !#
 ;;;; GNU mailutils - a suite of utilities for electronic mail
 ;;;; GNU mailutils - a suite of utilities for electronic mail
@@ -21,19 +21,21 @@
 
 
 ;;;; This is a Sieve to Scheme translator.
 ;;;; This is a Sieve to Scheme translator.
 ;;;;
 ;;;;
-;;;; To convert a sieve script into equivalent Scheme program, executable
-;;;; by guimb, run:
+;;;; To convert a sieve script into equivalent Scheme program, run:
 ;;;;
 ;;;;
 ;;;;  guile -s sieve.scm --file <sieve-script-name> --output <output-file-name>
 ;;;;  guile -s sieve.scm --file <sieve-script-name> --output <output-file-name>
 ;;;;
 ;;;;
 ;;;; To compile and execute a sieve script upon a mailbox, run:
 ;;;; To compile and execute a sieve script upon a mailbox, run:
 ;;;;
 ;;;;
-;;;;  guimb -f sieve.scm -{ --file <sieve-script-name> -} --mailbox ~/mbox
+;;;;  guile -s sieve.scm --file <sieve-script-name> [mailbox-name]
+;;;; or
+;;;;  guimb [--mailbox mailbox-name] -s sieve.scm --file <sieve-script-name> 
 
 
 (define sieve-debug 0)
 (define sieve-debug 0)
 (define sieve-parser #t)
 (define sieve-parser #t)
 (define sieve-libdir "%LIBDIR%")
 (define sieve-libdir "%LIBDIR%")
 (define sieve-load-files '())
 (define sieve-load-files '())
+(define sieve-script-args '())
 
 
 (define error-count 0)
 (define error-count 0)
 (define current-token #f)
 (define current-token #f)
@@ -374,65 +376,81 @@
 
 
 ;;;;
 ;;;;
 
 
+;;; Syntax tables.
+;;; A syntax table is a list of 
+;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)
+;;; NAME is a string representing the input language keyword,
+;;; FUNCTION is a corresponding function:
+;;;       (define (foo [arg [arg...]] . opt-args)
+;;; OPT-ARG-LIST is a list of optional arguments (tags),
+;;; REQ-ARG-LIST is a list of required (positional) arguments
+
 (define (sieve-syntax-table-lookup table name)
 (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)
+  (let ((entry (assoc name table)))
+    (if entry
+	(cdr entry)
 	#f)))
 	#f)))
 
 
+(define-macro (sieve-syntax-table-add table name function req-arg-list opt-arg-list)
+  `(cond
+    ((not (list? ,opt-arg-list))
+     (lex-error "sieve-syntax-table-add: opt-arg-list must be a list"))
+    ((not (list? ,req-arg-list))
+     (lex-error "sieve-syntax-table-add: req-arg-list must be a list"))
+    ((not (or (eq? ,function #f)
+	      (eq? ,function #t)
+	      (procedure? ,function)))
+     (lex-error "sieve-syntax-table-add: bad type for function" ,function))
+    (else
+     (set! ,table
+	   (append ,table
+		   (list
+		    (list ,name ,function ,opt-arg-list ,req-arg-list)))))))
+   
+;;;;
+
+;;;; Available syntax tables.
+
 ;;;; Comparators
 ;;;; Comparators
 
 
-;;; Each entry is (list COMP-NAME COMP-FUNCTION)
+;;; Syntax table for comparators. The opt-arg-list and req-arg-list have
+;;; no meaning for comparators, so they are ignored. The handler function
+;;; names must start with "comparator-"
 (define sieve-comparator-table '())
 (define sieve-comparator-table '())
 
 
 (define (sieve-find-comparator name)
 (define (sieve-find-comparator name)
   (sieve-syntax-table-lookup sieve-comparator-table name))
   (sieve-syntax-table-lookup sieve-comparator-table name))
 
 
 (define (sieve-register-comparator name function)
 (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)))))
+  (sieve-syntax-table-add sieve-comparator-table name function '() '()))
 
 
+;;;; Sieve Tests
 
 
-;;;; 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.
+;;; Syntax table for tests. Function names must start with "test-"
 (define sieve-test-table '())
 (define sieve-test-table '())
 
 
 (define (sieve-find-test name)
 (define (sieve-find-test name)
   (sieve-syntax-table-lookup sieve-test-table name))
   (sieve-syntax-table-lookup sieve-test-table name))
 
 
 (define (sieve-register-test name function req-arg-list opt-arg-list)
 (define (sieve-register-test name function req-arg-list opt-arg-list)
-  (DEBUG 100 "sieve-register-test" name req-arg-list opt-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)))))))
+  (sieve-syntax-table-add sieve-test-table name function
+			  req-arg-list opt-arg-list))
 
 
+;;;; Sieve Actions
+
+;;; Syntax table for actions. Function names start with "action-"
+(define sieve-action-table '())
+
+(define (sieve-find-action name)
+  (sieve-syntax-table-lookup sieve-action-table name))
+
+(define (sieve-register-action name function req-arg-list opt-arg-list)
+  (sieve-syntax-table-add sieve-action-table name function
+			  req-arg-list opt-arg-list))
+
+;;;;
+
+;;;; Command parsers
 
 
 ;;; sieve-preprocess-arguments: Preprocess and group the arguments. Returns
 ;;; sieve-preprocess-arguments: Preprocess and group the arguments. Returns
 ;;; a cons whose car is a list of all optional arguments, and the cdr is
 ;;; a cons whose car is a list of all optional arguments, and the cdr is
@@ -555,6 +573,10 @@
 			   (cdr tag)))))
 			   (cdr tag)))))
      (car arg-list))))
      (car arg-list))))
 
 
+;;;;
+
+;;;; Parser functions for tests
+
 ;;; test-list = "(" test *("," test) ")"
 ;;; test-list = "(" test *("," test) ")"
 (define (sieve-parse-test-list)
 (define (sieve-parse-test-list)
   (do ((token (sieve-parse-test) (sieve-parse-test)))
   (do ((token (sieve-parse-test) (sieve-parse-test)))
@@ -692,35 +714,9 @@
   (sieve-exp-finish)
   (sieve-exp-finish)
   (require-semicolon))
   (require-semicolon))
 
 
-;;; Actions
-
-;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)
-;;; NAME is a string representing the action name,
-;;; FUNCTION is a corresponding function:
-;;;       (define (action-foo [arg [arg...]] . opt-args)
-;;; notice, that its name must begin with "action-"
-;;; OPT-ARG-LIST is a list of optional arguments (tags),
-;;; REQ-ARG-LIST is a list of required (positional) arguments
-(define sieve-action-table '())
-
-(define (sieve-find-action name)
-  (sieve-syntax-table-lookup sieve-action-table name))
+;;;;
 
 
-(define (sieve-register-action name function req-arg-list opt-arg-list)
-  (cond
-   ((not (list? opt-arg-list))
-    (lex-error "sieve-register-action: opt-arg-list must be a list"))
-   ((not (list? req-arg-list))
-    (lex-error "sieve-register-action: req-arg-list must be a list"))
-   ((not (or (eq? function #f)
-	     (eq? function #t)
-	     (procedure? function)))
-    (lex-error "sieve-register-action: bad type for function" function))
-   (else
-    (set! sieve-action-table
-	  (append sieve-action-table
-		  (list
-		   (list name function opt-arg-list req-arg-list)))))))
+;;;; Parser functions for actions
 
 
 (define (sieve-parse-action)
 (define (sieve-parse-action)
   (let* ((name (cdr current-token))
   (let* ((name (cdr current-token))
@@ -738,7 +734,9 @@
      (else
      (else
       (syntax-error "Unknown identifier: " name)))))
       (syntax-error "Unknown identifier: " name)))))
 
 
-;;;; Parser
+;;;;
+
+;;;; The parser
 
 
 (define (sieve-parse-command)
 (define (sieve-parse-command)
   (DEBUG 10 "sieve-parse-command" current-token)
   (DEBUG 10 "sieve-parse-command" current-token)
@@ -829,6 +827,8 @@
 	  (call-with-input-file filename sieve-parse-from-port))
 	  (call-with-input-file filename sieve-parse-from-port))
 	(lambda args args))))
 	(lambda args args))))
 
 
+;;;;
+
 ;;;; Code generator
 ;;;; Code generator
 
 
 (define sieve-exp '())  ;; Expression currently being built
 (define sieve-exp '())  ;; Expression currently being built
@@ -876,15 +876,18 @@
 
 
 ;;; Save the program
 ;;; Save the program
 
 
-(define (sieve-save-program outfile)
+(define (sieve-save-program outfile guimb-header)
   (call-with-output-file
   (call-with-output-file
    outfile
    outfile
    (lambda (port)
    (lambda (port)
-     (display "#! /home/gray/mailutils/guimb/guimb --source\n!#\n" port)
+     (display "#! " port)
+     (if guimb-header
+	 (display "%BINDIR%/guimb -s\n" port)
+	 (display "%GUILE_BINDIR%/guile -s\n" port))
      (display (string-append
      (display (string-append
-	       ";;;; A Guile mailbox parser made from " filename) port)
+	       "# Guile mailbox parser made from " filename) port)
      (newline port) 
      (newline port) 
-     (display ";;;; by sieve.scm, GNU %PACKAGE% %VERSION%" port)
+     (display "# by sieve.scm, GNU %PACKAGE% %VERSION%\n!#" port)
      (newline port)
      (newline port)
      
      
      (display "(define sieve-parser #f)" port)
      (display "(define sieve-parser #f)" port)
@@ -894,6 +897,10 @@
      (newline port)
      (newline port)
 
 
      (display (string-append
      (display (string-append
+	       "(define sieve-libdir \"" sieve-libdir "\")") port)
+     (newline port)
+     
+     (display (string-append
 	       "(load \"" sieve-libdir "/sieve-core.scm\")") port)
 	       "(load \"" sieve-libdir "/sieve-core.scm\")") port)
      (newline port)
      (newline port)
      (for-each
      (for-each
@@ -906,40 +913,28 @@
      (newline port)
      (newline port)
      (display "(sieve-main)" port))))
      (display "(sieve-main)" port))))
 
 
+;;;;
+
 ;;;; Main
 ;;;; Main
 
 
 (define filename #f)
 (define filename #f)
 (define output #f)
 (define output #f)
+(define guimb-header #f)
 
 
 (define (sieve-usage)
 (define (sieve-usage)
-  (display "usage: sieve.scm [OPTIONS]\n")
+  (display "usage: sieve.scm [OPTIONS][mailbox]\n")
   (display "GNU sieve.scm -- compile a Sieve program into Scheme code\n")
   (display "GNU sieve.scm -- compile a Sieve program into Scheme code\n")
   (display "Options are:\n")
   (display "Options are:\n")
   (display "   -f, --file FILENAME      Set input file name\n")
   (display "   -f, --file FILENAME      Set input file name\n")
   (display "   -o, --output FILENAME    Set output file name\n")
   (display "   -o, --output FILENAME    Set output file name\n")
   (display "   -L, --lib-dir DIRNAME    Set sieve library directory name\n")
   (display "   -L, --lib-dir DIRNAME    Set sieve library directory name\n")
-  (display "   -d, --debug LEVEL        Set debugging level\n")
+  (display "   -g, --guimb              Make output file executable for guimb\n")
+  (display "   -d, --debug LEVEL        Set debugging level\n\n")
+  (display "If -o option is not given, the compiled program is executed\n")
+  (display "immediately. It operates on the user system mailbox unless\n")
+  (display "mailbox is given in the command line.\n")
   (exit 0))
   (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 
 ;;; Parse command line 
 
 
 (use-modules (ice-9 getopt-long))
 (use-modules (ice-9 getopt-long))
@@ -952,6 +947,7 @@
 	    (value #t))
 	    (value #t))
     (lib-dir (single-char #\L)
     (lib-dir (single-char #\L)
 	     (value #t))
 	     (value #t))
+    (guimb  (single-char #\g))
     (help   (single-char #\h))))
     (help   (single-char #\h))))
 
 
 (define program-name (car (command-line)))
 (define program-name (car (command-line)))
@@ -969,28 +965,21 @@
 	(set! sieve-libdir (cdr x)))
 	(set! sieve-libdir (cdr x)))
        ((output)
        ((output)
 	(set! output (cdr x)))
 	(set! output (cdr x)))
+       ((guimb)
+	(set! guimb-header #t))
        ((help)
        ((help)
-	(sieve-usage))))))
+	(sieve-usage))
+       ('()
+	(set! sieve-script-args (cdr x)))))))
  (getopt-long (command-line) grammar))
  (getopt-long (command-line) grammar))
 
 
-(if (not filename)
-    (begin
+(cond
+ ((not filename)
   (display program-name)
   (display program-name)
   (display ": missing input filename")
   (display ": missing input filename")
   (newline)
   (newline)
-     (sieve-usage)))
-
-(define guimb? (catch #t
-                      (lambda ()
-                        (let ((package mu-package))
-                          package))
-                      (lambda args #f)))
-
-(if (and guimb? (string? user-name))
-    (set! filename (sieve-expand-filename filename)))
-
-(if (not (file-exists? filename))
-    (begin
+  (sieve-usage))
+ ((not (file-exists? filename))
   (display (string-append
   (display (string-append
 	    program-name
 	    program-name
 	    ": Input file " filename " does not exist."))
 	    ": Input file " filename " does not exist."))
@@ -1019,23 +1008,20 @@
   (newline)
   (newline)
   (exit 1))
   (exit 1))
  (output
  (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))
+  (sieve-save-program output guimb-header))
  (else
  (else
   (let ((temp-file (tmpnam))
   (let ((temp-file (tmpnam))
 	(saved-umask (umask #o077)))
 	(saved-umask (umask #o077)))
     (sieve-save-program temp-file)
     (sieve-save-program temp-file)
-    (load temp-file)
+    (catch #t
+	   (lambda ()
+	     (load temp-file))
+	   (lambda (key . args)
+	     (apply display-error the-last-stack (current-error-port) args)))
     (delete-file temp-file)	
     (delete-file temp-file)	
     (umask saved-umask))))
     (umask saved-umask))))
 
 
-
+;;;; End of sieve.scm