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