release.
[elisp/lemi.git] / poe / pccl-20.el
1 ;;; pccl-20.el --- Portable CCL utility for Emacs 20 and XEmacs-21-mule
2
3 ;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc.
4
5 ;; Author: Tanaka Akira  <akr@m17n.org>
6 ;; Keywords: emulation, compatibility, Mule
7
8 ;; This file is part of APEL (A Portable Emacs Library).
9
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
14
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Code:
26
27 (eval-when-compile (require 'ccl))
28 (require 'broken)
29
30 (broken-facility ccl-accept-symbol-as-program
31   "Emacs does not accept symbol as CCL program."
32   (progn
33     (define-ccl-program test-ccl-identity
34       '(1 ((read r0) (loop (write-read-repeat r0)))))
35     (condition-case nil
36         (progn
37           (funcall
38            (if (fboundp 'ccl-vector-execute-on-string)
39                'ccl-vector-execute-on-string
40              'ccl-execute-on-string)
41            'test-ccl-identity
42            (make-vector 9 nil)
43            "")
44           t)
45       (error nil)))
46   t)
47
48 (eval-and-compile
49
50   (static-if (featurep 'xemacs)
51       (defadvice make-coding-system (before ccl-compat (name type &rest ad-subr-args) activate)
52         (when (and (integerp type)
53                    (eq type 4)
54                    (characterp (ad-get-arg 2))
55                    (stringp (ad-get-arg 3))
56                    (consp (ad-get-arg 4))
57                    (symbolp (car (ad-get-arg 4)))
58                    (symbolp (cdr (ad-get-arg 4))))
59           (setq type 'ccl)
60           (setq ad-subr-args
61                 (list
62                  (ad-get-arg 3)
63                  (append
64                   (list
65                    'mnemonic (char-to-string (ad-get-arg 2))
66                    'decode (symbol-value (car (ad-get-arg 4)))
67                    'encode (symbol-value (cdr (ad-get-arg 4))))
68                   (ad-get-arg 5)))))))
69
70   (if (featurep 'xemacs)
71       (defun make-ccl-coding-system (name mnemonic docstring decoder encoder)
72         "\
73 Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
74
75 CODING-SYSTEM, DECODER and ENCODER must be symbol."
76         (make-coding-system
77          name 'ccl docstring
78          (list 'mnemonic (char-to-string mnemonic)
79                'decode (symbol-value decoder)
80                'encode (symbol-value encoder))))
81     (defun make-ccl-coding-system
82       (coding-system mnemonic docstring decoder encoder)
83       "\
84 Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
85
86 CODING-SYSTEM, DECODER and ENCODER must be symbol."
87       (when-broken ccl-accept-symbol-as-program
88         (setq decoder (symbol-value decoder))
89         (setq encoder (symbol-value encoder)))
90       (make-coding-system coding-system 4 mnemonic docstring
91                           (cons decoder encoder)))
92     )
93
94   (when-broken ccl-accept-symbol-as-program
95
96     (when (subrp (symbol-function 'ccl-execute))
97       (fset 'ccl-vector-program-execute
98             (symbol-function 'ccl-execute))
99       (defun ccl-execute (ccl-prog reg)
100         "\
101 Execute CCL-PROG with registers initialized by REGISTERS.
102 If CCL-PROG is symbol, it is dereferenced."
103         (ccl-vector-program-execute
104          (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
105          reg)))
106
107     (when (subrp (symbol-function 'ccl-execute-on-string))
108       (fset 'ccl-vector-program-execute-on-string
109             (symbol-function 'ccl-execute-on-string))
110       (defun ccl-execute-on-string (ccl-prog status string &optional contin)
111         "\
112 Execute CCL-PROG with initial STATUS on STRING.
113 If CCL-PROG is symbol, it is dereferenced."
114         (ccl-vector-program-execute-on-string
115          (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
116          status string contin)))
117     )
118   )
119
120 (eval-when-compile
121   (define-ccl-program test-ccl-eof-block
122     '(1
123       ((read r0)
124        (write r0)
125        (read r0))
126       (write "[EOF]")))
127
128   (make-ccl-coding-system
129    'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
130    'test-ccl-eof-block 'test-ccl-eof-block)
131   )
132
133 (broken-facility ccl-execute-eof-block-on-encoding-null
134   "Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input. (Fixed on Emacs 20.4)"
135   (equal (encode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
136
137 (broken-facility ccl-execute-eof-block-on-encoding-some
138   "Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input. (Fixed on Emacs 20.3)"
139   (equal (encode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
140
141 (broken-facility ccl-execute-eof-block-on-decoding-null
142   "Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input. (Fixed on Emacs 20.4)"
143   (equal (decode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
144
145 (broken-facility ccl-execute-eof-block-on-decoding-some
146   "Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input. (Fixed on Emacs 20.4)"
147   (equal (decode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
148
149 (broken-facility ccl-execute-eof-block-on-encoding
150   "Emacs may forget executing CCL_EOF_BLOCK with encoding."
151   (not (or (broken-p 'ccl-execute-eof-block-on-encoding-null)
152            (broken-p 'ccl-execute-eof-block-on-encoding-some)))
153   t)
154
155 (broken-facility ccl-execute-eof-block-on-decoding
156   "Emacs may forget executing CCL_EOF_BLOCK with decoding."
157   (not (or (broken-p 'ccl-execute-eof-block-on-decoding-null)
158            (broken-p 'ccl-execute-eof-block-on-decoding-some)))
159   t)
160
161 (broken-facility ccl-execute-eof-block
162   "Emacs may forget executing CCL_EOF_BLOCK."
163   (not (or (broken-p 'ccl-execute-eof-block-on-encoding)
164            (broken-p 'ccl-execute-eof-block-on-decoding)))
165   t)
166
167
168 ;;; @ end
169 ;;;
170
171 (require 'product)
172 (product-provide (provide 'pccl-20) (require 'apel-ver))
173
174 ;;; pccl-20.el ends here