~ubuntu-branches/ubuntu/feisty/wnn7egg/feisty

« back to all changes in this revision

Viewing changes to elisp/xemacs21/wnn7egg-comx214.el

  • Committer: Bazaar Package Importer
  • Author(s): ISHIKAWA Mutsumi
  • Date: 2004-09-22 17:39:30 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040922173930-pna2yuvlq63wxgc9
Tags: 1.02-5
update dolist macro confliction fix, thanks TSUCHIYA Masatoshi.
realy closes: #270839

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
;; Wnn7Egg is Egg modified for Wnn7, and the current maintainer 
 
2
;; is OMRON SOFTWARE Co., Ltd. <wnn-info@omronsoft.co.jp>
 
3
;;
 
4
;; This file is part of Wnn7Egg. (base code is egg-com.el (eggV4))
 
5
;;
 
6
;;; ------------------------------------------------------------------
 
7
;;;
 
8
;;; Wnn7Egg ��Wnn "�ʤ�"���ޤ���--- Wnn7 Emacs Client 
 
9
;;; 
 
10
;;; Wnn7Egg �ϡ��֤��ޤ��裳�ǡ�v3.09 ��١����� �֤��ޤ��裴�ǡפ��̿���
 
11
;;; �饤�֥�������Ȥ߹������Wnn7 �ΰ٤����ѥ��饤����ȤǤ���
 
12
;;;
 
13
;;; ���٤ƤΥ������� Emacs Lisp �ǵ��Ҥ���Ƥ���Τǡ�Wnn SDK/Library ��ɬ��
 
14
;;; �Ȥ�����GNU Emacs �ڤ� XEmacs �Ķ��ǻ��Ѥ��뤳�Ȥ��Ǥ��ޤ������ѵ������
 
15
;;; �� GPL �Ǥ���
 
16
;;;
 
17
;;; GNU Emacs 20.3 �ʹߡ�XEmacs 21.x �ʹߤ�ư���ǧ���Ƥ��ޤ���
 
18
;;;
 
19
;;;
 
20
;;; Wnn7Egg �� Wnn7 �ε�ǽ�Ǥ���ڡ����ϡ�����ͽ¬�ˡ�Ϣ���Ѵ��򥵥ݡ���
 
21
;;; ���Ƥ��ޤ���
 
22
;;;
 
23
;;; �֤��ޤ��פ���Ω����¸�Ǥ���褦�ˡ��ƶ�������פʴؿ����ѿ�̾��
 
24
;;; "wnn7..." �Ȥ��������ѹ����Ƥ��ޤ���
 
25
;;;
 
26
;;; ------------------------------------------------------------------
 
27
 
 
28
;;; egg-com.el --- Communication Routines in Egg Input Method Architecture
 
29
 
 
30
;; Copyright (C) 1999, 2000 Free Software Foundation, Inc
 
31
 
 
32
;; Author: Hisashi Miyashita <himi@bird.scphys.kyoto-u.ac.jp>
 
33
;;         NIIBE Yutaka <gniibe@chroot.org>
 
34
;;         KATAYAMA Yoshio <kate@pfu.co.jp>  ; Korean, Chinese support.
 
35
 
 
36
;; Maintainer: TOMURA Satoru <tomura@etl.go.jp>
 
37
 
 
38
;; Keywords: mule, multilingual, input method
 
39
 
 
40
;; This file is part of EGG.
 
41
 
 
42
;; EGG is free software; you can redistribute it and/or modify
 
43
;; it under the terms of the GNU General Public License as published by
 
44
;; the Free Software Foundation; either version 2, or (at your option)
 
45
;; any later version.
 
46
 
 
47
;; EGG is distributed in the hope that it will be useful,
 
48
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 
49
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
50
;; GNU General Public License for more details.
 
51
 
 
52
;; You should have received a copy of the GNU General Public License
 
53
;; along with GNU Emacs; see the file COPYING.  If not, write to the
 
54
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 
55
;; Boston, MA 02111-1307, USA.
 
56
 
 
57
;;; Commentary:
 
58
 
 
59
;;; 2002/5/16  XEmacs�ˤ����ƥ桼������Υ��饤�����ž�����Ǥ��ʤ�������б�
 
