/[mailutils]/mailutils/guimb/scm/sieve.scm.in
ViewVC logotype

Diff of /mailutils/guimb/scm/sieve.scm.in

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by gray, Tue Sep 10 12:05:39 2002 UTC revision 1.3 by gray, Sun Oct 13 20:32:27 2002 UTC
# Line 1  Line 1 
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.
# Line 130  Line 131 
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))
# Line 145  Line 154 
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
# Line 410  Line 416 
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"))
# Line 427  Line 434 
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
# Line 472  Line 483 
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)))
# Line 527  Line 599 
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    
# Line 664  Line 694 
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    
# Line 853  Line 884 
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)

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26