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