From 469bf064edeca7e6b16f01a5ab94ad574720cb26 Mon Sep 17 00:00:00 2001 From: tomo Date: Tue, 5 Dec 2000 17:34:32 +0000 Subject: [PATCH] Merge clime-1_13. --- ChangeLog | 189 +++++++-- FLIM-CFG | 18 + Makefile | 2 +- README.ja | 2 +- VERSION | 21 + eword-decode.el | 36 +- luna.el | 176 +++++---- mel-b-ccl.el | 410 +++++++++---------- mel-b-el.el | 4 +- mel-q-ccl.el | 1171 +++++++++++++++++++++++++++---------------------------- mel.el | 2 +- mime-def.el | 81 ++-- mime-parse.el | 5 +- mime.el | 3 +- 14 files changed, 1161 insertions(+), 959 deletions(-) diff --git a/ChangeLog b/ChangeLog index 34faa90..7bc305e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,26 +1,5 @@ 2000-12-04 Daiki Ueno - * luna.el (luna-class-find-functions): Don't quote colon keywords. - (luna-send): Ditto. - (luna-call-next-method): Ditto. - -2000-11-28 Daiki Ueno - - * luna.el: Don't require `static'. - (luna-define-class-function): Don't bind colon keywords. - (luna-class-find-functions): Quote colon keywords. - (luna-send): Likewise. - (luna-call-next-method): Likewise. - -2000-11-12 Daiki Ueno - - * luna.el (luna-define-method): Clear method cache. - (luna-apply-generic): New function. - (luna-define-generic): Use `luna-apply-generic' instead of - `luna-send'. - -2000-12-04 Daiki Ueno - * smtpmail.el (smtpmail-send-it): Use `smtp-send-buffer' instead of `smtp-via-smtp'. (smtpmail-send-queued-mail): Ditto. @@ -439,16 +418,34 @@ * mmexternal.el: New module. + +1999-12-14 MORIOKA Tomohiko + + * CLIME: Version 1.13.6 (Nakanosh-Dò)-A released. + 1999-12-13 Katsumi Yamaoka * README.en, README.ja, mime-en.sgml, mime-ja.sgml: Update for the recent ML address and ftp site. +1999-11-12 Shuhei KOBAYASHI + + * mel-q-ccl.el (q-encoding-ccl-encoded-length): Removed comment. + +1999-10-21 Tsukamoto Tetsuo + + * eword-decode.el (mime-set-field-decoder): Doc string typo. + 1999-10-17 Yoshiki Hayashi * FLIM-MK (install-flim-package): Delete auto-autoloads.el and custom-load.el + +1999-10-18 MORIOKA Tomohiko + + * CLIME: Version 1.13.5 (Kaga-Fukuoka) released. + 1999-09-20 Katsumi Yamaoka * mailcap.el (mailcap-look-at-schar): Protect against unexpected @@ -458,9 +455,15 @@ * smtpmail.el (smtpmail-send-it): Remove needless `concat'. -1999-09-08 Yoshiki Hayashi + +1999-09-13 MORIOKA Tomohiko + + * CLIME: Version 1.13.4 (Shin-Terai) released. + +1999-09-13 MORIOKA Tomohiko - * mime-ja.sgml, mime-en.sgml (Entity creation): Fix typo. + * README.en (Installation): Modify for APEL 9.22; modify location + of APEL. 1999-09-01 Katsumi Yamaoka @@ -474,6 +477,10 @@ 1999-08-26 Katsumi Yamaoka + * FLIM-CFG: Emulate `add-to-list' and `data-directory' for old + Emacsen; require `poe' if the function `member' is not bound + because the function `add-path' uses it. + * smtpmail.el (smtpmail-send-it): Use `time-stamp-yyyy-mm-dd' and `time-stamp-hh:mm:ss' instead of `current-time'. @@ -482,12 +489,144 @@ * FLIM-ELS: Use `if' instead of `unless'. +1999-08-24 MORIOKA Tomohiko + + * CLIME: Version 1.13.3 (Hirahata) released. + + * README.en (Installation): Modify for APEL 9.21. + +1999-08-24 MORIOKA Tomohiko + + * mime-def.el: Don't require cl. + (make-mime-content-type): Don't use `list*'. + +1999-08-24 Taiji Can + + * mime-def.el: Use `int-to-string' instead of `number-to-string'. + + +1999-08-23 MORIOKA Tomohiko + + * CLIME: Version 1.13.2 (Nukatabe) released. + +1999-08-19 TSUMURA Tomoaki + + * mel-b-el.el (base64-num-to-char): Use <(` ...)> and <(, ...)> + instead of <`...> and <,...>. + (base64-char-to-num): Likewise. + +1999-08-20 Daiki Ueno + + * mel-b-ccl.el (mel-ccl-decode-b): Use <(` ...)>, <(, ...)> and + <(,@ ...)> instead of <`...>, <,...> and <,@...> unless + `ccl-cascading-read' is broken. + + * mel-q-ccl.el (mel-ccl-decode-quoted-printable-generic): Fix + quotation. + +1999-08-19 Daiki Ueno + + * mel-b-ccl.el (mel-ccl-decode-b): Use <(` ...)>, <(, ...)> and + <(,@ ...)> instead of <`...>, <,...> and <,@...>. + (mel-ccl-encode-base64-generic): Likewise. + + * mel-q-ccl.el (mel-ccl-decode-q): Use <(` ...)>, <(, ...)> and + <(,@ ...)> instead of <`...>, <,...> and <,@...>. + (mel-ccl-encode-q-generic): Likewise. + (mel-ccl-count-q-length): Likewise. + (mel-ccl-set-eof-block): Likewise. + (mel-ccl-try-to-read-crlf): Likewise. + (mel-ccl-encode-quoted-printable-generic): Likewise. + (mel-ccl-decode-quoted-printable-generic): Likewise. + + +1999-08-19 MORIOKA Tomohiko + + * CLIME: Version 1.13.1 (Ando) released. + +1999-08-19 MORIOKA Tomohiko + + * luna.el (luna-define-generic): Use <(` ...)>, <(, ...)> and <(,@ + ...)> instead of <`...>, <,...> and <,@...>. + (luna-define-internal-accessors): Use <(` ...)> and <(, ...)> + instead of <`...> and <,...>. + +1999-08-19 MORIOKA Tomohiko + + * smtpmail.el (smtpmail-send-it): Don't use bare lambda. + + * mime-def.el (mm-define-backend): Don't use bare lambda. + (mel-define-backend): Likewise. + (mel-define-method): Likewise. + + * luna.el (luna-define-class-function): Don't use bare lambda. + (luna-define-method): Likewise. + (luna-define-internal-accessors): Likewise. + + * mime-def.el: Delete <(require 'custom)>. + + +1999-08-19 MORIOKA Tomohiko + + * CLIME: Version 1.13.0 (Shin-H-Dòryþji)-A released. + +1999-08-18 MORIOKA Tomohiko + + * mime.el (mime-entity-send): Use <(` ...)>, <(, ...)> and <(,@ + ...)> instead of <`...>, <,...> and <,@...>. + + * mime-parse.el (mime-parse-Content-Type): Use + `eval-when-compile'. + + * mime-def.el (mime-product-name): Use <(` ...)> and <(, ...)> + instead of <`...> and <,...>. + (mime-product-version): Likewise. + (mime-product-code-name): Likewise. + (mime-library-version): Use <(function ...)> instead of <#'...>. + (mm-expand-class-name): Use <(` ...)> and <(, ...)> instead of + <`...> and <,...>. + (mm-define-backend): Likewise. + (mm-define-method): Use <(` ...)>, <(, ...)> and <(,@ ...)> + instead of <`...>, <,...> and <,@...>. + (mel-define-service): Likewise. + (mel-define-backend): Use <(` ...)> and <(, ...)> instead of + <`...> and <,...>. + (mel-define-method-function): Likewise. + (mel-define-function): Likewise. + + * mel.el (mime-encoding-alist): Use <(function ...)> instead of + <#'...>. + + * luna.el (luna-find-class): Use <(` ...)> and <(, ...)> instead + of <`...> and <,...>. + (luna-set-class): Likewise. + (luna-class-obarray): Likewise. + (luna-class-parents): Likewise. + (luna-class-number-of-slots): Likewise. + (luna-define-class): Likewise. + (luna-class-slot-index): Likewise. + (luna-slot-index): Likewise. + (luna-define-method): Use <(` ...)>, <(, ...)> and <(,@ ...)> + instead of <`...>, <,...> and <,@...>. + (luna-find-functions): Use <(` ...)> and <(, ...)> instead of + <`...> and <,...>. + (luna-class-name): Likewise. + (luna-set-class-name): Likewise. + (luna-get-obarray): Likewise. + (luna-set-obarray): Likewise. + (luna-make-entity): Use <(function ...)> instead of <#'...>. + + * eword-decode.el (mime-find-field-presentation-method): Use <(` + ...)> and <(, ...)> instead of <`...> and <,...>. + - Use <(function ...)> instead of <#'...>. + + 1999-08-17 MORIOKA Tomohiko * FLIM: Version 1.13.2 (Kasanui) released. 1999-08-03 Yuuichi Teranishi - + * smtp.el (smtp-notify-success): New option. * (smtp-via-smtp): Request return receipt (defined in RFC1891) to SMTP server if `smtp-notify-success' is non-nil. @@ -2607,7 +2746,7 @@ 1998-07-01 MORIOKA Tomohiko - * FLIM: Version 1.8.0 (ƒkubo) was released. + * FLIM: Version 1.8.0 (-DÒkubo)-A was released. * README.en: Delete `How to use'. diff --git a/FLIM-CFG b/FLIM-CFG index 965c7b8..fa56911 100644 --- a/FLIM-CFG +++ b/FLIM-CFG @@ -6,6 +6,19 @@ (defvar default-load-path load-path) +(if (fboundp 'add-to-list) + nil + ;; Emacs 19.29 emulating function. + (defun add-to-list (list-var element) + (set list-var (cons element (symbol-value list-var)))) + ) + +(if (boundp 'data-directory) + nil + ;; Emacs 19 emulating variable. + (defvar data-directory exec-directory) + ) + (add-to-list 'load-path (expand-file-name "../../site-lisp/apel" data-directory)) @@ -19,6 +32,11 @@ (if (boundp 'VERSION_SPECIFIC_LISPDIR) (add-to-list 'load-path VERSION_SPECIFIC_LISPDIR)) +(if (fboundp 'member) + nil + ;; It is needed because the function `add-path' uses it. + (require 'poe)) + (require 'install) (add-latest-path "custom") diff --git a/Makefile b/Makefile index 2e2759f..642d346 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ # Makefile for FLIM. # -PACKAGE = flim +PACKAGE = clime API = 1.14 RELEASE = 0 diff --git a/README.ja b/README.ja index 5327de3..467c9d4 100644 --- a/README.ja +++ b/README.ja @@ -37,7 +37,7 @@ FLIM $B$H$O!)(B $BF3F~(B (install) ============== -(0) $BF3F~(B (install) $B$9$kA0$K!"(BAPEL (9.22 $B0J9_(B) $B$rF3F~$7$F$/$@$5$$!#(BAPEL +(0) $BF3F~(B (install) $B$9$kA0$K!"(BAPEL (9.19 $B0J9_(B) $B$rF3F~$7$F$/$@$5$$!#(BAPEL $B$O0J2<$N$H$3$m$G $(B4X@>K\@~(B $(BK!N4;{(B +1.13.1 Ando $(B0BEH(B +1.13.2 Nukatabe $(B3[EDIt(B +1.13.3 Hirahata $(BJ?C<(B ; = $(BBg50(B $(BE7M}@~!"@&K5@~(B + +;;------------------------------------------------------------------------- +;; Hokuriku Railway $(BKLN&E4F;(B +;; Nomi Line $(BG=H~@~(B $(B!J5l(B $(BG=H~EE5$E4F;!K(B +;;------------------------------------------------------------------------- +1.13.4 Shin-Terai $(B?7;{0f(B ; <=> $(BKLN&K\@~(B $(B;{0f(B +1.13.5 Kaga-Fukuoka $(B2C2lJ!2,(B +1.13.6 Nakanosh-Dò-A $(BCf%N>1(B +1.14.0 Gokend-Dò-A $(B8^4VF2(B diff --git a/eword-decode.el b/eword-decode.el index dd46d32..d374d3f 100644 --- a/eword-decode.el +++ b/eword-decode.el @@ -270,7 +270,7 @@ such as a version of Net$cape)." ;;;###autoload (defun mime-set-field-decoder (field &rest specs) - "Set decoder of FILED. + "Set decoder of FIELD. SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'. Each mode must be `nil', `plain', `wide', `summary' or `nov'. If mode is `nil', corresponding decoder is set up for every modes." @@ -300,20 +300,20 @@ If mode is `nil', corresponding decoder is set up for every modes." "Return field-presentation-method from NAME. NAME must be `plain', `wide', `summary' or `nov'." (cond ((eq name nil) - `(or (assq 'summary mime-field-decoder-cache) - '(summary)) - ) + (` (or (assq 'summary mime-field-decoder-cache) + '(summary)) + )) ((and (consp name) (car name) (consp (cdr name)) (symbolp (car (cdr name))) (null (cdr (cdr name)))) - `(or (assq ,name mime-field-decoder-cache) - (cons ,name nil)) - ) + (` (or (assq (, name) mime-field-decoder-cache) + (cons (, name) nil)) + )) (t - `(or (assq (or ,name 'summary) mime-field-decoder-cache) - (cons (or ,name 'summary) nil)) + (` (or (assq (or (, name) 'summary) mime-field-decoder-cache) + (cons (or (, name) 'summary) nil))) ))) (defun mime-find-field-decoder-internal (field &optional mode) @@ -402,19 +402,19 @@ Default value of MODE is `summary'." (setq field (pop fields)) (mime-set-field-decoder field - 'plain #'eword-decode-structured-field-body - 'wide #'eword-decode-and-fold-structured-field-body - 'summary #'eword-decode-and-unfold-structured-field-body - 'nov #'eword-decode-and-unfold-structured-field-body) - )) + 'plain (function eword-decode-structured-field-body) + 'wide (function eword-decode-and-fold-structured-field-body) + 'summary (function eword-decode-and-unfold-structured-field-body) + 'nov (function eword-decode-and-unfold-structured-field-body) + ))) ;; unstructured fields (default) (mime-set-field-decoder t - 'plain #'eword-decode-unstructured-field-body - 'wide #'eword-decode-unstructured-field-body - 'summary #'eword-decode-and-unfold-unstructured-field-body - 'nov #'eword-decode-unfolded-unstructured-field-body) + 'plain (function eword-decode-unstructured-field-body) + 'wide (function eword-decode-unstructured-field-body) + 'summary (function eword-decode-and-unfold-unstructured-field-body) + 'nov (function eword-decode-unfolded-unstructured-field-body)) ;;;###autoload (defun mime-decode-field-body (field-body field-name diff --git a/luna.el b/luna.el index 7a8cb53..f7390b0 100644 --- a/luna.el +++ b/luna.el @@ -26,35 +26,52 @@ (eval-when-compile (require 'cl)) +(eval-when-compile (require 'static)) + +(static-condition-case nil + :symbol-for-testing-whether-colon-keyword-is-available-or-not + (void-variable + (defconst :before ':before) + (defconst :after ':after) + (defconst :around ':around))) + ;;; @ class ;;; (defmacro luna-find-class (name) "Return the luna-class of the given NAME." - `(get ,name 'luna-class)) + (` (get (, name) 'luna-class))) (defmacro luna-set-class (name class) - `(put ,name 'luna-class ,class)) + (` (put (, name) 'luna-class (, class)))) (defmacro luna-class-obarray (class) - `(aref ,class 1)) + (` (aref (, class) 1))) (defmacro luna-class-parents (class) - `(aref ,class 2)) + (` (aref (, class) 2))) (defmacro luna-class-number-of-slots (class) - `(aref ,class 3)) + (` (aref (, class) 3))) (defmacro luna-define-class (type &optional parents slots) "Define TYPE as a luna-class. If PARENTS is specified, TYPE inherits PARENTS. Each parent must be name of luna-class (symbol). If SLOTS is specified, TYPE will be defined to have them." - `(luna-define-class-function ',type ',(append parents '(standard-object)) - ',slots)) + (` (luna-define-class-function '(, type) + '(, (append parents '(standard-object))) + '(, slots)))) (defun luna-define-class-function (type &optional parents slots) + (static-condition-case nil + :symbol-for-testing-whether-colon-keyword-is-available-or-not + (void-variable + (let (key) + (dolist (slot slots) + (setq key (intern (format ":%s" slot))) + (set key key))))) (let ((oa (make-vector 31 0)) (rest parents) parent name @@ -63,13 +80,16 @@ If SLOTS is specified, TYPE will be defined to have them." (while rest (setq parent (pop rest) b (- i 2)) - (mapatoms (lambda (sym) - (when (setq j (get sym 'luna-slot-index)) - (setq name (symbol-name sym)) - (unless (intern-soft name oa) - (put (intern name oa) 'luna-slot-index (+ j b)) - (setq i (1+ i))))) - (luna-class-obarray (luna-find-class parent)))) + (mapatoms (function + (lambda (sym) + (when (setq j (get sym 'luna-slot-index)) + (setq name (symbol-name sym)) + (unless (intern-soft name oa) + (put (intern name oa) 'luna-slot-index (+ j b)) + (setq i (1+ i)) + )))) + (luna-class-obarray (luna-find-class parent))) + ) (setq rest slots) (while rest (setq name (symbol-name (pop rest))) @@ -97,7 +117,7 @@ If SLOTS is specified, TYPE will be defined to have them." (intern member-name (luna-class-obarray class))) (defmacro luna-class-slot-index (class slot-name) - `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index)) + (` (get (luna-class-find-member (, class) (, slot-name)) 'luna-slot-index))) (defmacro luna-define-method (name &rest definition) "Define NAME as a method function of a class. @@ -127,17 +147,17 @@ BODY is the body of method." (setq specializer (car args) class (nth 1 specializer) self (car specializer)) - `(let ((func (lambda ,(if self - (cons self (cdr args)) - (cdr args)) - ,@definition)) - (sym (luna-class-find-or-make-member - (luna-find-class ',class) ',name)) - (cache (get ',name 'luna-method-cache))) - (if cache - (unintern ',class cache)) - (fset sym func) - (put sym 'luna-method-qualifier ,method-qualifier)))) + (` (let ((func (function + (lambda (, (if self + (cons self (cdr args)) + (cdr args))) + (,@ definition)))) + (sym (luna-class-find-or-make-member + (luna-find-class '(, class)) '(, name)))) + (fset sym func) + (put sym 'luna-method-qualifier (, method-qualifier)) + )) + )) (put 'luna-define-method 'lisp-indent-function 'defun) @@ -180,20 +200,20 @@ BODY is the body of method." (defmacro luna-class-name (entity) "Return class-name of the ENTITY." - `(aref ,entity 0)) + (` (aref (, entity) 0))) (defmacro luna-set-class-name (entity name) - `(aset ,entity 0 ,name)) + (` (aset (, entity) 0 (, name)))) (defmacro luna-get-obarray (entity) - `(aref ,entity 1)) + (` (aref (, entity) 1))) (defmacro luna-set-obarray (entity obarray) - `(aset ,entity 1 ,obarray)) + (` (aset (, entity) 1 (, obarray)))) (defmacro luna-slot-index (entity slot-name) - `(luna-class-slot-index (luna-find-class (luna-class-name ,entity)) - ,slot-name)) + (` (luna-class-slot-index (luna-find-class (luna-class-name (, entity))) + (, slot-name)))) (defsubst luna-slot-value (entity slot) "Return the value of SLOT of ENTITY." @@ -204,8 +224,8 @@ BODY is the body of method." (aset entity (luna-slot-index entity slot) value)) (defmacro luna-find-functions (entity service) - `(luna-class-find-functions (luna-find-class (luna-class-name ,entity)) - ,service)) + (` (luna-class-find-functions (luna-find-class (luna-class-name (, entity))) + (, service)))) (defsubst luna-send (entity message &rest luna-current-method-arguments) "Send MESSAGE to ENTITY, and return the result. @@ -253,25 +273,12 @@ It must be plist and each slot name must have prefix `:'." (v (make-vector (luna-class-number-of-slots c) nil))) (luna-set-class-name v type) (luna-set-obarray v (make-vector 7 0)) - (apply #'luna-send v 'initialize-instance v init-args))) + (apply (function luna-send) v 'initialize-instance v init-args))) ;;; @ interface (generic function) ;;; -(defun luna-apply-generic (entity message &rest luna-current-method-arguments) - (let* ((class (luna-class-name entity)) - (cache (get message 'luna-method-cache)) - (sym (intern-soft (symbol-name class) cache)) - luna-next-methods) - (if sym - (setq luna-next-methods (symbol-value sym)) - (setq luna-next-methods - (luna-find-functions entity message)) - (set (intern (symbol-name class) cache) - luna-next-methods)) - (luna-call-next-method))) - (defsubst luna-arglist-to-arguments (arglist) (let (dest) (while arglist @@ -285,17 +292,15 @@ It must be plist and each slot name must have prefix `:'." "Define generic-function NAME. ARGS is argument of and DOC is DOC-string." (if doc - `(progn - (defun ,(intern (symbol-name name)) ,args - ,doc - (luna-apply-generic ,(car args) ',name - ,@(luna-arglist-to-arguments args))) - (put ',name 'luna-method-cache (make-vector 31 0))) - `(progn - (defun ,(intern (symbol-name name)) ,args - (luna-apply-generic ,(car args) ',name - ,@(luna-arglist-to-arguments args))) - (put ',name 'luna-method-cache (make-vector 31 0))))) + (` (defun (, (intern (symbol-name name))) (, args) + (, doc) + (luna-send (, (car args)) '(, name) + (,@ (luna-arglist-to-arguments args))) + )) + (` (defun (, (intern (symbol-name name))) (, args) + (luna-send (, (car args)) '(, name) + (,@ (luna-arglist-to-arguments args))) + )))) (put 'luna-define-generic 'lisp-indent-function 'defun) @@ -308,30 +313,35 @@ ARGS is argument of and DOC is DOC-string." (let ((entity-class (luna-find-class class-name)) parents parent-class) (mapatoms - (lambda (slot) - (if (luna-class-slot-index entity-class slot) - (catch 'derived - (setq parents (luna-class-parents entity-class)) - (while parents - (setq parent-class (luna-find-class (car parents))) - (if (luna-class-slot-index parent-class slot) - (throw 'derived nil)) - (setq parents (cdr parents))) - (eval - `(progn - (defmacro ,(intern (format "%s-%s-internal" - class-name slot)) - (entity) - (list 'aref entity - ,(luna-class-slot-index entity-class - (intern (symbol-name slot))))) - (defmacro ,(intern (format "%s-set-%s-internal" - class-name slot)) - (entity value) - (list 'aset entity - ,(luna-class-slot-index - entity-class (intern (symbol-name slot))) - value))))))) + (function + (lambda (slot) + (if (luna-class-slot-index entity-class slot) + (catch 'derived + (setq parents (luna-class-parents entity-class)) + (while parents + (setq parent-class (luna-find-class (car parents))) + (if (luna-class-slot-index parent-class slot) + (throw 'derived nil)) + (setq parents (cdr parents)) + ) + (eval + (` (progn + (defmacro (, (intern (format "%s-%s-internal" + class-name slot))) + (entity) + (list 'aref entity + (, (luna-class-slot-index entity-class + (intern (symbol-name slot)))) + )) + (defmacro (, (intern (format "%s-set-%s-internal" + class-name slot))) + (entity value) + (list 'aset entity + (, (luna-class-slot-index + entity-class (intern (symbol-name slot)))) + value)) + ))) + )))) (luna-class-obarray entity-class)))) diff --git a/mel-b-ccl.el b/mel-b-ccl.el index fa12483..32bd8c8 100644 --- a/mel-b-ccl.el +++ b/mel-b-ccl.el @@ -151,133 +151,147 @@ abcdefghijklmnopqrstuvwxyz\ (if-broken ccl-cascading-read (define-ccl-program mel-ccl-decode-b - `(1 - (loop - (loop - (read-branch - r1 - ,@(mapcar - (lambda (v) - (cond - ((or (eq v nil) (eq v t)) '(repeat)) - (t `((r0 = ,(lsh v 2)) (break))))) - mel-ccl-256-to-64-table))) - (loop - (read-branch - r1 - ,@(mapcar - (lambda (v) - (cond - ((or (eq v nil) (eq v t)) '(repeat)) - ((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break))) - (t `((r0 |= ,(lsh v -4)) (write r0) (r0 = ,(lsh (logand v 15) 4)) (break))))) - mel-ccl-256-to-64-table))) - (loop - (read-branch - r1 - ,@(mapcar - (lambda (v) - (cond - ((eq v nil) '(repeat)) - ((eq v t) '(end)) - ((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break))) - (t `((r0 |= ,(lsh v -2)) (write r0) (r0 = ,(lsh (logand v 3) 6)) (break))))) - mel-ccl-256-to-64-table))) - (loop - (read-branch - r1 - ,@(mapcar - (lambda (v) - (cond - ((eq v nil) '(repeat)) - ((eq v t) '(end)) - (t `((r0 |= ,v) (write r0) (break))))) - mel-ccl-256-to-64-table))) - (repeat)))) + (` (1 + (loop + (loop + (read-branch + r1 + (,@ (mapcar + (lambda (v) + (cond + ((or (eq v nil) (eq v t)) '(repeat)) + (t (` ((r0 = (, (lsh v 2))) (break)))))) + mel-ccl-256-to-64-table)))) + (loop + (read-branch + r1 + (,@ (mapcar + (lambda (v) + (cond + ((or (eq v nil) (eq v t)) '(repeat)) + ((= (lsh v -4) 0) + (` ((write r0) + (r0 = (, (lsh (logand v 15) 4))) + (break)))) + (t + (` ((r0 |= (, (lsh v -4))) + (write r0) + (r0 = (, (lsh (logand v 15) 4))) + (break)))))) + mel-ccl-256-to-64-table)))) + (loop + (read-branch + r1 + (,@ (mapcar + (lambda (v) + (cond + ((eq v nil) '(repeat)) + ((eq v t) '(end)) + ((= (lsh v -2) 0) + (` ((write r0) + (r0 = (, (lsh (logand v 3) 6))) + (break)))) + (t + (` ((r0 |= (, (lsh v -2))) + (write r0) + (r0 = (, (lsh (logand v 3) 6))) + (break)))))) + mel-ccl-256-to-64-table)))) + (loop + (read-branch + r1 + (,@ (mapcar + (lambda (v) + (cond + ((eq v nil) '(repeat)) + ((eq v t) '(end)) + (t (` ((r0 |= (, v)) (write r0) (break)))))) + mel-ccl-256-to-64-table)))) + (repeat))))) (define-ccl-program mel-ccl-decode-b - `(1 - (loop - (read r0 r1 r2 r3) - (r4 = r0 ,mel-ccl-decode-b-0-table) - (r5 = r1 ,mel-ccl-decode-b-1-table) - (r4 |= r5) - (r5 = r2 ,mel-ccl-decode-b-2-table) - (r4 |= r5) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (if (r4 & ,(lognot (1- (lsh 1 24)))) - ((loop - (if (r4 & ,(lsh 1 24)) - ((r0 = r1) (r1 = r2) (r2 = r3) (read r3) - (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (repeat)) - (break))) - (loop - (if (r4 & ,(lsh 1 25)) - ((r1 = r2) (r2 = r3) (read r3) - (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (repeat)) - (break))) - (loop - (if (r2 != ?=) - (if (r4 & ,(lsh 1 26)) - ((r2 = r3) (read r3) - (r4 >>= 1) (r4 &= ,(logior (lsh 7 24))) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (repeat)) - ((r6 = 0) - (break))) - ((r6 = 1) - (break)))) - (loop - (if (r3 != ?=) - (if (r4 & ,(lsh 1 27)) - ((read r3) - (r4 = r3 ,mel-ccl-decode-b-3-table) - (repeat)) - (break)) - ((r6 |= 2) - (break)))) - (r4 = r0 ,mel-ccl-decode-b-0-table) - (r5 = r1 ,mel-ccl-decode-b-1-table) - (r4 |= r5) - (branch - r6 - ;; BBBB - ((r5 = r2 ,mel-ccl-decode-b-2-table) - (r4 |= r5) - (r5 = r3 ,mel-ccl-decode-b-3-table) - (r4 |= r5) - (r4 >8= 0) - (write r7) - (r4 >8= 0) - (write r7) - (write-repeat r4)) - ;; error: BB=B - ((write (r4 & 255)) - (end)) - ;; BBB= - ((r5 = r2 ,mel-ccl-decode-b-2-table) + (` (1 + (loop + (read r0 r1 r2 r3) + (r4 = r0 (, mel-ccl-decode-b-0-table)) + (r5 = r1 (, mel-ccl-decode-b-1-table)) + (r4 |= r5) + (r5 = r2 (, mel-ccl-decode-b-2-table)) + (r4 |= r5) + (r5 = r3 (, mel-ccl-decode-b-3-table)) + (r4 |= r5) + (if (r4 & (, (lognot (1- (lsh 1 24))))) + ((loop + (if (r4 & (, (lsh 1 24))) + ((r0 = r1) (r1 = r2) (r2 = r3) (read r3) + (r4 >>= 1) (r4 &= (, (logior (lsh 7 24)))) + (r5 = r3 (, mel-ccl-decode-b-3-table)) + (r4 |= r5) + (repeat)) + (break))) + (loop + (if (r4 & (, (lsh 1 25))) + ((r1 = r2) (r2 = r3) (read r3) + (r4 >>= 1) (r4 &= (, (logior (lsh 7 24)))) + (r5 = r3 (, mel-ccl-decode-b-3-table)) + (r4 |= r5) + (repeat)) + (break))) + (loop + (if (r2 != ?=) + (if (r4 & (, (lsh 1 26))) + ((r2 = r3) (read r3) + (r4 >>= 1) (r4 &= (, (logior (lsh 7 24)))) + (r5 = r3 (, mel-ccl-decode-b-3-table)) + (r4 |= r5) + (repeat)) + ((r6 = 0) + (break))) + ((r6 = 1) + (break)))) + (loop + (if (r3 != ?=) + (if (r4 & (, (lsh 1 27))) + ((read r3) + (r4 = r3 (, mel-ccl-decode-b-3-table)) + (repeat)) + (break)) + ((r6 |= 2) + (break)))) + (r4 = r0 (, mel-ccl-decode-b-0-table)) + (r5 = r1 (, mel-ccl-decode-b-1-table)) (r4 |= r5) - (r4 >8= 0) - (write r7) - (write (r4 & 255)) - (end) ; Excessive (end) is workaround for XEmacs 21.0. + (branch + r6 + ;; BBBB + ((r5 = r2 (, mel-ccl-decode-b-2-table)) + (r4 |= r5) + (r5 = r3 (, mel-ccl-decode-b-3-table)) + (r4 |= r5) + (r4 >8= 0) + (write r7) + (r4 >8= 0) + (write r7) + (write-repeat r4)) + ;; error: BB=B + ((write (r4 & 255)) + (end)) + ;; BBB= + ((r5 = r2 (, mel-ccl-decode-b-2-table)) + (r4 |= r5) + (r4 >8= 0) + (write r7) + (write (r4 & 255)) + (end) ; Excessive (end) is workaround for XEmacs 21.0. ; Without this, "AAA=" is converted to "^@^@^@". - (end)) - ;; BB== - ((write (r4 & 255)) - (end)))) - ((r4 >8= 0) - (write r7) - (r4 >8= 0) - (write r7) - (write-repeat r4)))))) + (end)) + ;; BB== + ((write (r4 & 255)) + (end)))) + ((r4 >8= 0) + (write r7) + (r4 >8= 0) + (write r7) + (write-repeat r4))))))) ) (eval-when-compile @@ -286,81 +300,81 @@ abcdefghijklmnopqrstuvwxyz\ ;; is not executed. (defun mel-ccl-encode-base64-generic (&optional quantums-per-line output-crlf terminate-with-newline) - `(2 - ((r3 = 0) - (r2 = 0) - (read r1) - (loop + (` (2 + ((r3 = 0) + (r2 = 0) + (read r1) + (loop + (branch + r1 + (,@ (mapcar + (lambda (r1) + (` ((write (, (nth (lsh r1 -2) mel-ccl-64-to-256-table))) + (r0 = (, (logand r1 3)))))) + mel-ccl-256-table))) + (r2 = 1) + (read-branch + r1 + (,@ (mapcar + (lambda (r1) + (` ((write r0 (, (vconcat + (mapcar + (lambda (r0) + (nth (logior (lsh r0 4) + (lsh r1 -4)) + mel-ccl-64-to-256-table)) + mel-ccl-4-table)))) + (r0 = (, (logand r1 15)))))) + mel-ccl-256-table))) + (r2 = 2) + (read-branch + r1 + (,@ (mapcar + (lambda (r1) + (` ((write r0 (, (vconcat + (mapcar + (lambda (r0) + (nth (logior (lsh r0 2) + (lsh r1 -6)) + mel-ccl-64-to-256-table)) + mel-ccl-16-table))))))) + mel-ccl-256-table))) + (r1 &= 63) + (write r1 (, (vconcat + (mapcar + (lambda (r1) + (nth r1 mel-ccl-64-to-256-table)) + mel-ccl-64-table)))) + (r3 += 1) + (r2 = 0) + (read r1) + (,@ (when quantums-per-line + (` ((if (r3 == (, quantums-per-line)) + ((write (, (if output-crlf "\r\n" "\n"))) + (r3 = 0))))))) + (repeat))) (branch - r1 - ,@(mapcar - (lambda (r1) - `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table)) - (r0 = ,(logand r1 3)))) - mel-ccl-256-table)) - (r2 = 1) - (read-branch - r1 - ,@(mapcar - (lambda (r1) - `((write r0 ,(vconcat - (mapcar - (lambda (r0) - (nth (logior (lsh r0 4) - (lsh r1 -4)) - mel-ccl-64-to-256-table)) - mel-ccl-4-table))) - (r0 = ,(logand r1 15)))) - mel-ccl-256-table)) - (r2 = 2) - (read-branch - r1 - ,@(mapcar - (lambda (r1) - `((write r0 ,(vconcat - (mapcar - (lambda (r0) - (nth (logior (lsh r0 2) - (lsh r1 -6)) - mel-ccl-64-to-256-table)) - mel-ccl-16-table))))) - mel-ccl-256-table)) - (r1 &= 63) - (write r1 ,(vconcat - (mapcar - (lambda (r1) - (nth r1 mel-ccl-64-to-256-table)) - mel-ccl-64-table))) - (r3 += 1) - (r2 = 0) - (read r1) - ,@(when quantums-per-line - `((if (r3 == ,quantums-per-line) - ((write ,(if output-crlf "\r\n" "\n")) - (r3 = 0))))) - (repeat))) - (branch - r2 - ,(if terminate-with-newline - `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n"))) - `(r0 = 0)) - ((write r0 ,(vconcat - (mapcar - (lambda (r0) - (nth (lsh r0 4) mel-ccl-64-to-256-table)) - mel-ccl-4-table))) - (write ,(if terminate-with-newline - (if output-crlf "==\r\n" "==\n") - "=="))) - ((write r0 ,(vconcat - (mapcar - (lambda (r0) - (nth (lsh r0 2) mel-ccl-64-to-256-table)) - mel-ccl-16-table))) - (write ,(if terminate-with-newline - (if output-crlf "=\r\n" "=\n") - "=")))) - )) + r2 + (, (if terminate-with-newline + (` (if (r3 > 0) (write (, (if output-crlf "\r\n" "\n"))))) + (` (r0 = 0)))) + ((write r0 (, (vconcat + (mapcar + (lambda (r0) + (nth (lsh r0 4) mel-ccl-64-to-256-table)) + mel-ccl-4-table)))) + (write (, (if terminate-with-newline + (if output-crlf "==\r\n" "==\n") + "==")))) + ((write r0 (, (vconcat + (mapcar + (lambda (r0) + (nth (lsh r0 2) mel-ccl-64-to-256-table)) + mel-ccl-16-table)))) + (write (, (if terminate-with-newline + (if output-crlf "=\r\n" "=\n") + "="))))) + ))) ) (define-ccl-program mel-ccl-encode-b diff --git a/mel-b-el.el b/mel-b-el.el index 2937238..45c80c2 100644 --- a/mel-b-el.el +++ b/mel-b-el.el @@ -100,7 +100,7 @@ external decoder is called." ) (defmacro base64-num-to-char (n) - `(aref base64-characters ,n)) + (` (aref base64-characters (, n)))) (defun base64-encode-1 (pack) (let ((buf (make-string 4 ?=))) @@ -170,7 +170,7 @@ into shorter lines." vec))) (defmacro base64-char-to-num (c) - `(aref base64-numbers ,c)) + (` (aref base64-numbers (, c)))) (defsubst base64-internal-decode (string buffer) (let* ((len (length string)) diff --git a/mel-q-ccl.el b/mel-q-ccl.el index c71fab6..c15fed2 100644 --- a/mel-q-ccl.el +++ b/mel-q-ccl.el @@ -144,77 +144,77 @@ abcdefghijklmnopqrstuvwxyz\ ;;; Q (define-ccl-program mel-ccl-decode-q - `(1 - ((loop - (read-branch - r0 - ,@(mapcar - (lambda (r0) - (cond - ((= r0 (char-int ?_)) - `(write-repeat ? )) - ((= r0 (char-int ?=)) - `((loop - (read-branch - r1 - ,@(mapcar - (lambda (v) - (if (integerp v) - `((r0 = ,v) (break)) - '(repeat))) - mel-ccl-256-to-16-table))) - (loop - (read-branch - r1 - ,@(mapcar - (lambda (v) - (if (integerp v) - `((write r0 ,(vconcat - (mapcar - (lambda (r0) - (logior (lsh r0 4) v)) - mel-ccl-16-table))) - (break)) - '(repeat))) - mel-ccl-256-to-16-table))) - (repeat))) - (t - `(write-repeat ,r0)))) - mel-ccl-256-table)))))) + (` (1 + ((loop + (read-branch + r0 + (,@ (mapcar + (lambda (r0) + (cond + ((= r0 (char-int ?_)) + (` (write-repeat ? ))) + ((= r0 (char-int ?=)) + (` ((loop + (read-branch + r1 + (,@ (mapcar + (lambda (v) + (if (integerp v) + (` ((r0 = (, v)) (break))) + '(repeat))) + mel-ccl-256-to-16-table)))) + (loop + (read-branch + r1 + (,@ (mapcar + (lambda (v) + (if (integerp v) + (` ((write r0 (, (vconcat + (mapcar + (lambda (r0) + (logior (lsh r0 4) v)) + mel-ccl-16-table)))) + (break))) + '(repeat))) + mel-ccl-256-to-16-table)))) + (repeat)))) + (t + (` (write-repeat (, r0)))))) + mel-ccl-256-table)))))))) (eval-when-compile (defun mel-ccl-encode-q-generic (raw) - `(3 - (loop - (loop - (read-branch - r0 - ,@(mapcar - (lambda (r0) - (cond - ((= r0 32) `(write-repeat ?_)) - ((member r0 raw) `(write-repeat ,r0)) - (t '(break)))) - mel-ccl-256-table))) - (write ?=) - (write r0 ,mel-ccl-high-table) - (write r0 ,mel-ccl-low-table) - (repeat)))) + (` (3 + (loop + (loop + (read-branch + r0 + (,@ (mapcar + (lambda (r0) + (cond + ((= r0 32) '(write-repeat ?_)) + ((member r0 raw) (` (write-repeat (, r0)))) + (t '(break)))) + mel-ccl-256-table)))) + (write ?=) + (write r0 (, mel-ccl-high-table)) + (write r0 (, mel-ccl-low-table)) + (repeat))))) ;; On xemacs, generated program counts iso-8859-1 8bit character as 6bytes. (defun mel-ccl-count-q-length (raw) - `(0 - ((r0 = 0) - (loop - (read-branch - r1 - ,@(mapcar - (lambda (r1) - (if (or (= r1 32) (member r1 raw)) - '((r0 += 1) (repeat)) - '((r0 += 3) (repeat)))) - mel-ccl-256-table)))))) + (` (0 + ((r0 = 0) + (loop + (read-branch + r1 + (,@ (mapcar + (lambda (r1) + (if (or (= r1 32) (member r1 raw)) + '((r0 += 1) (repeat)) + '((r0 += 3) (repeat)))) + mel-ccl-256-table)))))))) ) @@ -243,7 +243,7 @@ abcdefghijklmnopqrstuvwxyz\ (unless p (setq p (cons branch (length eof-block-branches)) eof-block-branches (cons p eof-block-branches))) - `(,eof-block-reg = ,(cdr p)))) + (` ((, eof-block-reg) = (, (cdr p)))))) ) @@ -255,17 +255,17 @@ abcdefghijklmnopqrstuvwxyz\ lf-eof lf-fail crlf-eof crlf-fail) (if input-crlf - `(,(mel-ccl-set-eof-block cr-eof) - (read-if (,reg == ?\r) - (,(mel-ccl-set-eof-block lf-eof) - (read-if (,reg == ?\n) - ,succ - ,lf-fail)) - ,cr-fail)) - `(,(mel-ccl-set-eof-block crlf-eof) - (read-if (,reg == ?\n) - ,succ - ,crlf-fail)))) + (` ((, (mel-ccl-set-eof-block cr-eof)) + (read-if ((, reg) == ?\r) + ((, (mel-ccl-set-eof-block lf-eof)) + (read-if ((, reg) == ?\n) + (, succ) + (, lf-fail))) + (, cr-fail)))) + (` ((, (mel-ccl-set-eof-block crlf-eof)) + (read-if ((, reg) == ?\n) + (, succ) + (, crlf-fail)))))) ) @@ -287,528 +287,525 @@ abcdefghijklmnopqrstuvwxyz\ (type-wsp 2) (type-brk 3) ) - `(4 - ((,column = 0) - (,after-wsp = 0) - ,(mel-ccl-set-eof-block '(end)) - (read r0) - (loop ; invariant: column <= 75 - (loop - (loop - (branch - r0 - ,@(mapcar - (lambda (r0) - (let ((tmp (aref mel-ccl-qp-table r0))) - (cond - ((eq r0 (char-int ?F)) - `(if (,column == 0) - (,(mel-ccl-set-eof-block '((write "F") (end))) - (read-if (r0 == ?r) - (,(mel-ccl-set-eof-block '((write "Fr") (end))) - (read-if (r0 == ?o) - (,(mel-ccl-set-eof-block '((write "Fro") (end))) - (read-if (r0 == ?m) - (,(mel-ccl-set-eof-block '((write "From") (end))) - (read-if (r0 == ? ) - ((,column = 7) - (,after-wsp = 1) - ,(mel-ccl-set-eof-block '((write "From=20") (end))) - (read r0) - (write-repeat "=46rom ")) - ((,column = 4) - (write-repeat "From")))) - ((,column = 3) - (write-repeat "Fro")))) - ((,column = 2) - (write-repeat "Fr")))) - ((,column = 1) - (write-repeat "F")))) - ((,type = ,type-raw) (break)) ; RAW - )) - ((eq r0 (char-int ?.)) - `(if (,column == 0) - ,(mel-ccl-try-to-read-crlf - input-crlf 'r0 - ;; "." CR LF (input-crlf: t) - ;; "." LF (input-crlf: nil) - `((write ,(concat "=2E" hard)) - ,(mel-ccl-set-eof-block '(end)) - (read r0) - (repeat)) - ;; "." - '((write ".") (end)) - ;; "." noCR (input-crlf: t) - `((,column = 1) - (write-repeat ".")) - ;; "." CR (input-crlf: t) - '((write ".=0D") (end)) - ;; "." CR noLF (input-crlf: t) - `((,column = 4) - (write-repeat ".=0D")) - ;; "." (input-crlf: nil) - '((write ".") (end)) - ;; "." noLF (input-crlf: nil) - `((,column = 1) - (write-repeat "."))) - ((,type = ,type-raw) (break)) ; RAW - )) - ((eq tmp 'raw) `((,type = ,type-raw) (break))) - ((eq tmp 'enc) `((,type = ,type-enc) (break))) - ((eq tmp 'wsp) `((,type = ,type-wsp) (break))) - ((eq tmp 'cr) `((,type = ,(if input-crlf type-brk type-enc)) - (break))) - ((eq tmp 'lf) `((,type = ,(if input-crlf type-enc type-brk)) - (break))) - ))) - mel-ccl-256-table))) - ;; r0:type{raw,enc,wsp,brk} - (branch - ,type - ;; r0:type-raw - (if (,column < 75) - ((,column += 1) - (,after-wsp = 0) - ,(mel-ccl-set-eof-block '(end)) - (write-read-repeat r0)) - ((r1 = (r0 + 0)) - (,after-wsp = 0) - ,@(mel-ccl-try-to-read-crlf - input-crlf 'r0 - `((,column = 0) - (write r1) - ,(mel-ccl-set-eof-block `((write ,hard) (end))) - (read r0) - (write-repeat ,hard)) - '((write r1) (end)) - `((,column = 1) - (write ,soft) (write-repeat r1)) - `((write ,soft) (write r1) (write "=0D") (end)) - `((,column = 4) - (write ,soft) (write r1) (write-repeat "=0D")) - '((write r1) (end)) - `((,column = 1) - (write ,soft) (write-repeat r1))))) - ;; r0:type-enc - ((,after-wsp = 0) - (if (,column < 73) - ((,column += 3) - (write "=") - (write r0 ,mel-ccl-high-table) - ,(mel-ccl-set-eof-block '(end)) - (write-read-repeat r0 ,mel-ccl-low-table)) - (if (,column < 74) - ((r1 = (r0 + 0)) - (,after-wsp = 0) - ,@(mel-ccl-try-to-read-crlf - input-crlf 'r0 - `((,column = 0) - (write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (write ,hard) - ,(mel-ccl-set-eof-block '(end)) - (read r0) - (repeat)) - `((write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (end)) - `((,column = 3) - (write ,(concat soft "=")) - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (repeat)) - `((write ,(concat soft "=")) - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (write "=0D") - (end)) - `((,column = 6) - (write ,(concat soft "=")) - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (write-repeat "=0D")) - `((write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (end)) - `((,column = 3) - (write ,(concat soft "=")) - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (repeat)))) - ((,column = 3) - (write ,(concat soft "=")) - (write r0 ,mel-ccl-high-table) - ,(mel-ccl-set-eof-block '(end)) - (write-read-repeat r0 ,mel-ccl-low-table))))) - ;; r0:type-wsp - (if (,column < 73) + (` (4 + (((, column) = 0) + ((, after-wsp) = 0) + (, (mel-ccl-set-eof-block '(end))) + (read r0) + (loop ; invariant: column <= 75 + (loop + (loop + (branch + r0 + (,@ (mapcar + (lambda (r0) + (let ((tmp (aref mel-ccl-qp-table r0))) + (cond + ((eq r0 (char-int ?F)) + (` (if ((, column) == 0) + ((, (mel-ccl-set-eof-block '((write "F") (end)))) + (read-if (r0 == ?r) + ((, (mel-ccl-set-eof-block '((write "Fr") (end)))) + (read-if (r0 == ?o) + ((, (mel-ccl-set-eof-block '((write "Fro") (end)))) + (read-if (r0 == ?m) + ((, (mel-ccl-set-eof-block '((write "From") (end)))) + (read-if (r0 == ? ) + (((, column) = 7) + ((, after-wsp) = 1) + (, (mel-ccl-set-eof-block '((write "From=20") (end)))) + (read r0) + (write-repeat "=46rom ")) + (((, column) = 4) + (write-repeat "From")))) + (((, column) = 3) + (write-repeat "Fro")))) + (((, column) = 2) + (write-repeat "Fr")))) + (((, column) = 1) + (write-repeat "F")))) + (((, type) = (, type-raw)) (break)) ; RAW + ))) + ((eq r0 (char-int ?.)) + (` (if ((, column) == 0) + (, (mel-ccl-try-to-read-crlf + input-crlf 'r0 + ;; "." CR LF (input-crlf: t) + ;; "." LF (input-crlf: nil) + (` ((write (, (concat "=2E" hard))) + (, (mel-ccl-set-eof-block '(end))) + (read r0) + (repeat))) + ;; "." + '((write ".") (end)) + ;; "." noCR (input-crlf: t) + (` (((, column) = 1) + (write-repeat "."))) + ;; "." CR (input-crlf: t) + '((write ".=0D") (end)) + ;; "." CR noLF (input-crlf: t) + (` (((, column) = 4) + (write-repeat ".=0D"))) + ;; "." (input-crlf: nil) + '((write ".") (end)) + ;; "." noLF (input-crlf: nil) + (` (((, column) = 1) + (write-repeat "."))))) + (((, type) = (, type-raw)) (break)) ; RAW + ))) + ((eq tmp 'raw) (` (((, type) = (, type-raw)) (break)))) + ((eq tmp 'enc) (` (((, type) = (, type-enc)) (break)))) + ((eq tmp 'wsp) (` (((, type) = (, type-wsp)) (break)))) + ((eq tmp 'cr) (` (((, type) = (, (if input-crlf type-brk type-enc))) + (break)))) + ((eq tmp 'lf) (` (((, type) = (, (if input-crlf type-enc type-brk))) + (break)))) + ))) + mel-ccl-256-table)))) + ;; r0:type{raw,enc,wsp,brk} + (branch + (, type) + ;; r0:type-raw + (if ((, column) < 75) + (((, column) += 1) + ((, after-wsp) = 0) + (, (mel-ccl-set-eof-block '(end))) + (write-read-repeat r0)) ((r1 = (r0 + 0)) - ,@(mel-ccl-try-to-read-crlf - input-crlf 'r0 - `((,column = 0) - (,after-wsp = 0) - (write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (write ,hard) - ,(mel-ccl-set-eof-block `(end)) - (read r0) - (repeat)) - `((write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (end)) - `((,column += 1) - (,after-wsp = 1) - (write-repeat r1)) - `((write r1) - (write "=0D") - (end)) - `((,column += 4) - (,after-wsp = 0) - (write r1) - (write-repeat "=0D")) - `((write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (end)) - `((,column += 1) - (,after-wsp = 1) - (write-repeat r1)))) - (if (,column < 74) - ((r1 = (r0 + 0)) - ,@(mel-ccl-try-to-read-crlf + ((, after-wsp) = 0) + (,@ (mel-ccl-try-to-read-crlf input-crlf 'r0 - `((,column = 0) - (,after-wsp = 0) - (write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (write ,hard) - ,(mel-ccl-set-eof-block `(end)) - (read r0) - (repeat)) - `((write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (end)) - `((,column += 1) - (,after-wsp = 1) - (write-repeat r1)) - `((write r1) - (write ,(concat soft "=0D")) - (end)) - `((,column = 3) - (,after-wsp = 0) - (write r1) - (write-repeat ,(concat soft "=0D"))) - `((write "=") - (write r1 ,mel-ccl-high-table) - (write r1 ,mel-ccl-low-table) - (end)) - `((,column += 1) - (,after-wsp = 1) - (write-repeat r1)))) - (if (,column < 75) - ((,column += 1) - (,after-wsp = 1) - ,(mel-ccl-set-eof-block `((write ,soft) (end))) - (write-read-repeat r0)) - ((write ,soft) - (,column = 0) - (,after-wsp = 0) - (repeat))))) - ;; r0:type-brk - ,(if input-crlf - ;; r0{CR}:type-brk - `((if ((,column > 73) & ,after-wsp) - ((,column = 0) - (,after-wsp = 0) - (write ,soft))) - ,(mel-ccl-set-eof-block `((if (,column > 73) (write ,soft)) - (write "=0D") (end))) - (read-if (r0 == ?\n) - (if ,after-wsp - ((,after-wsp = 0) - (,column = 0) - (write ,(concat soft hard)) - ,(mel-ccl-set-eof-block '(end)) + (` (((, column) = 0) + (write r1) + (, (mel-ccl-set-eof-block (` ((write (, hard)) (end))))) (read r0) - (repeat)) - ((,after-wsp = 0) - (,column = 0) - (write ,hard) - ,(mel-ccl-set-eof-block '(end)) - (read r0) - (repeat))) - (if (,column < 73) - ((,after-wsp = 0) - (,column += 3) - (write-repeat "=0D")) - (if (,column < 74) - (if (r0 == ?\r) - ((,after-wsp = 0) - ,(mel-ccl-set-eof-block - `((write ,(concat soft "=0D=0D")) (end))) - (read-if (r0 == ?\n) - ((,column = 0) - ,(mel-ccl-set-eof-block - `((write ,(concat "=0D" hard)) (end))) - (read r0) - (write-repeat ,(concat "=0D" hard))) - ((,column = 6) - (write-repeat ,(concat soft "=0D=0D"))))) - ((,after-wsp = 0) - (,column = 3) - (write-repeat ,(concat soft "=0D")))) - ((,after-wsp = 0) - (,column = 3) - (write-repeat ,(concat soft "=0D"))))))) - ;; r0{LF}:type-brk - `(if ,after-wsp - ;; WSP ; r0{LF}:type-brk - ((,after-wsp = 0) - (,column = 0) - (write ,(concat soft (if output-crlf "\r" ""))) - ,(mel-ccl-set-eof-block `(end)) - (write-read-repeat r0)) - ;; noWSP ; r0{LF}:type-brk - ((,after-wsp = 0) - (,column = 0) - ,@(if output-crlf '((write ?\r)) '()) - ,(mel-ccl-set-eof-block `(end)) - (write-read-repeat r0))) - ))))) - (branch - ,eof-block-reg - ,@(reverse (mapcar 'car eof-block-branches)))))) + (write-repeat (, hard)))) + '((write r1) (end)) + (` (((, column) = 1) + (write (, soft)) (write-repeat r1))) + (` ((write (, soft)) (write r1) (write "=0D") (end))) + (` (((, column) = 4) + (write (, soft)) (write r1) (write-repeat "=0D"))) + '((write r1) (end)) + (` (((, column) = 1) + (write (, soft)) (write-repeat r1))))))) + ;; r0:type-enc + (((, after-wsp) = 0) + (if ((, column) < 73) + (((, column) += 3) + (write "=") + (write r0 (, mel-ccl-high-table)) + (, (mel-ccl-set-eof-block '(end))) + (write-read-repeat r0 (, mel-ccl-low-table))) + (if ((, column) < 74) + ((r1 = (r0 + 0)) + ((, after-wsp) = 0) + (,@ (mel-ccl-try-to-read-crlf + input-crlf 'r0 + (` (((, column) = 0) + (write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (write (, hard)) + (, (mel-ccl-set-eof-block '(end))) + (read r0) + (repeat))) + (` ((write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (end))) + (` (((, column) = 3) + (write (, (concat soft "="))) + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (repeat))) + (` ((write (, (concat soft "="))) + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (write "=0D") + (end))) + (` (((, column) = 6) + (write (, (concat soft "="))) + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (write-repeat "=0D"))) + (` ((write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (end))) + (` (((, column) = 3) + (write (, (concat soft "="))) + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (repeat)))))) + (((, column) = 3) + (write (, (concat soft "="))) + (write r0 (, mel-ccl-high-table)) + (, (mel-ccl-set-eof-block '(end))) + (write-read-repeat r0 (, mel-ccl-low-table)))))) + ;; r0:type-wsp + (if ((, column) < 73) + ((r1 = (r0 + 0)) + (,@ (mel-ccl-try-to-read-crlf + input-crlf 'r0 + (` (((, column) = 0) + ((, after-wsp) = 0) + (write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (write (, hard)) + (, (mel-ccl-set-eof-block (` (end)))) + (read r0) + (repeat))) + (` ((write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (end))) + (` (((, column) += 1) + ((, after-wsp) = 1) + (write-repeat r1))) + (` ((write r1) + (write "=0D") + (end))) + (` (((, column) += 4) + ((, after-wsp) = 0) + (write r1) + (write-repeat "=0D"))) + (` ((write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) (end))) + (` (((, column) += 1) + ((, after-wsp) = 1) + (write-repeat r1)))))) + (if ((, column) < 74) + ((r1 = (r0 + 0)) + (,@ (mel-ccl-try-to-read-crlf + input-crlf 'r0 + (` (((, column) = 0) + ((, after-wsp) = 0) + (write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (write (, hard)) + (, (mel-ccl-set-eof-block (` (end)))) + (read r0) + (repeat))) + (` ((write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) (end))) + (` (((, column) += 1) + ((, after-wsp) = 1) + (write-repeat r1))) + (` ((write r1) + (write (, (concat soft "=0D"))) + (end))) + (` (((, column) = 3) + ((, after-wsp) = 0) + (write r1) + (write-repeat (, (concat soft "=0D"))))) + (` ((write "=") + (write r1 (, mel-ccl-high-table)) + (write r1 (, mel-ccl-low-table)) + (end))) + (` (((, column) += 1) + ((, after-wsp) = 1) + (write-repeat r1)))))) + (if ((, column) < 75) + (((, column) += 1) + ((, after-wsp) = 1) + (, (mel-ccl-set-eof-block (` ((write (, soft)) (end))))) + (write-read-repeat r0)) + ((write (, soft)) + ((, column) = 0) + ((, after-wsp) = 0) + (repeat))))) + ;; r0:type-brk + (, (if input-crlf + ;; r0{CR}:type-brk + (` ((if (((, column) > 73) & (, after-wsp)) + (((, column) = 0) + ((, after-wsp) = 0) + (write (, soft)))) + (, (mel-ccl-set-eof-block (` ((if ((, column) > 73) (write (, soft))) + (write "=0D") (end))))) + (read-if (r0 == ?\n) + (if (, after-wsp) + (((, after-wsp) = 0) + ((, column) = 0) + (write (, (concat soft hard))) + (, (mel-ccl-set-eof-block '(end))) + (read r0) + (repeat)) + (((, after-wsp) = 0) + ((, column) = 0) + (write (, hard)) + (, (mel-ccl-set-eof-block '(end))) + (read r0) + (repeat))) + (if ((, column) < 73) + (((, after-wsp) = 0) + ((, column) += 3) + (write-repeat "=0D")) + (if ((, column) < 74) + (if (r0 == ?\r) + (((, after-wsp) = 0) + (, (mel-ccl-set-eof-block + (` ((write (, (concat soft "=0D=0D"))) (end))))) + (read-if (r0 == ?\n) + (((, column) = 0) + (, (mel-ccl-set-eof-block + (` ((write (, (concat "=0D" hard))) (end))))) + (read r0) + (write-repeat (, (concat "=0D" hard)))) + (((, column) = 6) + (write-repeat (, (concat soft "=0D=0D")))))) + (((, after-wsp) = 0) + ((, column) = 3) + (write-repeat (, (concat soft "=0D"))))) + (((, after-wsp) = 0) + ((, column) = 3) + (write-repeat (, (concat soft "=0D"))))))))) + ;; r0{LF}:type-brk + (` (if (, after-wsp) + ;; WSP ; r0{LF}:type-brk + (((, after-wsp) = 0) + ((, column) = 0) + (write (, (concat soft (if output-crlf "\r" "")))) + (, (mel-ccl-set-eof-block (` (end)))) (write-read-repeat r0)) + ;; noWSP ; r0{LF}:type-brk + (((, after-wsp) = 0) + ((, column) = 0) + (,@ (if output-crlf '((write ?\r)) '())) + (, (mel-ccl-set-eof-block (` (end)))) + (write-read-repeat r0)))) + )))))) + (branch + (, eof-block-reg) + (,@ (reverse (mapcar (quote car) eof-block-branches)))))))) (defun mel-ccl-decode-quoted-printable-generic (input-crlf output-crlf) - `(1 - ((read r0) - (loop - (branch - r0 - ,@(mapcar - (lambda (r0) - (let ((tmp (aref mel-ccl-qp-table r0))) - (cond - ((eq tmp 'raw) `(write-read-repeat r0)) - ((eq tmp 'wsp) (if (eq r0 (char-int ? )) - `(r1 = 1) - `(r1 = 0))) - ((eq tmp 'cr) - (if input-crlf - ;; r0='\r' - `((read r0) - ;; '\r' r0 - (if (r0 == ?\n) - ;; '\r' r0='\n' - ;; hard line break found. - ,(if output-crlf - '((write ?\r) - (write-read-repeat r0)) - '(write-read-repeat r0)) - ;; '\r' r0:[^\n] - ;; invalid control character (bare CR) found. - ;; -> ignore it and rescan from r0. - (repeat))) - ;; r0='\r' - ;; invalid character (bare CR) found. - ;; -> ignore. - `((read r0) - (repeat)))) - ((eq tmp 'lf) - (if input-crlf - ;; r0='\n' - ;; invalid character (bare LF) found. - ;; -> ignore. - `((read r0) - (repeat)) - ;; r0='\r\n' - ;; hard line break found. - (if output-crlf - '((write ?\r) - (write-read-repeat r0)) - '(write-read-repeat r0)))) - ((eq r0 (char-int ?=)) - ;; r0='=' - `((read r0) - ;; '=' r0 - (r1 = (r0 == ?\t)) - (if ((r0 == ? ) | r1) - ;; '=' r0:[\t ] - ;; Skip transport-padding. - ;; It should check CR LF after - ;; transport-padding. - (loop - (read-if (r0 == ?\t) - (repeat) - (if (r0 == ? ) - (repeat) - (break))))) - ;; '=' [\t ]* r0:[^\t ] - (branch - r0 - ,@(mapcar - (lambda (r0) - (cond - ((eq r0 (char-int ?\r)) - (if input-crlf - ;; '=' [\t ]* r0='\r' - `((read r0) - ;; '=' [\t ]* '\r' r0 - (if (r0 == ?\n) - ;; '=' [\t ]* '\r' r0='\n' - ;; soft line break found. - ((read r0) - (repeat)) - ;; '=' [\t ]* '\r' r0:[^\n] - ;; invalid input -> - ;; output "=" and rescan from r0. - ((write "=") - (repeat)))) - ;; '=' [\t ]* r0='\r' - ;; invalid input (bare CR found) -> - ;; output "=" and rescan from next. - `((write ?=) - (read r0) - (repeat)))) - ((eq r0 (char-int ?\n)) - (if input-crlf - ;; '=' [\t ]* r0='\n' - ;; invalid input (bare LF found) -> - ;; output "=" and rescan from next. - `((write ?=) - (read r0) - (repeat)) - ;; '=' [\t ]* r0='\r\n' - ;; soft line break found. - `((read r0) - (repeat)))) - ((setq tmp (nth r0 mel-ccl-256-to-16-table)) - ;; '=' [\t ]* r0:[0-9A-F] - ;; upper nibble of hexadecimal digit found. - `((r1 = (r0 + 0)) - (r0 = ,tmp))) - (t - ;; '=' [\t ]* r0:[^\r0-9A-F] - ;; invalid input -> - ;; output "=" and rescan from r0. - `((write ?=) - (repeat))))) - mel-ccl-256-table)) - ;; '=' [\t ]* r1:r0:[0-9A-F] - (read-branch - r2 - ,@(mapcar - (lambda (r2) - (if (setq tmp (nth r2 mel-ccl-256-to-16-table)) - ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F] - `(write-read-repeat - r0 - ,(vconcat - (mapcar - (lambda (r0) - (logior (lsh r0 4) tmp)) - mel-ccl-16-table))) - ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F] - ;; invalid input - `(r3 = 0) ; nop - )) - mel-ccl-256-table)) - ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F] - ;; invalid input -> - ;; output "=" with hex digit and rescan from r2. - (write ?=) - (r0 = (r2 + 0)) - (write-repeat r1))) - (t - ;; r0:[^\t\r -~] - ;; invalid character found. - ;; -> ignore. - `((read r0) - (repeat)))))) - mel-ccl-256-table)) + (` (1 + ((read r0) + (loop + (branch + r0 + (,@ (mapcar + (lambda (r0) + (let ((tmp (aref mel-ccl-qp-table r0))) + (cond + ((eq tmp 'raw) (` (write-read-repeat r0))) + ((eq tmp 'wsp) (if (eq r0 (char-int ? )) + (` (r1 = 1)) + (` (r1 = 0)))) + ((eq tmp 'cr) + (if input-crlf + ;; r0='\r' + (` ((read r0) + ;; '\r' r0 + (if (r0 == ?\n) + ;; '\r' r0='\n' + ;; hard line break found. + (, (if output-crlf + '((write ?\r) + (write-read-repeat r0)) + '(write-read-repeat r0))) + ;; '\r' r0:[^\n] + ;; invalid control character (bare CR) found. + ;; -> ignore it and rescan from r0. + (repeat)))) + ;; r0='\r' + ;; invalid character (bare CR) found. + ;; -> ignore. + (` ((read r0) + (repeat))))) + ((eq tmp 'lf) + (if input-crlf + ;; r0='\n' + ;; invalid character (bare LF) found. + ;; -> ignore. + (` ((read r0) + (repeat))) + ;; r0='\r\n' + ;; hard line break found. + (if output-crlf + '((write ?\r) + (write-read-repeat r0)) + '(write-read-repeat r0)))) + ((eq r0 (char-int ?=)) + ;; r0='=' + (` ((read r0) + ;; '=' r0 + (r1 = (r0 == ?\t)) + (if ((r0 == ? ) | r1) + ;; '=' r0:[\t ] + ;; Skip transport-padding. + ;; It should check CR LF after + ;; transport-padding. + (loop + (read-if (r0 == ?\t) + (repeat) + (if (r0 == ? ) + (repeat) + (break))))) + ;; '=' [\t ]* r0:[^\t ] + (branch + r0 + (,@ (mapcar + (lambda (r0) + (cond + ((eq r0 (char-int ?\r)) + (if input-crlf + ;; '=' [\t ]* r0='\r' + (` ((read r0) + ;; '=' [\t ]* '\r' r0 + (if (r0 == ?\n) + ;; '=' [\t ]* '\r' r0='\n' + ;; soft line break found. + ((read r0) + (repeat)) + ;; '=' [\t ]* '\r' r0:[^\n] + ;; invalid input -> + ;; output "=" and rescan from r0. + ((write "=") + (repeat))))) + ;; '=' [\t ]* r0='\r' + ;; invalid input (bare CR found) -> + ;; output "=" and rescan from next. + (` ((write ?=) + (read r0) + (repeat))))) + ((eq r0 (char-int ?\n)) + (if input-crlf + ;; '=' [\t ]* r0='\n' + ;; invalid input (bare LF found) -> + ;; output "=" and rescan from next. + (` ((write ?=) + (read r0) + (repeat))) + ;; '=' [\t ]* r0='\r\n' + ;; soft line break found. + (` ((read r0) + (repeat))))) + ((setq tmp (nth r0 mel-ccl-256-to-16-table)) + ;; '=' [\t ]* r0:[0-9A-F] + ;; upper nibble of hexadecimal digit found. + (` ((r1 = (r0 + 0)) + (r0 = (, tmp))))) + (t + ;; '=' [\t ]* r0:[^\r0-9A-F] + ;; invalid input -> + ;; output "=" and rescan from r0. + (` ((write ?=) + (repeat)))))) + mel-ccl-256-table))) + ;; '=' [\t ]* r1:r0:[0-9A-F] + (read-branch + r2 + (,@ (mapcar + (lambda (r2) + (if (setq tmp (nth r2 mel-ccl-256-to-16-table)) + ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F] + (` (write-read-repeat + r0 + (, (vconcat + (mapcar + (lambda (r0) + (logior (lsh r0 4) tmp)) + mel-ccl-16-table))))) + ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F] + ;; invalid input + (` (r3 = 0)) ; nop + )) + mel-ccl-256-table))) + ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F] + ;; invalid input -> + ;; output "=" with hex digit and rescan from r2. + (write ?=) + (r0 = (r2 + 0)) + (write-repeat r1)))) + (t + ;; r0:[^\t\r -~] + ;; invalid character found. + ;; -> ignore. + (` ((read r0) + (repeat))))))) + mel-ccl-256-table))) ;; r1[0]:[\t ] (loop - ,@(apply - 'append - (mapcar - (lambda (regnum) - (let ((reg (aref [r1 r2 r3 r4 r5] regnum))) - (apply - 'append - (mapcar - (lambda (bit) - (if (= bit 0) - (if (= regnum 0) - nil - `((read r0) - (if (r0 == ?\t) - (,reg = 0) - (if (r0 == ?\ ) - (,reg = 1) - ((r6 = ,(+ (* regnum 28) bit)) - (break)))))) - `((read r0) - (if (r0 == ?\ ) - (,reg |= ,(lsh 1 bit)) - (if (r0 != ?\t) - ((r6 = ,(+ (* regnum 28) bit)) - (break))))))) - mel-ccl-28-table)))) - '(0 1 2 3 4))) + (,@ (apply + 'append + (mapcar + (lambda (regnum) + (let ((reg (aref [r1 r2 r3 r4 r5] regnum))) + (apply + 'append + (mapcar + (lambda (bit) + (if (= bit 0) + (if (= regnum 0) + nil + (` ((read r0) + (if (r0 == ?\t) + ((, reg) = 0) + (if (r0 == ?\ ) + ((, reg) = 1) + ((r6 = (, (+ (* regnum 28) bit))) + (break))))))) + (` ((read r0) + (if (r0 == ?\ ) + ((, reg) |= (, (lsh 1 bit))) + (if (r0 != ?\t) + ((r6 = (, (+ (* regnum 28) bit))) + (break)))))))) + mel-ccl-28-table)))) + '(0 1 2 3 4)))) ;; white space buffer exhaust. ;; error: line length limit (76bytes) violation. ;; -> ignore these white spaces. (repeat)) - ,(if input-crlf - `(if (r0 == ?\r) - ((read r0) - (if (r0 == ?\n) - ;; trailing white spaces found. - ;; -> ignore these white spacs. - ((write ,(if output-crlf "\r\n" "\n")) - (read r0) - (repeat)) - ;; [\t ]* \r r0:[^\n] - ;; error: bare CR found. - ;; -> output white spaces and ignore bare CR. - )) - ;; [\t ]* r0:[^\r] - ;; middle white spaces found. - ) - `(if (r0 == ?\n) - ;; trailing white spaces found. - ;; -> ignore these white spacs. - ((write ,(if output-crlf "\r\n" "\n")) - (read r0) - (repeat)) - ;; [\t ]* r0:[^\n] - ;; middle white spaces found. - )) - ,@(apply - 'append - (mapcar - (lambda (regnum) - (let ((reg (aref [r1 r2 r3 r4 r5] regnum))) - (apply - 'append - (mapcar - (lambda (bit) - `((if (,reg & ,(lsh 1 bit)) - (write ?\ ) - (write ?\t)) - (if (r6 == ,(+ (* regnum 28) bit 1)) - (repeat)))) - mel-ccl-28-table)))) - '(0 1 2 3 4))) + (, (if input-crlf + (` (if (r0 == ?\r) + ((read r0) + (if (r0 == ?\n) + ;; trailing white spaces found. + ;; -> ignore these white spacs. + ((write (, (if output-crlf "\r\n" "\n"))) + (read r0) + (repeat)) + ;; [\t ]* \r r0:[^\n] + ;; error: bare CR found. + ;; -> output white spaces and ignore bare CR. + )) + ;; [\t ]* r0:[^\r] + ;; middle white spaces found. + )) + (` (if (r0 == ?\n) + ;; trailing white spaces found. + ;; -> ignore these white spacs. + ((write (, (if output-crlf "\r\n" "\n"))) + (read r0) + (repeat)) + ;; [\t ]* r0:[^\n] + ;; middle white spaces found. + )))) + (,@ (apply + 'append + (mapcar + (lambda (regnum) + (let ((reg (aref [r1 r2 r3 r4 r5] regnum))) + (apply + 'append + (mapcar + (lambda (bit) + (` ((if ((, reg) & (, (lsh 1 bit))) + (write ?\ ) + (write ?\t)) + (if (r6 == (, (+ (* regnum 28) bit 1))) + (repeat))))) + mel-ccl-28-table)))) + '(0 1 2 3 4)))) (repeat) - )))) + ))))) ) @@ -964,7 +961,7 @@ MODE allows `text', `comment', `phrase' or nil. Default value is (unless (featurep 'xemacs) (defun q-encoding-ccl-encoded-length (string &optional mode) (let ((status [nil nil nil nil nil nil nil nil nil])) - (fillarray status nil) ; XXX: Is this necessary? + (fillarray status nil) (ccl-execute-on-string (cond ((eq mode 'text) 'mel-ccl-count-uq) diff --git a/mel.el b/mel.el index 12fff86..0ea7809 100644 --- a/mel.el +++ b/mel.el @@ -61,7 +61,7 @@ Content-Transfer-Encoding for it." (defun mime-encoding-alist (&optional service) "Return table of Content-Transfer-Encoding for completion." - (mapcar #'list (mime-encoding-list service))) + (mapcar (function list) (mime-encoding-list service))) (defsubst mel-use-module (name encodings) (while encodings diff --git a/mime-def.el b/mime-def.el index 73602ac..32b5a17 100644 --- a/mime-def.el +++ b/mime-def.el @@ -1,4 +1,4 @@ -;;; mime-def.el --- definition module about MIME -*- coding: iso-8859-4; -*- +;;; mime-def.el --- definition module about MIME -*- coding: iso-2022-jp; -*- ;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc. @@ -37,22 +37,23 @@ ) (eval-and-compile - (defconst mime-library-product ["FLIM" (1 14 0) "Ninokuchi"] - "Product name, version number and code name of MIME-library package.")) + (defconst mime-library-product ["CLIME" (1 14 0) "$B8^4VF2(B"] + "Product name, version number and code name of MIME-library package.") + ) (defmacro mime-product-name (product) - `(aref ,product 0)) + (` (aref (, product) 0))) (defmacro mime-product-version (product) - `(aref ,product 1)) + (` (aref (, product) 1))) (defmacro mime-product-code-name (product) - `(aref ,product 2)) + (` (aref (, product) 2))) (defconst mime-library-version (eval-when-compile (concat (mime-product-name mime-library-product) " " - (mapconcat #'number-to-string + (mapconcat (function int-to-string) (mime-product-version mime-library-product) ".") " - \"" (mime-product-code-name mime-library-product) "\""))) @@ -60,8 +61,6 @@ ;;; @ variables ;;; -(require 'custom) - (defgroup mime '((default-mime-charset custom-variable)) "Emacs MIME Interfaces" :group 'news @@ -158,10 +157,9 @@ ;;; (defsubst make-mime-content-type (type subtype &optional parameters) - (list* (cons 'type type) - (cons 'subtype subtype) - (nreverse parameters)) - ) + (cons (cons 'type type) + (cons (cons 'subtype subtype) + (nreverse parameters)))) (defsubst mime-content-type-primary-type (content-type) "Return primary-type of CONTENT-TYPE." @@ -241,16 +239,17 @@ message/rfc822, `mime-entity' structures of them are included in "Define NAME as a service for Content-Transfer-Encodings. If ARGS is specified, NAME is defined as a generic function for the service." - `(progn - (add-to-list 'mel-service-list ',name) - (defvar ,(intern (format "%s-obarray" name)) (make-vector 7 0)) - ,@(if args - `((defun ,name ,args - ,@rest - (funcall (mel-find-function ',name ,(car (last args))) - ,@(luna-arglist-to-arguments (butlast args))) - ))) - )) + (` (progn + (add-to-list 'mel-service-list '(, name)) + (defvar (, (intern (format "%s-obarray" name))) (make-vector 7 0)) + (,@ (if args + (` ((defun (, name) (, args) + (,@ rest) + (funcall (mel-find-function '(, name) + (, (car (last args)))) + (,@ (luna-arglist-to-arguments (butlast args)))) + ))))) + ))) (put 'mel-define-service 'lisp-indent-function 'defun) @@ -291,9 +290,10 @@ service." If PARENTS is specified, TYPE inherits PARENTS. Each parent must be backend name (string)." (cons 'progn - (mapcar (lambda (parent) - `(mel-copy-backend ,parent ,type) - ) + (mapcar (function + (lambda (parent) + (` (mel-copy-backend (, parent) (, type))) + )) parents))) (defmacro mel-define-method (name args &rest body) @@ -303,11 +303,12 @@ specialized parameter. (car (car (last ARGS))) is name of variable and (nth 1 (car (last ARGS))) is name of backend (encoding)." (let* ((specializer (car (last args))) (class (nth 1 specializer))) - `(progn - (mel-define-service ,name) - (fset (intern ,class ,(intern (format "%s-obarray" name))) - (lambda ,(butlast args) - ,@body))))) + (` (progn + (mel-define-service (, name)) + (fset (intern (, class) (, (intern (format "%s-obarray" name)))) + (function + (lambda (, (butlast args)) + (,@ body)))))))) (put 'mel-define-method 'lisp-indent-function 'defun) @@ -321,21 +322,21 @@ variable and (nth 1 (car (last ARGS))) is name of backend (encoding)." (args (cdr spec)) (specializer (car (last args))) (class (nth 1 specializer))) - `(let (sym) - (mel-define-service ,name) - (setq sym (intern ,class ,(intern (format "%s-obarray" name)))) - (or (fboundp sym) - (fset sym (symbol-function ,function)))))) + (` (let (sym) + (mel-define-service (, name)) + (setq sym (intern (, class) (, (intern (format "%s-obarray" name))))) + (or (fboundp sym) + (fset sym (symbol-function (, function)))))))) (defmacro mel-define-function (function spec) (let* ((name (car spec)) (args (cdr spec)) (specializer (car (last args))) (class (nth 1 specializer))) - `(progn - (define-function ,function - (intern ,class ,(intern (format "%s-obarray" name)))) - ))) + (` (progn + (define-function (, function) + (intern (, class) (, (intern (format "%s-obarray" name))))) + )))) (defvar base64-dl-module (if (and (fboundp 'base64-encode-string) diff --git a/mime-parse.el b/mime-parse.el index 4aeb30c..d6d3d23 100644 --- a/mime-parse.el +++ b/mime-parse.el @@ -105,8 +105,9 @@ Return value is or nil. PRIMARY-TYPE and SUBTYPE are symbol and NAME_n and VALUE_n are string." (setq string (std11-unfold-string string)) - (if (string-match `,(concat "^\\(" mime-token-regexp - "\\)/\\(" mime-token-regexp "\\)") string) + (if (string-match (eval-when-compile + (concat "^\\(" mime-token-regexp + "\\)/\\(" mime-token-regexp "\\)")) string) (let* ((type (downcase (substring string (match-beginning 1) (match-end 1)))) (subtype (downcase diff --git a/mime.el b/mime.el index 328d599..a3da250 100644 --- a/mime.el +++ b/mime.el @@ -69,7 +69,8 @@ current-buffer, and return it.") ;;; (defmacro mime-entity-send (entity message &rest args) - `(luna-send ,entity ',(intern (format "mime-%s" (eval message))) ,@args)) + (` (luna-send (, entity) + '(, (intern (format "mime-%s" (eval message)))) (,@ args)))) (defun mime-open-entity (type location) "Open an entity and return it. -- 1.7.10.4