egg-com.el

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