emu-nemacs.el

   1 ;;;
   2 ;;; emu-nemacs.el --- Mule 2 emulation module for NEmacs
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1993 .. 1996 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; modified by KOBAYASHI Shuhei <shuhei-k@jaist.ac.jp>
   9 ;;; Version:
  10 ;;;     $Id: emu-nemacs.el,v 7.27 1996/05/27 12:27:59 morioka Exp $
  11 ;;; Keywords: emulation, compatibility, NEmacs, Mule
  12 ;;;
  13 ;;; This file is part of tl (Tiny Library).
  14 ;;;
  15 ;;; This program is free software; you can redistribute it and/or
  16 ;;; modify it under the terms of the GNU General Public License as
  17 ;;; published by the Free Software Foundation; either version 2, or
  18 ;;; (at your option) any later version.
  19 ;;;
  20 ;;; This program is distributed in the hope that it will be useful,
  21 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  23 ;;; General Public License for more details.
  24 ;;;
  25 ;;; You should have received a copy of the GNU General Public License
  26 ;;; along with This program.  If not, write to the Free Software
  27 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  28 ;;;
  29 ;;; Code:
  30
  31 (require 'emu-18)
  32
  33
  34 ;;; @ character set
  35 ;;;
  36
  37 (defconst charset-ascii 0 "Character set of ASCII")
  38 (defconst charset-jisx0208 146 "Character set of JIS X0208-1983")
  39
  40 ;;; @@ for Mule emulation
  41 ;;;
  42
  43 (defconst lc-ascii 0)
  44 (defconst lc-jp  146)
  45
  46
  47 ;;; @ coding system
  48 ;;;
  49
  50 (defconst *noconv*    0)
  51 (defconst *sjis*      1)
  52 (defconst *junet*     2)
  53 (defconst *ctext*     2)
  54 (defconst *internal*  3)
  55 (defconst *euc-japan* 3)
  56
  57 (defun character-encode-string (str coding-system)
  58   "Encode the string STR which is encoded in CODING-SYSTEM. [emu-nemacs.el]"
  59   (convert-string-kanji-code str 3 coding-system)
  60   )
  61
  62 (defun character-decode-string (str coding-system)
  63   "Decode the string STR which is encoded in CODING-SYSTEM. [emu-nemacs.el]"
  64   (convert-string-kanji-code str coding-system 3)
  65   )
  66
  67 (defun character-encode-region (start end coding-system)
  68   "Encode the text between START and END which is
  69 encoded in CODING-SYSTEM. [emu-nemacs.el]"
  70   (save-excursion
  71     (save-restriction
  72       (narrow-to-region beg end)
  73       (convert-region-kanji-code start end 3 coding-system)
  74       )))
  75
  76 (defun character-decode-region (start end coding-system)
  77   "Decode the text between START and END which is
  78 encoded in CODING-SYSTEM. [emu-nemacs.el]"
  79   (save-excursion
  80     (save-restriction
  81       (narrow-to-region beg end)
  82       (convert-region-kanji-code start end coding-system 3)
  83       )))
  84
  85 (defun code-convert-string (str ic oc)
  86   "Convert code in STRING from SOURCE code to TARGET code,
  87 On successful converion, returns the result string,
  88 else returns nil. [emu-nemacs.el; Mule emulating function]"
  89   (if (not (eq ic oc))
  90       (convert-string-kanji-code str ic oc)
  91     str))
  92
  93 (defun code-convert-region (beg end ic oc)
  94   "Convert code of the text between BEGIN and END from SOURCE
  95 to TARGET. On successful conversion returns t,
  96 else returns nil. [emu-nemacs.el; Mule emulating function]"
  97   (if (/= ic oc)
  98       (save-excursion
  99         (save-restriction
 100           (narrow-to-region beg end)
 101           (convert-region-kanji-code beg end ic oc)
 102           ))))
 103
 104 (defun code-detect-region (start end)
 105   "Detect coding-system of the text in the region between START and END.
 106 \[emu-nemacs.el; Mule emulating function]"
 107   (if (save-excursion
 108         (save-restriction
 109           (narrow-to-region start end)
 110           (goto-char start)
 111           (re-search-forward "[\200-\377]" nil t)
 112           ))
 113       *euc-japan*
 114     ))
 115
 116 (defun set-file-coding-system (coding-system &optional force)
 117   (set-kanji-fileio-code coding-system)
 118   )
 119
 120
 121 ;;; @ character
 122 ;;;
 123
 124 (defun char-charset (chr)
 125   "Return the character set of char CHR.
 126 \[emu-nemacs.el; XEmacs 20 emulating function]"
 127   (if (< chr 128)
 128       charset-ascii
 129     charset-jisx0208))
 130
 131 (defun char-bytes (chr)
 132   "Return number of bytes CHAR will occupy in a buffer.
 133 \[emu-nemacs.el; Mule emulating function]"
 134   (if (< chr 128) 1 2))
 135
 136 (defun char-columns (character)
 137   "Return number of columns a CHARACTER occupies when displayed.
 138 \[emu-nemacs.el]"
 139   (if (< character 128)
 140       1
 141     2))
 142
 143 ;;; @@ for Mule emulation
 144 ;;;
 145
 146 (defalias 'char-leading-char 'char-charset)
 147
 148 (defalias 'char-width 'char-columns)
 149
 150
 151 ;;; @ string
 152 ;;;
 153
 154 (defalias 'string-columns 'length)
 155
 156 (defun sref (str idx)
 157   "Return the character in STR at index IDX.
 158 \[emu-nemacs.el; Mule emulating function]"
 159   (let ((chr (aref str idx)))
 160     (if (< chr 128)
 161         chr
 162       (logior (lsh (aref str (1+ idx)) 8) chr)
 163       )))
 164
 165 (defun string-to-char-list (str)
 166   (let ((i 0)(len (length str)) dest chr)
 167     (while (< i len)
 168       (setq chr (aref str i))
 169       (if (>= chr 128)
 170           (setq i (1+ i)
 171                 chr (+ (lsh chr 8) (aref str i))
 172                 ))
 173       (setq dest (cons chr dest))
 174       (setq i (1+ i))
 175       )
 176     (reverse dest)
 177     ))
 178
 179 (fset 'string-to-int-list (symbol-function 'string-to-char-list))
 180
 181 (defun find-charset-string (str)
 182   "Return a list of leading-chars in the string.
 183 \[emu-nemacs.el; Mule emulating function]"
 184   (if (string-match "[\200-\377]" str)
 185       (list lc-jp)
 186     ))
 187
 188 (defun find-charset-region (start end)
 189   "Return a list of leading-chars in the region between START and END.
 190 \[emu-nemacs.el; Mule emulating function]"
 191   (if (save-excursion
 192         (save-restriction
 193           (narrow-to-region start end)
 194           (goto-char start)
 195           (re-search-forward "[\200-\377]" nil t)
 196           ))
 197       (list lc-jp)
 198     ))
 199
 200 (defun check-ASCII-string (str)
 201   (let ((i 0)
 202         len)
 203     (setq len (length str))
 204     (catch 'label
 205       (while (< i len)
 206         (if (>= (elt str i) 128)
 207             (throw 'label nil))
 208         (setq i (+ i 1))
 209         )
 210       str)))
 211
 212 ;;; Imported from Mule-2.3
 213 (defun truncate-string (str width &optional start-column)
 214   "Truncate STR to fit in WIDTH columns.
 215 Optional non-nil arg START-COLUMN specifies the starting column.
 216 \[emu-mule.el; Mule 2.3 emulating function]"
 217   (or start-column
 218       (setq start-column 0))
 219   (let ((max-width (string-width str))
 220         (len (length str))
 221         (from 0)
 222         (column 0)
 223         to-prev to ch)
 224     (if (>= width max-width)
 225         (setq width max-width))
 226     (if (>= start-column width)
 227         ""
 228       (while (< column start-column)
 229         (setq ch (aref str from)
 230               column (+ column (char-columns ch))
 231               from (+ from (char-bytes ch))))
 232       (if (< width max-width)
 233           (progn
 234             (setq to from)
 235             (while (<= column width)
 236               (setq ch (aref str to)
 237                     column (+ column (char-columns ch))
 238                     to-prev to
 239                     to (+ to (char-bytes ch))))
 240             (setq to to-prev)))
 241       (substring str from to))))
 242
 243 ;;; @@ for Mule emulation
 244 ;;;
 245
 246 (defalias 'string-width 'length)
 247
 248
 249 ;;; @ text property emulation
 250 ;;;
 251
 252 (setq tl:available-face-attribute-alist
 253       '(
 254         ;;(bold      . inversed-region)
 255         (italic    . underlined-region)
 256         (underline . underlined-region)
 257         ))
 258
 259 ;; by YAMATE Keiichirou 1994/10/28
 260 (defun attribute-add-narrow-attribute (attr from to)
 261   (or (consp (symbol-value attr))
 262       (set attr (list 1)))
 263   (let* ((attr-value (symbol-value attr))
 264          (len (car attr-value))
 265          (posfrom 1)
 266          posto)
 267     (while (and (< posfrom len)
 268                 (> from (nth posfrom attr-value)))
 269       (setq posfrom (1+ posfrom)))
 270     (setq posto posfrom)
 271     (while (and (< posto len)
 272                 (> to (nth posto attr-value)))
 273       (setq posto (1+ posto)))
 274     (if  (= posto posfrom)
 275         (if (= (% posto 2) 1)
 276             (if (and (< to len)
 277                      (= to (nth posto attr-value)))
 278                 (set-marker (nth posto attr-value) from)
 279               (setcdr (nthcdr (1- posfrom) attr-value)
 280                       (cons (set-marker-type (set-marker (make-marker)
 281                                                          from)
 282                                              'point-type)
 283                             (cons (set-marker-type (set-marker (make-marker)
 284                                                                to)
 285                                                    nil)
 286                                   (nthcdr posto attr-value))))
 287               (setcar attr-value (+ len 2))))
 288       (if (= (% posfrom 2) 0)
 289           (setq posfrom (1- posfrom))
 290         (set-marker (nth posfrom attr-value) from))
 291       (if (= (% posto 2) 0)
 292           nil
 293         (setq posto (1- posto))
 294         (set-marker (nth posto attr-value) to))
 295       (setcdr (nthcdr posfrom attr-value)
 296               (nthcdr posto attr-value)))))
 297
 298 (defalias 'tl:make-overlay 'cons)
 299
 300 (defun tl:overlay-put (overlay prop value)
 301   (let ((ret (and (eq prop 'face)
 302                   (assq value tl:available-face-attribute-alist)
 303                   )))
 304     (if ret
 305         (attribute-add-narrow-attribute (cdr ret)
 306                                         (car overlay)(cdr overlay))
 307       )))
 308
 309
 310 ;;; @ end
 311 ;;;
 312
 313 (provide 'emu-nemacs)
 314
 315 ;;; emu-nemacs.el ends here