From a5223faba443e1345b34098b841748f01e509204 Mon Sep 17 00:00:00 2001 From: morioka Date: Wed, 28 Aug 1996 20:34:53 +0000 Subject: [PATCH] Parser were moved from tl-822.el and renamed to `std11-*'. --- std11-parse.el | 302 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 301 insertions(+), 1 deletion(-) diff --git a/std11-parse.el b/std11-parse.el index 57d9353..35d5e7f 100644 --- a/std11-parse.el +++ b/std11-parse.el @@ -4,7 +4,7 @@ ;; Author: MORIOKA Tomohiko ;; Keywords: mail, news, RFC 822, STD 11 -;; Version: $Id: std11-parse.el,v 0.8 1996-08-28 18:11:29 morioka Exp $ +;; Version: $Id: std11-parse.el,v 0.9 1996-08-28 20:34:53 morioka Exp $ ;; This file is part of tl (Tiny Library). @@ -27,6 +27,8 @@ (require 'std11) +(autoload 'find-charset-string "emu") + ;;; @ lexical analyze ;;; @@ -133,6 +135,304 @@ )) +;;; @ parser +;;; + +(defun std11-ignored-token-p (token) + (let ((type (car token))) + (or (eq type 'spaces)(eq type 'comment)) + )) + +(defun std11-parse-token (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (std11-ignored-token-p token) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-ascii-token (lal) + (let (token itl parsed token-value) + (while (and lal + (setq token (car lal)) + (if (and (setq token-value (cdr token)) + (find-charset-string token-value) + ) + (setq token nil) + (std11-ignored-token-p token) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (if (and token + (setq parsed (nreverse (cons token itl))) + ) + (cons parsed (cdr lal)) + ))) + +(defun std11-parse-token-or-comment (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (eq (car token) 'spaces) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-word (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (if (or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ))))) + +(defun std11-parse-word-or-comment (lal) + (let ((ret (std11-parse-token-or-comment lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (cond ((or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ) + ((assq 'comment elt) + (cons (cons 'comment-word elt) rest) + )) + )))) + +(defun std11-parse-phrase (lal) + (let (ret phrase) + (while (setq ret (std11-parse-word-or-comment lal)) + (setq phrase (append phrase (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (if phrase + (cons (cons 'phrase phrase) lal) + ))) + +(defun std11-parse-local-part (lal) + (let ((ret (std11-parse-word lal))) + (if ret + (let ((local-part (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-word (cdr ret))) + (setq local-part + (append local-part dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'local-part local-part) lal) + )))) + +(defun std11-parse-sub-domain (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((sub-domain (car ret))) + (if (or (assq 'atom sub-domain) + (assq 'domain-literal sub-domain) + ) + (cons (cons 'sub-domain sub-domain) + (cdr ret) + ) + ))))) + +(defun std11-parse-domain (lal) + (let ((ret (std11-parse-sub-domain lal))) + (if ret + (let ((domain (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-sub-domain (cdr ret))) + (setq domain + (append domain dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'domain domain) lal) + )))) + +(defun std11-parse-at-domain (lal) + (let ((ret (std11-parse-ascii-token lal)) at-sign) + (if (and ret + (setq at-sign (car ret)) + (string-equal (cdr (assq 'specials at-sign)) "@") + (setq ret (std11-parse-domain (cdr ret))) + ) + (cons (cons 'at-domain (append at-sign (cdr (car ret)))) + (cdr ret)) + ))) + +(defun std11-parse-addr-spec (lal) + (let ((ret (std11-parse-local-part lal)) + addr) + (if (and ret + (prog1 + (setq addr (cdr (car ret))) + (setq lal (cdr ret)) + (and (setq ret (std11-parse-at-domain lal)) + (setq addr (append addr (cdr (car ret)))) + (setq lal (cdr ret)) + ))) + (cons (cons 'addr-spec addr) lal) + ))) + +(defun std11-parse-route (lal) + (let ((ret (std11-parse-at-domain lal)) + route comma colon) + (if (and ret + (progn + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal (cdr (assq 'specials comma)) ",") + (setq ret (std11-parse-at-domain (cdr ret))) + ) + (setq route (append route comma (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (and (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq route (append route colon)) + ) + )) + (cons (cons 'route route) + (cdr ret) + ) + ))) + +(defun std11-parse-route-addr (lal) + (let ((ret (std11-parse-ascii-token lal)) + < route addr-spec >) + (if (and ret + (setq < (car ret)) + (string-equal (cdr (assq 'specials <)) "<") + (setq lal (cdr ret)) + (progn (and (setq ret (std11-parse-route lal)) + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + ) + (setq ret (std11-parse-addr-spec lal)) + ) + (setq addr-spec (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq > (car ret)) + (string-equal (cdr (assq 'specials >)) ">") + ) + (cons (cons 'route-addr (append route addr-spec)) + (cdr ret) + ) + ))) + +(defun std11-parse-phrase-route-addr (lal) + (let ((ret (std11-parse-phrase lal)) phrase) + (if ret + (progn + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + )) + (if (setq ret (std11-parse-route-addr lal)) + (cons (list 'phrase-route-addr + phrase + (cdr (car ret))) + (cdr ret)) + ))) + +(defun std11-parse-mailbox (lal) + (let ((ret (or (std11-parse-phrase-route-addr lal) + (std11-parse-addr-spec lal))) + mbox comment) + (if (and ret + (prog1 + (setq mbox (car ret)) + (setq lal (cdr ret)) + (if (and (setq ret (std11-parse-token-or-comment lal)) + (setq comment (cdr (assq 'comment (car ret)))) + ) + (setq lal (cdr ret)) + ))) + (cons (list 'mailbox mbox comment) + lal) + ))) + +(defun std11-parse-group (lal) + (let ((ret (std11-parse-phrase lal)) + phrase colon comma mbox semicolon) + (if (and ret + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq lal (cdr ret)) + (progn + (and (setq ret (std11-parse-mailbox lal)) + (setq mbox (list (car ret))) + (setq lal (cdr ret)) + (progn + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal + (cdr (assq 'specials comma)) ",") + (setq lal (cdr ret)) + (setq ret (std11-parse-mailbox lal)) + (setq mbox (cons (car ret) mbox)) + (setq lal (cdr ret)) + ) + ))) + (and (setq ret (std11-parse-ascii-token lal)) + (setq semicolon (car ret)) + (string-equal (cdr (assq 'specials semicolon)) ";") + ))) + (cons (list 'group phrase (nreverse mbox)) + (cdr ret) + ) + ))) + +(defun std11-parse-address (lal) + (or (std11-parse-group lal) + (std11-parse-mailbox lal) + )) + +(defun std11-parse-addresses (lal) + (let ((ret (std11-parse-address lal))) + (if ret + (let ((dest (list (car ret)))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (string-equal (cdr (assq 'specials (car ret))) ",") + (setq ret (std11-parse-address (cdr ret))) + ) + (setq dest (cons (car ret) dest)) + (setq lal (cdr ret)) + ) + (nreverse dest) + )))) + + ;;; @ end ;;; -- 1.7.10.4