egg-com.el

   1 ;;; egg-com.el --- Communication Routines in Egg Input
   2 ;;;                   Method Architecture
   3
   4 ;; Copyright (C) 1997, 1998 Mule Project, Powered by Electrotechnical
   5 ;; Laboratory, JAPAN.
   6 ;; Project Leader: Satoru Tomura <tomura@etl.go.jp>
   7
   8 ;; Author: Hisashi Miyashita <himi@bird.scphys.kyoto-u.ac.jp>
   9 ;;         NIIBE Yutaka <gniibe@mri.co.jp>
  10 ;;         KATAYAMA Yoshio <kate@pfu.co.jp>  ; Korean, Chinese support.
  11 ;; Maintainer: NIIBE Yutaka <gniibe@mri.co.jp>
  12
  13 ;; This file will be part of GNU Emacs (in future).
  14
  15 ;; EGG is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation; either version 2, or (at your option)
  18 ;; any later version.
  19
  20 ;; EGG is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Commentary:
  31
  32 ;;; Code:
  33
  34 (defvar egg-fixed-euc 'fixed-euc-jp)
  35 (make-variable-buffer-local 'egg-fixed-euc)
  36
  37 (defvar egg-mb-euc 'euc-japan)
  38 (make-variable-buffer-local 'egg-mb-euc)
  39
  40 (eval-and-compile
  41 (define-ccl-program ccl-decode-fixed-euc-jp
  42   `(2
  43     ((r2 = ,(charset-id 'japanese-jisx0208))
  44      (r3 = ,(charset-id 'japanese-jisx0212))
  45      (r4 = ,(charset-id 'katakana-jisx0201))
  46      (read r0)
  47      (loop
  48       (read r1)
  49       (if (r0 < ?\x80)
  50           ((r0 = r1)
  51            (if (r1 < ?\x80)
  52                (write-read-repeat r0))
  53            (write r4)
  54            (write-read-repeat r0))
  55         ((if (r1 > ?\x80)
  56              ((write r2 r0)
  57               (r0 = r1)
  58               (write-read-repeat r0))
  59            ((write r3 r0)
  60             (r0 = (r1 | ?\x80))
  61             (write-read-repeat r0)))))))))
  62
  63 (define-ccl-program ccl-encode-fixed-euc
  64   `(2
  65     ((read r0)
  66      (loop
  67 ;      (if (r0 < ?\x20)
  68 ;         (write-read-repeat r0))
  69       (if (r0 == ,(charset-id 'latin-jisx0201))                 ; Unify
  70           ((read r0)
  71            (r0 &= ?\x7f)))
  72       (if (r0 < ?\x80)
  73           ((write 0)
  74            (write-read-repeat r0)))
  75       (r6 = (r0 == ,(charset-id 'japanese-jisx0208)))
  76       (r6 |= (r0 == ,(charset-id 'japanese-jisx0208-1978)))
  77       (r6 |= (r0 == ,(charset-id 'chinese-gb2312)))
  78       (r6 |= (r0 == ,(charset-id 'korean-ksc5601)))
  79       (if r6                                                      ;G1
  80           ((read r0)
  81            (write r0)
  82            (read r0)
  83            (write-read-repeat r0)))
  84       (r6 = (r0 == ,(charset-id 'katakana-jisx0201)))
  85       (r6 |= (r0 == ,(charset-id 'chinese-sisheng)))
  86       (if r6                                                      ;G2
  87           ((read r0)
  88            (write 0)
  89            (write-read-repeat r0)))
  90       (if (r0 == ,(charset-id 'japanese-jisx0212))                ;G3
  91           ((read r0)
  92            (write r0)
  93            (read r0)
  94            (r0 &= ?\x7f)
  95            (write-read-repeat r0)))
  96       (read r0)
  97       (repeat)))))
  98 )
  99
 100 (make-coding-system 'fixed-euc-jp 4 ?W "Coding System for fixed EUC Japanese"
 101                     (cons ccl-decode-fixed-euc-jp ccl-encode-fixed-euc))
 102
 103 (eval-and-compile
 104 (define-ccl-program ccl-decode-fixed-euc-kr
 105   `(2
 106     ((r2 = ,(charset-id 'korean-ksc5601))
 107      (read r0)
 108      (loop
 109       (read r1)
 110       (if (r0 < ?\x80)
 111           (r0 = r1 & ?\x7f)
 112         ((write r2 r0)
 113          (r0 = r1 | ?\x80)))
 114       (write-read-repeat r0)))))
 115
 116 (define-ccl-program ccl-encode-fixed-euc-kr
 117   `(2
 118     ((read r0)
 119      (loop
 120 ;      (if (r0 < ?\x20)
 121 ;         (write-read-repeat r0))
 122       (if (r0 < ?\x80)
 123           ((write 0)
 124            (write-read-repeat r0)))
 125       (if (r0 == ,(charset-id 'korean-ksc5601))
 126           ((read r0)
 127            (r0 |= ?\x80)
 128            (write r0)
 129            (read r0)
 130            (r0 |= ?\x80)
 131            (write-read-repeat r0)))
 132       (read r0)
 133       (repeat)))))
 134 )
 135
 136 (make-coding-system 'fixed-euc-kr 4 ?W "Coding System for fixed EUC Korean"
 137                     (cons ccl-decode-fixed-euc-kr ccl-encode-fixed-euc-kr))
 138 \f
 139 (defsubst comm-format-u32c (uint32c)
 140   (let ((h0 (car uint32c))
 141         (h1 (cdr uint32c)))
 142     (let ((b0 (logand (lsh h0 -8) 255))
 143           (b1 (logand h0 255))
 144           (b2 (logand (lsh h1 -8) 255))
 145           (b3 (logand h1 255)))
 146       (insert-char b0 1)
 147       (insert-char b1 1)
 148       (insert-char b2 1)
 149       (insert-char b3 1))))
 150
 151 (defsubst comm-format-u32 (uint32)
 152   (let ((b0 (logand (lsh uint32 -24) 255))
 153         (b1 (logand (lsh uint32 -16) 255))
 154         (b2 (logand (lsh uint32 -8) 255))
 155         (b3 (logand uint32 255)))
 156     (insert-char b0 1)
 157     (insert-char b1 1)
 158     (insert-char b2 1)
 159     (insert-char b3 1)))
 160
 161 (defsubst comm-format-i32 (int32)
 162   (let ((b0 (logand (ash int32 -24) 255))
 163         (b1 (logand (ash int32 -16) 255))
 164         (b2 (logand (ash int32 -8) 255))
 165         (b3 (logand int32 255)))
 166     (insert-char b0 1)
 167     (insert-char b1 1)
 168     (insert-char b2 1)
 169     (insert-char b3 1)))
 170
 171 (defsubst comm-format-u16 (uint16)
 172   (let ((b0 (logand (lsh uint16 -8) 255))
 173         (b1 (logand uint16 255)))
 174     (insert-char b0 1)
 175     (insert-char b1 1)))
 176
 177 (defsubst comm-format-u8 (uint8)
 178   (let ((b0 (logand uint8 255)))
 179     (insert-char b0 1)))
 180
 181 ;;; XXX should support other code conversion
 182 (defsubst comm-format-u16-string (s)
 183   (let ((euc-string (encode-coding-string s egg-fixed-euc)))
 184     (insert euc-string)
 185     (insert-char 0 1)
 186     (insert-char 0 1)))
 187
 188 ;;; XXX should support other code conversion
 189 (defsubst comm-format-mb-string (s)
 190   (let ((euc-string (encode-coding-string s egg-mb-euc)))
 191     (insert euc-string)
 192     (insert-char 0 1)))
 193
 194 (defsubst comm-format-u8-string (s)
 195   (insert s)
 196   (insert-char 0 1))
 197
 198 (defsubst comm-format-bytes (s)
 199   (insert s)
 200   (insert-char 255 1))
 201
 202 (defmacro comm-format (format &rest args)
 203   "Format a string out of a control-list and arguments into the buffer.
 204 u means unsigned 32-bit in big endian.
 205 i means unsigned 32-bit in big endian.
 206 w means unsigned 16-bit in big endian.
 207 b means unsigned  8-bit.
 208 S means 16-bit(big endian) wide-character string (0x0000 terminated).
 209 E means multibyte string (0x00 terminated).
 210 s means 8-bit string (0x00 terminated)."
 211   (let ((p args) result arg f)
 212     (while format
 213       (setq arg (car p))
 214       (setq f (car format))
 215       (setq result
 216             (append result
 217                     (list
 218                      (cond ((eq f 'U) (list 'comm-format-u32c arg))
 219                            ((eq f 'u) (list 'comm-format-u32 arg))
 220                            ((eq f 'i) (list 'comm-format-i32 arg))
 221                            ((eq f 'w) (list 'comm-format-u16 arg))
 222                            ((eq f 'b) (list 'comm-format-u8 arg))
 223                            ((eq f 'S) (list 'comm-format-u16-string arg))
 224                            ((eq f 'E) (list 'comm-format-mb-string arg))
 225                            ((eq f 's) (list 'comm-format-u8-string arg))
 226                            ((eq f 'B) (list 'comm-format-bytes arg))))))
 227       (setq p (cdr p))
 228       (setq format (cdr format)))
 229     (cons
 230      'progn
 231      result)))
 232 \f
 233 ;; Do not move the point, leave it where it was.
 234 (defun comm-accept-process-output (proc)
 235   (let ((p (point)))
 236     (accept-process-output proc)
 237     (goto-char p)))
 238
 239 ;; Assume PROC is bound to the process of current buffer
 240 (defsubst comm-following-char-or-wait (proc)
 241   (if (eobp)
 242       (let ((p (point)))
 243         (while (= p (point-max))
 244           (accept-process-output proc))
 245         (goto-char p)))
 246   (following-char))
 247
 248 (defun comm-following+forward-char (proc)
 249   (prog1
 250       (comm-following-char-or-wait proc)
 251     (forward-char 1)))
 252
 253 (defsubst comm-unpack-u32c (proc uint32c)
 254   (let (h0 h1)
 255     (setq h0
 256          (+
 257           (lsh (comm-following+forward-char proc) 8)
 258           (comm-following+forward-char proc)))
 259     (setq h1
 260          (+
 261           (lsh (comm-following+forward-char proc) 8)
 262           (comm-following+forward-char proc)))
 263     (set uint32c (cons h0 h1))))
 264
 265 (defsubst comm-unpack-u32 (proc uint32)
 266   (set uint32
 267        (+
 268         (lsh (comm-following+forward-char proc) 24)
 269         (lsh (comm-following+forward-char proc) 16)
 270         (lsh (comm-following+forward-char proc) 8)
 271         (comm-following+forward-char proc))))
 272
 273 (defsubst comm-unpack-u16 (proc uint16)
 274   (set uint16
 275        (+
 276         (lsh (comm-following+forward-char proc) 8)
 277         (comm-following+forward-char proc))))
 278
 279 (defsubst comm-unpack-u8 (proc uint8)
 280   (set uint8
 281        (comm-following+forward-char proc)))
 282
 283 ;;; XXX should support other conversion (euc-kr, cns)
 284 (defsubst comm-unpack-u16-string (proc s)
 285   (let ((start (point)))
 286     (while (not (search-forward "\0\0" nil t))
 287       (comm-accept-process-output proc))
 288     (set s (buffer-substring start
 289                              (+ start
 290                                 (decode-coding-region start (- (point) 2)
 291                                                       egg-fixed-euc))))))
 292
 293 ;;; XXX should support other conversion (euc-kr, cns)
 294 (defsubst comm-unpack-mb-string (proc s)
 295   (let ((start (point)))
 296     (while (not (search-forward "\0" nil t))
 297       (comm-accept-process-output proc))
 298     (set s (buffer-substring start
 299                              (+ start
 300                                 (decode-coding-region start (- (point) 1)
 301                                                       egg-mb-euc))))))
 302
 303 (defsubst comm-unpack-u8-string (proc s)
 304   (let ((start (point)))
 305     (while (not (search-forward "\0" nil 1))
 306       (comm-accept-process-output proc))
 307     (set s (buffer-substring start (1- (point))))))
 308
 309 (defsubst comm-unpack-bytes (proc s)
 310   (let ((start (point)))
 311     (while (not (search-forward "\377" nil 1))
 312       (comm-accept-process-output proc))
 313     (set s (buffer-substring start (1- (point))))))
 314
 315 (defmacro comm-unpack (format &rest args)
 316   "Unpack a string out of a control-string and set arguments.
 317 u means unsigned 32-bit in big endian.
 318 w means unsigned 16-bit in big endian.
 319 b means unsigned  8-bit.
 320 S means 16-bit(big endian) string (0x0000 terminated).
 321 E means multibyte string (0x00 terminated).
 322 s means 8-bit string (0x00 terminated).
 323 "
 324   (let ((p args) result arg f)
 325     (while format
 326       (setq arg (car p))
 327       (setq f (car format))
 328       (setq result
 329             (append result
 330                     (list
 331                      (cond ((eq f 'U) (list 'comm-unpack-u32c
 332                                             'proc (list 'quote arg)))
 333                            ((eq f 'u) (list 'comm-unpack-u32
 334                                             'proc (list 'quote arg)))
 335                            ((eq f 'w) (list 'comm-unpack-u16
 336                                             'proc (list 'quote arg)))
 337                            ((eq f 'b) (list 'comm-unpack-u8
 338                                             'proc (list 'quote arg)))
 339                            ((eq f 'S) (list 'comm-unpack-u16-string
 340                                             'proc (list 'quote arg)))
 341                            ((eq f 'E) (list 'comm-unpack-mb-string
 342                                             'proc (list 'quote arg)))
 343                            ((eq f 's) (list 'comm-unpack-u8-string
 344                                             'proc (list 'quote arg)))
 345                            ((eq f 'B) (list 'comm-unpack-u8-string
 346                                             'proc (list 'quote arg)))))))
 347       (setq p (cdr p))
 348       (setq format (cdr format)))
 349     (cons
 350      'progn
 351      result)))
 352 \f
 353 (defmacro comm-call-with-proc (proc vlist send-expr &rest receive-exprs)
 354   (list
 355    'let vlist
 356    (append
 357     `(save-excursion
 358        (set-buffer (process-buffer proc))
 359        (erase-buffer)
 360        ,send-expr
 361        (process-send-region proc (point-min) (point-max))
 362        (goto-char (prog1 (point) (accept-process-output proc))))
 363     receive-exprs)))
 364
 365 (defmacro comm-call-with-proc-1 (proc vlist send-expr &rest receive-exprs)
 366   (list
 367    'let vlist
 368    (append
 369     `(progn
 370        (erase-buffer)
 371        ,send-expr
 372        (process-send-region proc (point-min) (point-max))
 373        (goto-char (prog1 (point) (accept-process-output proc))))
 374     receive-exprs)))
 375
 376 (provide 'egg-com)
 377 ;;; egg-com.el ends here.