(o-UU+4EDE): Use U+4EBB instead of <CJK RADICAL PERSON> in
[chise/xemacs-chise.git.1] / src / casetab.c
1 /* XEmacs routines to deal with case tables.
2    Copyright (C) 1987, 1992, 1993, 1994 Free Software Foundation, Inc.
3    Copyright (C) 1995 Sun Microsystems, Inc.
4    Copyright (C) 2002 MORIOKA Tomohiko
5
6 This file is part of XEmacs.
7
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING.  If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA.  */
22
23  /* Synched up with: FSF 19.28.  Between FSF 19.28 and 19.30, casetab.c
24    was rewritten to use junky FSF char tables.  Meanwhile I rewrote it
25    to use more logical char tables.  RMS also discards the "list of four
26    tables" format and instead stuffs the other tables as "extra slots"
27    in the downcase table.  I've kept the four-lists format for now. */
28
29 /* Written by Howard Gayle.  See some mythical and not-in-the-Emacs-
30    distribution file chartab.c for details. */
31
32 /* Modified for Mule by Ben Wing. */
33 /* Modified for UTF-2000 by MORIOKA Tomohiko */
34
35 /* Case table consists of four char-table.  Those are for downcase,
36    upcase, canonical and equivalent respectively.
37
38    It's entry is like this:
39
40    downcase:    a -> a, A -> a.
41    upcase:      a -> A, A -> a.  (The latter is for NOCASEP.)
42    canon:       a -> a, A -> a.
43    eqv:         a -> A, A -> a.
44 */
45
46 #include <config.h>
47 #include "lisp.h"
48 #include "buffer.h"
49 #include "opaque.h"
50 #include "chartab.h"
51 #include "casetab.h"
52
53 Lisp_Object Qcase_tablep, Qdowncase, Qupcase;
54 Lisp_Object Vstandard_case_table;
55 #ifdef UTF2000
56 Lisp_Object Qflippedcase, Q_lowercase, Q_uppercase;
57 #endif
58
59 static void compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse);
60 Lisp_Object case_table_char (Lisp_Object ch, Lisp_Object table);
61
62 #define STRING256_P(obj) ((STRINGP (obj) && XSTRING_CHAR_LENGTH (obj) == 256))
63
64 static Lisp_Object
65 mark_case_table (Lisp_Object obj)
66 {
67   Lisp_Case_Table *ct = XCASE_TABLE (obj);
68
69   mark_object (CASE_TABLE_DOWNCASE (ct));
70   mark_object (CASE_TABLE_UPCASE (ct));
71   mark_object (CASE_TABLE_CANON (ct));
72   mark_object (CASE_TABLE_EQV (ct));
73   return Qnil;
74 }
75
76 static void
77 print_case_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
78 {
79   Lisp_Case_Table *ct = XCASE_TABLE (obj);
80   char buf[200];
81   if (print_readably)
82     error ("printing unreadable object #<case-table 0x%x", ct->header.uid);
83   write_c_string ("#<case-table ", printcharfun);
84   sprintf (buf, "0x%x>", ct->header.uid);
85   write_c_string (buf, printcharfun);
86 }
87
88 static const struct lrecord_description case_table_description [] = {
89   { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, downcase_table) },
90   { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, upcase_table) },
91   { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_canon_table) },
92   { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_eqv_table) },
93   { XD_END }
94 };
95
96 DEFINE_LRECORD_IMPLEMENTATION ("case-table", case_table,
97                               mark_case_table, print_case_table, 0,
98                               0, 0, case_table_description, Lisp_Case_Table);
99
100 static Lisp_Object
101 allocate_case_table (void)
102 {
103   Lisp_Object val;
104   Lisp_Case_Table *ct =
105     alloc_lcrecord_type (Lisp_Case_Table, &lrecord_case_table);
106
107   SET_CASE_TABLE_DOWNCASE (ct, Qnil);
108   SET_CASE_TABLE_UPCASE (ct, Qnil);
109   SET_CASE_TABLE_CANON (ct, Qnil);
110   SET_CASE_TABLE_EQV (ct, Qnil);
111
112   XSETCASE_TABLE (val, ct);
113   return val;
114 }
115
116 DEFUN ("case-table-p", Fcase_table_p, 1, 1, 0, /*
117 Return t if OBJECT is a case table.
118 See `set-case-table' for more information on these data structures.
119 */
120        (object))
121 {
122   if (CASE_TABLEP (object))
123     return Qt;
124   else
125     {
126       Lisp_Object down, up, canon, eqv;
127       if (!CONSP (object))
128         return Qnil;
129       down = XCAR (object); object = XCDR (object);
130       if (!CONSP (object))
131         return Qnil;
132       up = XCAR (object); object = XCDR (object);
133       if (!CONSP (object))
134         return Qnil;
135       canon = XCAR (object); object = XCDR (object);
136       if (!CONSP (object))
137         return Qnil;
138       eqv = XCAR (object);
139
140       return ((STRING256_P (down)
141                && (NILP (up) || STRING256_P (up))
142                && ((NILP (canon) && NILP (eqv))
143                    || STRING256_P (canon))
144                && (NILP (eqv) || STRING256_P (eqv)))
145               ? Qt : Qnil);
146
147     }
148 }
149
150 static Lisp_Object
151 check_case_table (Lisp_Object object)
152 {
153   /* This function can GC */
154   while (NILP (Fcase_table_p (object)))
155     object = wrong_type_argument (Qcase_tablep, object);
156   return object;
157 }
158
159 Lisp_Object
160 case_table_char (Lisp_Object ch, Lisp_Object table)
161 {
162   Lisp_Object ct_char;
163   ct_char = get_char_table (XCHAR (ch), XCHAR_TABLE (table));
164   if (NILP (ct_char))
165     return ch;
166   else
167     return ct_char;
168 }
169
170 DEFUN ("get-case-table", Fget_case_table, 3, 3, 0, /*
171 Return CHAR-CASE version of CHARACTER in CASE-TABLE.
172
173 CHAR-CASE is either downcase or upcase.
174 */
175        (char_case, character, case_table))
176 {
177   CHECK_CHAR (character);
178   CHECK_CASE_TABLE (case_table);
179   if (EQ (char_case, Qdowncase))
180     return case_table_char (character, XCASE_TABLE_DOWNCASE (case_table));
181   else if (EQ (char_case, Qupcase))
182     return case_table_char (character, XCASE_TABLE_UPCASE (case_table));
183   else
184     signal_simple_error ("Char case must be downcase or upcase", char_case);
185
186   return Qnil; /* Not reached. */
187 }
188
189 DEFUN ("put-case-table", Fput_case_table, 4, 4, 0, /*
190 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE.
191
192 CHAR-CASE is either downcase or upcase.
193 See also `put-case-table-pair'.
194 */
195        (char_case, character, value, case_table))
196 {
197   CHECK_CHAR (character);
198   CHECK_CHAR (value);
199
200   if (EQ (char_case, Qdowncase))
201     {
202       Fput_char_table (character, value, XCASE_TABLE_DOWNCASE (case_table));
203       /* This one is not at all intuitive.  */
204       Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table));
205       Fput_char_table (character, value, XCASE_TABLE_CANON (case_table));
206       Fput_char_table (value, value, XCASE_TABLE_CANON (case_table));
207       Fput_char_table (value, character, XCASE_TABLE_EQV (case_table));
208       Fput_char_table (character, value, XCASE_TABLE_EQV (case_table));
209     }
210   else if (EQ (char_case, Qupcase))
211     {
212       Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table));
213       Fput_char_table (character, character, XCASE_TABLE_DOWNCASE (case_table));
214       Fput_char_table (character, character, XCASE_TABLE_CANON (case_table));
215       Fput_char_table (value, character, XCASE_TABLE_CANON (case_table));
216       Fput_char_table (value, character, XCASE_TABLE_EQV (case_table));
217       Fput_char_table (character, value, XCASE_TABLE_EQV (case_table));
218     }
219   else
220     signal_simple_error ("Char case must be downcase or upcase", char_case);
221
222   return Qnil;
223 }
224
225 DEFUN ("put-case-table-pair", Fput_case_table_pair, 3, 3, 0, /*
226 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE.
227 UC is an uppercase character and LC is a downcase character.
228 */
229        (uc, lc, case_table))
230 {
231   CHECK_CHAR (uc);
232   CHECK_CHAR (lc);
233   CHECK_CASE_TABLE (case_table);
234
235   Fput_char_table (lc, lc, XCASE_TABLE_DOWNCASE (case_table));
236   Fput_char_table (uc, lc, XCASE_TABLE_UPCASE (case_table));
237   Fput_char_table (uc, lc, XCASE_TABLE_DOWNCASE (case_table));
238   Fput_char_table (lc, uc, XCASE_TABLE_UPCASE (case_table));
239
240   Fput_char_table (lc, lc, XCASE_TABLE_CANON (case_table));
241   Fput_char_table (uc, lc, XCASE_TABLE_CANON (case_table));
242   Fput_char_table (uc, lc, XCASE_TABLE_EQV (case_table));
243   Fput_char_table (lc, uc, XCASE_TABLE_EQV (case_table));
244   return Qnil;
245 }
246
247 DEFUN ("copy-case-table", Fcopy_case_table, 1, 1, 0, /*
248 Return a new case table which is a copy of CASE-TABLE
249 */
250        (case_table))
251 {
252   Lisp_Object new_obj;
253   CHECK_CASE_TABLE (case_table);
254
255   new_obj = allocate_case_table ();
256   XSET_CASE_TABLE_DOWNCASE
257     (new_obj, Fcopy_char_table (XCASE_TABLE_DOWNCASE (case_table)));
258   XSET_CASE_TABLE_UPCASE
259     (new_obj, Fcopy_char_table (XCASE_TABLE_UPCASE (case_table)));
260   XSET_CASE_TABLE_CANON
261     (new_obj, Fcopy_char_table (XCASE_TABLE_CANON (case_table)));
262   XSET_CASE_TABLE_EQV
263     (new_obj, Fcopy_char_table (XCASE_TABLE_EQV (case_table)));
264   return new_obj;
265 }
266
267 DEFUN ("current-case-table", Fcurrent_case_table, 0, 1, 0, /*
268 Return the case table of BUFFER, which defaults to the current buffer.
269 */
270        (buffer))
271 {
272   struct buffer *buf = decode_buffer (buffer, 0);
273
274   return buf->case_table;
275 }
276
277 DEFUN ("standard-case-table", Fstandard_case_table, 0, 0, 0, /*
278 Return the standard case table.
279 This is the one used for new buffers.
280 */
281        ())
282 {
283   return Vstandard_case_table;
284 }
285
286 static Lisp_Object set_case_table (Lisp_Object table, int standard);
287
288 DEFUN ("set-case-table", Fset_case_table, 1, 1, 0, /*
289 Select CASE-TABLE as the new case table for the current buffer.
290 A case table is a case-table object or list
291  (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)
292  where each element is either nil or a string of length 256.
293 The latter is provided for backward-compatibility.
294 DOWNCASE maps each character to its lower-case equivalent.
295 UPCASE maps each character to its upper-case equivalent;
296  if lower and upper case characters are in 1-1 correspondence,
297  you may use nil and the upcase table will be deduced from DOWNCASE.
298 CANONICALIZE maps each character to a canonical equivalent;
299  any two characters that are related by case-conversion have the same
300  canonical equivalent character; it may be nil, in which case it is
301  deduced from DOWNCASE and UPCASE.
302 EQUIVALENCES is a map that cyclicly permutes each equivalence class
303  (of characters with the same canonical equivalent); it may be nil,
304  in which case it is deduced from CANONICALIZE.
305
306 See also `get-case-table', `put-case-table' and `put-case-table-pair'.
307 */
308        (case_table))
309 {
310   /* This function can GC */
311   return set_case_table (case_table, 0);
312 }
313
314 DEFUN ("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /*
315 Select CASE-TABLE as the new standard case table for new buffers.
316 See `set-case-table' for more info on case tables.
317 */
318        (case_table))
319 {
320   /* This function can GC */
321   return set_case_table (case_table, 1);
322 }
323
324 static Lisp_Object
325 set_case_table (Lisp_Object table, int standard)
326 {
327   /* This function can GC */
328   struct buffer *buf =
329     standard ? XBUFFER(Vbuffer_defaults) : current_buffer;
330
331   check_case_table (table);
332
333   if (CASE_TABLEP (table))
334     {
335       if (standard)
336         Vstandard_case_table = table;
337
338       buf->case_table = table;
339     }
340   else
341     {
342       /* For backward compatibility. */
343       Lisp_Object down, up, canon, eqv, tail = table;
344       Lisp_Object temp;
345       int i;
346
347       down = XCAR (tail); tail = XCDR (tail);
348       up = XCAR (tail); tail = XCDR (tail);
349       canon = XCAR (tail); tail = XCDR (tail);
350       eqv = XCAR (tail);
351
352       temp = down;
353       down = MAKE_TRT_TABLE ();
354       for (i = 0; i < 256; i++)
355         SET_TRT_TABLE_CHAR_1 (down, i, string_char (XSTRING (temp), i));
356
357       if (NILP (up))
358         {
359           up = MAKE_TRT_TABLE ();
360           compute_trt_inverse (down, up);
361         }
362       else
363         {
364           temp = up;
365           up = MAKE_TRT_TABLE ();
366           for (i = 0; i < 256; i++)
367             SET_TRT_TABLE_CHAR_1 (up, i, string_char (XSTRING (temp), i));
368         }
369       if (NILP (canon))
370         {
371           canon = MAKE_TRT_TABLE ();
372
373           /* Set up the CANON table; for each character,
374              this sequence of upcasing and downcasing ought to
375              get the "preferred" lowercase equivalent.  */
376           for (i = 0; i < 256; i++)
377             SET_TRT_TABLE_CHAR_1 (canon, i,
378                                   TRT_TABLE_CHAR_1
379                                   (down,
380                                    TRT_TABLE_CHAR_1
381                                    (up,
382                                     TRT_TABLE_CHAR_1 (down, i))));
383         }
384       else
385         {
386           temp = canon;
387           canon = MAKE_TRT_TABLE ();
388           for (i = 0; i < 256; i++)
389             SET_TRT_TABLE_CHAR_1 (canon, i, string_char (XSTRING (temp), i));
390         }
391
392       if (NILP (eqv))
393         {
394           eqv = MAKE_TRT_TABLE ();
395           compute_trt_inverse (canon, eqv);
396         }
397       else
398         {
399           temp = eqv;
400           eqv = MAKE_TRT_TABLE ();
401           for (i = 0; i < 256; i++)
402             SET_TRT_TABLE_CHAR_1 (eqv, i, string_char (XSTRING (temp), i));
403         }
404
405       if (standard)
406         {
407           XSET_CASE_TABLE_DOWNCASE (Vstandard_case_table, down);
408           XSET_CASE_TABLE_UPCASE (Vstandard_case_table, up);
409           XSET_CASE_TABLE_CANON (Vstandard_case_table, canon);
410           XSET_CASE_TABLE_EQV (Vstandard_case_table, eqv);
411         }
412
413       buf->case_table = allocate_case_table ();
414       XSET_CASE_TABLE_DOWNCASE (buf->case_table, down);
415       XSET_CASE_TABLE_UPCASE (buf->case_table, up);
416       XSET_CASE_TABLE_CANON (buf->case_table, canon);
417       XSET_CASE_TABLE_EQV (buf->case_table, eqv);
418     }
419
420   return buf->case_table;
421 }
422 \f
423 /* Given a translate table TRT, store the inverse mapping into INVERSE.
424    Since TRT is not one-to-one, INVERSE is not a simple mapping.
425    Instead, it divides the space of characters into equivalence classes.
426    All characters in a given class form one circular list, chained through
427    the elements of INVERSE.  */
428
429 static void
430 compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse)
431 {
432   Charcount i = 0400;
433   Emchar c, q;
434
435   while (--i)
436     SET_TRT_TABLE_CHAR_1 (inverse, i, (Emchar) i);
437   i = 0400;
438   while (--i)
439     {
440       if ((q = TRT_TABLE_CHAR_1 (trt, i)) != (Emchar) i)
441         {
442           c = TRT_TABLE_CHAR_1 (inverse, q);
443           SET_TRT_TABLE_CHAR_1 (inverse, q, (Emchar) i);
444           SET_TRT_TABLE_CHAR_1 (inverse, i, c);
445         }
446     }
447 }
448
449 \f
450 void
451 syms_of_casetab (void)
452 {
453   INIT_LRECORD_IMPLEMENTATION (case_table);
454
455   defsymbol (&Qcase_tablep, "case-table-p");
456   defsymbol (&Qdowncase, "downcase");
457   defsymbol (&Qupcase, "upcase");
458 #ifdef UTF2000
459   defsymbol (&Qflippedcase, "flippedcase");
460   defsymbol (&Q_lowercase, "->lowercase");
461   defsymbol (&Q_uppercase, "->uppercase");
462 #endif
463
464   DEFSUBR (Fcase_table_p);
465   DEFSUBR (Fget_case_table);
466   DEFSUBR (Fput_case_table);
467   DEFSUBR (Fput_case_table_pair);
468   DEFSUBR (Fcurrent_case_table);
469   DEFSUBR (Fstandard_case_table);
470   DEFSUBR (Fcopy_case_table);
471   DEFSUBR (Fset_case_table);
472   DEFSUBR (Fset_standard_case_table);
473 }
474
475 void
476 complex_vars_of_casetab (void)
477 {
478   REGISTER Emchar i;
479   Lisp_Object tem;
480
481   staticpro (&Vstandard_case_table);
482
483   Vstandard_case_table = allocate_case_table ();
484
485 #ifdef UTF2000
486   tem = MAKE_TRT_TABLE ();
487
488 #ifdef HAVE_CHISE
489   XCHAR_TABLE_NAME (tem) = Qdowncase;
490 #endif
491 #else
492   tem = MAKE_TRT_TABLE ();
493 #endif
494   XSET_CASE_TABLE_DOWNCASE (Vstandard_case_table, tem);
495   XSET_CASE_TABLE_CANON (Vstandard_case_table, tem);
496
497   /* Under Mule, can't do set_string_char() until Vcharset_control_1
498      and Vcharset_ascii are initialized. */
499   for (i = 0; i < 256; i++)
500     {
501       unsigned char lowered = tolower (i);
502
503       SET_TRT_TABLE_CHAR_1 (tem, i, lowered);
504     }
505
506 #ifdef UTF2000
507   tem = MAKE_TRT_TABLE ();
508 #ifdef HAVE_CHISE
509   XCHAR_TABLE_NAME (tem) = Qflippedcase;
510 #endif
511 #else
512   tem = MAKE_TRT_TABLE ();
513 #endif
514   XSET_CASE_TABLE_UPCASE (Vstandard_case_table, tem);
515   XSET_CASE_TABLE_EQV (Vstandard_case_table, tem);
516
517   for (i = 0; i < 256; i++)
518     {
519       unsigned char flipped = (isupper (i) ? tolower (i)
520                                : (islower (i) ? toupper (i) : i));
521
522       SET_TRT_TABLE_CHAR_1 (tem, i, flipped);
523     }
524 }