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