60
 
 
61
;;; Code:
 
62
 
 
63
 
 
64
(require 'wnn7egg-edep)
 
65
;;(require 'wnn7egg-cnv)
 
66
 
 
67
(defvar egg-fixed-euc '(fixed-euc-jp))
 
68
(make-variable-buffer-local 'egg-fixed-euc)
 
69
(put 'egg-fixed-euc 'permanent-local t)
 
70
 
 
71
(defvar egg-mb-euc 'euc-japan)
 
72
(make-variable-buffer-local 'egg-mb-euc)
 
73
(put 'egg-mb-euc 'permanent-local t)
 
74
 
 
75
;; Japanese
 
76
 
 
77
(eval-and-compile
 
78
(define-ccl-program ccl-decode-fixed-euc-jp
 
79
  `(2
 
80
    ((r2 = ,(charset-id 'japanese-jisx0208))
 
81
     (r3 = ,(charset-id 'japanese-jisx0212))
 
82
     (r4 = ,(charset-id 'katakana-jisx0201))
 
83
     (read r0)
 
84
     (loop
 
85
      (read r1)
 
86
      (if (r0 < #x80)
 
87
          ((r0 = r1)
 
88
           (if (r1 < #x80)
 
89
               (write-read-repeat r0))
 
90
           (write-multibyte-character r4 r0)
 
91
           (read r0)
 
92
           (repeat))
 
93
        ((if (r1 > #x80)
 
94
             ((r0 &= #x7f)
 
95
              (r0 <<= 7)
 
96
              (r0 |= (r1 & #x7f))
 
97
              (write-multibyte-character r2 r0)
 
98
              (read r0)
 
99
              (repeat))
 
100
           ((r0 &= #x7f)
 
101
            (r0 <<= 7)
 
102
            (r0 |= r1)
 
103
            (write-multibyte-character r3 r0)
 
104
            (read r0)
 
105
            (repeat)))))))))
 
106
 
 
107
(define-ccl-program ccl-encode-fixed-euc-jp
 
108
  `(2
 
109
    ((read r0)
 
110
     (loop
 
111
      (if (r0 == ,(charset-id 'latin-jisx0201))                   ; Unify
 
112
          ((read r0)
 
113
           (r0 &= #x7f)))
 
114
      (if (r0 < #x80)                                            ;G0
 
115
          ((write 0)
 
116
           (write-read-repeat r0)))
 
117
      (r6 = (r0 == ,(charset-id 'japanese-jisx0208)))
 
118
      (r6 |= (r0 == ,(charset-id 'japanese-jisx0208-1978)))
 
119
      (if r6                                                      ;G1
 
120
          ((read r0)
 
121
           (write r0)
 
122
           (read r0)
 
123
           (write-read-repeat r0)))
 
124
      (if (r0 == ,(charset-id 'katakana-jisx0201))                ;G2
 
125
          ((read r0)
 
126
           (write 0)
 
127
           (write-read-repeat r0)))
 
128
      (if (r0 == ,(charset-id 'japanese-jisx0212))                ;G3
 
129
          ((read r0)
 
130
           (write r0)
 
131
           (read r0)
 
132
           (r0 &= #x7f)
 
133
           (write-read-repeat r0)))
 
134
      (read r0)
 
135
      (repeat)))))
 
136
)
 
137
 
 
138
(if (not (coding-system-p 'fixed-euc-jp))
 
139
    (make-coding-system 'fixed-euc-jp 'ccl
 
140
                    "Coding System for fixed EUC Japanese"
 
141
                    `(decode ,ccl-decode-fixed-euc-jp
 
142
                             encode ,ccl-encode-fixed-euc-jp
 
143
                             mnemonic "WNN")))
 
144
 
 
145
 
 
146
 
 
147
(defun comm-format-u32c (uint32c)
 
148
  (insert-char (logand (lsh (car uint32c) -8) 255) 1)
 
149
  (insert-char (logand (car uint32c) 255) 1)
 
150
  (insert-char (logand (lsh (nth 1 uint32c) -8) 255) 1)
 
151
  (insert-char (logand (nth 1 uint32c) 255) 1))
 
152
 
 
153
(defun comm-format-u32 (uint32)
 
154
  (insert-char (logand (lsh uint32 -24) 255) 1)
 
155
  (insert-char (logand (lsh uint32 -16) 255) 1)
 
156
  (insert-char (logand (lsh uint32 -8) 255) 1)
 
157
  (insert-char (logand uint32 255) 1))
 
158
 
 
159
(defun comm-format-i32 (int32)
 
160
  (insert-char (logand (ash int32 -24) 255) 1)
 
161
  (insert-char (logand (ash int32 -16) 255) 1)
 
162
  (insert-char (logand (ash int32 -8) 255) 1)
 
163
  (insert-char (logand int32 255) 1))
 
164
 
 
165
(defun comm-format-u16 (uint16)
 
166
  (insert-char (logand (lsh uint16 -8) 255) 1)
 
167
  (insert-char (logand uint16 255) 1))
 
168
 
 
169
(defun comm-format-u8 (uint8)
 
170
  (insert-char (logand uint8 255) 1))
 
171
 
 
172
(defun comm-format-truncate-after-null (s)
 
173
  (if (string-match "\0" s)
 
174
      (substring s 0 (match-beginning 0))
 
175
    s))
 
176
 
 
177
(defun comm-format-u16-string (s)
 
178
  (insert (encode-coding-string (comm-format-truncate-after-null s)
 
179
                                egg-fixed-euc))
 
180
  (insert-char 0 2))
 
181
 
 
182
(defun comm-format-mb-string (s)
 
183
  (insert (encode-coding-string  (comm-format-truncate-after-null s)
 
184
                                 egg-mb-euc))
 
185
  (insert-char 0 1))
 
186
 
 
187
(defun comm-format-u8-string (s)
 
188
  (insert (comm-format-truncate-after-null s))
 
189
  (insert-char 0 1))
 
190
 
 
191
(defun comm-format-binary-data (s)
 
192
  (insert (encode-coding-string s 'binary))
 
193
  (save-excursion
 
194
    (goto-char (point-min))
 
195
    (wnn-perform-replace "\377" "\377\0"))
 
196
  (insert-char ?\377 2))
 
197
 
 
198
(defun comm-format-fixlen-string (s len)
 
199
  (setq s (comm-format-truncate-after-null s))
 
200
  (insert (if (< (length s) len) s (substring s 0 (1- len))))
 
201
  (insert-char 0 (max (- len (length s)) 1)))
 
202
 
 
203
(defun comm-format-vector (s len)
 
204
  (setq s (concat s))
 
205
  (insert (if (<= (length s) len) s (substring s 0 len)))
 
206
  (insert-char 0 (- len (length s))))
 
207
 
 
208
(defmacro comm-format (format &rest args)
 
209
  "Format a string out of a control-list and arguments into the buffer.
 
210
The formated datas are network byte oder (i.e. big endian)..
 
211
U: 32-bit integer.  The argument is 2 element 16-bit unsigned integer list.
 
212
u: 32-bit integer.  The argument is treat as unsigned integer.
 
213
   (Note:  Elisp's integer may be less than 32 bits)
 
214
i: 32-bit integer.
 
215
w: 16-bit integer.
 
216
b: 8-bit integer.
 
217
S: 16-bit wide-character EUC string (0x0000 terminated).
 
218
E: Multibyte EUC string (0x00 terminated).
 
219
s: 8-bit string (0x00 terminated).
 
220
B: Binary data (0xff terminated).
 
221
v: 8-bit vector (no terminator).  This takes 2 args (data length).
 
222
V: Fixed length string (0x00 terminated).  This takes 2 args (data length)."
 
223
  (let ((p args)
 
224
        (form format)
 
225
        (result (list 'progn))
 
226
        f arg)
 
227
    (while (and form p)
 
228
      (setq f (car form)
 
229
            arg (car p))
 
230
      (nconc result
 
231
             (list
 
232
              (cond ((eq f 'U) (list 'comm-format-u32c arg))
 
233
                    ((eq f 'u) (list 'comm-format-u32 arg))
 
234
                    ((eq f 'i) (list 'comm-format-i32 arg))
 
235
                    ((eq f 'w) (list 'comm-format-u16 arg))
 
236
                    ((eq f 'b) (list 'comm-format-u8 arg))
 
237
                    ((eq f 'S) (list 'comm-format-u16-string arg))
 
238
                    ((eq f 'E) (list 'comm-format-mb-string arg))
 
239
                    ((eq f 's) (list 'comm-format-u8-string arg))
 
240
                    ((eq f 'B) (list 'comm-format-binary-data arg))
 
241
                    ((eq f 'V) (setq p (cdr p))
 
242
                               (list 'comm-format-fixlen-string arg (car p)))
 
243
                    ((eq f 'v) (setq p (cdr p))
 
244
                               (list 'comm-format-vector arg (car p))))))
 
245
      (setq form (cdr form)
 
246
            p (cdr p)))
 
247
    (if (or form p)
 
248
        (error "comm-format %s: arguments mismatch" format))
 
249
    result))
 
250
 
 
251
(defvar comm-accept-timeout nil)
 
252
 
 
253
;; Assume PROC is bound to the process of current buffer
 
254
;; Do not move the point, leave it where it was.
 
255
(defmacro comm-accept-process-output ()
 
256
  `(let ((p (point)))
 
257
     (if (null (accept-process-output proc comm-accept-timeout))
 
258
         (error "backend timeout"))
 
259
     (goto-char p)))
 
260
 
 
261
(defmacro comm-require-process-output (n)
 
262
  `(if (< (point-max) (+ (point) ,n))
 
263
       (comm-wait-for-space proc ,n)))
 
264
 
 
265
(defun comm-wait-for-space (proc n)
 
266
  (let ((p (point))
 
267
        (r (+ (point) n)))
 
268
    (while (< (point-max) r)
 
269
      (if (null (accept-process-output proc comm-accept-timeout))
 
270
          (error "backend timeout"))
 
271
      (goto-char p))))
 
272
 
 
273
(defmacro comm-following+forward-char ()
 
274
  `(prog1
 
275
       (following-char)
 
276
     (forward-char 1)))
 
277
 
 
278
(defun comm-unpack-u32c ()
 
279
  (progn
 
280
    (comm-require-process-output 4)
 
281
    (list (+ (lsh (comm-following+forward-char) 8)
 
282
             (comm-following+forward-char))
 
283
          (+ (lsh (comm-following+forward-char) 8)
 
284
             (comm-following+forward-char)))))
 
285
 
 
286
(defun comm-unpack-u32 ()
 
287
  (progn
 
288
    (comm-require-process-output 4)
 
289
    (+ (lsh (comm-following+forward-char) 24)
 
290
       (lsh (comm-following+forward-char) 16)
 
291
       (lsh (comm-following+forward-char) 8)
 
292
       (comm-following+forward-char))))
 
293
 
 
294
(defun comm-unpack-u16 ()
 
295
  (progn
 
296
    (comm-require-process-output 2)
 
297
    (+ (lsh (comm-following+forward-char) 8)
 
298
       (comm-following+forward-char))))
 
299
 
 
300
(defun comm-unpack-u8 ()
 
301
  (progn
 
302
    (comm-require-process-output 1)
 
303
    (comm-following+forward-char)))
 
304
 
 
305
(defun comm-unpack-u16-string ()
 
306
  (let ((start (point)))
 
307
    (while (not (search-forward "\0\0" nil t))
 
308
      (comm-accept-process-output))
 
309
    (decode-coding-string (buffer-substring start (- (point) 2))
 
310
                          egg-fixed-euc)))
 
311
 
 
312
(defun comm-unpack-mb-string ()
 
313
  (let ((start (point)))
 
314
    (while (not (search-forward "\0" nil t))
 
315
      (comm-accept-process-output))
 
316
    (decode-coding-string (buffer-substring start (1- (point)))
 
317
                          egg-mb-euc)))
 
318
 
 
319
(defun comm-unpack-u8-string ()
 
320
  (let ((start (point)))
 
321
    (while (not (search-forward "\0" nil 1))
 
322
      (comm-accept-process-output))
 
323
    (buffer-substring start (1- (point)))))
 
324
 
 
325
(defun comm-unpack-binary-data ()
 
326
  (let ((start (point)))
 
327
    (while (not (search-forward "\377\377" nil 1))
 
328
      (comm-accept-process-output))
 
329
    (string-as-unibyte
 
330
      (decode-coding-string (buffer-substring start (- (point) 2))
 
331
                           'binary))))
 
332
 
 
333
(defun comm-unpack-fixlen-string (len)
 
334
  (let (s)
 
335
    (comm-require-process-output len)
 
336
    (goto-char (+ (point) len))
 
337
    (setq s (buffer-substring (- (point) len) (point)))
 
338
    (if (string-match "\0" s)
 
339
        (setq s (substring s 0 (match-beginning 0))))
 
340
    s))
 
341
 
 
342
(defun comm-unpack-vector (len)
 
343
  (progn
 
344
    (comm-require-process-output len)
 
345
    (goto-char (+ (point) len))
 
346
    (buffer-substring (- (point) len) (point))))
 
347
 
 
348
(defmacro comm-unpack (format &rest args)
 
349
  "Unpack a string out of a control-string and set arguments.
 
350
See `comm-format' for FORMAT."
 
351
  (let ((p args)
 
352
        (form format)
 
353
        (result (list 'progn))
 
354
        arg f)
 
355
    (while (and form p)
 
356
      (setq f (car form)
 
357
            arg (car p))
 
358
      (nconc result
 
359
             (list
 
360
              (cond ((eq f 'U) `(setq ,arg (comm-unpack-u32c)))
 
361
                    ((eq f 'u) `(setq ,arg (comm-unpack-u32)))
 
362
                    ((eq f 'i) `(setq ,arg (comm-unpack-u32)))
 
363
                    ((eq f 'w) `(setq ,arg (comm-unpack-u16)))
 
364
                    ((eq f 'b) `(setq ,arg (comm-unpack-u8)))
 
365
                    ((eq f 'S) `(setq ,arg (comm-unpack-u16-string)))
 
366
                    ((eq f 'E) `(setq ,arg (comm-unpack-mb-string)))
 
367
                    ((eq f 's) `(setq ,arg (comm-unpack-u8-string)))
 
368
                    ((eq f 'B) `(setq ,arg (comm-unpack-binary-data)))
 
369
                    ((eq f 'V) (setq p (cdr p))
 
370
                               `(setq ,arg (comm-unpack-fixlen-string ,(car p))))
 
371
                    ((eq f 'v) (setq p (cdr p))
 
372
                               `(setq ,arg (comm-unpack-vector ,(car p)))))))
 
373
      (setq form (cdr form)
 
374
            p (cdr p)))
 
375
    (if (or form p)
 
376
        (error "comm-unpack %s: arguments mismatch" format))
 
377
    result))
 
378
 
 
379
(defmacro comm-call-with-proc (proc vlist send-expr &rest receive-exprs)
 
380
  (let ((euc-select
 
381
         (and (eq (car-safe (car vlist)) 'zhuyin)
 
382
              '((egg-fixed-euc (nth (if zhuyin 1 0) egg-fixed-euc))))))
 
383
  `(let* ((proc ,proc)
 
384
          (buffer (process-buffer proc))
 
385
          ,@vlist)
 
386
     (if (and (eq (process-status proc) 'open)
 
387
              (buffer-live-p buffer))
 
388
         (save-excursion
 
389
           (set-buffer buffer)
 
390
           (let ,euc-select
 
391
             (erase-buffer)
 
392
             ,send-expr
 
393
             (goto-char (point-max))
 
394
             (process-send-region proc (point-min) (point-max))
 
395
             ,@receive-exprs))
 
396
       (error "process %s was killed" proc)))))
 
397
 
 
398
(defmacro comm-call-with-proc-1 (proc vlist send-expr &rest receive-exprs)
 
399
  `(let ,vlist
 
400
     (erase-buffer)
 
401
     ,send-expr
 
402
     (goto-char (point-max))
 
403
     (process-send-region proc (point-min) (point-max))
 
404
     ,@receive-exprs))
 
405
 
 
406
(provide 'wnn7egg-comx214)
 
407
;;; wnn7egg-comx214.el ends here.