;;; egg-com.el --- Communication Routines in Egg Input
;;;                   Method Architecture

;; Copyright (C) 1997 Mule Project, Powered by Electrotechnical
;; Laboratory, JAPAN.
;; Project Leader: Satoru Tomura <tomura@etl.go.jp>

;; Author: Hisashi Miyashita <himi@bird.scphys.kyoto-u.ac.jp>
;;         NIIBE Yutaka <gniibe@mri.co.jp>
;; Maintainer: NIIBE Yutaka <gniibe@mri.co.jp>

;; This file will be part of GNU Emacs (in future).

;; GNU Emacs 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.

;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(eval-and-compile
(define-ccl-program ccl-decode-fixed-euc-jp
  `(2
    ((r2 = ,(charset-id 'japanese-jisx0208))
     (r3 = ,(charset-id 'japanese-jisx0212))
     (r4 = ,(charset-id 'katakana-jisx0201))
     (read r0)
     (loop
      (read r1)
      (if (r0 < ?\x80)
	  ((r0 = r1)
	   (if (r1 < ?\x80)
	       (write-read-repeat r0))
	   (write r4)
	   (write-read-repeat r0))
	((if (r1 > ?\x80)
	     ((write r2 r0)
	      (r0 = r1)
	      (write-read-repeat r0))
	   ((write r3 r0)
	    (r0 = (r1 | ?\x80))
	    (write-read-repeat r0)))))))))

(define-ccl-program ccl-encode-fixed-euc
  `(2
    ((read r0)
     (loop
;      (if (r0 < ?\x20)
;	  (write-read-repeat r0))
      (if (r0 == ,(charset-id 'latin-jisx0201))                 ; Unify
	  ((read r0)
	   (r0 &= ?\x7f)))
      (if (r0 < ?\x80)
	  ((write 0)
	   (write-read-repeat r0)))
      (r6 = (r0 == ,(charset-id 'japanese-jisx0208)))
      (r6 |= (r0 == ,(charset-id 'japanese-jisx0208-1978)))
      (r6 |= (r0 == ,(charset-id 'chinese-gb2312)))
      (r6 |= (r0 == ,(charset-id 'korean-ksc5601)))
      (if r6                                                      ;G1
	  ((read r0)
	   (write r0)
	   (read r0)
	   (write-read-repeat r0)))
      (r6 = (r0 == ,(charset-id 'katakana-jisx0201)))
      (r6 |= (r0 == ,(charset-id 'chinese-sisheng)))
      (if r6                                                      ;G2
	  ((read r0)
	   (write 0)
	   (write-read-repeat r0)))
      (if (r0 == ,(charset-id 'japanese-jisx0212))                ;G3
	  ((read r0)
	   (write r0)
	   (read r0)
	   (r0 &= ?\x7f)
	   (write-read-repeat r0)))
      (read r0)
      (repeat)))))
)

(make-coding-system 'fixed-euc-jp 4 ?W "Coding System for fixed EUC Japanese"
		    (cons ccl-decode-fixed-euc-jp ccl-encode-fixed-euc))

(defsubst comm-format-u32c (uint32c)
  (let ((h0 (car uint32c))
	(h1 (cdr uint32c)))
    (let ((b0 (logand (lsh h0 -8) 255))
	  (b1 (logand h0 255))
	  (b2 (logand (lsh h1 -8) 255))
	  (b3 (logand h1 255)))
      (insert-char b0 1)
      (insert-char b1 1)
      (insert-char b2 1)
      (insert-char b3 1))))

(defsubst comm-format-u32 (uint32)
  (let ((b0 (logand (lsh uint32 -24) 255))
	(b1 (logand (lsh uint32 -16) 255))
	(b2 (logand (lsh uint32 -8) 255))
	(b3 (logand uint32 255)))
    (insert-char b0 1)
    (insert-char b1 1)
    (insert-char b2 1)
    (insert-char b3 1)))

(defsubst comm-format-i32 (int32)
  (let ((b0 (logand (ash int32 -24) 255))
	(b1 (logand (ash int32 -16) 255))
	(b2 (logand (ash int32 -8) 255))
	(b3 (logand int32 255)))
    (insert-char b0 1)
    (insert-char b1 1)
    (insert-char b2 1)
    (insert-char b3 1)))

(defsubst comm-format-u16 (uint16)
  (let ((b0 (logand (lsh uint16 -8) 255))
	(b1 (logand uint16 255)))
    (insert-char b0 1)
    (insert-char b1 1)))

(defsubst comm-format-u8 (uint8)
  (let ((b0 (logand uint8 255)))
    (insert-char b0 1)))

;;; XXX should support other code conversion
(defsubst comm-format-u16-string (s)
  (let ((euc-string (encode-coding-string s 'fixed-euc-jp)))
    (insert euc-string)
    (insert-char 0 1)
    (insert-char 0 1)))

;;; XXX should support other code conversion
(defsubst comm-format-mb-string (s)
  (let ((euc-string (encode-coding-string s 'euc-japan)))
    (insert euc-string)
    (insert-char 0 1)))

(defsubst comm-format-u8-string (s)
  (insert s)
  (insert-char 0 1))

(defsubst comm-format-bytes (s)
  (insert s)
  (insert-char 255 1))

(defmacro comm-format (format &rest args)
  "Format a string out of a control-list and arguments into the buffer.
u means unsigned 32-bit in big endian.
i means unsigned 32-bit in big endian.
w means unsigned 16-bit in big endian.
b means unsigned  8-bit.
S means 16-bit(big endian) wide-character string (0x0000 terminated).
E means multibyte string (0x00 terminated).
s means 8-bit string (0x00 terminated)."
  (let ((p args) result arg f)
    (while format
      (setq arg (car p))
      (setq f (car format))
      (setq result
	    (append result
		    (list
		     (cond ((eq f 'U) (list 'comm-format-u32c arg))
			   ((eq f 'u) (list 'comm-format-u32 arg))
			   ((eq f 'i) (list 'comm-format-i32 arg))
			   ((eq f 'w) (list 'comm-format-u16 arg))
			   ((eq f 'b) (list 'comm-format-u8 arg))
			   ((eq f 'S) (list 'comm-format-u16-string arg))
			   ((eq f 'E) (list 'comm-format-mb-string arg))
			   ((eq f 's) (list 'comm-format-u8-string arg))
			   ((eq f 'B) (list 'comm-format-bytes arg))))))
      (setq p (cdr p))
      (setq format (cdr format)))
    (cons
     'progn
     result)))

;; Do not move the point, leave it where it was.
(defun comm-accept-process-output (proc)
  (let ((p (point)))
    (accept-process-output proc)
    (goto-char p)))

;; Assume PROC is bound to the process of current buffer
(defsubst comm-following-char-or-wait (proc)
  (if (eobp)
      (let ((p (point)))
	(while (= p (point-max))
	  (accept-process-output proc))
	(goto-char p)))
  (following-char))

(defun comm-following+forward-char (proc)
  (prog1
      (comm-following-char-or-wait proc)
    (forward-char 1)))

(defsubst comm-unpack-u32c (proc uint32c)
  (let (h0 h1)
    (setq h0
	 (+
	  (lsh (comm-following+forward-char proc) 8)
	  (comm-following+forward-char proc)))
    (setq h1
	 (+
	  (lsh (comm-following+forward-char proc) 8)
	  (comm-following+forward-char proc)))
    (set uint32c (cons h0 h1))))

(defsubst comm-unpack-u32 (proc uint32)
  (set uint32
       (+
	(lsh (comm-following+forward-char proc) 24)
	(lsh (comm-following+forward-char proc) 16)
	(lsh (comm-following+forward-char proc) 8)
	(comm-following+forward-char proc))))

(defsubst comm-unpack-u16 (proc uint16)
  (set uint16
       (+
	(lsh (comm-following+forward-char proc) 8)
	(comm-following+forward-char proc))))

(defsubst comm-unpack-u8 (proc uint8)
  (set uint8
       (comm-following+forward-char proc)))

;;; XXX should support other conversion (euc-kr, cns)
(defsubst comm-unpack-u16-string (proc s)
  (let ((start (point)))
    (while (not (search-forward "\0\0" nil t))
      (comm-accept-process-output proc))
    (set s (buffer-substring start
			     (+ start
				(decode-coding-region start (- (point) 2)
						      'fixed-euc-jp))))))

;;; XXX should support other conversion (euc-kr, cns)
(defsubst comm-unpack-mb-string (proc s)
  (let ((start (point)))
    (while (not (search-forward "\0" nil t))
      (comm-accept-process-output proc))
    (set s (buffer-substring start
			     (+ start
				(decode-coding-region start (- (point) 1)
						      'euc-japan))))))

(defsubst comm-unpack-u8-string (proc s)
  (let ((start (point)))
    (while (not (search-forward "\0" nil 1))
      (comm-accept-process-output proc))
    (set s (buffer-substring start (1- (point))))))

(defsubst comm-unpack-bytes (proc s)
  (let ((start (point)))
    (while (not (search-forward "\377" nil 1))
      (comm-accept-process-output proc))
    (set s (buffer-substring start (1- (point))))))

(defmacro comm-unpack (format &rest args)
  "Unpack a string out of a control-string and set arguments.
u means unsigned 32-bit in big endian.
w means unsigned 16-bit in big endian.
b means unsigned  8-bit.
S means 16-bit(big endian) string (0x0000 terminated).
E means multibyte string (0x00 terminated).
s means 8-bit string (0x00 terminated).
"
  (let ((p args) result arg f)
    (while format
      (setq arg (car p))
      (setq f (car format))
      (setq result
	    (append result
		    (list
		     (cond ((eq f 'U) (list 'comm-unpack-u32c
					    'proc (list 'quote arg)))
			   ((eq f 'u) (list 'comm-unpack-u32
					    'proc (list 'quote arg)))
			   ((eq f 'w) (list 'comm-unpack-u16
					    'proc (list 'quote arg)))
			   ((eq f 'b) (list 'comm-unpack-u8
					    'proc (list 'quote arg)))
			   ((eq f 'S) (list 'comm-unpack-u16-string
					    'proc (list 'quote arg)))
			   ((eq f 'E) (list 'comm-unpack-mb-string
					    'proc (list 'quote arg)))
			   ((eq f 's) (list 'comm-unpack-u8-string
					    'proc (list 'quote arg)))
			   ((eq f 'B) (list 'comm-unpack-u8-string
					    'proc (list 'quote arg)))))))
      (setq p (cdr p))
      (setq format (cdr format)))
    (cons
     'progn
     result)))

(defmacro comm-call-with-proc (proc vlist send-expr &rest receive-exprs)
  (list
   'let vlist
   (append
    `(save-excursion
       (set-buffer (process-buffer proc))
       (erase-buffer)
       ,send-expr
       (process-send-region proc (point-min) (point-max))
       (goto-char (prog1 (point) (accept-process-output proc))))
    receive-exprs)))

(defmacro comm-call-with-proc-1 (proc vlist send-expr &rest receive-exprs)
  (list
   'let vlist
   (append
    `(progn
       (erase-buffer)
       ,send-expr
       (process-send-region proc (point-min) (point-max))
       (goto-char (prog1 (point) (accept-process-output proc))))
    receive-exprs)))

(provide 'egg-com)
;;; egg-com.el ends here.