;;; utf.el --- library for UCS Transformation Formats

;; Copyright (C) 2000 Miyashita Hisashi

;; Keywords: mule, multilingual, 
;;           coding-system, ISO/IEC 10646, UTF, Unicode

;; This file is part of Mule-UCS

;; Mule-UCS is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; Mule-UCS is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; 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.

;; Comment:
;;  This module supports major Transformation Formats for UCS.

(or (featurep 'mule-ucs-unicode)
    (load-library "unicode"))
;(require 'unicode)
(require 'tae)

;; Because of the incompatibility between XEmacs and Emacs on
;; number literal, we use cn macro that translates a string in
;; C-notation to number.  But if all hexadeciman numbers are
;; described by cn macro, the code seems very dirty, so I use
;; cn macro only on numbers more than 0xFF.  Strictly, it is
;; not reasonable, because we cannot apply arithmetic
;; transformation to characters. But we can use ?\x00-?\xFF, because
;; all of them are mapped into 0-255 in CCL environments of
;; both XEmacs and Emacs.

(require 'trans-util)

;;; Buffer magnification scales for UTFs.

(defconst utf-7-encode-buffer-magnification 3)
(defconst utf-7-decode-buffer-magnification 1)
(defconst utf-8-encode-buffer-magnification 2)
(defconst utf-8-decode-buffer-magnification 2)
(defconst utf-16-encode-buffer-magnification 2)
(defconst utf-16-decode-buffer-magnification 2)

;;
;; Dealing with line separator problem.
;;

(defun convert-unicode-lf-2-crlf (cr-output)
  `((if (r0 == ,unicode-lf)
	,(append cr-output))))

;; The following CCL programs supprots
;; WRITE SIGNATURE, CHECK AND READ SIGNATURE
;; READ, and WRITE functions.

;UTF 8 ------------------------------------------------

(defvar utf-8-ccl-encode
  `((if (r0 < ?\x80)
	((write r0))
      (if (r0 < ,(cn "0x800"))
	  ((write ((r0 >> 6) | ?\xC0))
	   (write ((r0 & ?\x3F) | ?\x80)))
	(if (r0 < ,(cn "0x10000"))
	    ((write ((r0 >> 12) | ?\xE0))
	     (write (((r0 >> 6) & ?\x3F) | ?\x80))
	     (write ((r0 & ?\x3F) | ?\x80)))
	  (if (r0 < ,(cn "0x200000"))
	      ((write ((r0 >> 18) | ?\xF0))
	       (write (((r0 >> 12) & ?\x3F) | ?\x80))
	       (write (((r0 >> 6) & ?\x3F) | ?\x80))
	       (write ((r0 & ?\x3F) | ?\x80)))
	    (if (r0 < ,(cn "0x4000000"))
		((write ((r0 >> 24) | ?\xF8))
		 (write (((r0 >> 18) & ?\x3F) | ?\x80))
		 (write (((r0 >> 12) & ?\x3F) | ?\x80))
		 (write (((r0 >> 6) & ?\x3F) | ?\x80))
		 (write ((r0 & ?\x3f) | ?\x80)))
	      ((write ((r0 >> 30) | ?\xFC))
	       (write (((r0 >> 24) & ?\x3F) | ?\x80))
	       (write (((r0 >> 18) & ?\x3F) | ?\x80))
	       (write (((r0 >> 12) & ?\x3F) | ?\x80))
	       (write (((r0 >> 6) & ?\x3F) | ?\x80))
	       (write ((r0 & ?\x3f) | ?\x80))))))))))

(defvar utf-8-ccl-decode
  `((read-if (r0 >= ?\x80)
	((if (r0 < ?\xE0)
	     ((read r4)
	      (r4 &= ?\x3F)
	      (r0 = (((r0 & ?\x1F) << 6) | r4)))
	   (if (r0 < ?\xF0)
	       ((read r4 r6)
		(r4 = ((r4  & ?\x3F) << 6))
		(r6 &= ?\x3F)
		(r0 = ((((r0 & ?\x0F) << 12) | r4) | r6)))
	     (if (r0 < ?\xF8)
		 ((read r1 r4 r6)
		  (r1 = ((r1  & ?\x3F) << 12))
		  (r4 = ((r4  & ?\x3F) << 6))
		  (r6 &= ?\x3F)
		  (r0 = (((((r0 & ?\x07) << 18) | r1) | r4) | r6)))
	       (if (r0 < ?\xFC)
;;;; MUCS can't read any numbers lager than 24bit
		   ((read r0 r1 r4 r6)
		    (r1 = ((r1  & ?\x3F) << 12))
		    (r4 = ((r4  & ?\x3F) << 6))
		    (r6 &= ?\x3F)
		    (r0 = (((((r0 & ?\x3F) << 18) | r1) | r4) | r6)))
		 (r0 = 0)))))))))

(mucs-type-register-serialization
 'ucs-generic
 'utf-8
 (quote `(,utf-8-ccl-encode))
 (quote `(,utf-8-ccl-decode)))

(mucs-type-register-serialization
 'ucs-generic
 'utf-8-dos
 (quote
  `(,(append
      (convert-unicode-lf-2-crlf '((write ?\xd)))
      utf-8-ccl-encode)))
 'none)

(defun mucs-ccl-write-utf-8-signature ()
  '((write "\xEF\xBB\xBF")))

(defun mucs-ccl-utf-8-check-signature-read ()
  (append
   utf-8-ccl-decode
   `((if (r0 == ,unicode-signature)
	 ,utf-8-ccl-decode))))

;UTF 16 -----------------------------------------------

(defun utf-16-ccl-surrogate-pair-p (reg)
  `((,reg & ,(cn "0xF800")) == ,(cn "0xD800")))

(mucs-ccl-internal-state-reserve 'utf-16-little-endian-p 1)

(defvar utf-16-ccl-decode
  `((if ,(mucs-ccl-check-internal-state 'utf-16-little-endian-p)
	,mucs-ccl-read-ex-le-2-octet
      ,mucs-ccl-read-ex-be-2-octet)
    (if ,(utf-16-ccl-surrogate-pair-p 'r0)
	((if ,(mucs-ccl-check-internal-state 'utf-16-little-endian-p)
	     ((read r6 r4))
	   ((read r4 r6)))
	 (r0 = (((r0 & #x3ff) + ?\x40) << 10))
	 (r6 &= ?\x3f)
	 (r4 = ((r4 & ?\x3) << 6) | r6)
	 (r0 |=  r4)))))

(defun mucs-ccl-utf-16-check-signature-read ()
  (append mucs-ccl-read-ex-le-2-octet
	  `((if (r0 == ,unicode-signature)
		,(append (mucs-ccl-set-internal-state
			  'utf-16-little-endian-p t)
			 mucs-ccl-read-ex-le-2-octet)
	      (if (r0 == ,unicode-reverse-signature)
		  ,(append (mucs-ccl-set-internal-state
			    'utf-16-little-endian-p nil)
			   mucs-ccl-read-ex-be-2-octet)))
	    (if ,(utf-16-ccl-surrogate-pair-p 'r0)
		((if ,(mucs-ccl-check-internal-state 'utf-16-little-endian-p)
		     ((read r6 r4))
		   ((read r4 r6)))
		 (r0 = (((r0 & ,(cn "0x3FF")) + ?\x40) << 10))
		 (r6 &= ?\x3F)
		 (r4 = ((r4 & ?\x03) << 6) | r6)
		 (r0 |=  r4))))))

(defun mucs-ccl-read-utf-16 ()
  utf-16-ccl-decode)

;UTF 16 Little Endian----------------------------------

(defvar utf-16-le-ccl-encode
  `((if (r0 < ,(cn "0xFFFF"))
	,mucs-ccl-write-ex-be-2-octet
      ((r4 = (((r0 >> 10) & ,(cn "0x03FF")) - ?\x40)) ; - 0x10000
       (write (r4 & ?\xFF))
       (write ((r4 >> 8) | ?\xD8))
       (write (r0 & ?\xFF))
       (write (((r0 >> 8) & ?\x03) | ?\xDC))))))

(defvar utf-16-le-ccl-decode
  (append mucs-ccl-read-ex-le-2-octet
    `((if ,(utf-16-ccl-surrogate-pair-p 'r0)
	  ((read r6 r4)
	   (r4 = (((r4 & ?\x03) << 8) | r6))
	   (r0 = ((((r0 & ,(cn "0x3FF")) + ?\x40) << 10)
		  | r4)))))))

(mucs-type-register-serialization
 'ucs-generic
 'utf-16-le
 (quote `(,utf-16-le-ccl-encode))
 (quote `(,utf-16-le-ccl-decode)))

(mucs-type-register-serialization
 'ucs-generic
 'utf-16-le-dos
 (quote
  `(,(append
      (convert-unicode-lf-2-crlf '((write "\x0D\x00")))
      utf-16-le-ccl-encode)))
 'none)

(defun mucs-ccl-write-utf-16-le-signature ()
  '((write "\xFF\xFE")))

;UTF 16 Big Endian-------------------------------------

(defvar utf-16-be-ccl-decode
  (append mucs-ccl-read-ex-be-2-octet
    `((if ,(utf-16-ccl-surrogate-pair-p 'r0)
	  ((read r4 r6)
	   (r4 = (((r4 & ?\x03) << 8) | r6))
	   (r0 = ((((r0 & ,(cn "0x3FF")) + ?\x40) << 10)
		  | r4)))))))

(defvar utf-16-be-ccl-encode
  `((if (r0 < ,(cn "0xFFFF"))
	,mucs-ccl-write-ex-be-2-octet
      ((r4 = (((r0 >> 10) & ,(cn "0x03FF")) - ?\x40)) ; - 0x10000
       (write ((r4 >> 8) | ?\xD8))
       (write (r4 & ?\xFF))
       (write (((r0 >> 8) & ?\x03) | ?\xDC))
       (write (r0 & ?\xFF))))))

(mucs-type-register-serialization
 'ucs-generic
 'utf-16-be
 (quote `(,utf-16-be-ccl-encode))
 (quote `(,utf-16-be-ccl-decode)))

(mucs-type-register-serialization
 'ucs-generic
 'utf-16-be-dos
 (quote
  `(,(append
      (convert-unicode-lf-2-crlf
       '((write "\x00\x0D")))
      utf-16-be-ccl-encode)))
 'none)

(defun mucs-ccl-write-utf-16-be-signature ()
  '((write "\xFE\xFF")))

;UTF 7 ------------------------------------------------

(mucs-ccl-internal-state-reserve 'utf-7-shifted-p 2)

(defconst utf-7-direct-characters-assoc
  `(assoc
    (ucs-generic . ucs-generic)
    ,(mapcar
      (lambda (x)
	(cons x x))
      '(?+ ?  ?\t ?\r ?\n ;;;; Notice that `+' is included.
	   ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J
	   ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T
	   ?U ?V ?W ?X ?Y ?Z
	   ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j
	   ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t
	   ?u ?v ?w ?x ?y ?z
	   ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
	   ?' ?\( ?\)  ?, ?- ?. ?/ ?: ??))))

(defconst utf-7-optional-direct-characters-assoc
  `(assoc
    (ucs-generic . ucs-generic)
    ,(mapcar
      (lambda (x)
	(cons x x))
      '(?! ?\" ?# ?$ ?% ?& ?* ?; ?< ?=
	   ?> ?@ ?\[ ?\] ?^ ?_ ?` ?\{ ?| ?\}))))

(defconst utf-7-shifted-character-assoc
  '(assoc (ucs-generic . ucs-generic)
	  ((all . invalid))))

; (defconst utf-7-b64-assoc
;   `(assoc
;     (b64-char . number)
;     '((?A . 00) (?B . 01) (?C . 02) (?D . 03)
;       (?E . 04) (?F . 05) (?G . 06) (?H . 07)
;       (?I . 08) (?J . 09) (?K . 10) (?L . 11)
;       (?M . 12) (?N . 13) (?O . 14) (?P . 15)
;       (?Q . 16) (?R . 17) (?S . 18) (?T . 19)
;       (?U . 20) (?V . 21) (?W . 22) (?X . 23)
;       (?Y . 24) (?Z . 25) (?a . 26) (?b . 27)
;       (?c . 28) (?d . 29) (?e . 30) (?f . 31)
;       (?g . 32) (?h . 33) (?i . 34) (?j . 35) 
;       (?k . 36) (?l . 37) (?m . 38) (?n . 39) 
;       (?o . 40) (?p . 41) (?q . 42) (?r . 43) 
;       (?s . 44) (?t . 45) (?u . 46) (?v . 47)
;       (?w . 48) (?x . 49) (?y . 50) (?z . 51)
;       (?0 . 52) (?1 . 53) (?2 . 54) (?3 . 55)
;       (?4 . 56) (?5 . 57) (?6 . 58) (?7 . 59)
;       (?8 . 60) (?9 . 61) (?+ . 62) (?/ . 63)
;       (all . invalid) (invalid . all))))

(defconst ccl-b64-encode-table
  '[?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ;; 0-9
    ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ;; 10-19
    ?U ?V ?W ?X ?Y ?Z             ;; 20-25
    ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ;; 26-35
    ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ;; 36-45
    ?u ?v ?w ?x ?y ?z             ;; 46-51
    ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ;; 52-61
    ?+ ?/])                       ;; 62-63

(defconst ccl-b64-decode-table
  '[ -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  62  -1  -1  -1  63
     52  53  54  55  56  57  58  59  60  61  -1  -1  -1  -2  -1  -1
     -1   0   1   2   3   4   5   6   7   8   9  10  11  12  13  14
     15  16  17  18  19  20  21  22  23  24  25  -1  -1  -1  -1  -1
     -1  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40
     41  42  43  44  45  46  47  48  49  50  51  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1
     -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1  -1])

(tae-declare-translation
 'utf-7-direct-character-p-translation
 `(| ,utf-7-direct-characters-assoc
     ,utf-7-shifted-character-assoc))

(tae-declare-translation
 'utf-7-direct-or-optional-character-p-translation
 `(| ,utf-7-direct-characters-assoc
     ,utf-7-optional-direct-characters-assoc
     ,utf-7-shifted-character-assoc))

(defun ccl-utf-7-base64-encode (valc valp &optional init)
  (if (or (eq valc 'r0)
	  (eq valp 'r0))
      (error "r0 is reserved for caliculation."))
  (let (result)
    (if init
	(setq result
	      `(,@(mucs-ccl-set-internal-state 'utf-7-shifted-p t)
		  (,valp = 0))))
    (setq result
	  (append
	   result
	   `((if (,valc > ,(cn "0xFFFF"))
		 ((r0 = ((((,valc >> 10) - ?\x40)
			  & ,(cn "0x3FF")) | ,(cn "0xD800")))
		  (,valc = ((,valc & ,(cn "0x3FF"))
			    | ,(cn "0xDC00"))))
	       ((r0 = ,valc)
		(,valc = 0)))
	     (loop
	      (if (,valp == 0) ;; 0bit
		  ((,valp = (r0 >> 10))
		   (write ,valp ,ccl-b64-encode-table)
		   (,valp = ((r0 >> 4) & ?\x3F))
		   (write ,valp ,ccl-b64-encode-table)
		   (,valp = ((r0 & ?\x0F) | ?\x30)))
		((if (,valp >= ?\x30) ;; 4bit
		     ((,valp = ((,valp & ?\x0F) << 2))
		      (,valp |= (r0 >> 14))
		      (write ,valp ,ccl-b64-encode-table)
		      (,valp = ((r0 >> 8) & ?\x3F))
		      (write ,valp ,ccl-b64-encode-table)
		      (,valp = ((r0 >> 2) & ?\x3F))
		      (write ,valp ,ccl-b64-encode-table)
		      (,valp = ((r0 & ?\x03) | ?\x20)))
		   ((if (,valp >= ?\x20) ;; 2bit
			((,valp = ((,valp & ?\x03) << 4))
			 (,valp |= (r0 >> 12))
			 (write ,valp ,ccl-b64-encode-table)
			 (,valp = ((r0 >> 6) & ?\x3F))
			 (write ,valp ,ccl-b64-encode-table)
			 (,valp = (r0 & ?\x3F))
			 (write ,valp ,ccl-b64-encode-table)
			 (,valp = 0)))))))
	      (if (,valc != 0)
		  ((r0 = ,valc)
		   (,valc = 0)
		   (repeat)))))))))

(defun ccl-utf-7-base64-encode-flush (valp)
  `(,@(mucs-ccl-set-internal-state 'utf-7-shifted-p nil)
    (if (,valp >= ?\x30) ;; 4bit
	((,valp = ((,valp << 2) & ?\x3F))
	 (write ,valp ,ccl-b64-encode-table))
      ((if (,valp >= ?\x20) ;; 2bit
	   ((,valp = ((,valp << 4) & ?\x3F))
	    (write ,valp ,ccl-b64-encode-table)))))
    (write ?-)
    (,valp = 0)))

(defun mucs-ccl-utf-7-encode-eof ()
  `((if ,(mucs-ccl-check-internal-state 'utf-7-shifted-p)
	,(ccl-utf-7-base64-encode-flush 'r6))))

(defun mucs-ccl-utf-7-encode (direct-character-translation dos)
  `(((r4 = r0))
    ,(tae-compile direct-character-translation nil)
    ,(mucs-ccl-if-invalid
       ;;; shifted state
      (quote
       `(((if ,(mucs-ccl-check-internal-state 'utf-7-shifted-p)
	      ,(ccl-utf-7-base64-encode 'r4 'r6)
	    ((write ?+)
	     ,@(ccl-utf-7-base64-encode 'r4 'r6 t))))))
       ;;; Non-shifted state
      (quote
       `(((if ,(mucs-ccl-check-internal-state 'utf-7-shifted-p)
	      ,(ccl-utf-7-base64-encode-flush 'r6))
	  ,@(if dos
		'((if (r0 == ?\n)
		      ((write "\x0D\x0A"))
		    ((write r0))))
	      '((write r0)))
	  (if (r0 == ?+)
	      ((write ?-)))))))))

(defconst ccl-utf-7-decode
  `((r4 = 0)
    (loop
     (if ,(mucs-ccl-check-internal-state 'utf-7-shifted-p)
	 ((read r0)
	  (r1 = r0 ,ccl-b64-decode-table)
	  (if (r1 >= 0)
	      ((r6 = ((r6 << 6) | r1))
	       (read r0)
	       (r1 = r0 ,ccl-b64-decode-table)
	       (if (r1 >= 0)
		   ((r6 = ((r6 << 6) | r1))
		    (if (r6 >= ,(cn "0x30000"))
			((r0 = (r6 & #xFFFF))
			 (r6 = 0))
		      ((read r0)
		       (r1 = r0 ,ccl-b64-decode-table)
		       (if (r1 >= 0)
			   ((r6 = ((r6 << 6) | r1))
			    (if (r6 >= #x800000)
				;; r6 = 1000 XXXX XXXX XXXX XXXX XXXX
				((r0 = ((r6 >> 4) & ,(cn "0xFFFF")))
				 (r6 = ((r6 & ?\xF) | ?\x30)))
			      ;; r6 = XXXX XXXX XXXX XXXX XX
			      ((r0 = ((r6 >> 2) & ,(cn "0xFFFF")))
			       (r6 = ((r6 & ?\x3) | ?\x20)))))
			 ,(mucs-ccl-set-internal-state
			   'utf-7-shifted-p nil)))))
		 ,(mucs-ccl-set-internal-state
		   'utf-7-shifted-p nil)))
	    (,@(mucs-ccl-set-internal-state
		'utf-7-shifted-p nil)
	     (if (r0 == ?-)
		 ((repeat))))))
       ((read-if (r0 == ?+)
		 ((read-if (r0 == ?-)
			   ((r0 = ?+))
			((r6 = r0 ,ccl-b64-decode-table)
			 (if (r6 >= 0)
			     ((read r0)
			      (r1 = r0 ,ccl-b64-decode-table)
			      (if (r1 >= 0)
				  ((r6 = ((r6 << 6) | r1))
				   (read r0)
				   (r1 = r0 ,ccl-b64-decode-table)
				   (if (r1 >= 0)
				       ((r6 = ((r6 << 6) | r1))
					(r0 = (r6 >> 2))
					(r6 = ((r6 & ?\x03) | ?\x20))
					,@(mucs-ccl-set-internal-state
					   'utf-7-shifted-p t)))))))))))))
     (if (r4 != 0)
	 ((r0 &= ,(cn "0x3FF"))
	  (r0 = ((((r4 & ,(cn "0x3FF")) + ?\x40) << 10)
		 | r0)))
       ((if ,(utf-16-ccl-surrogate-pair-p 'r0)
	    ((r4 = r0)
	     (repeat))))))))

(mucs-type-register-serialization
 'ucs-generic
 'utf-7
 '(mucs-ccl-utf-7-encode
   'utf-7-direct-or-optional-character-p-translation
   nil)
 (quote `(,ccl-utf-7-decode)))

(mucs-type-register-serialization
 'ucs-generic
 'utf-7-safe
 '(mucs-ccl-utf-7-encode
   'utf-7-direct-character-p-translation
   nil)
 'none)

(mucs-type-register-serialization
 'ucs-generic
 'utf-7-dos
 '(mucs-ccl-utf-7-encode
   'utf-7-direct-or-optional-character-p-translation
   t)
 'none)

(mucs-type-register-serialization
 'ucs-generic
 'utf-7-safe-dos
 '(mucs-ccl-utf-7-encode
   'utf-7-direct-character-p-translation
   t)
 'none)

(provide 'utf)
