1 |
#! %BINDIR%/guimb --source |
#! %BINDIR%/guimb --source |
2 |
|
# Emacs, its -*- scheme -*- |
3 |
!# |
!# |
4 |
;;;; GNU mailutils - a suite of utilities for electronic mail |
;;;; GNU mailutils - a suite of utilities for electronic mail |
5 |
;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. |
;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. |
131 |
(>= end (1- input-length)) |
(>= end (1- input-length)) |
132 |
(not (char-numeric? |
(not (char-numeric? |
133 |
(string-ref input-line end)))) |
(string-ref input-line end)))) |
134 |
end))) |
|
135 |
|
(cond |
136 |
|
((char-numeric? (string-ref input-line end)) |
137 |
|
(1+ end)) |
138 |
|
(else |
139 |
|
end))))) |
140 |
(num (string->number (substring input-line start end))) |
(num (string->number (substring input-line start end))) |
141 |
(q (string-ref input-line end)) |
(q (if (< end input-length) |
142 |
|
(string-ref input-line end) |
143 |
|
#f)) |
144 |
(k 1)) |
(k 1)) |
145 |
(case q |
(case q |
146 |
|
((#f) #f) ;; nothing |
147 |
((#\K) |
((#\K) |
148 |
(set! end (1+ end)) |
(set! end (1+ end)) |
149 |
(set! k 1024)) |
(set! k 1024)) |
154 |
(set! end (1+ end)) |
(set! end (1+ end)) |
155 |
(set! k 1073741824)) |
(set! k 1073741824)) |
156 |
(else |
(else |
157 |
(cond |
(if (not (delimiter? q)) |
158 |
((char-numeric? q) |
(lex-error "Unknown qualifier (" q ")")))) |
|
(set! end (1+ end))) |
|
|
((not (delimiter? q)) |
|
|
(lex-error "Unknown qualifier (" q ")"))))) |
|
159 |
(set! input-index end) |
(set! input-index end) |
160 |
(cons 'number (* num k)))) |
(cons 'number (* num k)))) |
161 |
(else |
(else |
416 |
(define (sieve-find-test name) |
(define (sieve-find-test name) |
417 |
(sieve-syntax-table-lookup sieve-test-table name)) |
(sieve-syntax-table-lookup sieve-test-table name)) |
418 |
|
|
419 |
(define (sieve-register-test name function opt-arg-list req-arg-list) |
(define (sieve-register-test name function req-arg-list opt-arg-list) |
420 |
|
(DEBUG 100 "sieve-register-test" name req-arg-list opt-arg-list) |
421 |
(cond |
(cond |
422 |
((not (list? opt-arg-list)) |
((not (list? opt-arg-list)) |
423 |
(lex-error "sieve-register-test: opt-arg-list must be a list")) |
(lex-error "sieve-register-test: opt-arg-list must be a list")) |
434 |
(list name function opt-arg-list req-arg-list))))))) |
(list name function opt-arg-list req-arg-list))))))) |
435 |
|
|
436 |
|
|
437 |
|
;;; sieve-preprocess-arguments: Preprocess and group the arguments. Returns |
438 |
|
;;; a cons whose car is a list of all optional arguments, and the cdr is |
439 |
|
;;; a list of the rest of the arguments. |
440 |
|
;;; |
441 |
;;; arguments = *argument [test / test-list] |
;;; arguments = *argument [test / test-list] |
442 |
;;; argument = string-list / number / tag |
;;; argument = string-list / number / tag |
443 |
|
|
444 |
(define (sieve-parse-arguments tag-gram) |
(define (sieve-preprocess-arguments tag-gram) |
445 |
(do ((opt-list '()) ;; List of optional arguments (tags) |
(do ((opt-list '()) ;; List of optional arguments (tags) |
446 |
(arg-list '()) ;; List of positional arguments |
(arg-list '()) ;; List of positional arguments |
447 |
(last-tag #f) ;; Description of the last tag from tag-gram |
(last-tag #f) ;; Description of the last tag from tag-gram |
483 |
(else |
(else |
484 |
(set! arg-list (append arg-list (list token))))) |
(set! arg-list (append arg-list (list token))))) |
485 |
#f) |
#f) |
486 |
((delimiter token #\[) ;;FIXME: tags are not allowed to take |
((delimiter token #\[) |
|
;;string-list arguments. |
|
|
(set! state 'arg) |
|
487 |
(putback-token) |
(putback-token) |
488 |
(set! arg-list (append arg-list |
(cond |
489 |
(list (require-string-list)))) |
((and (eq? state 'opt) (pair? last-tag)) |
490 |
#f) |
(cond |
491 |
|
((cdr last-tag) |
492 |
|
(if (not (eq? (cdr last-tag) 'string-list)) |
493 |
|
(syntax-error |
494 |
|
"Tag :" (car last-tag) " takes string list argument")) |
495 |
|
(set! opt-list (append opt-list (list (require-string-list)))) |
496 |
|
(set! last-tag #f)) |
497 |
|
(else |
498 |
|
(set! state 'arg) |
499 |
|
(set! arg-list (append arg-list (list (require-string-list))))))) |
500 |
|
(else |
501 |
|
(set! arg-list (append arg-list (list (require-string-list)))))) |
502 |
|
#f) |
503 |
(else |
(else |
504 |
#t)) |
#t)) |
505 |
(cons opt-list arg-list)))) |
(cons opt-list arg-list)))) |
506 |
|
|
507 |
|
;;; sieve-parse-arguments: Parse the arguments to a test or an action. |
508 |
|
;;; ENTRY is the syntax table entry to guide the parsing |
509 |
|
;;; |
510 |
|
(define (sieve-parse-arguments ident entry) |
511 |
|
(DEBUG 100 "sieve-parse-arguments" entry) |
512 |
|
(let ((arg-list (sieve-preprocess-arguments (car (cdr entry))))) |
513 |
|
;; Process positional arguments |
514 |
|
(do ((expect (car (cdr (cdr entry))) (cdr expect)) |
515 |
|
(argl (cdr arg-list) (cdr argl)) |
516 |
|
(n 1 (1+ n))) |
517 |
|
((cond |
518 |
|
((null? expect) |
519 |
|
(if (not (null? argl)) |
520 |
|
(syntax-error |
521 |
|
"Too many positional arguments for " ident |
522 |
|
" (bailed out at " (car argl) ")")) |
523 |
|
#t) |
524 |
|
((null? argl) |
525 |
|
(if (not (null? expect)) |
526 |
|
(syntax-error |
527 |
|
"Too few positional arguments for " ident)) |
528 |
|
#t) |
529 |
|
(else #f)) #f) |
530 |
|
(let ((expect-type (car expect)) |
531 |
|
(arg (car argl))) |
532 |
|
(cond |
533 |
|
((and (eq? expect-type 'string-list) |
534 |
|
(eq? (car arg) 'string)) |
535 |
|
;; Coerce string to string-list |
536 |
|
(sieve-exp-append (list 'list (cdr arg)))) |
537 |
|
((eq? expect-type (car arg)) |
538 |
|
(if (eq? expect-type 'string-list) |
539 |
|
(sieve-exp-append (append (list 'list) (cdr arg))) |
540 |
|
(sieve-exp-append (cdr arg)))) |
541 |
|
(else |
542 |
|
(syntax-error |
543 |
|
"Type mismatch in argument " n " to " (cdr ident) |
544 |
|
"; expected " expect-type ", but got " (car arg)))))) |
545 |
|
;; Process optional arguments (tags). |
546 |
|
;; They have already been tested |
547 |
|
(for-each |
548 |
|
(lambda (tag) |
549 |
|
(sieve-exp-append (cond |
550 |
|
((eq? (car tag) 'tag) |
551 |
|
(string->symbol (string-append "#:" (cdr tag)))) |
552 |
|
((eq? (car tag) 'string-list) |
553 |
|
(append (list 'list) (cdr tag))) |
554 |
|
(else |
555 |
|
(cdr tag))))) |
556 |
|
(car arg-list)))) |
557 |
|
|
558 |
;;; test-list = "(" test *("," test) ")" |
;;; test-list = "(" test *("," test) ")" |
559 |
(define (sieve-parse-test-list) |
(define (sieve-parse-test-list) |
560 |
(do ((token (sieve-parse-test) (sieve-parse-test))) |
(do ((token (sieve-parse-test) (sieve-parse-test))) |
599 |
(if (not test) |
(if (not test) |
600 |
(syntax-error "Unknown test name: " (cdr ident))) |
(syntax-error "Unknown test name: " (cdr ident))) |
601 |
(putback-token) |
(putback-token) |
602 |
(let ((arg-list (sieve-parse-arguments (car (cdr test))))) |
(sieve-exp-append (car test)) |
603 |
(sieve-exp-append (car test)) |
(sieve-parse-arguments (cdr ident) 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)) |
|
|
)))))) |
|
604 |
(sieve-exp-finish)) |
(sieve-exp-finish)) |
605 |
current-token) |
current-token) |
606 |
|
|
694 |
|
|
695 |
;;; Actions |
;;; Actions |
696 |
|
|
697 |
;;; Each entry is: (list ACTION-NAME FUNCTION ARG-LIST) |
;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST) |
698 |
;;; ARG-LIST is a list of argument types |
;;; NAME is a string representing the action name, |
699 |
|
;;; FUNCTION is a corresponding function: |
700 |
|
;;; (define (action-foo [arg [arg...]] . opt-args) |
701 |
|
;;; notice, that its name must begin with "action-" |
702 |
|
;;; OPT-ARG-LIST is a list of optional arguments (tags), |
703 |
|
;;; REQ-ARG-LIST is a list of required (positional) arguments |
704 |
(define sieve-action-table '()) |
(define sieve-action-table '()) |
705 |
|
|
706 |
(define (sieve-find-action name) |
(define (sieve-find-action name) |
707 |
(sieve-syntax-table-lookup sieve-action-table name)) |
(sieve-syntax-table-lookup sieve-action-table name)) |
708 |
|
|
709 |
(define (sieve-register-action name proc . arg-list) |
(define (sieve-register-action name function req-arg-list opt-arg-list) |
710 |
(if (not (sieve-find-action name)) |
(cond |
711 |
(set! sieve-action-table (append sieve-action-table |
((not (list? opt-arg-list)) |
712 |
(list |
(lex-error "sieve-register-action: opt-arg-list must be a list")) |
713 |
(append |
((not (list? req-arg-list)) |
714 |
(list name proc) arg-list)))))) |
(lex-error "sieve-register-action: req-arg-list must be a list")) |
715 |
|
((not (or (eq? function #f) |
716 |
|
(eq? function #t) |
717 |
|
(procedure? function))) |
718 |
|
(lex-error "sieve-register-action: bad type for function" function)) |
719 |
|
(else |
720 |
|
(set! sieve-action-table |
721 |
|
(append sieve-action-table |
722 |
|
(list |
723 |
|
(list name function opt-arg-list req-arg-list))))))) |
724 |
|
|
725 |
(define (sieve-parse-action) |
(define (sieve-parse-action) |
726 |
(let* ((name (cdr current-token)) |
(let* ((name (cdr current-token)) |
727 |
(descr (sieve-find-action name))) |
(descr (sieve-find-action name))) |
728 |
(cond |
(cond |
729 |
(descr |
(descr |
730 |
(if (car descr) |
(cond |
731 |
(sieve-exp-begin (car descr))) |
((car descr) |
732 |
(do ((arg (cdr descr) (cdr arg))) |
(sieve-exp-begin (car descr)) |
733 |
((null? arg) #f) |
(sieve-parse-arguments name descr) |
734 |
(read-token) |
(require-semicolon 'dont-read) |
735 |
(case (car arg) |
(sieve-exp-finish)) |
736 |
((string) |
(else |
737 |
(require-string 'dont-read)) |
(require-semicolon)))) |
|
((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))) |
|
738 |
(else |
(else |
739 |
(syntax-error "Unknown identifier: " name))))) |
(syntax-error "Unknown identifier: " name))))) |
740 |
|
|
884 |
(display (string-append |
(display (string-append |
885 |
";;;; A Guile mailbox parser made from " filename) port) |
";;;; A Guile mailbox parser made from " filename) port) |
886 |
(newline port) |
(newline port) |
887 |
(display ";;;; by sieve.scm, GNU mailutils (0.0.9)" port) |
(display ";;;; by sieve.scm, GNU %PACKAGE% %VERSION%" port) |
888 |
(newline port) |
(newline port) |
889 |
|
|
890 |
(display "(define sieve-parser #f)" port) |
(display "(define sieve-parser #f)" port) |