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.19 1996/05/09 15:06:53 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 lc-ascii 0)
  38 (defconst lc-jp  146)
  39
  40 (defun char-charset (chr)
  41   "Return the character set of char CHR.
  42 \[emu-nemacs.el; XEmacs 20 emulating function]"
  43   (if (< chr 128)
  44       lc-ascii
  45     lc-jp))
  46
  47 (defalias 'char-leading-char 'char-charset)
  48
  49
  50 ;;; @ coding system
  51 ;;;
  52
  53 (defconst *noconv*    0)
  54 (defconst *sjis*      1)
  55 (defconst *junet*     2)
  56 (defconst *ctext*     2)
  57 (defconst *internal*  3)
  58 (defconst *euc-japan* 3)
  59
  60 (defun character-encode-string (str coding-system)
  61   "Encode the string STR which is encoded in CODING-SYSTEM. [emu-nemacs.el]"
  62   (convert-string-kanji-code str 3 coding-system)
  63   )
  64
  65 (defun character-decode-string (str coding-system)
  66   "Decode the string STR which is encoded in CODING-SYSTEM. [emu-nemacs.el]"
  67   (convert-string-kanji-code str coding-system 3)
  68   )
  69
  70 (defun character-encode-region (start end coding-system)
  71   "Encode the text between START and END which is
  72 encoded in CODING-SYSTEM. [emu-nemacs.el]"
  73   (save-excursion
  74     (save-restriction
  75       (narrow-to-region beg end)
  76       (convert-region-kanji-code start end 3 coding-system)
  77       )))
  78
  79 (defun character-decode-region (start end coding-system)
  80   "Decode the text between START and END which is
  81 encoded in CODING-SYSTEM. [emu-nemacs.el]"
  82   (save-excursion
  83     (save-restriction
  84       (narrow-to-region beg end)
  85       (convert-region-kanji-code start end coding-system 3)
  86       )))
  87
  88 (defun code-convert-string (str ic oc)
  89   "Convert code in STRING from SOURCE code to TARGET code,
  90 On successful converion, returns the result string,
  91 else returns nil. [emu-nemacs.el; Mule emulating function]"
  92   (if (not (eq ic oc))
  93       (convert-string-kanji-code str ic oc)
  94     str))
  95
  96 (defun code-convert-region (beg end ic oc)
  97   "Convert code of the text between BEGIN and END from SOURCE
  98 to TARGET. On successful conversion returns t,
  99 else returns nil. [emu-nemacs.el; Mule emulating function]"
 100   (if (/= ic oc)
 101       (save-excursion
 102         (save-restriction
 103           (narrow-to-region beg end)
 104           (convert-region-kanji-code beg end ic oc)
 105           ))))
 106
 107 (defun code-detect-region (start end)
 108   "Detect coding-system of the text in the region between START and END.
 109 \[emu-nemacs.el; Mule emulating function]"
 110   (if (save-excursion
 111         (save-restriction
 112           (narrow-to-region start end)
 113           (goto-char start)
 114           (re-search-forward "[\200-\377]" nil t)
 115           ))
 116       *euc-japan*
 117     ))
 118
 119 (defun set-file-coding-system (coding-system &optional force)
 120   (set-kanji-fileio-code coding-system)
 121   )
 122
 123
 124 ;;; @ character and string
 125 ;;;
 126
 127 (defun char-bytes (chr)
 128   "Return number of bytes CHAR will occupy in a buffer.
 129 \[emu-nemacs.el; Mule emulating function]"
 130   (if (< chr 128) 1 2))
 131
 132 (defun char-width (chr)
 133   "Return number of columns CHAR will occupy when displayed.
 134 \[emu-nemacs.el; Mule emulating function]"
 135   (if (< chr 128) 1 2))
 136
 137 (defun string-width (str)
 138   "Return number of columns STRING will occupy.
 139 \[emu-nemacs.el; Mule emulating function]"
 140   (length str))
 141
 142 (defun sref (str idx)
 143   "Return the character in STR at index IDX.
 144 \[emu-nemacs.el; Mule emulating function]"
 145   (let ((chr (aref str idx)))
 146     (if (< chr 128)
 147         chr
 148       (logior (lsh (aref str (1+ idx)) 8) chr)
 149       )))
 150
 151 (defun string-to-char-list (str)
 152   (let ((i 0)(len (length str)) dest chr)
 153     (while (< i len)
 154       (setq chr (aref str i))
 155       (if (>= chr 128)
 156           (setq i (1+ i)
 157                 chr (+ (lsh chr 8) (aref str i))
 158                 ))
 159       (setq dest (cons chr dest))
 160       (setq i (1+ i))
 161       )
 162     (reverse dest)
 163     ))
 164
 165 (fset 'string-to-int-list (symbol-function 'string-to-char-list))
 166
 167 (defun find-charset-string (str)
 168   "Return a list of leading-chars in the string.
 169 \[emu-nemacs.el; Mule emulating function]"
 170   (if (string-match "[\200-\377]" str)
 171       (list lc-jp)
 172     ))
 173
 174 (defun find-charset-region (start end)
 175   "Return a list of leading-chars in the region between START and END.
 176 \[emu-nemacs.el; Mule emulating function]"
 177   (if (save-excursion
 178         (save-restriction
 179           (narrow-to-region start end)
 180           (goto-char start)
 181           (re-search-forward "[\200-\377]" nil t)
 182           ))
 183       (list lc-jp)
 184     ))
 185
 186 (defun check-ASCII-string (str)
 187   (let ((i 0)
 188         len)
 189     (setq len (length str))
 190     (catch 'label
 191       (while (< i len)
 192         (if (>= (elt str i) 128)
 193             (throw 'label nil))
 194         (setq i (+ i 1))
 195         )
 196       str)))
 197
 198 ;;; Imported from Mule-2.3
 199 (defun truncate-string (str width &optional start-column)
 200   "Truncate STR to fit in WIDTH columns.
 201 Optional non-nil arg START-COLUMN specifies the starting column.
 202 \[emu-mule.el; Mule 2.3 emulating function]"
 203   (or start-column
 204       (setq start-column 0))
 205   (let ((max-width (string-width str))
 206         (len (length str))
 207         (from 0)
 208         (column 0)
 209         to-prev to ch)
 210     (if (>= width max-width)
 211         (setq width max-width))
 212     (if (>= start-column width)
 213         ""
 214       (while (< column start-column)
 215         (setq ch (aref str from)
 216               column (+ column (char-width ch))
 217               from (+ from (char-bytes ch))))
 218       (if (< width max-width)
 219           (progn
 220             (setq to from)
 221             (while (<= column width)
 222               (setq ch (aref str to)
 223                     column (+ column (char-width ch))
 224                     to-prev to
 225                     to (+ to (char-bytes ch))))
 226             (setq to to-prev)))
 227       (substring str from to))))
 228
 229
 230 ;;; @ text property emulation
 231 ;;;
 232
 233 (setq tl:available-face-attribute-alist
 234       '(
 235         ;;(bold      . inversed-region)
 236         (italic    . underlined-region)
 237         (underline . underlined-region)
 238         ))
 239
 240 ;; by YAMATE Keiichirou 1994/10/28
 241 (defun attribute-add-narrow-attribute (attr from to)
 242   (or (consp (symbol-value attr))
 243       (set attr (list 1)))
 244   (let* ((attr-value (symbol-value attr))
 245          (len (car attr-value))
 246          (posfrom 1)
 247          posto)
 248     (while (and (< posfrom len)
 249                 (> from (nth posfrom attr-value)))
 250       (setq posfrom (1+ posfrom)))
 251     (setq posto posfrom)
 252     (while (and (< posto len)
 253                 (> to (nth posto attr-value)))
 254       (setq posto (1+ posto)))
 255     (if  (= posto posfrom)
 256         (if (= (% posto 2) 1)
 257             (if (and (< to len)
 258                      (= to (nth posto attr-value)))
 259                 (set-marker (nth posto attr-value) from)
 260               (setcdr (nthcdr (1- posfrom) attr-value)
 261                       (cons (set-marker-type (set-marker (make-marker)
 262                                                          from)
 263                                              'point-type)
 264                             (cons (set-marker-type (set-marker (make-marker)
 265                                                                to)
 266                                                    nil)
 267                                   (nthcdr posto attr-value))))
 268               (setcar attr-value (+ len 2))))
 269       (if (= (% posfrom 2) 0)
 270           (setq posfrom (1- posfrom))
 271         (set-marker (nth posfrom attr-value) from))
 272       (if (= (% posto 2) 0)
 273           nil
 274         (setq posto (1- posto))
 275         (set-marker (nth posto attr-value) to))
 276       (setcdr (nthcdr posfrom attr-value)
 277               (nthcdr posto attr-value)))))
 278
 279 (defalias 'tl:make-overlay 'cons)
 280
 281 (defun tl:overlay-put (overlay prop value)
 282   (let ((ret (and (eq prop 'face)
 283                   (assq value tl:available-face-attribute-alist)
 284                   )))
 285     (if ret
 286         (attribute-add-narrow-attribute (cdr ret)
 287                                         (car overlay)(cdr overlay))
 288       )))
 289
 290
 291 ;;; @ end
 292 ;;;
 293
 294 (provide 'emu-nemacs)
 295
 296 ;;; emu-nemacs.el ends here