emu-e20.el

   1 ;;; emu-e20.el --- emu API implementation for Emacs 20.1 and 20.2
   2
   3 ;; Copyright (C) 1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: emulation, compatibility, Mule
   7
   8 ;; This file is part of emu.
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;    This module requires Emacs 20.1 and 20.2.
  28
  29 ;;; Code:
  30
  31 (require 'emu-e19)
  32
  33 (defun fontset-pixel-size (fontset)
  34   (let* ((info (fontset-info fontset))
  35          (height (aref info 1))
  36          )
  37     (cond ((> height 0) height)
  38           ((string-match "-\\([0-9]+\\)-" fontset)
  39            (string-to-number
  40             (substring fontset (match-beginning 1)(match-end 1))))
  41           (t 0))))
  42
  43
  44 ;;; @ character set
  45 ;;;
  46
  47 ;; (defalias 'charset-columns 'charset-width)
  48
  49 (defun find-non-ascii-charset-string (string)
  50   "Return a list of charsets in the STRING except ascii."
  51   (delq 'ascii (find-charset-string string)))
  52
  53 (defun find-non-ascii-charset-region (start end)
  54   "Return a list of charsets except ascii
  55 in the region between START and END."
  56   (delq 'ascii (find-charset-string (buffer-substring start end))))
  57
  58
  59 ;;; @ coding system
  60 ;;;
  61
  62 (defsubst-maybe find-coding-system (obj)
  63   "Return OBJ if it is a coding-system."
  64   (if (coding-system-p obj)
  65       obj))
  66
  67 (defalias 'set-process-input-coding-system 'set-process-coding-system)
  68
  69
  70 ;;; @ MIME charset
  71 ;;;
  72
  73 (defsubst encode-mime-charset-region (start end charset)
  74   "Encode the text between START and END as MIME CHARSET."
  75   (let (cs)
  76     (if (and enable-multibyte-characters
  77              (setq cs (mime-charset-to-coding-system charset)))
  78         (encode-coding-region start end cs)
  79       )))
  80
  81 (defsubst decode-mime-charset-region (start end charset &optional lbt)
  82   "Decode the text between START and END as MIME CHARSET."
  83   (let (cs)
  84     (if (and enable-multibyte-characters
  85              (setq cs (mime-charset-to-coding-system charset lbt)))
  86         (decode-coding-region start end cs)
  87       )))
  88
  89 (defsubst encode-mime-charset-string (string charset)
  90   "Encode the STRING as MIME CHARSET."
  91   (let (cs)
  92     (if (and enable-multibyte-characters
  93              (setq cs (mime-charset-to-coding-system charset)))
  94         (encode-coding-string string cs)
  95       string)))
  96
  97 (defsubst decode-mime-charset-string (string charset &optional lbt)
  98   "Decode the STRING as MIME CHARSET."
  99   (let (cs)
 100     (if (and enable-multibyte-characters
 101              (setq cs (mime-charset-to-coding-system charset lbt)))
 102         (decode-coding-string string cs)
 103       string)))
 104
 105
 106 (defvar charsets-mime-charset-alist
 107   '(((ascii)                                            . us-ascii)
 108     ((ascii latin-iso8859-1)                            . iso-8859-1)
 109     ((ascii latin-iso8859-2)                            . iso-8859-2)
 110     ((ascii latin-iso8859-3)                            . iso-8859-3)
 111     ((ascii latin-iso8859-4)                            . iso-8859-4)
 112 ;;; ((ascii cyrillic-iso8859-5)                         . iso-8859-5)
 113     ((ascii cyrillic-iso8859-5)                         . koi8-r)
 114     ((ascii arabic-iso8859-6)                           . iso-8859-6)
 115     ((ascii greek-iso8859-7)                            . iso-8859-7)
 116     ((ascii hebrew-iso8859-8)                           . iso-8859-8)
 117     ((ascii latin-iso8859-9)                            . iso-8859-9)
 118     ((ascii latin-jisx0201
 119             japanese-jisx0208-1978 japanese-jisx0208)   . iso-2022-jp)
 120     ((ascii latin-jisx0201
 121             katakana-jisx0201 japanese-jisx0208)        . shift_jis)
 122     ((ascii korean-ksc5601)                             . euc-kr)
 123     ((ascii chinese-gb2312)                             . cn-gb-2312)
 124     ((ascii chinese-big5-1 chinese-big5-2)              . cn-big5)
 125     ((ascii latin-iso8859-1 greek-iso8859-7
 126             latin-jisx0201 japanese-jisx0208-1978
 127             chinese-gb2312 japanese-jisx0208
 128             korean-ksc5601 japanese-jisx0212)           . iso-2022-jp-2)
 129     ((ascii latin-iso8859-1 greek-iso8859-7
 130             latin-jisx0201 japanese-jisx0208-1978
 131             chinese-gb2312 japanese-jisx0208
 132             korean-ksc5601 japanese-jisx0212
 133             chinese-cns11643-1 chinese-cns11643-2)      . iso-2022-int-1)
 134     ((ascii latin-iso8859-1 latin-iso8859-2
 135             cyrillic-iso8859-5 greek-iso8859-7
 136             latin-jisx0201 japanese-jisx0208-1978
 137             chinese-gb2312 japanese-jisx0208
 138             korean-ksc5601 japanese-jisx0212
 139             chinese-cns11643-1 chinese-cns11643-2
 140             chinese-cns11643-3 chinese-cns11643-4
 141             chinese-cns11643-5 chinese-cns11643-6
 142             chinese-cns11643-7)                         . iso-2022-int-1)
 143     ))
 144
 145
 146 ;;; @ character
 147 ;;;
 148
 149 ;;; @@ Mule emulating aliases
 150 ;;;
 151 ;;; You should not use them.
 152
 153 (defun char-category (character)
 154   "Return string of category mnemonics for CHAR in TABLE.
 155 CHAR can be any multilingual character
 156 TABLE defaults to the current buffer's category table."
 157   (category-set-mnemonics (char-category-set character)))
 158
 159
 160 ;;; @ CCL
 161 ;;;
 162 (eval-when-compile (require 'ccl))
 163
 164 (eval-when-compile
 165   (defconst ccl-use-symbol-as-program
 166     (progn
 167       (define-ccl-program ew-ccl-identity-program
 168         '(1 ((read r0) (loop (write-read-repeat r0)))))
 169       (condition-case nil
 170           (progn
 171             (funcall
 172              (if (fboundp 'ccl-vector-program-execute-on-string)
 173                  'ccl-vector-program-execute-on-string
 174                'ccl-execute-on-string)
 175              'ew-ccl-identity-program
 176              (make-vector 9 nil)
 177              "")
 178             t)
 179         (error nil)))
 180     "\
 181 T if CCL related builtins accept symbol as CCL program.
 182 (20.2 with ExCCL, 20.3 or later)
 183 Otherwise nil (20.2 without ExCCL or former).
 184
 185 Because emu provides functions accepting symbol as CCL program,
 186 user programs should not refer this variable.")
 187   )
 188
 189 (eval-and-compile
 190   (defconst ccl-use-symbol-as-program
 191     (eval-when-compile ccl-use-symbol-as-program))
 192
 193   (defun make-ccl-coding-system
 194     (coding-system mnemonic doc-string decoder encoder)
 195     "\
 196 Define a new CODING-SYSTEM (symbol) by CCL programs
 197 DECODER (symbol) and ENCODER (symbol)."
 198     (unless ccl-use-symbol-as-program
 199       (setq decoder (symbol-value decoder))
 200       (setq encoder (symbol-value encoder)))
 201     (make-coding-system coding-system 4 mnemonic doc-string
 202                         (cons decoder encoder)))
 203   )
 204
 205 (eval-when-compile
 206   (define-ccl-program test-ccl-eof-block
 207     '(1
 208       (read r0)
 209       (write "[EOF]")))
 210
 211   (unless (coding-system-p 'test-ccl-eof-block-cs)
 212     (make-ccl-coding-system
 213      'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
 214      'test-ccl-eof-block 'test-ccl-eof-block)
 215     )
 216   )
 217
 218 (defconst ccl-encoder-eof-block-is-broken
 219   (eval-when-compile
 220     (not (equal (encode-coding-string "" 'test-ccl-eof-block-cs)
 221                 "[EOF]")))
 222   "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
 223 encoding.")
 224
 225 (defconst ccl-decoder-eof-block-is-broken
 226   (eval-when-compile
 227     (not (equal (decode-coding-string "" 'test-ccl-eof-block-cs)
 228                 "[EOF]")))
 229   "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
 230 decoding.")
 231
 232 (defconst ccl-eof-block-is-broken
 233   (or ccl-encoder-eof-block-is-broken
 234       ccl-decoder-eof-block-is-broken))
 235
 236 (unless ccl-use-symbol-as-program
 237
 238   (when (subrp (symbol-function 'ccl-execute))
 239     (fset 'ccl-vector-program-execute
 240           (symbol-function 'ccl-execute))
 241     (defun ccl-execute (ccl-prog reg)
 242       "\
 243 Execute CCL-PROG with registers initialized by REGISTERS.
 244 If CCL-PROG is symbol, it is dereferenced.
 245 \[Emacs 20.3 emulating function]"
 246       (ccl-vector-program-execute
 247        (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
 248        reg)))
 249
 250   (when (subrp (symbol-function 'ccl-execute-on-string))
 251     (fset 'ccl-vector-program-execute-on-string
 252           (symbol-function 'ccl-execute-on-string))
 253     (defun ccl-execute-on-string (ccl-prog status string &optional contin)
 254       "\
 255 Execute CCL-PROG with initial STATUS on STRING.
 256 If CCL-PROG is symbol, it is dereferenced.
 257 \[Emacs 20.3 emulating function]"
 258       (ccl-vector-program-execute-on-string
 259        (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
 260        status string contin)))
 261   )
 262
 263
 264 ;;; @ end
 265 ;;;
 266
 267 (require 'emu-20)
 268
 269 (defalias 'insert-binary-file-contents 'insert-file-contents-as-binary)
 270 (make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary)
 271
 272 (defalias 'insert-binary-file-contents-literally
 273   'insert-file-contents-literally)
 274
 275 (if (and (fboundp 'set-buffer-multibyte)
 276          (subrp (symbol-function 'set-buffer-multibyte)))
 277     (require 'emu-e20_3) ; for Emacs 20.3
 278   (require 'emu-e20_2) ; for Emacs 20.1 and 20.2
 279   )
 280
 281
 282 (provide 'emu-e20)
 283
 284 ;;; emu-e20.el ends here