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) 1994,1995 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Version:
   9 ;;;     $Id: emu-nemacs.el,v 7.1 1995/10/11 11:49:55 morioka Exp $
  10 ;;; Keywords: emulation, compatibility, NEmacs, Mule
  11 ;;;
  12 ;;; This file is part of tl and tm (Tools for MIME).
  13 ;;;
  14
  15 (require 'emu-18)
  16
  17
  18 ;;; @ constants
  19 ;;;
  20
  21 (defconst emacs-major-version (string-to-int emacs-version))
  22
  23
  24 ;;; @ leading-char
  25 ;;;
  26
  27 (defconst lc-ascii 0)
  28 (defconst lc-jp  146)
  29
  30 (defun char-leading-char (chr)
  31   "Return leading character of CHAR.
  32 \[emu-nemacs.el; Mule emulating function]"
  33   (if (< chr 128)
  34       lc-ascii
  35     lc-jp))
  36
  37 (defalias 'get-lc 'char-leading-char)
  38
  39
  40 ;;; @ coding-system
  41 ;;;
  42
  43 (defconst *junet* 2)
  44 (defconst *internal* 3)
  45 (defconst *euc-japan* 3)
  46
  47 (defun code-convert-string (str ic oc)
  48   "Convert code in STRING from SOURCE code to TARGET code,
  49 On successful converion, returns the result string,
  50 else returns nil. [emu-nemacs.el; Mule emulating function]"
  51   (if (not (eq ic oc))
  52       (convert-string-kanji-code str ic oc)
  53     str))
  54
  55
  56 ;;; @ character and string
  57 ;;;
  58
  59 (defun char-bytes (chr)
  60   "Return number of bytes CHAR will occupy in a buffer.
  61  [Mule compatible function in tm-nemacs]"
  62   (if (< chr 128) 1 2))
  63
  64 (defun char-width (chr)
  65   "Return number of columns CHAR will occupy when displayed.
  66  [Mule compatible function in tm-nemacs]"
  67   (if (< chr 128) 1 2))
  68
  69 ;; by mol. 1993/9/26
  70 (defun string-width (str)
  71   "Return number of columns STRING will occupy.
  72  [Mule compatible function in tm-nemacs]"
  73   (length str))
  74
  75 (defun string-to-char-list (str)
  76   (let ((i 0)(len (length str)) dest chr)
  77     (while (< i len)
  78       (setq chr (aref str i))
  79       (if (>= chr 128)
  80           (setq i (1+ i)
  81                 chr (+ (lsh chr 8) (aref str i))
  82                 ))
  83       (setq dest (cons chr dest))
  84       (setq i (1+ i))
  85       )
  86     (reverse dest)
  87     ))
  88
  89 (defun find-charset-string (str)
  90   (if (string-match "[\200-\377]" str)
  91       (list lc-jp)
  92     ))
  93
  94 (defun find-charset-region (start end)
  95   (if (save-excursion
  96         (save-restriction
  97           (narrow-to-region start end)
  98           (goto-char start)
  99           (re-search-forward "[\200-\377]" nil t)
 100           ))
 101       (list lc-jp)
 102     ))
 103
 104 (defun check-ASCII-string (str)
 105   (let ((i 0)
 106         len)
 107     (setq len (length str))
 108     (catch 'label
 109       (while (< i len)
 110         (if (>= (elt str i) 128)
 111             (throw 'label nil))
 112         (setq i (+ i 1))
 113         )
 114       str)))
 115
 116
 117 ;;; @ text property emulation
 118 ;;;
 119
 120 (setq tl:available-face-attribute-alist
 121       '(
 122         ;;(bold      . inversed-region)
 123         (italic    . underlined-region)
 124         (underline . underlined-region)
 125         ))
 126
 127 ;; by YAMATE Keiichirou 1994/10/28
 128 (defun attribute-add-narrow-attribute (attr from to)
 129   (or (consp (symbol-value attr))
 130       (set attr (list 1)))
 131   (let* ((attr-value (symbol-value attr))
 132          (len (car attr-value))
 133          (posfrom 1)
 134          posto)
 135     (while (and (< posfrom len)
 136                 (> from (nth posfrom attr-value)))
 137       (setq posfrom (1+ posfrom)))
 138     (setq posto posfrom)
 139     (while (and (< posto len)
 140                 (> to (nth posto attr-value)))
 141       (setq posto (1+ posto)))
 142     (if  (= posto posfrom)
 143         (if (= (% posto 2) 1)
 144             (if (and (< to len)
 145                      (= to (nth posto attr-value)))
 146                 (set-marker (nth posto attr-value) from)
 147               (setcdr (nthcdr (1- posfrom) attr-value)
 148                       (cons (set-marker-type (set-marker (make-marker)
 149                                                          from)
 150                                              'point-type)
 151                             (cons (set-marker-type (set-marker (make-marker)
 152                                                                to)
 153                                                    nil)
 154                                   (nthcdr posto attr-value))))
 155               (setcar attr-value (+ len 2))))
 156       (if (= (% posfrom 2) 0)
 157           (setq posfrom (1- posfrom))
 158         (set-marker (nth posfrom attr-value) from))
 159       (if (= (% posto 2) 0)
 160           nil
 161         (setq posto (1- posto))
 162         (set-marker (nth posto attr-value) to))
 163       (setcdr (nthcdr posfrom attr-value)
 164               (nthcdr posto attr-value)))))
 165
 166 (defalias 'tl:make-overlay 'cons)
 167
 168 (defun tl:overlay-put (overlay prop value)
 169   (let ((ret (and (eq prop 'face)
 170                   (assq value tl:available-face-attribute-alist)
 171                   )))
 172     (if ret
 173         (attribute-add-narrow-attribute (cdr ret)
 174                                         (car overlay)(cdr overlay))
 175       )))
 176
 177 (defun tl:add-text-properties (start end properties &optional object))
 178
 179
 180 ;;; @ end
 181 ;;;
 182
 183 (provide 'emu-nemacs)