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         (ccl-vector-program-execute
  85          (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
  86          reg)))
  87
  88     (when (subrp (symbol-function 'ccl-execute-on-string))
  89       (fset 'ccl-vector-program-execute-on-string
  90             (symbol-function 'ccl-execute-on-string))
  91       (defun ccl-execute-on-string (ccl-prog status string &optional contin)
  92         "\
  93 Execute CCL-PROG with initial STATUS on STRING.
  94 If CCL-PROG is symbol, it is dereferenced."
  95         (ccl-vector-program-execute-on-string
  96          (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
  97          status string contin)))
  98     )
  99   )
 100
 101 (eval-when-compile
 102   (define-ccl-program test-ccl-eof-block
 103     '(1
 104       ((read r0)
 105        (write r0)
 106        (read r0))
 107       (write "[EOF]")))
 108
 109   (make-ccl-coding-system
 110    'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
 111    'test-ccl-eof-block 'test-ccl-eof-block)
 112   )
 113
 114 (broken-facility ccl-execute-eof-block-on-encoding-null
 115   "Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input. (Fixed on Emacs 20.4)"
 116   (equal (encode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
 117
 118 (broken-facility ccl-execute-eof-block-on-encoding-some
 119   "Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input. (Fixed on Emacs 20.3)"
 120   (equal (encode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
 121
 122 (broken-facility ccl-execute-eof-block-on-decoding-null
 123   "Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input. (Fixed on Emacs 20.4)"
 124   (equal (decode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
 125
 126 (broken-facility ccl-execute-eof-block-on-decoding-some
 127   "Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input. (Fixed on Emacs 20.4)"
 128   (equal (decode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
 129
 130 (broken-facility ccl-execute-eof-block-on-encoding
 131   "Emacs may forget executing CCL_EOF_BLOCK with encoding."
 132   (not (or (broken-p 'ccl-execute-eof-block-on-encoding-null)
 133            (broken-p 'ccl-execute-eof-block-on-encoding-some)))
 134   t)
 135
 136 (broken-facility ccl-execute-eof-block-on-decoding
 137   "Emacs may forget executing CCL_EOF_BLOCK with decoding."
 138   (not (or (broken-p 'ccl-execute-eof-block-on-decoding-null)
 139            (broken-p 'ccl-execute-eof-block-on-decoding-some)))
 140   t)
 141
 142 (broken-facility ccl-execute-eof-block
 143   "Emacs may forget executing CCL_EOF_BLOCK."
 144   (not (or (broken-p 'ccl-execute-eof-block-on-encoding)
 145            (broken-p 'ccl-execute-eof-block-on-decoding)))
 146   t)
 147
 148
 149 ;;; @ end
 150 ;;;
 151
 152 (require 'product)
 153 (product-provide (provide 'pccl-20) (require 'apel-ver))
 154
 155 ;;; pccl-20.el ends here