(poly-funcall): fix comment to avoid wrong hilihgt
[elisp/apel.git] / poem-nemacs.el
1 ;;; poem-nemacs.el --- poem implementation for Nemacs
2
3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
6 ;; Keywords: emulation, compatibility, Mule
7
8 ;; This file is part of APEL (A Portable Emacs Library).
9
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
14
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Code:
26
27 ;;; @ character set
28 ;;;
29
30 (put 'ascii
31      'charset-description "Character set of ASCII")
32 (put 'ascii
33      'charset-registry "ASCII")
34
35 (put 'japanese-jisx0208
36      'charset-description "Character set of JIS X0208-1983")
37 (put 'japanese-jisx0208
38      'charset-registry "JISX0208.1983")
39
40 (defun charset-description (charset)
41   "Return description of CHARSET. [emu-nemacs.el]"
42   (get charset 'charset-description))
43
44 (defun charset-registry (charset)
45   "Return registry name of CHARSET. [emu-nemacs.el]"
46   (get charset 'charset-registry))
47
48 (defun charset-width (charset)
49   "Return number of columns a CHARSET occupies when displayed.
50 \[emu-nemacs.el]"
51   (if (eq charset 'ascii)
52       1
53     2))
54
55 (defun charset-direction (charset)
56   "Return the direction of a character of CHARSET by
57   0 (left-to-right) or 1 (right-to-left). [emu-nemacs.el]"
58   0)
59
60 (defun find-charset-string (str)
61   "Return a list of charsets in the string.
62 \[emu-nemacs.el; Mule emulating function]"
63   (if (string-match "[\200-\377]" str)
64       '(japanese-jisx0208)
65     ))
66
67 (defalias 'find-non-ascii-charset-string 'find-charset-string)
68
69 (defun find-charset-region (start end)
70   "Return a list of charsets in the region between START and END.
71 \[emu-nemacs.el; Mule emulating function]"
72   (if (save-excursion
73         (save-restriction
74           (narrow-to-region start end)
75           (goto-char start)
76           (re-search-forward "[\200-\377]" nil t)))
77       '(japanese-jisx0208)
78     ))
79
80 (defalias 'find-non-ascii-charset-region 'find-charset-region)
81
82 (defun check-ASCII-string (str)
83   (let ((i 0)
84         len)
85     (setq len (length str))
86     (catch 'label
87       (while (< i len)
88         (if (>= (elt str i) 128)
89             (throw 'label nil))
90         (setq i (+ i 1)))
91       str)))
92
93 ;;; @@ for old MULE emulation
94 ;;;
95
96 ;;(defconst lc-ascii 0)
97 ;;(defconst lc-jp  146)
98
99
100 ;;; @ buffer representation
101 ;;;
102
103 (defsubst-maybe set-buffer-multibyte (flag)
104   "Set the multibyte flag of the current buffer to FLAG.
105 If FLAG is t, this makes the buffer a multibyte buffer.
106 If FLAG is nil, this makes the buffer a single-byte buffer.
107 The buffer contents remain unchanged as a sequence of bytes
108 but the contents viewed as characters do change.
109 \[Emacs 20.3 emulating function]"
110   (setq kanji-flag flag)
111   )
112
113
114 ;;; @ character
115 ;;;
116
117 (defun char-charset (chr)
118   "Return the character set of char CHR.
119 \[emu-nemacs.el; MULE emulating function]"
120   (if (< chr 128)
121       'ascii
122     'japanese-jisx0208))
123
124 (defun char-bytes (chr)
125   "Return number of bytes CHAR will occupy in a buffer.
126 \[emu-nemacs.el; Mule emulating function]"
127   (if (< chr 128)
128       1
129     2))
130
131 (defun char-width (char)
132   "Return number of columns a CHAR occupies when displayed.
133 \[emu-nemacs.el]"
134   (if (< char 128)
135       1
136     2))
137
138 (defalias 'char-length 'char-bytes)
139
140 (defmacro char-next-index (char index)
141   "Return index of character succeeding CHAR whose index is INDEX.
142 \[emu-nemacs.el]"
143   (` (+ (, index) (char-bytes (, char)))))
144
145
146 ;;; @ string
147 ;;;
148
149 (defalias 'string-width 'length)
150
151 (defun sref (str idx)
152   "Return the character in STR at index IDX.
153 \[emu-nemacs.el; Mule emulating function]"
154   (let ((chr (aref str idx)))
155     (if (< chr 128)
156         chr
157       (logior (lsh (aref str (1+ idx)) 8) chr))))
158
159 (defun string-to-char-list (str)
160   (let ((i 0)(len (length str)) dest chr)
161     (while (< i len)
162       (setq chr (aref str i))
163       (if (>= chr 128)
164           (setq i (1+ i)
165                 chr (+ (lsh chr 8) (aref str i)))
166         )
167       (setq dest (cons chr dest))
168       (setq i (1+ i)))
169     (reverse dest)))
170
171 (fset 'string-to-int-list (symbol-function 'string-to-char-list))
172
173 ;;; Imported from Mule-2.3
174 (defun truncate-string (str width &optional start-column)
175   "Truncate STR to fit in WIDTH columns.
176 Optional non-nil arg START-COLUMN specifies the starting column.
177 \[emu-mule.el; Mule 2.3 emulating function]"
178   (or start-column
179       (setq start-column 0))
180   (let ((max-width (string-width str))
181         (len (length str))
182         (from 0)
183         (column 0)
184         to-prev to ch)
185     (if (>= width max-width)
186         (setq width max-width))
187     (if (>= start-column width)
188         ""
189       (while (< column start-column)
190         (setq ch (aref str from)
191               column (+ column (char-width ch))
192               from (+ from (char-bytes ch))))
193       (if (< width max-width)
194           (progn
195             (setq to from)
196             (while (<= column width)
197               (setq ch (aref str to)
198                     column (+ column (char-width ch))
199                     to-prev to
200                     to (+ to (char-bytes ch))))
201             (setq to to-prev)))
202       (substring str from to))))
203
204 (defalias 'looking-at-as-unibyte 'looking-at)
205
206 ;;; @@ obsoleted aliases
207 ;;;
208 ;;; You should not use them.
209
210 (defalias 'string-columns 'length)
211
212
213 ;;; @ end
214 ;;;
215
216 (require 'product)
217 (product-provide (provide 'poem-nemacs) (require 'apel-ver))
218
219 ;;; poem-nemacs.el ends here