From 53b92684a5ab835cbcf68296ecd4b0a2b8649cd5 Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Mon, 14 Oct 2002 17:47:46 +0000 Subject: Cleaned up the source. --- guimb/scm/sieve.scm.in | 258 +++++++++++++++++++++++-------------------------- 1 file changed, 122 insertions(+), 136 deletions(-) (limited to 'guimb') diff --git a/guimb/scm/sieve.scm.in b/guimb/scm/sieve.scm.in index 9fc4be1af..226fc9ae5 100644 --- a/guimb/scm/sieve.scm.in +++ b/guimb/scm/sieve.scm.in @@ -1,4 +1,4 @@ -#! %BINDIR%/guimb --source +#! %GUILE_BINDIR%/guile -s # Emacs, its -*- scheme -*- !# ;;;; GNU mailutils - a suite of utilities for electronic mail @@ -21,19 +21,21 @@ ;;;; 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 --output ;;;; ;;;; To compile and execute a sieve script upon a mailbox, run: ;;;; -;;;; guimb -f sieve.scm -{ --file -} --mailbox ~/mbox +;;;; guile -s sieve.scm --file [mailbox-name] +;;;; or +;;;; guimb [--mailbox mailbox-name] -s sieve.scm --file (define sieve-debug 0) (define sieve-parser #t) (define sieve-libdir "%LIBDIR%") (define sieve-load-files '()) +(define sieve-script-args '()) (define error-count 0) (define current-token #f) @@ -373,66 +375,82 @@ current-token) ;;;; + +;;; 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) - (call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (string=? (car x) name) - (exit (cdr x)))) - table) - #f))) + (let ((entry (assoc name table))) + (if entry + (cdr entry) + #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 -;;; 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-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))))) - + (sieve-syntax-table-add sieve-comparator-table name function '() '())) -;;;; Command parsers +;;;; Sieve Tests -;;; 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 ), -;;; 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-find-test name) (sieve-syntax-table-lookup sieve-test-table name)) -(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))))))) - +(define (sieve-register-test name function req-arg-list opt-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 ;;; a cons whose car is a list of all optional arguments, and the cdr is @@ -555,6 +573,10 @@ (cdr tag))))) (car arg-list)))) +;;;; + +;;;; Parser functions for tests + ;;; test-list = "(" test *("," test) ")" (define (sieve-parse-test-list) (do ((token (sieve-parse-test) (sieve-parse-test))) @@ -692,35 +714,9 @@ (sieve-exp-finish) (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) (let* ((name (cdr current-token)) @@ -738,7 +734,9 @@ (else (syntax-error "Unknown identifier: " name))))) -;;;; Parser +;;;; + +;;;; The parser (define (sieve-parse-command) (DEBUG 10 "sieve-parse-command" current-token) @@ -829,6 +827,8 @@ (call-with-input-file filename sieve-parse-from-port)) (lambda args args)))) +;;;; + ;;;; Code generator (define sieve-exp '()) ;; Expression currently being built @@ -876,15 +876,18 @@ ;;; Save the program -(define (sieve-save-program outfile) +(define (sieve-save-program outfile guimb-header) (call-with-output-file outfile (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 - ";;;; A Guile mailbox parser made from " filename) port) + "# Guile mailbox parser made from " filename) port) (newline port) - (display ";;;; by sieve.scm, GNU %PACKAGE% %VERSION%" port) + (display "# by sieve.scm, GNU %PACKAGE% %VERSION%\n!#" port) (newline port) (display "(define sieve-parser #f)" port) @@ -892,6 +895,10 @@ (display (string-append "(define sieve-source \"" filename "\")") port) (newline port) + + (display (string-append + "(define sieve-libdir \"" sieve-libdir "\")") port) + (newline port) (display (string-append "(load \"" sieve-libdir "/sieve-core.scm\")") port) @@ -905,41 +912,29 @@ (sieve-code-print-list sieve-code-list port) (newline port) (display "(sieve-main)" port)))) - + +;;;; + ;;;; Main (define filename #f) (define output #f) +(define guimb-header #f) (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 "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") + (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)) -(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)) @@ -952,6 +947,7 @@ (value #t)) (lib-dir (single-char #\L) (value #t)) + (guimb (single-char #\g)) (help (single-char #\h)))) (define program-name (car (command-line))) @@ -969,33 +965,26 @@ (set! sieve-libdir (cdr x))) ((output) (set! output (cdr x))) + ((guimb) + (set! guimb-header #t)) ((help) - (sieve-usage)))))) + (sieve-usage)) + ('() + (set! sieve-script-args (cdr x))))))) (getopt-long (command-line) grammar)) -(if (not filename) - (begin - (display program-name) - (display ": missing input filename") - (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 - (display (string-append - program-name - ": Input file " filename " does not exist.")) - (newline) - (exit 0))) +(cond + ((not filename) + (display program-name) + (display ": missing input filename") + (newline) + (sieve-usage)) + ((not (file-exists? filename)) + (display (string-append + program-name + ": Input file " filename " does not exist.")) + (newline) + (exit 0))) (if (not sieve-libdir) (set! sieve-libdir @@ -1019,23 +1008,20 @@ (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)) + (sieve-save-program output guimb-header)) (else (let ((temp-file (tmpnam)) (saved-umask (umask #o077))) (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) (umask saved-umask)))) - +;;;; End of sieve.scm -- cgit v1.2.1