pccl-20.el

   1 ;;; pccl-20.el --- Portable CCL utility for Emacs 20 and XEmacs-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
  32 (eval-when-compile
  33   (defconst ccl-use-symbol-as-program
  34     (progn
  35       (define-ccl-program ew-ccl-identity-program
  36         '(1 ((read r0) (loop (write-read-repeat r0)))))
  37       (condition-case nil
  38           (progn
  39             (funcall
  40              (if (fboundp 'ccl-vector-program-execute-on-string)
  41                  'ccl-vector-program-execute-on-string
  42                'ccl-execute-on-string)
  43              'ew-ccl-identity-program
  44              (make-vector 9 nil)
  45              "")
  46             t)
  47         (error nil)))
  48     "\
  49 T if CCL related builtins accept symbol as CCL program.
  50 (20.2 with ExCCL, 20.3 or later)
  51 Otherwise nil (20.2 without ExCCL or former).
  52
  53 Because emu provides functions accepting symbol as CCL program,
  54 user programs should not refer this variable.")
  55   )
  56
  57 (eval-and-compile
  58   (defconst ccl-use-symbol-as-program
  59     (eval-when-compile ccl-use-symbol-as-program))
  60
  61   (if (featurep 'xemacs)
  62       (defun make-ccl-coding-system (name mnemonic doc-string decoder encoder)
  63         (make-coding-system
  64          name 'ccl doc-string
  65          (list 'mnemonic (char-to-string mnemonic)
  66                'decode (symbol-value decoder)
  67                'encode (symbol-value encoder))))
  68     (defun make-ccl-coding-system
  69       (coding-system mnemonic doc-string decoder encoder)
  70       "\
  71 Define a new CODING-SYSTEM (symbol) by CCL programs
  72 DECODER (symbol) and ENCODER (symbol)."
  73       (unless ccl-use-symbol-as-program
  74         (setq decoder (symbol-value decoder))
  75         (setq encoder (symbol-value encoder)))
  76       (make-coding-system coding-system 4 mnemonic doc-string
  77                           (cons decoder encoder)))
  78     ))
  79
  80 (eval-when-compile
  81   (define-ccl-program test-ccl-eof-block
  82     '(1
  83       (read r0)
  84       (write "[EOF]")))
  85
  86   (unless (coding-system-p 'test-ccl-eof-block-cs)
  87     (make-ccl-coding-system
  88      'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
  89      'test-ccl-eof-block 'test-ccl-eof-block)
  90     )
  91   )
  92
  93 (defconst ccl-encoder-eof-block-is-broken
  94   (eval-when-compile
  95     (not (equal (encode-coding-string "" 'test-ccl-eof-block-cs)
  96                 "[EOF]")))
  97   "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
  98 encoding.")
  99
 100 (defconst ccl-decoder-eof-block-is-broken
 101   (eval-when-compile
 102     (not (equal (decode-coding-string "" 'test-ccl-eof-block-cs)
 103                 "[EOF]")))
 104   "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
 105 decoding.")
 106
 107 (defconst ccl-eof-block-is-broken
 108   (or ccl-encoder-eof-block-is-broken
 109       ccl-decoder-eof-block-is-broken))
 110
 111 (unless ccl-use-symbol-as-program
 112
 113   (when (subrp (symbol-function 'ccl-execute))
 114     (fset 'ccl-vector-program-execute
 115           (symbol-function 'ccl-execute))
 116     (defun ccl-execute (ccl-prog reg)
 117       "\
 118 Execute CCL-PROG with registers initialized by REGISTERS.
 119 If CCL-PROG is symbol, it is dereferenced.
 120 \[Emacs 20.3 emulating function]"
 121       (ccl-vector-program-execute
 122        (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
 123        reg)))
 124
 125   (when (subrp (symbol-function 'ccl-execute-on-string))
 126     (fset 'ccl-vector-program-execute-on-string
 127           (symbol-function 'ccl-execute-on-string))
 128     (defun ccl-execute-on-string (ccl-prog status string &optional contin)
 129       "\
 130 Execute CCL-PROG with initial STATUS on STRING.
 131 If CCL-PROG is symbol, it is dereferenced.
 132 \[Emacs 20.3 emulating function]"
 133       (ccl-vector-program-execute-on-string
 134        (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
 135        status string contin)))
 136   )
 137
 138
 139 ;;; @ end
 140 ;;;
 141
 142 (provide 'pccl-20)
 143
 144 ;;; pccl-20.el ends here