X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mel-b-ccl.el;h=32bd8c800a966c58f98beb542807bc6918888ee2;hb=2cdf2dfc7fc737128e09ac46edaa074cbe27e690;hp=b01650c112e70b9ec421b31547bcd5c0679288f6;hpb=f7230fcb61e32630f6bcf87e6eb8b35c564dd06c;p=elisp%2Fflim.git

diff --git a/mel-b-ccl.el b/mel-b-ccl.el
index b01650c..32bd8c8 100644
--- a/mel-b-ccl.el
+++ b/mel-b-ccl.el
@@ -1,6 +1,6 @@
-;;; mel-b-ccl.el: CCL based encoder/decoder of Base64
+;;; mel-b-ccl.el --- Base64 encoder/decoder using CCL.
 
-;; Copyright (C) 1998 Tanaka Akira
+;; Copyright (C) 1998,1999 Tanaka Akira
 
 ;; Author: Tanaka Akira <akr@jaist.ac.jp>
 ;; Created: 1998/9/17
@@ -19,7 +19,7 @@
 ;; General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; along with this program; see the file COPYING.  If not, write to the
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 
@@ -105,6 +105,10 @@ abcdefghijklmnopqrstuvwxyz\
    (logand v (lsh 255 8))
    (lsh (logand v 255) 16)))
 
+)
+
+(eval-when-compile
+
 (defconst mel-ccl-decode-b-0-table
   (vconcat
    (mapcar
@@ -143,168 +147,234 @@ abcdefghijklmnopqrstuvwxyz\
 
 )
 
-(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)))
+(check-broken-facility ccl-cascading-read)
+
+(if-broken ccl-cascading-read
+    (define-ccl-program mel-ccl-decode-b
+      (` (1
 	  (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)
+	   (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))
-		 ((r6 = 0)
-		  (break)))
-	     ((r6 = 1)
-	      (break))))
-	  (loop
-	   (if (r3 != ?=)
-	       (if (r4 & ,(lsh 1 27))
-		   ((read r3)
-		    (r4 = r3 ,mel-ccl-decode-b-3-table)
+		 (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))
-	     ((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)
+		 (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))
+		(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)
-	    (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))))))
+	    (write-repeat r4)))))))
+  )
 
 (eval-when-compile
 
 ;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
 ;; is not executed.
-(defun mel-ccl-encode-base64-generic (&optional quantums-per-line output-crlf terminate-with-newline)
-  `(2
-    ((r3 = 0)
-     (loop
-      (r2 = 0)
-      (read-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)
-      ,@(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")
-		"="))))
-    ))
+(defun mel-ccl-encode-base64-generic
+  (&optional quantums-per-line output-crlf terminate-with-newline)
+  (` (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
+       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
@@ -345,20 +415,25 @@ abcdefghijklmnopqrstuvwxyz\
 
 (unless-broken ccl-execute-eof-block-on-decoding-some
 
-  (defun base64-ccl-encode-string (string)
+  (defun base64-ccl-encode-string (string &optional no-line-break)
     "Encode STRING with base64 encoding."
-    (decode-coding-string string 'mel-ccl-base64-lf-rev))
+    (if no-line-break
+	(decode-coding-string string 'mel-ccl-b-rev)
+      (decode-coding-string string 'mel-ccl-base64-lf-rev)))
+  (defalias-maybe 'base64-encode-string 'base64-ccl-encode-string)
 
-  (defun base64-ccl-encode-region (start end)
+  (defun base64-ccl-encode-region (start end &optional no-line-break)
     "Encode region from START to END with base64 encoding."
-    (interactive "r")
-    (decode-coding-region start end 'mel-ccl-base64-lf-rev))
+    (interactive "*r")
+    (if no-line-break
+	(decode-coding-region start end 'mel-ccl-b-rev)
+      (decode-coding-region start end 'mel-ccl-base64-lf-rev)))
+  (defalias-maybe 'base64-encode-region 'base64-ccl-encode-region)
 
   (defun base64-ccl-insert-encoded-file (filename)
     "Encode contents of file FILENAME to base64, and insert the result."
-    (interactive (list (read-file-name "Insert encoded file: ")))
-    (let ((coding-system-for-read 'mel-ccl-base64-lf-rev))
-      (insert-file-contents filename)))
+    (interactive "*fInsert encoded file: ")
+    (insert-file-contents-as-coding-system 'mel-ccl-base64-lf-rev filename))
 
   (mel-define-method-function (mime-encode-string string (nil "base64"))
 			      'base64-ccl-encode-string)
@@ -375,20 +450,18 @@ abcdefghijklmnopqrstuvwxyz\
 (defun base64-ccl-decode-string (string)
   "Decode base64 encoded STRING"
   (encode-coding-string string 'mel-ccl-b-rev))
+(defalias-maybe 'base64-decode-string 'base64-ccl-decode-string)
 
 (defun base64-ccl-decode-region (start end)
   "Decode base64 encoded the region from START to END."
-  (interactive "r")
+  (interactive "*r")
   (encode-coding-region start end 'mel-ccl-b-rev))
+(defalias-maybe 'base64-decode-region 'base64-ccl-decode-region)
 
 (defun base64-ccl-write-decoded-region (start end filename)
   "Decode the region from START to END and write out to FILENAME."
-  (interactive
-    (list (region-beginning) (region-end)
-          (read-file-name "Write decoded region to file: ")))
-  (let ((coding-system-for-write 'mel-ccl-b-rev)
-	jka-compr-compression-info-list)
-    (write-region start end filename)))
+  (interactive "*r\nFWrite decoded region to file: ")
+  (write-region-as-coding-system 'mel-ccl-b-rev start end filename))
 
 (mel-define-method-function (mime-decode-string string (nil "base64"))
 			    'base64-ccl-decode-string)
@@ -399,8 +472,9 @@ abcdefghijklmnopqrstuvwxyz\
  'base64-ccl-write-decoded-region)
 
 (mel-define-method encoded-text-decode-string (string (nil "B"))
-  (if (and (string-match B-encoded-text-regexp string)
-	   (string= string (match-string 0 string)))
+  (if (string-match (eval-when-compile
+		      (concat "\\`" B-encoded-text-regexp "\\'"))
+		    string)
       (base64-ccl-decode-string string)
     (error "Invalid encoded-text %s" string)))
 
@@ -410,4 +484,4 @@ abcdefghijklmnopqrstuvwxyz\
 
 (provide 'mel-b-ccl)
 
-;;; mel-b-ccl.el ends here
+;;; mel-b-ccl.el ends here.