mel-ccl.el

   1 (require 'ccl)
   2 (require 'emu)
   3
   4
   5 ;;; @ constants
   6 ;;;
   7
   8 (eval-when-compile
   9
  10 (defconst mel-ccl-4-table
  11   '(  0   1   2   3))
  12
  13 (defconst mel-ccl-16-table
  14   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15))
  15
  16 (defconst mel-ccl-28-table
  17   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  18      16  17  18  19  20  21  22  23  24  25  26  27))
  19
  20 (defconst mel-ccl-64-table
  21   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  22      16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
  23      32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
  24      48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63))
  25
  26 (defconst mel-ccl-256-table
  27   '(  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
  28      16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
  29      32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47
  30      48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63
  31      64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79
  32      80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95
  33      96  97  98  99 100 101 102 103 104 105 106 107 108 109 110 111
  34     112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
  35     128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
  36     144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
  37     160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
  38     176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
  39     192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
  40     208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
  41     224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
  42     240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))
  43
  44 (defconst mel-ccl-256-to-16-table
  45   '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  46     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  47     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  48       0   1   2   3   4   5   6   7   8   9 nil nil nil nil nil nil
  49     nil  10  11  12  13  14  15 nil nil nil nil nil nil nil nil nil
  50     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  51     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  52     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  53     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  54     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  55     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  56     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  57     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  58     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  59     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  60     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
  61
  62 (defconst mel-ccl-16-to-256-table
  63   (mapcar 'char-int "0123456789ABCDEF"))
  64
  65 (defconst mel-ccl-high-table
  66   (vconcat
  67    (mapcar
  68     (lambda (v) (nth (lsh v -4) mel-ccl-16-to-256-table))
  69     mel-ccl-256-table)))
  70
  71 (defconst mel-ccl-low-table
  72   (vconcat
  73    (mapcar
  74     (lambda (v) (nth (logand v 15) mel-ccl-16-to-256-table))
  75     mel-ccl-256-table)))
  76
  77 (defconst mel-ccl-u-raw
  78   (mapcar
  79    'char-int
  80    "0123456789\
  81 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
  82 abcdefghijklmnopqrstuvwxyz\
  83 !@#$%&'()*+,-./:;<>@[\\]^`{|}~"))
  84
  85 (defconst mel-ccl-c-raw
  86   (mapcar
  87    'char-int
  88    "0123456789\
  89 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
  90 abcdefghijklmnopqrstuvwxyz\
  91 !@#$%&'*+,-./:;<>@[]^`{|}~"))
  92
  93 (defconst mel-ccl-p-raw
  94   (mapcar
  95    'char-int
  96    "0123456789\
  97 ABCDEFGHIJKLMNOPQRSTUVWXYZ\
  98 abcdefghijklmnopqrstuvwxyz\
  99 !*+-/"))
 100
 101 (defconst mel-ccl-256-to-64-table
 102   '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 103     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 104     nil nil nil nil nil nil nil nil nil nil nil  62 nil nil nil  63
 105      52  53  54  55  56  57  58  59  60  61 nil nil nil   t nil nil
 106     nil   0   1   2   3   4   5   6   7   8   9  10  11  12  13  14
 107      15  16  17  18  19  20  21  22  23  24  25 nil nil nil nil nil
 108     nil  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40
 109      41  42  43  44  45  46  47  48  49  50  51 nil nil nil nil nil
 110     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 111     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 112     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 113     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 114     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 115     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 116     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
 117     nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
 118
 119 (defconst mel-ccl-64-to-256-table
 120   (mapcar
 121    'char-int
 122    "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
 123 abcdefghijklmnopqrstuvwxyz\
 124 0123456789\
 125 +/"))
 126
 127 (defconst mel-ccl-qp-table
 128   [enc enc enc enc enc enc enc enc enc wsp lf  enc enc cr  enc enc
 129    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 130    wsp raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 131    raw raw raw raw raw raw raw raw raw raw raw raw raw enc raw raw
 132    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 133    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 134    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw
 135    raw raw raw raw raw raw raw raw raw raw raw raw raw raw raw enc
 136    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 137    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 138    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 139    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 140    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 141    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 142    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc
 143    enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc enc])
 144
 145 )
 146
 147
 148 ;;; @ CCL programs
 149 ;;;
 150
 151 ;;; Q
 152
 153 (define-ccl-program mel-ccl-decode-q
 154   `(1
 155     ((loop
 156       (read-branch
 157        r0
 158        ,@(mapcar
 159           (lambda (r0)
 160             (cond
 161              ((= r0 (char-int ?_))
 162               `(write-repeat ? ))
 163              ((= r0 (char-int ?=))
 164               `((loop
 165                  (read-branch
 166                   r1
 167                   ,@(mapcar
 168                      (lambda (v)
 169                        (if (integerp v)
 170                            `((r0 = ,v) (break))
 171                          '(repeat)))
 172                      mel-ccl-256-to-16-table)))
 173                 (loop
 174                  (read-branch
 175                   r1
 176                   ,@(mapcar
 177                      (lambda (v)
 178                        (if (integerp v)
 179                            `((write r0 ,(vconcat
 180                                          (mapcar
 181                                           (lambda (r0)
 182                                             (logior (lsh r0 4) v))
 183                                           mel-ccl-16-table)))
 184                              (break))
 185                          '(repeat)))
 186                      mel-ccl-256-to-16-table)))
 187                 (repeat)))
 188              (t
 189               `(write-repeat ,r0))))
 190           mel-ccl-256-table))))))
 191
 192 (eval-when-compile
 193
 194 (defun mel-ccl-encode-q-generic (raw)
 195   `(3
 196     (loop
 197      (loop
 198       (read-branch
 199        r0
 200        ,@(mapcar
 201           (lambda (r0)
 202             (cond
 203              ((= r0 32) `(write-repeat ?_))
 204              ((member r0 raw) `(write-repeat ,r0))
 205              (t '(break))))
 206           mel-ccl-256-table)))
 207      (write ?=)
 208      (write r0 ,mel-ccl-high-table)
 209      (write r0 ,mel-ccl-low-table)
 210      (repeat))))
 211
 212 ;; On xemacs, generated program counts iso-8859-1 8bit character as 6bytes.
 213 (defun mel-ccl-count-q-length (raw)
 214   `(0
 215     ((r0 = 0)
 216      (loop
 217       (read-branch
 218        r1
 219        ,@(mapcar
 220           (lambda (r1)
 221             (if (or (= r1 32) (member r1 raw))
 222                 '((r0 += 1) (repeat))
 223               '((r0 += 3) (repeat))))
 224           mel-ccl-256-table))))))
 225
 226 )
 227
 228 (define-ccl-program mel-ccl-encode-uq
 229   (mel-ccl-encode-q-generic mel-ccl-u-raw))
 230 (define-ccl-program mel-ccl-encode-cq
 231   (mel-ccl-encode-q-generic mel-ccl-c-raw))
 232 (define-ccl-program mel-ccl-encode-pq
 233   (mel-ccl-encode-q-generic mel-ccl-p-raw))
 234
 235 (define-ccl-program mel-ccl-count-uq
 236   (mel-ccl-count-q-length mel-ccl-u-raw))
 237 (define-ccl-program mel-ccl-count-cq
 238   (mel-ccl-count-q-length mel-ccl-c-raw))
 239 (define-ccl-program mel-ccl-count-pq
 240   (mel-ccl-count-q-length mel-ccl-p-raw))
 241
 242 ;;; B/Base64
 243
 244 (eval-when-compile
 245
 246 (defun mel-ccl-decode-b-bit-ex (v)
 247   (logior
 248    (lsh (logand v (lsh 255 16)) -16)
 249    (logand v (lsh 255 8))
 250    (lsh (logand v 255) 16)))
 251
 252 (defconst mel-ccl-decode-b-0-table
 253   (vconcat
 254    (mapcar
 255     (lambda (v)
 256       (if (integerp v)
 257           (mel-ccl-decode-b-bit-ex (lsh v 18))
 258         (lsh 1 24)))
 259     mel-ccl-256-to-64-table)))
 260
 261 (defconst mel-ccl-decode-b-1-table
 262   (vconcat
 263    (mapcar
 264     (lambda (v)
 265       (if (integerp v)
 266           (mel-ccl-decode-b-bit-ex (lsh v 12))
 267         (lsh 1 25)))
 268     mel-ccl-256-to-64-table)))
 269
 270 (defconst mel-ccl-decode-b-2-table
 271   (vconcat
 272    (mapcar
 273     (lambda (v)
 274       (if (integerp v)
 275           (mel-ccl-decode-b-bit-ex (lsh v 6))
 276         (lsh 1 26)))
 277     mel-ccl-256-to-64-table)))
 278
 279 (defconst mel-ccl-decode-b-3-table
 280   (vconcat
 281    (mapcar
 282     (lambda (v)
 283       (if (integerp v)
 284           (mel-ccl-decode-b-bit-ex v)
 285         (lsh 1 27)))
 286     mel-ccl-256-to-64-table)))
 287
 288 )
 289
 290 (define-ccl-program mel-ccl-decode-b
 291   `(1
 292     (loop
 293      (read r0 r1 r2 r3)
 294      (r4 = r0 ,mel-ccl-decode-b-0-table)
 295      (r5 = r1 ,mel-ccl-decode-b-1-table)
 296      (r4 |= r5)
 297      (r5 = r2 ,mel-ccl-decode-b-2-table)
 298      (r4 |= r5)
 299      (r5 = r3 ,mel-ccl-decode-b-3-table)
 300      (r4 |= r5)
 301      (if (r4 & ,(lognot (1- (lsh 1 24))))
 302          ((loop
 303            (if (r4 & ,(lsh 1 24))
 304                ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
 305                 (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 306                 (r5 = r3 ,mel-ccl-decode-b-3-table)
 307                 (r4 |= r5)
 308                 (repeat))
 309              (break)))
 310           (loop
 311            (if (r4 & ,(lsh 1 25))
 312                ((r1 = r2) (r2 = r3) (read r3)
 313                 (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 314                 (r5 = r3 ,mel-ccl-decode-b-3-table)
 315                 (r4 |= r5)
 316                 (repeat))
 317              (break)))
 318           (loop
 319            (if (r2 != ?=)
 320                (if (r4 & ,(lsh 1 26))
 321                    ((r2 = r3) (read r3)
 322                     (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
 323                     (r5 = r3 ,mel-ccl-decode-b-3-table)
 324                     (r4 |= r5)
 325                     (repeat))
 326                  ((r6 = 0)
 327                   (break)))
 328              ((r6 = 1)
 329               (break))))
 330           (loop
 331            (if (r3 != ?=)
 332                (if (r4 & ,(lsh 1 27))
 333                    ((read r3)
 334                     (r4 = r3 ,mel-ccl-decode-b-3-table)
 335                     (repeat))
 336                  (break))
 337              ((r6 |= 2)
 338               (break))))
 339           (r4 = r0 ,mel-ccl-decode-b-0-table)
 340           (r5 = r1 ,mel-ccl-decode-b-1-table)
 341           (r4 |= r5)
 342           (branch
 343            r6
 344            ;; BBBB
 345            ((r5 = r2 ,mel-ccl-decode-b-2-table)
 346             (r4 |= r5)
 347             (r5 = r3 ,mel-ccl-decode-b-3-table)
 348             (r4 |= r5)
 349             (r4 >8= 0)
 350             (write r7)
 351             (r4 >8= 0)
 352             (write r7)
 353             (write-repeat r4))
 354            ;; error: BB=B
 355            ((write r4)
 356             (end))
 357            ;; BBB=
 358            ((r5 = r2 ,mel-ccl-decode-b-2-table)
 359             (r4 |= r5)
 360             (r4 >8= 0)
 361             (write r7)
 362             (write r4)
 363             (end))
 364            ;; BB==
 365            ((write r4)
 366             (end))))
 367        ((r4 >8= 0)
 368         (write r7)
 369         (r4 >8= 0)
 370         (write r7)
 371         (write-repeat r4))))))
 372
 373 (eval-when-compile
 374
 375 ;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
 376 ;; is not executed.
 377 (defun mel-ccl-encode-base64-generic (&optional quantums-per-line output-crlf terminate-with-newline)
 378   `(2
 379     ((r3 = 0)
 380      (loop
 381       (r2 = 0)
 382       (read-branch
 383        r1
 384        ,@(mapcar
 385           (lambda (r1)
 386             `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table))
 387               (r0 = ,(logand r1 3))))
 388           mel-ccl-256-table))
 389       (r2 = 1)
 390       (read-branch
 391        r1
 392        ,@(mapcar
 393           (lambda (r1)
 394             `((write r0 ,(vconcat
 395                           (mapcar
 396                            (lambda (r0)
 397                              (nth (logior (lsh r0 4)
 398                                           (lsh r1 -4))
 399                                   mel-ccl-64-to-256-table))
 400                            mel-ccl-4-table)))
 401               (r0 = ,(logand r1 15))))
 402           mel-ccl-256-table))
 403       (r2 = 2)
 404       (read-branch
 405        r1
 406        ,@(mapcar
 407           (lambda (r1)
 408             `((write r0 ,(vconcat
 409                           (mapcar
 410                            (lambda (r0)
 411                              (nth (logior (lsh r0 2)
 412                                           (lsh r1 -6))
 413                                   mel-ccl-64-to-256-table))
 414                            mel-ccl-16-table)))))
 415           mel-ccl-256-table))
 416       (r1 &= 63)
 417       (write r1 ,(vconcat
 418                   (mapcar
 419                    (lambda (r1)
 420                      (nth r1 mel-ccl-64-to-256-table))
 421                    mel-ccl-64-table)))
 422       (r3 += 1)
 423       ,@(when quantums-per-line
 424           `((if (r3 == ,quantums-per-line)
 425                 ((write ,(if output-crlf "\r\n" "\n"))
 426                  (r3 = 0)))))
 427       (repeat)))
 428     (branch
 429      r2
 430      ,(if terminate-with-newline
 431           `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n")))
 432         `(r0 = 0))
 433      ((write r0 ,(vconcat
 434                   (mapcar
 435                    (lambda (r0)
 436                      (nth (lsh r0 4) mel-ccl-64-to-256-table))
 437                    mel-ccl-4-table)))
 438       (write ,(if terminate-with-newline
 439                   (if output-crlf "==\r\n" "==\n")
 440                 "==")))
 441      ((write r0 ,(vconcat
 442                   (mapcar
 443                    (lambda (r0)
 444                      (nth (lsh r0 2) mel-ccl-64-to-256-table))
 445                    mel-ccl-16-table)))
 446       (write ,(if terminate-with-newline
 447                   (if output-crlf "=\r\n" "=\n")
 448                 "="))))
 449     ))
 450 )
 451
 452 (define-ccl-program mel-ccl-encode-b
 453   (mel-ccl-encode-base64-generic))
 454
 455 ;; 19 * 4 = 76
 456 (define-ccl-program mel-ccl-encode-base64-crlf-crlf
 457   (mel-ccl-encode-base64-generic 19 t))
 458
 459 (define-ccl-program mel-ccl-encode-base64-crlf-lf
 460   (mel-ccl-encode-base64-generic 19 nil))
 461
 462 ;; Quoted-Printable
 463
 464 (eval-when-compile
 465
 466 ;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
 467 ;; is not executed.
 468 (defun mel-ccl-encode-quoted-printable-generic (input-crlf output-crlf)
 469   `(4
 470     ((r6 = 0)                           ; column
 471      (r5 = 0)                           ; previous character is white space
 472      (r4 = 0)
 473      (read r0)
 474      (loop                              ; r6 <= 75
 475       (loop
 476        (loop
 477         (branch
 478          r0
 479          ,@(mapcar
 480             (lambda (r0)
 481               (let ((tmp (aref mel-ccl-qp-table r0)))
 482                 (cond
 483                  ((eq tmp 'raw) '((r3 = 0) (break))) ; RAW
 484                  ((eq tmp 'enc) '((r3 = 1) (break))) ; ENC
 485                  ((eq tmp 'wsp) '((r3 = 2) (break))) ; WSP
 486                  ((eq tmp 'cr) (if input-crlf
 487                                    '((r3 = 3) (break)) ; CR
 488                                  '((r3 = 1) (break)))) ; ENC
 489                  ((eq tmp 'lf) (if input-crlf
 490                                    '((r3 = 1) (break)) ; ENC
 491                                  '((r3 = 3) (break)))) ; CRLF
 492                  )))
 493             mel-ccl-256-table)))
 494        (branch
 495         r3
 496         ;; r0:r3=RAW
 497         (if (r6 < 75)
 498             ((r6 += 1)
 499              (r5 = 0)
 500              (r4 = 1)
 501              (write-read-repeat r0))
 502           (break))
 503         ;; r0:r3=ENC
 504         ((r5 = 0)
 505          (if (r6 < 73)
 506              ((r6 += 3)
 507               (write "=")
 508               (write r0 ,mel-ccl-high-table)
 509               (r4 = 2)
 510               (write-read-repeat r0 ,mel-ccl-low-table))
 511            (if (r6 > 73)
 512                ((r6 = 3)
 513                 (write ,(if output-crlf "=\r\n=" "=\n="))
 514                 (write r0 ,mel-ccl-high-table)
 515                 (r4 = 3)
 516                 (write-read-repeat r0 ,mel-ccl-low-table))
 517              (break))))
 518         ;; r0:r3=WSP
 519         ((r5 = 1)
 520          (if (r6 < 75)
 521              ((r6 += 1)
 522               (r4 = 4)
 523               (write-read-repeat r0))
 524            ((r6 = 1)
 525             (write ,(if output-crlf "=\r\n" "=\n"))
 526             (r4 = 5)
 527             (write-read-repeat r0))))
 528         ;; r0:r3=CR/CRLF
 529         ,(if input-crlf
 530              ;; r0:r3=CR
 531              `((if ((r6 > 73) & r5)
 532                    ((r6 = 0)
 533                     (r5 = 0)
 534                     (write ,(if output-crlf "=\r\n" "=\n"))))
 535                (break))
 536            ;; r0:r3=CRLF
 537            `(if r5
 538                 ;; WSP ; r0:r3=CRLF
 539                 ((r5 = 0)
 540                  (r6 = 0)
 541                  (write ,(if output-crlf "=\r\n" "=\n"))
 542                  ,@(if output-crlf '((write ?\r)) '())
 543                  (write-read-repeat r0))
 544               ;; noWSP ; r0:r3=CRLF
 545               ((r5 = 0)
 546                (r6 = 0)
 547                ,@(if output-crlf '((write ?\r)) '())
 548                (write-read-repeat r0)))
 549            )))
 550       ;; r0:r3={RAW,ENC,CR}
 551       (loop
 552        ,(funcall
 553          (lambda (after-cr after-raw-enc)
 554            (if input-crlf
 555                `(if (r0 == ?\r)
 556                     ,after-cr
 557                   ,after-raw-enc)
 558              after-raw-enc))
 559          ;; r0=\r:r3=CR
 560          `((r4 = 6)
 561            (read r0)
 562            ;; CR:r3=CR r0
 563            (if (r0 == ?\n)
 564                ;; CR:r3=CR r0=LF
 565                (if r5
 566                    ;; r5=WSP ; CR:r3=CR r0=LF
 567                    ((r6 = 0)
 568                     (r5 = 0)
 569                     (write ,(if output-crlf "=\r\n\r\n" "=\n\n"))
 570                     (r4 = 7)
 571                     (read r0)
 572                     (break))
 573                  ;; r5=noWSP ; CR:r3=CR r0=LF
 574                  ((r6 = 0)
 575                   (r5 = 0)
 576                   (write ,(if output-crlf "\r\n" "\n"))
 577                   (r4 = 8)
 578                   (read r0)
 579                   (break)))
 580              ;; CR:r3=CR r0=noLF
 581              (if (r6 < 73)
 582                  ((r6 += 3)
 583                   (r5 = 0)
 584                   (write "=0D")
 585                   (break))
 586                (if (r6 == 73)
 587                    (if (r0 == ?\r)
 588                        ;; CR:r3=CR r0=CR
 589                        ((r4 = 9)
 590                         (read r0)
 591                         ;; CR:r3=CR CR r0
 592                         (if (r0 == ?\n)
 593                             ;; CR:r3=CR CR LF
 594                             ((r6 = 0)
 595                              (r5 = 0)
 596                              (write ,(if output-crlf "=0D\r\n" "=0D\n"))
 597                              (r4 = 10)
 598                              (read r0)
 599                              (break))
 600                           ;; CR:r3=CR CR noLF
 601                           ((r6 = 6)
 602                            (r5 = 0)
 603                            (write ,(if output-crlf "=\r\n=0D=0D" "=\n=0D=0D"))
 604                            (break))))
 605                      ;; CR:r3=CR r0=noLFnorCR
 606                      ((r6 = 3)
 607                       (r5 = 0)
 608                       (write ,(if output-crlf "=\r\n=0D" "=\n=0D"))
 609                       (break)))
 610                  ((r6 = 3)
 611                   (r5 = 0)
 612                   (write ,(if output-crlf "=\r\n=0D" "=\n=0D"))
 613                   (break))))))
 614          (funcall
 615           (lambda (after-newline after-cr-nolf after-nonewline)
 616             (if input-crlf
 617                 ;; r0:r3={RAW,ENC}
 618                 `((r4 = 11)
 619                   (read r1)
 620                   ;; r0:r3={RAW,ENC} r1
 621                   (if (r1 == ?\r)
 622                       ;; r0:r3={RAW,ENC} r1=CR
 623                       ((r4 = 12)
 624                        (read r1)
 625                        ;; r0:r3={RAW,ENC} CR r1
 626                        (if (r1 == ?\n)
 627                            ;; r0:r3=RAW CR r1=LF
 628                            ,after-newline
 629                          ;; r0:r3=RAW CR r1=noLF
 630                          ,after-cr-nolf))
 631                     ;; r0:r3={RAW,ENC} r1:noCR
 632                     ,after-nonewline))
 633               ;; r0:r3={RAW,ENC}
 634               `((r4 = 11)
 635                 (read r1)
 636                 ;; r0:r3={RAW,ENC} r1
 637                 (if (r1 == ?\n)
 638                     ;; r0:r3={RAW,ENC} r1=CRLF
 639                     ,after-newline
 640                   ;; r0:r3={RAW,ENC} r1:noCRLF
 641                   ,after-nonewline))))
 642           ;; r0:r3={RAW,ENC} CR r1=LF
 643           ;; r0:r3={RAW,ENC} r1=CRLF
 644           `((r6 = 0)
 645             (r5 = 0)
 646             (branch
 647              r3
 648              ;; r0:r3=RAW CR r1=LF
 649              ;; r0:r3=RAW r1=CRLF
 650              ((write r0)
 651               (write ,(if output-crlf "\r\n" "\n"))
 652               (r4 = 13)
 653               (read r0)
 654               (break))
 655              ;; r0:r3=ENC CR r1=LF
 656              ;; r0:r3=ENC r1=CRLF
 657              ((write ?=)
 658               (write r0 ,mel-ccl-high-table)
 659               (write r0 ,mel-ccl-low-table)
 660               (write ,(if output-crlf "\r\n" "\n"))
 661               (r4 = 14)
 662               (read r0)
 663               (break))))
 664           ;; r0:r3={RAW,ENC} CR r1=noLF
 665           `((branch
 666              r3
 667              ;; r0:r3=RAW CR r1:noLF
 668              ((r6 = 4)
 669               (r5 = 0)
 670               (write ,(if output-crlf "=\r\n" "=\n"))
 671               (write r0)
 672               (write "=0D")
 673               (r0 = r1)
 674               (break))
 675              ;; r0:r3=ENC CR r1:noLF
 676              ((r6 = 6)
 677               (r5 = 0)
 678               (write ,(if output-crlf "=\r\n=" "=\n="))
 679               (write r0 ,mel-ccl-high-table)
 680               (write r0 ,mel-ccl-low-table)
 681               (write "=0D")
 682               (r0 = r1)
 683               (break))))
 684           ;; r0:r3={RAW,ENC} r1:noCR
 685           ;; r0:r3={RAW,ENC} r1:noCRLF
 686           `((branch
 687              r3
 688              ;; r0:r3=RAW r1:noCR
 689              ;; r0:r3=RAW r1:noCRLF
 690              ((r6 = 1)
 691               (r5 = 0)
 692               (write ,(if output-crlf "=\r\n" "=\n"))
 693               (write r0)
 694               (r0 = r1)
 695               (break))
 696              ;; r0:r3=ENC r1:noCR
 697              ;; r0:r3=ENC r1:noCRLF
 698              ((r6 = 3)
 699               (r5 = 0)
 700               (write ,(if output-crlf "=\r\n=" "=\n="))
 701               (write r0 ,mel-ccl-high-table)
 702               (write r0 ,mel-ccl-low-table)
 703               (r0 = r1)
 704               (break)))))))
 705       (repeat)))
 706     ;; EOF
 707     (                                   ;(write "[EOF:") (write r4 ,mel-ccl-high-table) (write r4 ,mel-ccl-low-table) (write "]")
 708      (branch
 709       r4
 710       ;; 0: (start) ;
 711       (end)
 712       ;; 1: RAW ;
 713       (end)
 714       ;; 2: r0:r3=ENC ;
 715       (end)
 716       ;; 3: SOFTBREAK r0:r3=ENC ;
 717       (end)
 718       ;; 4: r0:r3=WSP ;
 719       ((write ,(if output-crlf "=\r\n" "=\n")) (end))
 720       ;; 5: SOFTBREAK r0:r3=WSP ;
 721       ((write ,(if output-crlf "=\r\n" "=\n")) (end))
 722       ;; 6: ; r0=\r:r3=CR
 723       (if (r6 <= 73)
 724           ((write "=0D") (end))
 725         ((write ,(if output-crlf "=\r\n=0D" "=\n=0D")) (end)))
 726       ;; 7: r5=WSP SOFTBREAK CR:r3=CR r0=LF ;
 727       (end)
 728       ;; 8: r5=noWSP CR:r3=CR r0=LF ;
 729       (end)
 730       ;; 9: (r6=73) ; CR:r3=CR r0=CR
 731       ((write ,(if output-crlf "=\r\n=0D=0D" "=\n=0D=0D")) (end))
 732       ;; 10: (r6=73) CR:r3=CR CR LF ;
 733       (end)
 734       ;; 11: ; r0:r3={RAW,ENC}
 735       (branch
 736        r3
 737        ((write r0) (end))
 738        ((write "=")
 739         (write r0 ,mel-ccl-high-table)
 740         (write r0 ,mel-ccl-low-table)
 741         (end)))
 742       ;; 12: ; r0:r3={RAW,ENC} r1=CR
 743       (branch
 744        r3
 745        ;; ; r0:r3=RAW r1=CR
 746        ((write ,(if output-crlf "=\r\n" "=\n"))
 747         (write r0)
 748         (write "=0D")
 749         (end))
 750        ;; ; r0:r3=ENC r1=CR
 751        ((write ,(if output-crlf "=\r\n=" "=\n="))
 752         (write r0 ,mel-ccl-high-table)
 753         (write r0 ,mel-ccl-low-table)
 754         (write "=0D")
 755         (end)))
 756       ;; 13: r0:r3=RAW CR LF ;
 757       ;; 13: r0:r3=RAW CRLF ;
 758       (end)
 759       ;; 14: r0:r3=ENC CR LF ;
 760       ;; 14: r0:r3=ENC CRLF ;
 761       (end)
 762       ))
 763     ))
 764
 765 (defun mel-ccl-decode-quoted-printable-generic (input-crlf output-crlf)
 766   `(1
 767     ((read r0)
 768      (loop
 769       (branch
 770        r0
 771        ,@(mapcar
 772           (lambda (r0)
 773             (let ((tmp (aref mel-ccl-qp-table r0)))
 774               (cond
 775                ((eq tmp 'raw) `(write-read-repeat r0))
 776                ((eq tmp 'wsp) (if (eq r0 (char-int ? ))
 777                                   `(r1 = 1)
 778                                 `(r1 = 0)))
 779                ((eq tmp 'cr)
 780                 (if input-crlf
 781                     ;; r0='\r'
 782                     `((read r0)
 783                       ;; '\r' r0
 784                       (if (r0 == ?\n)
 785                           ;; '\r' r0='\n'
 786                           ;; hard line break found.
 787                           ,(if output-crlf
 788                                '((write ?\r)
 789                                  (write-read-repeat r0))
 790                              '(write-read-repeat r0))
 791                         ;; '\r' r0:[^\n]
 792                         ;; invalid control character (bare CR) found.
 793                         ;; -> ignore it and rescan from r0.
 794                         (repeat)))
 795                   ;; r0='\r'
 796                   ;; invalid character (bare CR) found.
 797                   ;; -> ignore.
 798                   `((read r0)
 799                     (repeat))))
 800                ((eq tmp 'lf)
 801                 (if input-crlf
 802                     ;; r0='\n'
 803                     ;; invalid character (bare LF) found.
 804                     ;; -> ignore.
 805                     `((read r0)
 806                       (repeat))
 807                   ;; r0='\r\n'
 808                   ;; hard line break found.
 809                   (if output-crlf
 810                       '((write ?\r)
 811                         (write-read-repeat r0))
 812                     '(write-read-repeat r0))))
 813                ((eq r0 (char-int ?=))
 814                 ;; r0='='
 815                 `((read r0)
 816                   ;; '=' r0
 817                   (r1 = (r0 == ?\t))
 818                   (if ((r0 == ? ) | r1)
 819                       ;; '=' r0:[\t ]
 820                       ;; Skip transport-padding.
 821                       ;; It should check CR LF after
 822                       ;; transport-padding.
 823                       (loop
 824                        (read-if (r0 == ?\t)
 825                                 (repeat)
 826                                 (if (r0 == ? )
 827                                     (repeat)
 828                                   (break)))))
 829                   ;; '=' [\t ]* r0:[^\t ]
 830                   (branch
 831                    r0
 832                    ,@(mapcar
 833                       (lambda (r0)
 834                         (cond
 835                          ((eq r0 (char-int ?\r))
 836                           (if input-crlf
 837                               ;; '=' [\t ]* r0='\r'
 838                               `((read r0)
 839                                 ;; '=' [\t ]* '\r' r0
 840                                 (if (r0 == ?\n)
 841                                     ;; '=' [\t ]* '\r' r0='\n'
 842                                     ;; soft line break found.
 843                                     ((read r0)
 844                                      (repeat))
 845                                   ;; '=' [\t ]* '\r' r0:[^\n]
 846                                   ;; invalid input ->
 847                                   ;; output "=" and rescan from r0.
 848                                   ((write "=")
 849                                    (repeat))))
 850                             ;; '=' [\t ]* r0='\r'
 851                             ;; invalid input (bare CR found) ->
 852                             ;; output "=" and rescan from next.
 853                             `((write ?=)
 854                               (read r0)
 855                               (repeat))))
 856                          ((eq r0 (char-int ?\n))
 857                           (if input-crlf
 858                               ;; '=' [\t ]* r0='\n'
 859                               ;; invalid input (bare LF found) ->
 860                               ;; output "=" and rescan from next.
 861                               `((write ?=)
 862                                 (read r0)
 863                                 (repeat))
 864                             ;; '=' [\t ]* r0='\r\n'
 865                             ;; soft line break found.
 866                             `((read r0)
 867                               (repeat))))
 868                          ((setq tmp (nth r0 mel-ccl-256-to-16-table))
 869                           ;; '=' [\t ]* r0:[0-9A-F]
 870                           ;; upper nibble of hexadecimal digit found.
 871                           `((r1 = r0)
 872                             (r0 = ,tmp)))
 873                          (t
 874                           ;; '=' [\t ]* r0:[^\r0-9A-F]
 875                           ;; invalid input ->
 876                           ;; output "=" and rescan from r0.
 877                           `((write ?=)
 878                             (repeat)))))
 879                       mel-ccl-256-table))
 880                   ;; '=' [\t ]* r1:r0:[0-9A-F]
 881                   (read-branch
 882                    r2
 883                    ,@(mapcar
 884                       (lambda (r2)
 885                         (if (setq tmp (nth r2 mel-ccl-256-to-16-table))
 886                             ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[0-9A-F]
 887                             `(write-read-repeat
 888                               r0
 889                               ,(vconcat
 890                                 (mapcar
 891                                  (lambda (r0)
 892                                    (logior (lsh r0 4) tmp))
 893                                  mel-ccl-16-table)))
 894                           ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
 895                           ;; invalid input
 896                           `(r3 = 0)     ; nop
 897                           ))
 898                       mel-ccl-256-table))
 899                   ;; '=' [\t ]* r1:r0:[0-9A-F] r2:[^0-9A-F]
 900                   ;; invalid input ->
 901                   ;; output "=" with hex digit and rescan from r2.
 902                   (write ?=)
 903                   (r0 = r2)
 904                   (write-repeat r1)))
 905                (t
 906                 ;; r0:[^\t\r -~]
 907                 ;; invalid character found.
 908                 ;; -> ignore.
 909                 `((read r0)
 910                   (repeat))))))
 911           mel-ccl-256-table))
 912       ;; r1[0]:[\t ]
 913       (loop
 914        ,@(apply
 915           'append
 916           (mapcar
 917            (lambda (regnum)
 918              (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
 919                (apply
 920                 'append
 921                 (mapcar
 922                  (lambda (bit)
 923                    (if (= bit 0)
 924                        (if (= regnum 0)
 925                            nil
 926                          `((read r0)
 927                            (if (r0 == ?\t)
 928                                (,reg = 0)
 929                              (if (r0 == ?\ )
 930                                  (,reg = 1)
 931                                ((r6 = ,(+ (* regnum 28) bit))
 932                                 (break))))))
 933                      `((read r0)
 934                        (if (r0 == ?\ )
 935                            (,reg |= ,(lsh 1 bit))
 936                          (if (r0 != ?\t)
 937                              ((r6 = ,(+ (* regnum 28) bit))
 938                               (break)))))))
 939                  mel-ccl-28-table))))
 940            '(0 1 2 3 4)))
 941        ;; white space buffer exhaust.
 942        ;; error: line length limit (76bytes) violation.
 943        ;; -> ignore these white spaces.
 944        (repeat))
 945       ,(if input-crlf
 946            `(if (r0 == ?\r)
 947                 ((read r0)
 948                  (if (r0 == ?\n)
 949                      ;; trailing white spaces found.
 950                      ;; -> ignore these white spacs.
 951                      ((write ,(if output-crlf "\r\n" "\n"))
 952                       (read r0)
 953                       (repeat))
 954                    ;; [\t ]* \r r0:[^\n]
 955                    ;; error: bare CR found.
 956                    ;; -> output white spaces and ignore bare CR.
 957                    ))
 958               ;; [\t ]* r0:[^\r]
 959               ;; middle white spaces found.
 960               )
 961          `(if (r0 == ?\n)
 962               ;; trailing white spaces found.
 963               ;; -> ignore these white spacs.
 964               ((write ,(if output-crlf "\r\n" "\n"))
 965                (read r0)
 966                (repeat))
 967             ;; [\t ]* r0:[^\n]
 968             ;; middle white spaces found.
 969             ))
 970       ,@(apply
 971          'append
 972          (mapcar
 973           (lambda (regnum)
 974             (let ((reg (aref [r1 r2 r3 r4 r5] regnum)))
 975               (apply
 976                'append
 977                (mapcar
 978                 (lambda (bit)
 979                   `((if (,reg & ,(lsh 1 bit))
 980                         (write ?\ )
 981                       (write ?\t))
 982                     (if (r6 == ,(+ (* regnum 28) bit 1))
 983                         (repeat))))
 984                 mel-ccl-28-table))))
 985           '(0 1 2 3 4)))
 986       (repeat)
 987       ))))
 988
 989 )
 990
 991 (define-ccl-program mel-ccl-encode-quoted-printable-crlf-crlf
 992   (mel-ccl-encode-quoted-printable-generic t t))
 993
 994 (define-ccl-program mel-ccl-encode-quoted-printable-crlf-lf
 995   (mel-ccl-encode-quoted-printable-generic t nil))
 996
 997 (define-ccl-program mel-ccl-encode-quoted-printable-lf-crlf
 998   (mel-ccl-encode-quoted-printable-generic nil t))
 999
