pccl-20.el

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