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