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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, 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   (if (featurep 'xemacs)
  52       (defun make-ccl-coding-system (name mnemonic docstring decoder encoder)
  53         "\
  54 Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
  55
  56 CODING-SYSTEM, DECODER and ENCODER must be symbol."
  57         (make-coding-system
  58          name 'ccl docstring
  59          (list 'mnemonic (char-to-string mnemonic)
  60                'decode (symbol-value decoder)
  61                'encode (symbol-value encoder))))
  62     (defun make-ccl-coding-system
  63       (coding-system mnemonic docstring decoder encoder)
  64       "\
  65 Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
  66
  67 CODING-SYSTEM, DECODER and ENCODER must be symbol."
  68       (when-broken ccl-accept-symbol-as-program
  69         (setq decoder (symbol-value decoder))
  70         (setq encoder (symbol-value encoder)))
  71       (make-coding-system coding-system 4 mnemonic docstring
  72                           (cons decoder encoder)))
  73     )
  74
  75   (when-broken ccl-accept-symbol-as-program
  76
  77     (when (subrp (symbol-function 'ccl-execute))
  78       (fset 'ccl-vector-program-execute
  79             (symbol-function 'ccl-execute))
  80       (defun ccl-execute (ccl-prog reg)
  81         "\
  82 Execute CCL-PROG with registers initialized by REGISTERS.
  83 If CCL-PROG is symbol, it is dereferenced.
  84 \[Emacs 20.3 emulating function]"
  85         (ccl-vector-program-execute
  86          (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
  87          reg)))
  88
  89     (when (subrp (symbol-function 'ccl-execute-on-string))
  90       (fset 'ccl-vector-program-execute-on-string
  91             (symbol-function 'ccl-execute-on-string))
  92       (defun ccl-execute-on-string (ccl-prog status string &optional contin)
  93         "\
  94 Execute CCL-PROG with initial STATUS on STRING.
  95 If CCL-PROG is symbol, it is dereferenced.
  96 \[Emacs 20.3 emulating function]"
  97         (ccl-vector-program-execute-on-string
  98          (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
  99          status string contin)))
 100     )
 101   )
 102
 103 (eval-when-compile
 104   (define-ccl-program test-ccl-eof-block
 105     '(1
 106       ((read r0)
 107        (write r0)
 108        (read r0))
 109       (write "[EOF]")))
 110
 111   (make-ccl-coding-system
 112    'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
 113    'test-ccl-eof-block 'test-ccl-eof-block)
 114   )
 115
 116 (broken-facility ccl-execute-eof-block-on-encoding-null
 117   "Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input. (Fixed on Emacs 20.4)"
 118   (equal (encode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
 119
 120 (broken-facility ccl-execute-eof-block-on-encoding-some
 121   "Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input. (Fixed on Emacs 20.3)"
 122   (equal (encode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
 123
 124 (broken-facility ccl-execute-eof-block-on-decoding-null
 125   "Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input. (Fixed on Emacs 20.4)"
 126   (equal (decode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
 127
 128 (broken-facility ccl-execute-eof-block-on-decoding-some
 129   "Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input. (Fixed on Emacs 20.4)"
 130   (equal (decode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
 131
 132 (broken-facility ccl-execute-eof-block-on-encoding
 133   "Emacs may forget executing CCL_EOF_BLOCK with encoding."
 134   (not (or (broken-p 'ccl-execute-eof-block-on-encoding-null)
 135            (broken-p 'ccl-execute-eof-block-on-encoding-some)))
 136   t)
 137
 138 (broken-facility ccl-execute-eof-block-on-decoding
 139   "Emacs may forget executing CCL_EOF_BLOCK with decoding."
 140   (not (or (broken-p 'ccl-execute-eof-block-on-decoding-null)
 141            (broken-p 'ccl-execute-eof-block-on-decoding-some)))
 142   t)
 143
 144 (broken-facility ccl-execute-eof-block
 145   "Emacs may forget executing CCL_EOF_BLOCK."
 146   (not (or (broken-p 'ccl-execute-eof-block-on-encoding)
 147            (broken-p 'ccl-execute-eof-block-on-decoding)))
 148   t)
 149
 150
 151 ;;; @ end
 152 ;;;
 153
 154 (require 'product)
 155 (product-provide (provide 'pccl-20) (require 'apel-ver))
 156
 157 ;;; pccl-20.el ends here