1000 (define-ccl-program mel-ccl-encode-quoted-printable-lf-lf
1001   (mel-ccl-encode-quoted-printable-generic nil nil))
1002
1003 (define-ccl-program mel-ccl-decode-quoted-printable-crlf-crlf
1004   (mel-ccl-decode-quoted-printable-generic t t))
1005
1006 (define-ccl-program mel-ccl-decode-quoted-printable-crlf-lf
1007   (mel-ccl-decode-quoted-printable-generic t nil))
1008
1009 (define-ccl-program mel-ccl-decode-quoted-printable-lf-crlf
1010   (mel-ccl-decode-quoted-printable-generic nil t))
1011
1012 (define-ccl-program mel-ccl-decode-quoted-printable-lf-lf
1013   (mel-ccl-decode-quoted-printable-generic nil nil))
1014
1015
1016 ;;; @ coding system
1017 ;;;
1018
1019 (make-ccl-coding-system
1020  'mel-ccl-uq-rev ?Q "MIME Q-encoding in unstructured field (reversed)"
1021  'mel-ccl-encode-uq 'mel-ccl-decode-q)
1022
1023 (make-ccl-coding-system
1024  'mel-ccl-cq-rev ?Q "MIME Q-encoding in comment (reversed)"
1025  'mel-ccl-encode-cq 'mel-ccl-decode-q)
1026
1027 (make-ccl-coding-system
1028  'mel-ccl-pq-rev ?Q "MIME Q-encoding in phrase (reversed)"
1029  'mel-ccl-encode-pq 'mel-ccl-decode-q)
1030
1031 (make-ccl-coding-system
1032  'mel-ccl-b-rev ?B "MIME B-encoding (reversed)"
1033  'mel-ccl-encode-b 'mel-ccl-decode-b)
1034
1035 (make-ccl-coding-system
1036  'mel-ccl-quoted-printable-crlf-crlf-rev
1037  ?Q "MIME Quoted-Printable-encoding (reversed)"
1038  'mel-ccl-encode-quoted-printable-crlf-crlf
1039  'mel-ccl-decode-quoted-printable-crlf-crlf)
1040
1041 (make-ccl-coding-system
1042  'mel-ccl-quoted-printable-lf-crlf-rev
1043  ?Q "MIME Quoted-Printable-encoding (LF encoding) (reversed)"
1044  'mel-ccl-encode-quoted-printable-crlf-lf
1045  'mel-ccl-decode-quoted-printable-lf-crlf)
1046
1047 (make-ccl-coding-system
1048  'mel-ccl-quoted-printable-crlf-lf-rev
1049  ?Q "MIME Quoted-Printable-encoding (LF internal) (reversed)"
1050  'mel-ccl-encode-quoted-printable-lf-crlf
1051  'mel-ccl-decode-quoted-printable-crlf-lf)
1052
1053 (make-ccl-coding-system
1054  'mel-ccl-quoted-printable-lf-lf-rev
1055  ?Q "MIME Quoted-Printable-encoding (LF encoding) (LF internal) (reversed)"
1056  'mel-ccl-encode-quoted-printable-lf-lf
1057  'mel-ccl-decode-quoted-printable-lf-lf)
1058
1059 (make-ccl-coding-system
1060  'mel-ccl-base64-crlf-rev
1061  ?B "MIME Base64-encoding (reversed)"
1062  'mel-ccl-encode-base64-crlf-crlf
1063  'mel-ccl-decode-b)
1064
1065 (make-ccl-coding-system
1066  'mel-ccl-base64-lf-rev
1067  ?B "MIME Base64-encoding (LF encoding) (reversed)"
1068  'mel-ccl-encode-base64-crlf-lf
1069  'mel-ccl-decode-b)
1070
1071
1072 ;;; @ B
1073 ;;;
1074
1075 (unless (and (boundp 'ccl-encoder-eof-block-is-broken)
1076              ccl-encoder-eof-block-is-broken)
1077
1078   (defun base64-ccl-encode-string (string)
1079     "Encode STRING with base64 encoding."
1080     (decode-coding-string string 'mel-ccl-base64-lf-rev))
1081
1082   (defun base64-ccl-encode-region (start end)
1083     "Encode region from START to END with base64 encoding."
1084     (interactive "r")
1085     (decode-coding-region start end 'mel-ccl-base64-lf-rev))
1086
1087   (defun base64-ccl-insert-encoded-file (filename)
1088     "Encode contents of file FILENAME to base64, and insert the result."
1089     (interactive (list (read-file-name "Insert encoded file: ")))
1090     (let ((coding-system-for-read 'mel-ccl-b-rev))
1091       (insert-file-contents filename)))
1092
1093   )
1094
1095 (defun base64-ccl-decode-string (string)
1096   "Decode base64 encoded STRING"
1097   (encode-coding-string string 'mel-ccl-b-rev))
1098
1099 (defun base64-ccl-decode-region (start end)
1100   "Decode base64 encoded the region from START to END."
1101   (interactive "r")
1102   (encode-coding-region start end 'mel-ccl-b-rev))
1103
1104 (defun base64-ccl-write-decoded-region (start end filename)
1105   "Decode the region from START to END and write out to FILENAME."
1106   (interactive
1107     (list (region-beginning) (region-end)
1108           (read-file-name "Write decoded region to file: ")))
1109   (let ((coding-system-for-write 'mel-ccl-b-rev))
1110     (write-region start end filename)))
1111
1112
1113 ;;; @ quoted-printable
1114 ;;;
1115
1116 (unless (and (boundp 'ccl-encoder-eof-block-is-broken)
1117              ccl-encoder-eof-block-is-broken)
1118
1119   (defun quoted-printable-ccl-encode-string (string)
1120     "Encode STRING with quoted-printable encoding."
1121     (decode-coding-string
1122      string
1123      'mel-ccl-quoted-printable-lf-lf-rev))
1124
1125   (defun quoted-printable-ccl-encode-region (start end)
1126     "Encode the region from START to END with quoted-printable
1127 encoding."
1128     (interactive "r")
1129     (decode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
1130
1131   (defun quoted-printable-ccl-insert-encoded-file (filename)
1132     "Encode contents of the file named as FILENAME, and insert it."
1133     (interactive (list (read-file-name "Insert encoded file: ")))
1134     (let ((coding-system-for-read 'mel-ccl-quoted-printable-lf-lf-rev))
1135       (insert-file-contents filename)))
1136
1137   )
1138
1139 (defun quoted-printable-ccl-decode-string (string)
1140   "Decode quoted-printable encoded STRING."
1141   (encode-coding-string
1142    string
1143    'mel-ccl-quoted-printable-lf-lf-rev))
1144
1145 (defun quoted-printable-ccl-decode-region (start end)
1146   "Decode the region from START to END with quoted-printable
1147 encoding."
1148   (interactive "r")
1149   (encode-coding-region start end 'mel-ccl-quoted-printable-lf-lf-rev))
1150
1151 (defun quoted-printable-ccl-write-decoded-region
1152   (start end filename)
1153   "Decode quoted-printable encoded current region and write out to FILENAME."
1154   (interactive
1155    (list (region-beginning) (region-end)
1156          (read-file-name "Write decoded region to file: ")))
1157   (let ((coding-system-for-write 'mel-ccl-quoted-printable-lf-lf-rev))
1158     (write-region start end filename)))
1159
1160
1161 ;;; @ Q
1162 ;;;
1163
1164 (defun q-encoding-ccl-encode-string (string &optional mode)
1165   "Encode STRING to Q-encoding of encoded-word, and return the result.
1166 MODE allows `text', `comment', `phrase' or nil.  Default value is
1167 `phrase'."
1168   (decode-coding-string
1169    string
1170    (cond
1171     ((eq mode 'text) 'mel-ccl-uq-rev)
1172     ((eq mode 'comment) 'mel-ccl-cq-rev)
1173     (t 'mel-ccl-pq-rev))))
1174
1175 (defun q-encoding-ccl-decode-string (string)
1176   "Decode Q encoded STRING and return the result."
1177   (encode-coding-string
1178    string
1179    'mel-ccl-uq-rev))
1180
1181 (unless running-xemacs
1182   (defun q-encoding-ccl-encoded-length (string &optional mode)
1183     "Encode STRING to Q-encoding of encoded-word, and return the result.
1184 MODE allows `text', `comment', `phrase' or nil.  Default value is
1185 `phrase'."
1186     (let ((status [nil nil nil nil nil nil nil nil nil]))
1187       (fillarray status nil)
1188       (ccl-execute-on-string
1189        (cond
1190         ((eq mode 'text) 'mel-ccl-count-uq)
1191         ((eq mode 'comment) 'mel-ccl-count-cq)
1192         (t 'mel-ccl-count-pq))
1193        status
1194        string)
1195       (aref status 0)))
1196   )
1197
1198 ;;; @ end
1199 ;;;
1200
1201 (provide 'mel-ccl)
1202
1203 '(
1204 (let ((str0 "a\f \t\r
1205 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\r
1206 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\r
1207 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\r
1208 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\f\r
1209 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\f\r
1210 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\f\r
1211                                                                           \r
1212                                                                            \r
1213                                                                             \r
1214 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa \r
1215 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa \r
1216 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa \r
1217 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa \r
1218 bbb \r
1219 bbbb\r
1220 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc\rccc\r
1221 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc\r\r\nccc\r
1222 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc\r\rccc\r
1223 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc\rccc\r
1224 dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\r\neee\r
1225 dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\reee\r
1226 ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddeee\r
1227 ")
1228       str1 encoded decoded)
1229   (setq str1 (ew-crlf-to-lf str0)
1230         encoded
1231         (list
1232          (decode-coding-string
1233           str0
1234           'mel-ccl-quoted-printable-crlf-crlf-rev)
1235          (decode-coding-string
1236           str0
1237           'mel-ccl-quoted-printable-lf-crlf-rev)
1238          (decode-coding-string
1239           str1
1240           'mel-ccl-quoted-printable-crlf-lf-rev)
1241          (decode-coding-string
1242           str1
1243           'mel-ccl-quoted-printable-lf-lf-rev))
1244         decoded
1245         (list
1246          (encode-coding-string
1247           (nth 0 encoded)
1248           'mel-ccl-quoted-printable-crlf-crlf-rev)
1249          (encode-coding-string
1250           (nth 1 encoded)
1251           'mel-ccl-quoted-printable-lf-crlf-rev)
1252          (encode-coding-string
1253           (nth 2 encoded)
1254           'mel-ccl-quoted-printable-crlf-lf-rev)
1255          (encode-coding-string
1256           (nth 3 encoded)
1257           'mel-ccl-quoted-printable-lf-lf-rev)))
1258   (list
1259    (string= str0 (nth 0 decoded))
1260    (string= str0 (nth 1 decoded))
1261    (string= str1 (nth 2 decoded))
1262    (string= str1 (nth 3 decoded))))
1263
1264 ;; for xemacs
1265 (defun make-ccl-coding-system (name mnemonic doc-string decoder encoder)
1266   (make-coding-system
1267    name 'ccl doc-string
1268    (list 'mnemonic (char-to-string mnemonic)
1269          'decode (symbol-value decoder)
1270          'encode (symbol-value encoder))))
1271
1272 )