tl-nemacs.el

   1 ;;;
   2 ;;; $Id: tl-nemacs.el,v 2.0 1994/10/29 18:31:55 morioka Exp $
   3 ;;;
   4
   5 (provide 'tl-nemacs)
   6
   7
   8 ;;; @ constants
   9 ;;;
  10
  11 (defconst *junet* 2)
  12 (defconst *internal* 3)
  13 (defconst *euc-japan* 3)
  14
  15 (defconst lc-ascii 0)
  16 (defconst lc-jp  146)
  17
  18 ;; by mol. 1993/9/26
  19 (defun string-width (str)
  20   "Return number of columns STRING will occupy.
  21  [Mule compatible function in tm-nemacs]"
  22   (length str))
  23
  24 (defun char-bytes (chr)
  25   "Return number of bytes CHAR will occupy in a buffer.
  26  [Mule compatible function in tm-nemacs]"
  27   (if (< chr 128) 1 2))
  28
  29 (defun char-width (chr)
  30   "Return number of columns CHAR will occupy when displayed.
  31  [Mule compatible function in tm-nemacs]"
  32   (if (< chr 128) 1 2))
  33
  34 (defun code-convert-string (str ic oc)
  35   "Convert code in STRING from SOURCE code to TARGET code,
  36 On successful converion, returns the result string,
  37 else returns nil. [Mule compatible function in tm-nemacs]"
  38   (if (not (eq ic oc))
  39       (convert-string-kanji-code str ic oc)
  40     str))
  41
  42 (defun check-ASCII-string (str)
  43   (let ((i 0)
  44         len)
  45     (setq len (length str))
  46     (catch 'label
  47       (while (< i len)
  48         (if (>= (elt str i) 128)
  49             (throw 'label nil))
  50         (setq i (+ i 1))
  51         )
  52       str)))
  53
  54 (defun get-lc (chr)
  55   "Return leading character of CHAR or LEADING-CHARACTER."
  56   (if (< chr 128)
  57       lc-ascii
  58     lc-jp))
  59
  60
  61 ;; by YAMATE Keiichirou 1994/10/28
  62 (defun attribute-add-narrow-attribute (attr from to)
  63   (or (consp (symbol-value attr))
  64       (set attr (list 1)))
  65   (let* ((attr-value (symbol-value attr))
  66          (len (car attr-value))
  67          (posfrom 1)
  68          posto)
  69     (while (and (< posfrom len)
  70                 (> from (nth posfrom attr-value)))
  71       (setq posfrom (1+ posfrom)))
  72     (setq posto posfrom)
  73     (while (and (< posto len)
  74                 (> to (nth posto attr-value)))
  75       (setq posto (1+ posto)))
  76     (if  (= posto posfrom)
  77         (if (= (% posto 2) 1)
  78             (if (and (< to len)
  79                      (= to (nth posto attr-value)))
  80                 (set-marker (nth posto attr-value) from)
  81               (setcdr (nthcdr (1- posfrom) attr-value)
  82                       (cons (set-marker-type (set-marker (make-marker)
  83                                                          from)
  84                                              'point-type)
  85                             (cons (set-marker-type (set-marker (make-marker)
  86                                                                to)
  87                                                    nil)
  88                                   (nthcdr posto attr-value))))
  89               (setcar attr-value (+ len 2))))
  90       (if (= (% posfrom 2) 0)
  91           (setq posfrom (1- posfrom))
  92         (set-marker (nth posfrom attr-value) from))
  93       (if (= (% posto 2) 0)
  94           nil
  95         (setq posto (1- posto))
  96         (set-marker (nth posto attr-value) to))
  97       (setcdr (nthcdr posfrom attr-value)
  98               (nthcdr posto attr-value)))))