* lisp/files.el (dir-locals-read-from-file): Check file non-empty
[emacs.git] / src / charset.c
blob6b999824dab920dc3bf00d13765da28f85a451b2
1 /* Basic character set support.
2 Copyright (C) 2001-2012 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010, 2011
5 National Institute of Advanced Industrial Science and Technology (AIST)
6 Registration Number H14PRO021
8 Copyright (C) 2003, 2004
9 National Institute of Advanced Industrial Science and Technology (AIST)
10 Registration Number H13PRO009
12 This file is part of GNU Emacs.
14 GNU Emacs is free software: you can redistribute it and/or modify
15 it under the terms of the GNU General Public License as published by
16 the Free Software Foundation, either version 3 of the License, or
17 (at your option) any later version.
19 GNU Emacs is distributed in the hope that it will be useful,
20 but WITHOUT ANY WARRANTY; without even the implied warranty of
21 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 GNU General Public License for more details.
24 You should have received a copy of the GNU General Public License
25 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
27 #include <config.h>
29 #define CHARSET_INLINE EXTERN_INLINE
31 #include <stdio.h>
32 #include <unistd.h>
33 #include <limits.h>
34 #include <sys/types.h>
35 #include <c-ctype.h>
36 #include "lisp.h"
37 #include "character.h"
38 #include "charset.h"
39 #include "coding.h"
40 #include "disptab.h"
41 #include "buffer.h"
43 /*** GENERAL NOTES on CODED CHARACTER SETS (CHARSETS) ***
45 A coded character set ("charset" hereafter) is a meaningful
46 collection (i.e. language, culture, functionality, etc.) of
47 characters. Emacs handles multiple charsets at once. In Emacs Lisp
48 code, a charset is represented by a symbol. In C code, a charset is
49 represented by its ID number or by a pointer to a struct charset.
51 The actual information about each charset is stored in two places.
52 Lispy information is stored in the hash table Vcharset_hash_table as
53 a vector (charset attributes). The other information is stored in
54 charset_table as a struct charset.
58 /* Hash table that contains attributes of each charset. Keys are
59 charset symbols, and values are vectors of charset attributes. */
60 Lisp_Object Vcharset_hash_table;
62 /* Table of struct charset. */
63 struct charset *charset_table;
65 static ptrdiff_t charset_table_size;
66 static int charset_table_used;
68 Lisp_Object Qcharsetp;
70 /* Special charset symbols. */
71 Lisp_Object Qascii;
72 static Lisp_Object Qeight_bit;
73 static Lisp_Object Qiso_8859_1;
74 static Lisp_Object Qunicode;
75 static Lisp_Object Qemacs;
77 /* The corresponding charsets. */
78 int charset_ascii;
79 int charset_eight_bit;
80 static int charset_iso_8859_1;
81 int charset_unicode;
82 static int charset_emacs;
84 /* The other special charsets. */
85 int charset_jisx0201_roman;
86 int charset_jisx0208_1978;
87 int charset_jisx0208;
88 int charset_ksc5601;
90 /* Value of charset attribute `charset-iso-plane'. */
91 static Lisp_Object Qgl, Qgr;
93 /* Charset of unibyte characters. */
94 int charset_unibyte;
96 /* List of charsets ordered by the priority. */
97 Lisp_Object Vcharset_ordered_list;
99 /* Sub-list of Vcharset_ordered_list that contains all non-preferred
100 charsets. */
101 Lisp_Object Vcharset_non_preferred_head;
103 /* Incremented everytime we change Vcharset_ordered_list. This is
104 unsigned short so that it fits in Lisp_Int and never matches
105 -1. */
106 unsigned short charset_ordered_list_tick;
108 /* List of iso-2022 charsets. */
109 Lisp_Object Viso_2022_charset_list;
111 /* List of emacs-mule charsets. */
112 Lisp_Object Vemacs_mule_charset_list;
114 int emacs_mule_charset[256];
116 /* Mapping table from ISO2022's charset (specified by DIMENSION,
117 CHARS, and FINAL-CHAR) to Emacs' charset. */
118 int iso_charset_table[ISO_MAX_DIMENSION][ISO_MAX_CHARS][ISO_MAX_FINAL];
120 #define CODE_POINT_TO_INDEX(charset, code) \
121 ((charset)->code_linear_p \
122 ? (int) ((code) - (charset)->min_code) \
123 : (((charset)->code_space_mask[(code) >> 24] & 0x8) \
124 && ((charset)->code_space_mask[((code) >> 16) & 0xFF] & 0x4) \
125 && ((charset)->code_space_mask[((code) >> 8) & 0xFF] & 0x2) \
126 && ((charset)->code_space_mask[(code) & 0xFF] & 0x1)) \
127 ? (int) (((((code) >> 24) - (charset)->code_space[12]) \
128 * (charset)->code_space[11]) \
129 + (((((code) >> 16) & 0xFF) - (charset)->code_space[8]) \
130 * (charset)->code_space[7]) \
131 + (((((code) >> 8) & 0xFF) - (charset)->code_space[4]) \
132 * (charset)->code_space[3]) \
133 + (((code) & 0xFF) - (charset)->code_space[0]) \
134 - ((charset)->char_index_offset)) \
135 : -1)
138 /* Return the code-point for the character index IDX in CHARSET.
139 IDX should be an unsigned int variable in a valid range (which is
140 always in nonnegative int range too). IDX contains garbage afterwards. */
142 #define INDEX_TO_CODE_POINT(charset, idx) \
143 ((charset)->code_linear_p \
144 ? (idx) + (charset)->min_code \
145 : (idx += (charset)->char_index_offset, \
146 (((charset)->code_space[0] + (idx) % (charset)->code_space[2]) \
147 | (((charset)->code_space[4] \
148 + ((idx) / (charset)->code_space[3] % (charset)->code_space[6])) \
149 << 8) \
150 | (((charset)->code_space[8] \
151 + ((idx) / (charset)->code_space[7] % (charset)->code_space[10])) \
152 << 16) \
153 | (((charset)->code_space[12] + ((idx) / (charset)->code_space[11])) \
154 << 24))))
156 /* Structure to hold mapping tables for a charset. Used by temacs
157 invoked for dumping. */
159 static struct
161 /* The current charset for which the following tables are setup. */
162 struct charset *current;
164 /* 1 iff the following table is used for encoder. */
165 short for_encoder;
167 /* When the following table is used for encoding, minimum and
168 maximum character of the current charset. */
169 int min_char, max_char;
171 /* A Unicode character corresponding to the code index 0 (i.e. the
172 minimum code-point) of the current charset, or -1 if the code
173 index 0 is not a Unicode character. This is checked when
174 table.encoder[CHAR] is zero. */
175 int zero_index_char;
177 union {
178 /* Table mapping code-indices (not code-points) of the current
179 charset to Unicode characters. If decoder[CHAR] is -1, CHAR
180 doesn't belong to the current charset. */
181 int decoder[0x10000];
182 /* Table mapping Unicode characters to code-indices of the current
183 charset. The first 0x10000 elements are for BMP (0..0xFFFF),
184 and the last 0x10000 are for SMP (0x10000..0x1FFFF) or SIP
185 (0x20000..0x2FFFF). Note that there is no charset map that
186 uses both SMP and SIP. */
187 unsigned short encoder[0x20000];
188 } table;
189 } *temp_charset_work;
191 #define SET_TEMP_CHARSET_WORK_ENCODER(C, CODE) \
192 do { \
193 if ((CODE) == 0) \
194 temp_charset_work->zero_index_char = (C); \
195 else if ((C) < 0x20000) \
196 temp_charset_work->table.encoder[(C)] = (CODE); \
197 else \
198 temp_charset_work->table.encoder[(C) - 0x10000] = (CODE); \
199 } while (0)
201 #define GET_TEMP_CHARSET_WORK_ENCODER(C) \
202 ((C) == temp_charset_work->zero_index_char ? 0 \
203 : (C) < 0x20000 ? (temp_charset_work->table.encoder[(C)] \
204 ? (int) temp_charset_work->table.encoder[(C)] : -1) \
205 : temp_charset_work->table.encoder[(C) - 0x10000] \
206 ? temp_charset_work->table.encoder[(C) - 0x10000] : -1)
208 #define SET_TEMP_CHARSET_WORK_DECODER(C, CODE) \
209 (temp_charset_work->table.decoder[(CODE)] = (C))
211 #define GET_TEMP_CHARSET_WORK_DECODER(CODE) \
212 (temp_charset_work->table.decoder[(CODE)])
215 /* Set to 1 to warn that a charset map is loaded and thus a buffer
216 text and a string data may be relocated. */
217 bool charset_map_loaded;
219 struct charset_map_entries
221 struct {
222 unsigned from, to;
223 int c;
224 } entry[0x10000];
225 struct charset_map_entries *next;
228 /* Load the mapping information of CHARSET from ENTRIES for
229 initializing (CONTROL_FLAG == 0), decoding (CONTROL_FLAG == 1), and
230 encoding (CONTROL_FLAG == 2).
232 If CONTROL_FLAG is 0, setup CHARSET->min_char, CHARSET->max_char,
233 and CHARSET->fast_map.
235 If CONTROL_FLAG is 1, setup the following tables according to
236 CHARSET->method and inhibit_load_charset_map.
238 CHARSET->method | inhibit_lcm == 0 | inhibit_lcm == 1
239 ----------------------+--------------------+---------------------------
240 CHARSET_METHOD_MAP | CHARSET->decoder | temp_charset_work->decoder
241 ----------------------+--------------------+---------------------------
242 CHARSET_METHOD_OFFSET | Vchar_unify_table | temp_charset_work->decoder
244 If CONTROL_FLAG is 2, setup the following tables.
246 CHARSET->method | inhibit_lcm == 0 | inhibit_lcm == 1
247 ----------------------+--------------------+---------------------------
248 CHARSET_METHOD_MAP | CHARSET->encoder | temp_charset_work->encoder
249 ----------------------+--------------------+--------------------------
250 CHARSET_METHOD_OFFSET | CHARSET->deunifier | temp_charset_work->encoder
253 static void
254 load_charset_map (struct charset *charset, struct charset_map_entries *entries, int n_entries, int control_flag)
256 Lisp_Object vec IF_LINT (= Qnil), table IF_LINT (= Qnil);
257 unsigned max_code = CHARSET_MAX_CODE (charset);
258 bool ascii_compatible_p = charset->ascii_compatible_p;
259 int min_char, max_char, nonascii_min_char;
260 int i;
261 unsigned char *fast_map = charset->fast_map;
263 if (n_entries <= 0)
264 return;
266 if (control_flag)
268 if (! inhibit_load_charset_map)
270 if (control_flag == 1)
272 if (charset->method == CHARSET_METHOD_MAP)
274 int n = CODE_POINT_TO_INDEX (charset, max_code) + 1;
276 vec = Fmake_vector (make_number (n), make_number (-1));
277 set_charset_attr (charset, charset_decoder, vec);
279 else
281 char_table_set_range (Vchar_unify_table,
282 charset->min_char, charset->max_char,
283 Qnil);
286 else
288 table = Fmake_char_table (Qnil, Qnil);
289 set_charset_attr (charset,
290 (charset->method == CHARSET_METHOD_MAP
291 ? charset_encoder : charset_deunifier),
292 table);
295 else
297 if (! temp_charset_work)
298 temp_charset_work = xmalloc (sizeof *temp_charset_work);
299 if (control_flag == 1)
301 memset (temp_charset_work->table.decoder, -1,
302 sizeof (int) * 0x10000);
304 else
306 memset (temp_charset_work->table.encoder, 0,
307 sizeof (unsigned short) * 0x20000);
308 temp_charset_work->zero_index_char = -1;
310 temp_charset_work->current = charset;
311 temp_charset_work->for_encoder = (control_flag == 2);
312 control_flag += 2;
314 charset_map_loaded = 1;
317 min_char = max_char = entries->entry[0].c;
318 nonascii_min_char = MAX_CHAR;
319 for (i = 0; i < n_entries; i++)
321 unsigned from, to;
322 int from_index, to_index, lim_index;
323 int from_c, to_c;
324 int idx = i % 0x10000;
326 if (i > 0 && idx == 0)
327 entries = entries->next;
328 from = entries->entry[idx].from;
329 to = entries->entry[idx].to;
330 from_c = entries->entry[idx].c;
331 from_index = CODE_POINT_TO_INDEX (charset, from);
332 if (from == to)
334 to_index = from_index;
335 to_c = from_c;
337 else
339 to_index = CODE_POINT_TO_INDEX (charset, to);
340 to_c = from_c + (to_index - from_index);
342 if (from_index < 0 || to_index < 0)
343 continue;
344 lim_index = to_index + 1;
346 if (to_c > max_char)
347 max_char = to_c;
348 else if (from_c < min_char)
349 min_char = from_c;
351 if (control_flag == 1)
353 if (charset->method == CHARSET_METHOD_MAP)
354 for (; from_index < lim_index; from_index++, from_c++)
355 ASET (vec, from_index, make_number (from_c));
356 else
357 for (; from_index < lim_index; from_index++, from_c++)
358 CHAR_TABLE_SET (Vchar_unify_table,
359 CHARSET_CODE_OFFSET (charset) + from_index,
360 make_number (from_c));
362 else if (control_flag == 2)
364 if (charset->method == CHARSET_METHOD_MAP
365 && CHARSET_COMPACT_CODES_P (charset))
366 for (; from_index < lim_index; from_index++, from_c++)
368 unsigned code = from_index;
369 code = INDEX_TO_CODE_POINT (charset, code);
371 if (NILP (CHAR_TABLE_REF (table, from_c)))
372 CHAR_TABLE_SET (table, from_c, make_number (code));
374 else
375 for (; from_index < lim_index; from_index++, from_c++)
377 if (NILP (CHAR_TABLE_REF (table, from_c)))
378 CHAR_TABLE_SET (table, from_c, make_number (from_index));
381 else if (control_flag == 3)
382 for (; from_index < lim_index; from_index++, from_c++)
383 SET_TEMP_CHARSET_WORK_DECODER (from_c, from_index);
384 else if (control_flag == 4)
385 for (; from_index < lim_index; from_index++, from_c++)
386 SET_TEMP_CHARSET_WORK_ENCODER (from_c, from_index);
387 else /* control_flag == 0 */
389 if (ascii_compatible_p)
391 if (! ASCII_BYTE_P (from_c))
393 if (from_c < nonascii_min_char)
394 nonascii_min_char = from_c;
396 else if (! ASCII_BYTE_P (to_c))
398 nonascii_min_char = 0x80;
402 for (; from_c <= to_c; from_c++)
403 CHARSET_FAST_MAP_SET (from_c, fast_map);
407 if (control_flag == 0)
409 CHARSET_MIN_CHAR (charset) = (ascii_compatible_p
410 ? nonascii_min_char : min_char);
411 CHARSET_MAX_CHAR (charset) = max_char;
413 else if (control_flag == 4)
415 temp_charset_work->min_char = min_char;
416 temp_charset_work->max_char = max_char;
421 /* Read a hexadecimal number (preceded by "0x") from the file FP while
422 paying attention to comment character '#'. */
424 static unsigned
425 read_hex (FILE *fp, bool *eof, bool *overflow)
427 int c;
428 unsigned n;
430 while ((c = getc (fp)) != EOF)
432 if (c == '#')
434 while ((c = getc (fp)) != EOF && c != '\n');
436 else if (c == '0')
438 if ((c = getc (fp)) == EOF || c == 'x')
439 break;
442 if (c == EOF)
444 *eof = 1;
445 return 0;
447 n = 0;
448 while (c_isxdigit (c = getc (fp)))
450 if (UINT_MAX >> 4 < n)
451 *overflow = 1;
452 n = ((n << 4)
453 | (c - ('0' <= c && c <= '9' ? '0'
454 : 'A' <= c && c <= 'F' ? 'A' - 10
455 : 'a' - 10)));
457 if (c != EOF)
458 ungetc (c, fp);
459 return n;
462 /* Return a mapping vector for CHARSET loaded from MAPFILE.
463 Each line of MAPFILE has this form
464 0xAAAA 0xCCCC
465 where 0xAAAA is a code-point and 0xCCCC is the corresponding
466 character code, or this form
467 0xAAAA-0xBBBB 0xCCCC
468 where 0xAAAA and 0xBBBB are code-points specifying a range, and
469 0xCCCC is the first character code of the range.
471 The returned vector has this form:
472 [ CODE1 CHAR1 CODE2 CHAR2 .... ]
473 where CODE1 is a code-point or a cons of code-points specifying a
474 range.
476 Note that this function uses `openp' to open MAPFILE but ignores
477 `file-name-handler-alist' to avoid running any Lisp code. */
479 static void
480 load_charset_map_from_file (struct charset *charset, Lisp_Object mapfile, int control_flag)
482 unsigned min_code = CHARSET_MIN_CODE (charset);
483 unsigned max_code = CHARSET_MAX_CODE (charset);
484 int fd;
485 FILE *fp;
486 Lisp_Object suffixes;
487 struct charset_map_entries *head, *entries;
488 int n_entries;
489 ptrdiff_t count;
490 USE_SAFE_ALLOCA;
492 suffixes = Fcons (build_string (".map"),
493 Fcons (build_string (".TXT"), Qnil));
495 count = SPECPDL_INDEX ();
496 specbind (Qfile_name_handler_alist, Qnil);
497 fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil);
498 unbind_to (count, Qnil);
499 if (fd < 0
500 || ! (fp = fdopen (fd, "r")))
501 error ("Failure in loading charset map: %s", SDATA (mapfile));
503 /* Use SAFE_ALLOCA instead of alloca, as `charset_map_entries' is
504 large (larger than MAX_ALLOCA). */
505 head = SAFE_ALLOCA (sizeof *head);
506 entries = head;
507 memset (entries, 0, sizeof (struct charset_map_entries));
509 n_entries = 0;
510 while (1)
512 unsigned from, to, c;
513 int idx;
514 bool eof = 0, overflow = 0;
516 from = read_hex (fp, &eof, &overflow);
517 if (eof)
518 break;
519 if (getc (fp) == '-')
520 to = read_hex (fp, &eof, &overflow);
521 else
522 to = from;
523 if (eof)
524 break;
525 c = read_hex (fp, &eof, &overflow);
526 if (eof)
527 break;
529 if (overflow)
530 continue;
531 if (from < min_code || to > max_code || from > to || c > MAX_CHAR)
532 continue;
534 if (n_entries > 0 && (n_entries % 0x10000) == 0)
536 entries->next = SAFE_ALLOCA (sizeof *entries->next);
537 entries = entries->next;
538 memset (entries, 0, sizeof (struct charset_map_entries));
539 n_entries = 0;
541 idx = n_entries;
542 entries->entry[idx].from = from;
543 entries->entry[idx].to = to;
544 entries->entry[idx].c = c;
545 n_entries++;
547 fclose (fp);
549 load_charset_map (charset, head, n_entries, control_flag);
550 SAFE_FREE ();
553 static void
554 load_charset_map_from_vector (struct charset *charset, Lisp_Object vec, int control_flag)
556 unsigned min_code = CHARSET_MIN_CODE (charset);
557 unsigned max_code = CHARSET_MAX_CODE (charset);
558 struct charset_map_entries *head, *entries;
559 int n_entries;
560 int len = ASIZE (vec);
561 int i;
562 USE_SAFE_ALLOCA;
564 if (len % 2 == 1)
566 add_to_log ("Failure in loading charset map: %V", vec, Qnil);
567 return;
570 /* Use SAFE_ALLOCA instead of alloca, as `charset_map_entries' is
571 large (larger than MAX_ALLOCA). */
572 head = SAFE_ALLOCA (sizeof *head);
573 entries = head;
574 memset (entries, 0, sizeof (struct charset_map_entries));
576 n_entries = 0;
577 for (i = 0; i < len; i += 2)
579 Lisp_Object val, val2;
580 unsigned from, to;
581 EMACS_INT c;
582 int idx;
584 val = AREF (vec, i);
585 if (CONSP (val))
587 val2 = XCDR (val);
588 val = XCAR (val);
589 from = XFASTINT (val);
590 to = XFASTINT (val2);
592 else
593 from = to = XFASTINT (val);
594 val = AREF (vec, i + 1);
595 CHECK_NATNUM (val);
596 c = XFASTINT (val);
598 if (from < min_code || to > max_code || from > to || c > MAX_CHAR)
599 continue;
601 if (n_entries > 0 && (n_entries % 0x10000) == 0)
603 entries->next = SAFE_ALLOCA (sizeof *entries->next);
604 entries = entries->next;
605 memset (entries, 0, sizeof (struct charset_map_entries));
607 idx = n_entries % 0x10000;
608 entries->entry[idx].from = from;
609 entries->entry[idx].to = to;
610 entries->entry[idx].c = c;
611 n_entries++;
614 load_charset_map (charset, head, n_entries, control_flag);
615 SAFE_FREE ();
619 /* Load a mapping table for CHARSET. CONTROL-FLAG tells what kind of
620 map it is (see the comment of load_charset_map for the detail). */
622 static void
623 load_charset (struct charset *charset, int control_flag)
625 Lisp_Object map;
627 if (inhibit_load_charset_map
628 && temp_charset_work
629 && charset == temp_charset_work->current
630 && ((control_flag == 2) == temp_charset_work->for_encoder))
631 return;
633 if (CHARSET_METHOD (charset) == CHARSET_METHOD_MAP)
634 map = CHARSET_MAP (charset);
635 else
637 if (! CHARSET_UNIFIED_P (charset))
638 emacs_abort ();
639 map = CHARSET_UNIFY_MAP (charset);
641 if (STRINGP (map))
642 load_charset_map_from_file (charset, map, control_flag);
643 else
644 load_charset_map_from_vector (charset, map, control_flag);
648 DEFUN ("charsetp", Fcharsetp, Scharsetp, 1, 1, 0,
649 doc: /* Return non-nil if and only if OBJECT is a charset.*/)
650 (Lisp_Object object)
652 return (CHARSETP (object) ? Qt : Qnil);
656 static void
657 map_charset_for_dump (void (*c_function) (Lisp_Object, Lisp_Object),
658 Lisp_Object function, Lisp_Object arg,
659 unsigned int from, unsigned int to)
661 int from_idx = CODE_POINT_TO_INDEX (temp_charset_work->current, from);
662 int to_idx = CODE_POINT_TO_INDEX (temp_charset_work->current, to);
663 Lisp_Object range;
664 int c, stop;
665 struct gcpro gcpro1;
667 range = Fcons (Qnil, Qnil);
668 GCPRO1 (range);
670 c = temp_charset_work->min_char;
671 stop = (temp_charset_work->max_char < 0x20000
672 ? temp_charset_work->max_char : 0xFFFF);
674 while (1)
676 int idx = GET_TEMP_CHARSET_WORK_ENCODER (c);
678 if (idx >= from_idx && idx <= to_idx)
680 if (NILP (XCAR (range)))
681 XSETCAR (range, make_number (c));
683 else if (! NILP (XCAR (range)))
685 XSETCDR (range, make_number (c - 1));
686 if (c_function)
687 (*c_function) (arg, range);
688 else
689 call2 (function, range, arg);
690 XSETCAR (range, Qnil);
692 if (c == stop)
694 if (c == temp_charset_work->max_char)
696 if (! NILP (XCAR (range)))
698 XSETCDR (range, make_number (c));
699 if (c_function)
700 (*c_function) (arg, range);
701 else
702 call2 (function, range, arg);
704 break;
706 c = 0x1FFFF;
707 stop = temp_charset_work->max_char;
709 c++;
711 UNGCPRO;
714 void
715 map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object function,
716 Lisp_Object arg, struct charset *charset, unsigned from, unsigned to)
718 Lisp_Object range;
719 bool partial = (from > CHARSET_MIN_CODE (charset)
720 || to < CHARSET_MAX_CODE (charset));
722 if (CHARSET_METHOD (charset) == CHARSET_METHOD_OFFSET)
724 int from_idx = CODE_POINT_TO_INDEX (charset, from);
725 int to_idx = CODE_POINT_TO_INDEX (charset, to);
726 int from_c = from_idx + CHARSET_CODE_OFFSET (charset);
727 int to_c = to_idx + CHARSET_CODE_OFFSET (charset);
729 if (CHARSET_UNIFIED_P (charset))
731 if (! CHAR_TABLE_P (CHARSET_DEUNIFIER (charset)))
732 load_charset (charset, 2);
733 if (CHAR_TABLE_P (CHARSET_DEUNIFIER (charset)))
734 map_char_table_for_charset (c_function, function,
735 CHARSET_DEUNIFIER (charset), arg,
736 partial ? charset : NULL, from, to);
737 else
738 map_charset_for_dump (c_function, function, arg, from, to);
741 range = Fcons (make_number (from_c), make_number (to_c));
742 if (NILP (function))
743 (*c_function) (arg, range);
744 else
745 call2 (function, range, arg);
747 else if (CHARSET_METHOD (charset) == CHARSET_METHOD_MAP)
749 if (! CHAR_TABLE_P (CHARSET_ENCODER (charset)))
750 load_charset (charset, 2);
751 if (CHAR_TABLE_P (CHARSET_ENCODER (charset)))
752 map_char_table_for_charset (c_function, function,
753 CHARSET_ENCODER (charset), arg,
754 partial ? charset : NULL, from, to);
755 else
756 map_charset_for_dump (c_function, function, arg, from, to);
758 else if (CHARSET_METHOD (charset) == CHARSET_METHOD_SUBSET)
760 Lisp_Object subset_info;
761 int offset;
763 subset_info = CHARSET_SUBSET (charset);
764 charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
765 offset = XINT (AREF (subset_info, 3));
766 from -= offset;
767 if (from < XFASTINT (AREF (subset_info, 1)))
768 from = XFASTINT (AREF (subset_info, 1));
769 to -= offset;
770 if (to > XFASTINT (AREF (subset_info, 2)))
771 to = XFASTINT (AREF (subset_info, 2));
772 map_charset_chars (c_function, function, arg, charset, from, to);
774 else /* i.e. CHARSET_METHOD_SUPERSET */
776 Lisp_Object parents;
778 for (parents = CHARSET_SUPERSET (charset); CONSP (parents);
779 parents = XCDR (parents))
781 int offset;
782 unsigned this_from, this_to;
784 charset = CHARSET_FROM_ID (XFASTINT (XCAR (XCAR (parents))));
785 offset = XINT (XCDR (XCAR (parents)));
786 this_from = from > offset ? from - offset : 0;
787 this_to = to > offset ? to - offset : 0;
788 if (this_from < CHARSET_MIN_CODE (charset))
789 this_from = CHARSET_MIN_CODE (charset);
790 if (this_to > CHARSET_MAX_CODE (charset))
791 this_to = CHARSET_MAX_CODE (charset);
792 map_charset_chars (c_function, function, arg, charset,
793 this_from, this_to);
798 DEFUN ("map-charset-chars", Fmap_charset_chars, Smap_charset_chars, 2, 5, 0,
799 doc: /* Call FUNCTION for all characters in CHARSET.
800 FUNCTION is called with an argument RANGE and the optional 3rd
801 argument ARG.
803 RANGE is a cons (FROM . TO), where FROM and TO indicate a range of
804 characters contained in CHARSET.
806 The optional 4th and 5th arguments FROM-CODE and TO-CODE specify the
807 range of code points (in CHARSET) of target characters. */)
808 (Lisp_Object function, Lisp_Object charset, Lisp_Object arg, Lisp_Object from_code, Lisp_Object to_code)
810 struct charset *cs;
811 unsigned from, to;
813 CHECK_CHARSET_GET_CHARSET (charset, cs);
814 if (NILP (from_code))
815 from = CHARSET_MIN_CODE (cs);
816 else
818 from = XINT (from_code);
819 if (from < CHARSET_MIN_CODE (cs))
820 from = CHARSET_MIN_CODE (cs);
822 if (NILP (to_code))
823 to = CHARSET_MAX_CODE (cs);
824 else
826 to = XINT (to_code);
827 if (to > CHARSET_MAX_CODE (cs))
828 to = CHARSET_MAX_CODE (cs);
830 map_charset_chars (NULL, function, arg, cs, from, to);
831 return Qnil;
835 /* Define a charset according to the arguments. The Nth argument is
836 the Nth attribute of the charset (the last attribute `charset-id'
837 is not included). See the docstring of `define-charset' for the
838 detail. */
840 DEFUN ("define-charset-internal", Fdefine_charset_internal,
841 Sdefine_charset_internal, charset_arg_max, MANY, 0,
842 doc: /* For internal use only.
843 usage: (define-charset-internal ...) */)
844 (ptrdiff_t nargs, Lisp_Object *args)
846 /* Charset attr vector. */
847 Lisp_Object attrs;
848 Lisp_Object val;
849 EMACS_UINT hash_code;
850 struct Lisp_Hash_Table *hash_table = XHASH_TABLE (Vcharset_hash_table);
851 int i, j;
852 struct charset charset;
853 int id;
854 int dimension;
855 bool new_definition_p;
856 int nchars;
858 if (nargs != charset_arg_max)
859 return Fsignal (Qwrong_number_of_arguments,
860 Fcons (intern ("define-charset-internal"),
861 make_number (nargs)));
863 attrs = Fmake_vector (make_number (charset_attr_max), Qnil);
865 CHECK_SYMBOL (args[charset_arg_name]);
866 ASET (attrs, charset_name, args[charset_arg_name]);
868 val = args[charset_arg_code_space];
869 for (i = 0, dimension = 0, nchars = 1; ; i++)
871 Lisp_Object min_byte_obj, max_byte_obj;
872 int min_byte, max_byte;
874 min_byte_obj = Faref (val, make_number (i * 2));
875 max_byte_obj = Faref (val, make_number (i * 2 + 1));
876 CHECK_RANGED_INTEGER (min_byte_obj, 0, 255);
877 min_byte = XINT (min_byte_obj);
878 CHECK_RANGED_INTEGER (max_byte_obj, min_byte, 255);
879 max_byte = XINT (max_byte_obj);
880 charset.code_space[i * 4] = min_byte;
881 charset.code_space[i * 4 + 1] = max_byte;
882 charset.code_space[i * 4 + 2] = max_byte - min_byte + 1;
883 if (max_byte > 0)
884 dimension = i + 1;
885 if (i == 3)
886 break;
887 nchars *= charset.code_space[i * 4 + 2];
888 charset.code_space[i * 4 + 3] = nchars;
891 val = args[charset_arg_dimension];
892 if (NILP (val))
893 charset.dimension = dimension;
894 else
896 CHECK_RANGED_INTEGER (val, 1, 4);
897 charset.dimension = XINT (val);
900 charset.code_linear_p
901 = (charset.dimension == 1
902 || (charset.code_space[2] == 256
903 && (charset.dimension == 2
904 || (charset.code_space[6] == 256
905 && (charset.dimension == 3
906 || charset.code_space[10] == 256)))));
908 if (! charset.code_linear_p)
910 charset.code_space_mask = xzalloc (256);
911 for (i = 0; i < 4; i++)
912 for (j = charset.code_space[i * 4]; j <= charset.code_space[i * 4 + 1];
913 j++)
914 charset.code_space_mask[j] |= (1 << i);
917 charset.iso_chars_96 = charset.code_space[2] == 96;
919 charset.min_code = (charset.code_space[0]
920 | (charset.code_space[4] << 8)
921 | (charset.code_space[8] << 16)
922 | ((unsigned) charset.code_space[12] << 24));
923 charset.max_code = (charset.code_space[1]
924 | (charset.code_space[5] << 8)
925 | (charset.code_space[9] << 16)
926 | ((unsigned) charset.code_space[13] << 24));
927 charset.char_index_offset = 0;
929 val = args[charset_arg_min_code];
930 if (! NILP (val))
932 unsigned code = cons_to_unsigned (val, UINT_MAX);
934 if (code < charset.min_code
935 || code > charset.max_code)
936 args_out_of_range_3 (make_fixnum_or_float (charset.min_code),
937 make_fixnum_or_float (charset.max_code), val);
938 charset.char_index_offset = CODE_POINT_TO_INDEX (&charset, code);
939 charset.min_code = code;
942 val = args[charset_arg_max_code];
943 if (! NILP (val))
945 unsigned code = cons_to_unsigned (val, UINT_MAX);
947 if (code < charset.min_code
948 || code > charset.max_code)
949 args_out_of_range_3 (make_fixnum_or_float (charset.min_code),
950 make_fixnum_or_float (charset.max_code), val);
951 charset.max_code = code;
954 charset.compact_codes_p = charset.max_code < 0x10000;
956 val = args[charset_arg_invalid_code];
957 if (NILP (val))
959 if (charset.min_code > 0)
960 charset.invalid_code = 0;
961 else
963 if (charset.max_code < UINT_MAX)
964 charset.invalid_code = charset.max_code + 1;
965 else
966 error ("Attribute :invalid-code must be specified");
969 else
970 charset.invalid_code = cons_to_unsigned (val, UINT_MAX);
972 val = args[charset_arg_iso_final];
973 if (NILP (val))
974 charset.iso_final = -1;
975 else
977 CHECK_NUMBER (val);
978 if (XINT (val) < '0' || XINT (val) > 127)
979 error ("Invalid iso-final-char: %"pI"d", XINT (val));
980 charset.iso_final = XINT (val);
983 val = args[charset_arg_iso_revision];
984 if (NILP (val))
985 charset.iso_revision = -1;
986 else
988 CHECK_RANGED_INTEGER (val, -1, 63);
989 charset.iso_revision = XINT (val);
992 val = args[charset_arg_emacs_mule_id];
993 if (NILP (val))
994 charset.emacs_mule_id = -1;
995 else
997 CHECK_NATNUM (val);
998 if ((XINT (val) > 0 && XINT (val) <= 128) || XINT (val) >= 256)
999 error ("Invalid emacs-mule-id: %"pI"d", XINT (val));
1000 charset.emacs_mule_id = XINT (val);
1003 charset.ascii_compatible_p = ! NILP (args[charset_arg_ascii_compatible_p]);
1005 charset.supplementary_p = ! NILP (args[charset_arg_supplementary_p]);
1007 charset.unified_p = 0;
1009 memset (charset.fast_map, 0, sizeof (charset.fast_map));
1011 if (! NILP (args[charset_arg_code_offset]))
1013 val = args[charset_arg_code_offset];
1014 CHECK_CHARACTER (val);
1016 charset.method = CHARSET_METHOD_OFFSET;
1017 charset.code_offset = XINT (val);
1019 i = CODE_POINT_TO_INDEX (&charset, charset.max_code);
1020 if (MAX_CHAR - charset.code_offset < i)
1021 error ("Unsupported max char: %d", charset.max_char);
1022 charset.max_char = i + charset.code_offset;
1023 i = CODE_POINT_TO_INDEX (&charset, charset.min_code);
1024 charset.min_char = i + charset.code_offset;
1026 i = (charset.min_char >> 7) << 7;
1027 for (; i < 0x10000 && i <= charset.max_char; i += 128)
1028 CHARSET_FAST_MAP_SET (i, charset.fast_map);
1029 i = (i >> 12) << 12;
1030 for (; i <= charset.max_char; i += 0x1000)
1031 CHARSET_FAST_MAP_SET (i, charset.fast_map);
1032 if (charset.code_offset == 0 && charset.max_char >= 0x80)
1033 charset.ascii_compatible_p = 1;
1035 else if (! NILP (args[charset_arg_map]))
1037 val = args[charset_arg_map];
1038 ASET (attrs, charset_map, val);
1039 charset.method = CHARSET_METHOD_MAP;
1041 else if (! NILP (args[charset_arg_subset]))
1043 Lisp_Object parent;
1044 Lisp_Object parent_min_code, parent_max_code, parent_code_offset;
1045 struct charset *parent_charset;
1047 val = args[charset_arg_subset];
1048 parent = Fcar (val);
1049 CHECK_CHARSET_GET_CHARSET (parent, parent_charset);
1050 parent_min_code = Fnth (make_number (1), val);
1051 CHECK_NATNUM (parent_min_code);
1052 parent_max_code = Fnth (make_number (2), val);
1053 CHECK_NATNUM (parent_max_code);
1054 parent_code_offset = Fnth (make_number (3), val);
1055 CHECK_NUMBER (parent_code_offset);
1056 val = Fmake_vector (make_number (4), Qnil);
1057 ASET (val, 0, make_number (parent_charset->id));
1058 ASET (val, 1, parent_min_code);
1059 ASET (val, 2, parent_max_code);
1060 ASET (val, 3, parent_code_offset);
1061 ASET (attrs, charset_subset, val);
1063 charset.method = CHARSET_METHOD_SUBSET;
1064 /* Here, we just copy the parent's fast_map. It's not accurate,
1065 but at least it works for quickly detecting which character
1066 DOESN'T belong to this charset. */
1067 for (i = 0; i < 190; i++)
1068 charset.fast_map[i] = parent_charset->fast_map[i];
1070 /* We also copy these for parents. */
1071 charset.min_char = parent_charset->min_char;
1072 charset.max_char = parent_charset->max_char;
1074 else if (! NILP (args[charset_arg_superset]))
1076 val = args[charset_arg_superset];
1077 charset.method = CHARSET_METHOD_SUPERSET;
1078 val = Fcopy_sequence (val);
1079 ASET (attrs, charset_superset, val);
1081 charset.min_char = MAX_CHAR;
1082 charset.max_char = 0;
1083 for (; ! NILP (val); val = Fcdr (val))
1085 Lisp_Object elt, car_part, cdr_part;
1086 int this_id, offset;
1087 struct charset *this_charset;
1089 elt = Fcar (val);
1090 if (CONSP (elt))
1092 car_part = XCAR (elt);
1093 cdr_part = XCDR (elt);
1094 CHECK_CHARSET_GET_ID (car_part, this_id);
1095 CHECK_TYPE_RANGED_INTEGER (int, cdr_part);
1096 offset = XINT (cdr_part);
1098 else
1100 CHECK_CHARSET_GET_ID (elt, this_id);
1101 offset = 0;
1103 XSETCAR (val, Fcons (make_number (this_id), make_number (offset)));
1105 this_charset = CHARSET_FROM_ID (this_id);
1106 if (charset.min_char > this_charset->min_char)
1107 charset.min_char = this_charset->min_char;
1108 if (charset.max_char < this_charset->max_char)
1109 charset.max_char = this_charset->max_char;
1110 for (i = 0; i < 190; i++)
1111 charset.fast_map[i] |= this_charset->fast_map[i];
1114 else
1115 error ("None of :code-offset, :map, :parents are specified");
1117 val = args[charset_arg_unify_map];
1118 if (! NILP (val) && !STRINGP (val))
1119 CHECK_VECTOR (val);
1120 ASET (attrs, charset_unify_map, val);
1122 CHECK_LIST (args[charset_arg_plist]);
1123 ASET (attrs, charset_plist, args[charset_arg_plist]);
1125 charset.hash_index = hash_lookup (hash_table, args[charset_arg_name],
1126 &hash_code);
1127 if (charset.hash_index >= 0)
1129 new_definition_p = 0;
1130 id = XFASTINT (CHARSET_SYMBOL_ID (args[charset_arg_name]));
1131 set_hash_value_slot (hash_table, charset.hash_index, attrs);
1133 else
1135 charset.hash_index = hash_put (hash_table, args[charset_arg_name], attrs,
1136 hash_code);
1137 if (charset_table_used == charset_table_size)
1139 /* Ensure that charset IDs fit into 'int' as well as into the
1140 restriction imposed by fixnums. Although the 'int' restriction
1141 could be removed, too much other code would need altering; for
1142 example, the IDs are stuffed into struct
1143 coding_system.charbuf[i] entries, which are 'int'. */
1144 int old_size = charset_table_size;
1145 struct charset *new_table =
1146 xpalloc (0, &charset_table_size, 1,
1147 min (INT_MAX, MOST_POSITIVE_FIXNUM),
1148 sizeof *charset_table);
1149 memcpy (new_table, charset_table, old_size * sizeof *new_table);
1150 charset_table = new_table;
1151 /* FIXME: This leaks memory, as the old charset_table becomes
1152 unreachable. If the old charset table is charset_table_init
1153 then this leak is intentional; otherwise, it's unclear.
1154 If the latter memory leak is intentional, a
1155 comment should be added to explain this. If not, the old
1156 charset_table should be freed, by passing it as the 1st argument
1157 to xpalloc and removing the memcpy. */
1159 id = charset_table_used++;
1160 new_definition_p = 1;
1163 ASET (attrs, charset_id, make_number (id));
1164 charset.id = id;
1165 charset_table[id] = charset;
1167 if (charset.method == CHARSET_METHOD_MAP)
1169 load_charset (&charset, 0);
1170 charset_table[id] = charset;
1173 if (charset.iso_final >= 0)
1175 ISO_CHARSET_TABLE (charset.dimension, charset.iso_chars_96,
1176 charset.iso_final) = id;
1177 if (new_definition_p)
1178 Viso_2022_charset_list = nconc2 (Viso_2022_charset_list,
1179 Fcons (make_number (id), Qnil));
1180 if (ISO_CHARSET_TABLE (1, 0, 'J') == id)
1181 charset_jisx0201_roman = id;
1182 else if (ISO_CHARSET_TABLE (2, 0, '@') == id)
1183 charset_jisx0208_1978 = id;
1184 else if (ISO_CHARSET_TABLE (2, 0, 'B') == id)
1185 charset_jisx0208 = id;
1186 else if (ISO_CHARSET_TABLE (2, 0, 'C') == id)
1187 charset_ksc5601 = id;
1190 if (charset.emacs_mule_id >= 0)
1192 emacs_mule_charset[charset.emacs_mule_id] = id;
1193 if (charset.emacs_mule_id < 0xA0)
1194 emacs_mule_bytes[charset.emacs_mule_id] = charset.dimension + 1;
1195 else
1196 emacs_mule_bytes[charset.emacs_mule_id] = charset.dimension + 2;
1197 if (new_definition_p)
1198 Vemacs_mule_charset_list = nconc2 (Vemacs_mule_charset_list,
1199 Fcons (make_number (id), Qnil));
1202 if (new_definition_p)
1204 Vcharset_list = Fcons (args[charset_arg_name], Vcharset_list);
1205 if (charset.supplementary_p)
1206 Vcharset_ordered_list = nconc2 (Vcharset_ordered_list,
1207 Fcons (make_number (id), Qnil));
1208 else
1210 Lisp_Object tail;
1212 for (tail = Vcharset_ordered_list; CONSP (tail); tail = XCDR (tail))
1214 struct charset *cs = CHARSET_FROM_ID (XINT (XCAR (tail)));
1216 if (cs->supplementary_p)
1217 break;
1219 if (EQ (tail, Vcharset_ordered_list))
1220 Vcharset_ordered_list = Fcons (make_number (id),
1221 Vcharset_ordered_list);
1222 else if (NILP (tail))
1223 Vcharset_ordered_list = nconc2 (Vcharset_ordered_list,
1224 Fcons (make_number (id), Qnil));
1225 else
1227 val = Fcons (XCAR (tail), XCDR (tail));
1228 XSETCDR (tail, val);
1229 XSETCAR (tail, make_number (id));
1232 charset_ordered_list_tick++;
1235 return Qnil;
1239 /* Same as Fdefine_charset_internal but arguments are more convenient
1240 to call from C (typically in syms_of_charset). This can define a
1241 charset of `offset' method only. Return the ID of the new
1242 charset. */
1244 static int
1245 define_charset_internal (Lisp_Object name,
1246 int dimension,
1247 const char *code_space_chars,
1248 unsigned min_code, unsigned max_code,
1249 int iso_final, int iso_revision, int emacs_mule_id,
1250 bool ascii_compatible, bool supplementary,
1251 int code_offset)
1253 const unsigned char *code_space = (const unsigned char *) code_space_chars;
1254 Lisp_Object args[charset_arg_max];
1255 Lisp_Object val;
1256 int i;
1258 args[charset_arg_name] = name;
1259 args[charset_arg_dimension] = make_number (dimension);
1260 val = Fmake_vector (make_number (8), make_number (0));
1261 for (i = 0; i < 8; i++)
1262 ASET (val, i, make_number (code_space[i]));
1263 args[charset_arg_code_space] = val;
1264 args[charset_arg_min_code] = make_number (min_code);
1265 args[charset_arg_max_code] = make_number (max_code);
1266 args[charset_arg_iso_final]
1267 = (iso_final < 0 ? Qnil : make_number (iso_final));
1268 args[charset_arg_iso_revision] = make_number (iso_revision);
1269 args[charset_arg_emacs_mule_id]
1270 = (emacs_mule_id < 0 ? Qnil : make_number (emacs_mule_id));
1271 args[charset_arg_ascii_compatible_p] = ascii_compatible ? Qt : Qnil;
1272 args[charset_arg_supplementary_p] = supplementary ? Qt : Qnil;
1273 args[charset_arg_invalid_code] = Qnil;
1274 args[charset_arg_code_offset] = make_number (code_offset);
1275 args[charset_arg_map] = Qnil;
1276 args[charset_arg_subset] = Qnil;
1277 args[charset_arg_superset] = Qnil;
1278 args[charset_arg_unify_map] = Qnil;
1280 args[charset_arg_plist] =
1281 listn (CONSTYPE_HEAP, 14,
1282 intern_c_string (":name"),
1283 args[charset_arg_name],
1284 intern_c_string (":dimension"),
1285 args[charset_arg_dimension],
1286 intern_c_string (":code-space"),
1287 args[charset_arg_code_space],
1288 intern_c_string (":iso-final-char"),
1289 args[charset_arg_iso_final],
1290 intern_c_string (":emacs-mule-id"),
1291 args[charset_arg_emacs_mule_id],
1292 intern_c_string (":ascii-compatible-p"),
1293 args[charset_arg_ascii_compatible_p],
1294 intern_c_string (":code-offset"),
1295 args[charset_arg_code_offset]);
1296 Fdefine_charset_internal (charset_arg_max, args);
1298 return XINT (CHARSET_SYMBOL_ID (name));
1302 DEFUN ("define-charset-alias", Fdefine_charset_alias,
1303 Sdefine_charset_alias, 2, 2, 0,
1304 doc: /* Define ALIAS as an alias for charset CHARSET. */)
1305 (Lisp_Object alias, Lisp_Object charset)
1307 Lisp_Object attr;
1309 CHECK_CHARSET_GET_ATTR (charset, attr);
1310 Fputhash (alias, attr, Vcharset_hash_table);
1311 Vcharset_list = Fcons (alias, Vcharset_list);
1312 return Qnil;
1316 DEFUN ("charset-plist", Fcharset_plist, Scharset_plist, 1, 1, 0,
1317 doc: /* Return the property list of CHARSET. */)
1318 (Lisp_Object charset)
1320 Lisp_Object attrs;
1322 CHECK_CHARSET_GET_ATTR (charset, attrs);
1323 return CHARSET_ATTR_PLIST (attrs);
1327 DEFUN ("set-charset-plist", Fset_charset_plist, Sset_charset_plist, 2, 2, 0,
1328 doc: /* Set CHARSET's property list to PLIST. */)
1329 (Lisp_Object charset, Lisp_Object plist)
1331 Lisp_Object attrs;
1333 CHECK_CHARSET_GET_ATTR (charset, attrs);
1334 ASET (attrs, charset_plist, plist);
1335 return plist;
1339 DEFUN ("unify-charset", Funify_charset, Sunify_charset, 1, 3, 0,
1340 doc: /* Unify characters of CHARSET with Unicode.
1341 This means reading the relevant file and installing the table defined
1342 by CHARSET's `:unify-map' property.
1344 Optional second arg UNIFY-MAP is a file name string or a vector. It has
1345 the same meaning as the `:unify-map' attribute in the function
1346 `define-charset' (which see).
1348 Optional third argument DEUNIFY, if non-nil, means to de-unify CHARSET. */)
1349 (Lisp_Object charset, Lisp_Object unify_map, Lisp_Object deunify)
1351 int id;
1352 struct charset *cs;
1354 CHECK_CHARSET_GET_ID (charset, id);
1355 cs = CHARSET_FROM_ID (id);
1356 if (NILP (deunify)
1357 ? CHARSET_UNIFIED_P (cs) && ! NILP (CHARSET_DEUNIFIER (cs))
1358 : ! CHARSET_UNIFIED_P (cs))
1359 return Qnil;
1361 CHARSET_UNIFIED_P (cs) = 0;
1362 if (NILP (deunify))
1364 if (CHARSET_METHOD (cs) != CHARSET_METHOD_OFFSET
1365 || CHARSET_CODE_OFFSET (cs) < 0x110000)
1366 error ("Can't unify charset: %s", SDATA (SYMBOL_NAME (charset)));
1367 if (NILP (unify_map))
1368 unify_map = CHARSET_UNIFY_MAP (cs);
1369 else
1371 if (! STRINGP (unify_map) && ! VECTORP (unify_map))
1372 signal_error ("Bad unify-map", unify_map);
1373 set_charset_attr (cs, charset_unify_map, unify_map);
1375 if (NILP (Vchar_unify_table))
1376 Vchar_unify_table = Fmake_char_table (Qnil, Qnil);
1377 char_table_set_range (Vchar_unify_table,
1378 cs->min_char, cs->max_char, charset);
1379 CHARSET_UNIFIED_P (cs) = 1;
1381 else if (CHAR_TABLE_P (Vchar_unify_table))
1383 unsigned min_code = CHARSET_MIN_CODE (cs);
1384 unsigned max_code = CHARSET_MAX_CODE (cs);
1385 int min_char = DECODE_CHAR (cs, min_code);
1386 int max_char = DECODE_CHAR (cs, max_code);
1388 char_table_set_range (Vchar_unify_table, min_char, max_char, Qnil);
1391 return Qnil;
1394 DEFUN ("get-unused-iso-final-char", Fget_unused_iso_final_char,
1395 Sget_unused_iso_final_char, 2, 2, 0,
1396 doc: /*
1397 Return an unused ISO final char for a charset of DIMENSION and CHARS.
1398 DIMENSION is the number of bytes to represent a character: 1 or 2.
1399 CHARS is the number of characters in a dimension: 94 or 96.
1401 This final char is for private use, thus the range is `0' (48) .. `?' (63).
1402 If there's no unused final char for the specified kind of charset,
1403 return nil. */)
1404 (Lisp_Object dimension, Lisp_Object chars)
1406 int final_char;
1408 CHECK_NUMBER (dimension);
1409 CHECK_NUMBER (chars);
1410 if (XINT (dimension) != 1 && XINT (dimension) != 2 && XINT (dimension) != 3)
1411 args_out_of_range_3 (dimension, make_number (1), make_number (3));
1412 if (XINT (chars) != 94 && XINT (chars) != 96)
1413 args_out_of_range_3 (chars, make_number (94), make_number (96));
1414 for (final_char = '0'; final_char <= '?'; final_char++)
1415 if (ISO_CHARSET_TABLE (XINT (dimension), XINT (chars), final_char) < 0)
1416 break;
1417 return (final_char <= '?' ? make_number (final_char) : Qnil);
1420 static void
1421 check_iso_charset_parameter (Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char)
1423 CHECK_NATNUM (dimension);
1424 CHECK_NATNUM (chars);
1425 CHECK_CHARACTER (final_char);
1427 if (XINT (dimension) > 3)
1428 error ("Invalid DIMENSION %"pI"d, it should be 1, 2, or 3",
1429 XINT (dimension));
1430 if (XINT (chars) != 94 && XINT (chars) != 96)
1431 error ("Invalid CHARS %"pI"d, it should be 94 or 96", XINT (chars));
1432 if (XINT (final_char) < '0' || XINT (final_char) > '~')
1433 error ("Invalid FINAL-CHAR %c, it should be `0'..`~'",
1434 (int)XINT (final_char));
1438 DEFUN ("declare-equiv-charset", Fdeclare_equiv_charset, Sdeclare_equiv_charset,
1439 4, 4, 0,
1440 doc: /* Declare an equivalent charset for ISO-2022 decoding.
1442 On decoding by an ISO-2022 base coding system, when a charset
1443 specified by DIMENSION, CHARS, and FINAL-CHAR is designated, behave as
1444 if CHARSET is designated instead. */)
1445 (Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char, Lisp_Object charset)
1447 int id;
1448 bool chars_flag;
1450 CHECK_CHARSET_GET_ID (charset, id);
1451 check_iso_charset_parameter (dimension, chars, final_char);
1452 chars_flag = XINT (chars) == 96;
1453 ISO_CHARSET_TABLE (XINT (dimension), chars_flag, XINT (final_char)) = id;
1454 return Qnil;
1458 /* Return information about charsets in the text at PTR of NBYTES
1459 bytes, which are NCHARS characters. The value is:
1461 0: Each character is represented by one byte. This is always
1462 true for a unibyte string. For a multibyte string, true if
1463 it contains only ASCII characters.
1465 1: No charsets other than ascii, control-1, and latin-1 are
1466 found.
1468 2: Otherwise.
1472 string_xstring_p (Lisp_Object string)
1474 const unsigned char *p = SDATA (string);
1475 const unsigned char *endp = p + SBYTES (string);
1477 if (SCHARS (string) == SBYTES (string))
1478 return 0;
1480 while (p < endp)
1482 int c = STRING_CHAR_ADVANCE (p);
1484 if (c >= 0x100)
1485 return 2;
1487 return 1;
1491 /* Find charsets in the string at PTR of NCHARS and NBYTES.
1493 CHARSETS is a vector. If Nth element is non-nil, it means the
1494 charset whose id is N is already found.
1496 It may lookup a translation table TABLE if supplied. */
1498 static void
1499 find_charsets_in_text (const unsigned char *ptr, ptrdiff_t nchars,
1500 ptrdiff_t nbytes, Lisp_Object charsets,
1501 Lisp_Object table, bool multibyte)
1503 const unsigned char *pend = ptr + nbytes;
1505 if (nchars == nbytes)
1507 if (multibyte)
1508 ASET (charsets, charset_ascii, Qt);
1509 else
1510 while (ptr < pend)
1512 int c = *ptr++;
1514 if (!NILP (table))
1515 c = translate_char (table, c);
1516 if (ASCII_BYTE_P (c))
1517 ASET (charsets, charset_ascii, Qt);
1518 else
1519 ASET (charsets, charset_eight_bit, Qt);
1522 else
1524 while (ptr < pend)
1526 int c = STRING_CHAR_ADVANCE (ptr);
1527 struct charset *charset;
1529 if (!NILP (table))
1530 c = translate_char (table, c);
1531 charset = CHAR_CHARSET (c);
1532 ASET (charsets, CHARSET_ID (charset), Qt);
1537 DEFUN ("find-charset-region", Ffind_charset_region, Sfind_charset_region,
1538 2, 3, 0,
1539 doc: /* Return a list of charsets in the region between BEG and END.
1540 BEG and END are buffer positions.
1541 Optional arg TABLE if non-nil is a translation table to look up.
1543 If the current buffer is unibyte, the returned list may contain
1544 only `ascii', `eight-bit-control', and `eight-bit-graphic'. */)
1545 (Lisp_Object beg, Lisp_Object end, Lisp_Object table)
1547 Lisp_Object charsets;
1548 ptrdiff_t from, from_byte, to, stop, stop_byte;
1549 int i;
1550 Lisp_Object val;
1551 bool multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
1553 validate_region (&beg, &end);
1554 from = XFASTINT (beg);
1555 stop = to = XFASTINT (end);
1557 if (from < GPT && GPT < to)
1559 stop = GPT;
1560 stop_byte = GPT_BYTE;
1562 else
1563 stop_byte = CHAR_TO_BYTE (stop);
1565 from_byte = CHAR_TO_BYTE (from);
1567 charsets = Fmake_vector (make_number (charset_table_used), Qnil);
1568 while (1)
1570 find_charsets_in_text (BYTE_POS_ADDR (from_byte), stop - from,
1571 stop_byte - from_byte, charsets, table,
1572 multibyte);
1573 if (stop < to)
1575 from = stop, from_byte = stop_byte;
1576 stop = to, stop_byte = CHAR_TO_BYTE (stop);
1578 else
1579 break;
1582 val = Qnil;
1583 for (i = charset_table_used - 1; i >= 0; i--)
1584 if (!NILP (AREF (charsets, i)))
1585 val = Fcons (CHARSET_NAME (charset_table + i), val);
1586 return val;
1589 DEFUN ("find-charset-string", Ffind_charset_string, Sfind_charset_string,
1590 1, 2, 0,
1591 doc: /* Return a list of charsets in STR.
1592 Optional arg TABLE if non-nil is a translation table to look up.
1594 If STR is unibyte, the returned list may contain
1595 only `ascii', `eight-bit-control', and `eight-bit-graphic'. */)
1596 (Lisp_Object str, Lisp_Object table)
1598 Lisp_Object charsets;
1599 int i;
1600 Lisp_Object val;
1602 CHECK_STRING (str);
1604 charsets = Fmake_vector (make_number (charset_table_used), Qnil);
1605 find_charsets_in_text (SDATA (str), SCHARS (str), SBYTES (str),
1606 charsets, table,
1607 STRING_MULTIBYTE (str));
1608 val = Qnil;
1609 for (i = charset_table_used - 1; i >= 0; i--)
1610 if (!NILP (AREF (charsets, i)))
1611 val = Fcons (CHARSET_NAME (charset_table + i), val);
1612 return val;
1617 /* Return a unified character code for C (>= 0x110000). VAL is a
1618 value of Vchar_unify_table for C; i.e. it is nil, an integer, or a
1619 charset symbol. */
1620 static int
1621 maybe_unify_char (int c, Lisp_Object val)
1623 struct charset *charset;
1625 if (INTEGERP (val))
1626 return XFASTINT (val);
1627 if (NILP (val))
1628 return c;
1630 CHECK_CHARSET_GET_CHARSET (val, charset);
1631 #ifdef REL_ALLOC
1632 /* The call to load_charset below can allocate memory, which screws
1633 callers of this function through STRING_CHAR_* macros that hold C
1634 pointers to buffer text, if REL_ALLOC is used. */
1635 r_alloc_inhibit_buffer_relocation (1);
1636 #endif
1637 load_charset (charset, 1);
1638 if (! inhibit_load_charset_map)
1640 val = CHAR_TABLE_REF (Vchar_unify_table, c);
1641 if (! NILP (val))
1642 c = XFASTINT (val);
1644 else
1646 int code_index = c - CHARSET_CODE_OFFSET (charset);
1647 int unified = GET_TEMP_CHARSET_WORK_DECODER (code_index);
1649 if (unified > 0)
1650 c = unified;
1652 #ifdef REL_ALLOC
1653 r_alloc_inhibit_buffer_relocation (0);
1654 #endif
1655 return c;
1659 /* Return a character corresponding to the code-point CODE of
1660 CHARSET. */
1663 decode_char (struct charset *charset, unsigned int code)
1665 int c, char_index;
1666 enum charset_method method = CHARSET_METHOD (charset);
1668 if (code < CHARSET_MIN_CODE (charset) || code > CHARSET_MAX_CODE (charset))
1669 return -1;
1671 if (method == CHARSET_METHOD_SUBSET)
1673 Lisp_Object subset_info;
1675 subset_info = CHARSET_SUBSET (charset);
1676 charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
1677 code -= XINT (AREF (subset_info, 3));
1678 if (code < XFASTINT (AREF (subset_info, 1))
1679 || code > XFASTINT (AREF (subset_info, 2)))
1680 c = -1;
1681 else
1682 c = DECODE_CHAR (charset, code);
1684 else if (method == CHARSET_METHOD_SUPERSET)
1686 Lisp_Object parents;
1688 parents = CHARSET_SUPERSET (charset);
1689 c = -1;
1690 for (; CONSP (parents); parents = XCDR (parents))
1692 int id = XINT (XCAR (XCAR (parents)));
1693 int code_offset = XINT (XCDR (XCAR (parents)));
1694 unsigned this_code = code - code_offset;
1696 charset = CHARSET_FROM_ID (id);
1697 if ((c = DECODE_CHAR (charset, this_code)) >= 0)
1698 break;
1701 else
1703 char_index = CODE_POINT_TO_INDEX (charset, code);
1704 if (char_index < 0)
1705 return -1;
1707 if (method == CHARSET_METHOD_MAP)
1709 Lisp_Object decoder;
1711 decoder = CHARSET_DECODER (charset);
1712 if (! VECTORP (decoder))
1714 load_charset (charset, 1);
1715 decoder = CHARSET_DECODER (charset);
1717 if (VECTORP (decoder))
1718 c = XINT (AREF (decoder, char_index));
1719 else
1720 c = GET_TEMP_CHARSET_WORK_DECODER (char_index);
1722 else /* method == CHARSET_METHOD_OFFSET */
1724 c = char_index + CHARSET_CODE_OFFSET (charset);
1725 if (CHARSET_UNIFIED_P (charset)
1726 && MAX_UNICODE_CHAR < c && c <= MAX_5_BYTE_CHAR)
1728 /* Unify C with a Unicode character if possible. */
1729 Lisp_Object val = CHAR_TABLE_REF (Vchar_unify_table, c);
1730 c = maybe_unify_char (c, val);
1735 return c;
1738 /* Variable used temporarily by the macro ENCODE_CHAR. */
1739 Lisp_Object charset_work;
1741 /* Return a code-point of C in CHARSET. If C doesn't belong to
1742 CHARSET, return CHARSET_INVALID_CODE (CHARSET). If STRICT is true,
1743 use CHARSET's strict_max_char instead of max_char. */
1745 unsigned
1746 encode_char (struct charset *charset, int c)
1748 unsigned code;
1749 enum charset_method method = CHARSET_METHOD (charset);
1751 if (CHARSET_UNIFIED_P (charset))
1753 Lisp_Object deunifier;
1754 int code_index = -1;
1756 deunifier = CHARSET_DEUNIFIER (charset);
1757 if (! CHAR_TABLE_P (deunifier))
1759 load_charset (charset, 2);
1760 deunifier = CHARSET_DEUNIFIER (charset);
1762 if (CHAR_TABLE_P (deunifier))
1764 Lisp_Object deunified = CHAR_TABLE_REF (deunifier, c);
1766 if (INTEGERP (deunified))
1767 code_index = XINT (deunified);
1769 else
1771 code_index = GET_TEMP_CHARSET_WORK_ENCODER (c);
1773 if (code_index >= 0)
1774 c = CHARSET_CODE_OFFSET (charset) + code_index;
1777 if (method == CHARSET_METHOD_SUBSET)
1779 Lisp_Object subset_info;
1780 struct charset *this_charset;
1782 subset_info = CHARSET_SUBSET (charset);
1783 this_charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
1784 code = ENCODE_CHAR (this_charset, c);
1785 if (code == CHARSET_INVALID_CODE (this_charset)
1786 || code < XFASTINT (AREF (subset_info, 1))
1787 || code > XFASTINT (AREF (subset_info, 2)))
1788 return CHARSET_INVALID_CODE (charset);
1789 code += XINT (AREF (subset_info, 3));
1790 return code;
1793 if (method == CHARSET_METHOD_SUPERSET)
1795 Lisp_Object parents;
1797 parents = CHARSET_SUPERSET (charset);
1798 for (; CONSP (parents); parents = XCDR (parents))
1800 int id = XINT (XCAR (XCAR (parents)));
1801 int code_offset = XINT (XCDR (XCAR (parents)));
1802 struct charset *this_charset = CHARSET_FROM_ID (id);
1804 code = ENCODE_CHAR (this_charset, c);
1805 if (code != CHARSET_INVALID_CODE (this_charset))
1806 return code + code_offset;
1808 return CHARSET_INVALID_CODE (charset);
1811 if (! CHARSET_FAST_MAP_REF ((c), charset->fast_map)
1812 || c < CHARSET_MIN_CHAR (charset) || c > CHARSET_MAX_CHAR (charset))
1813 return CHARSET_INVALID_CODE (charset);
1815 if (method == CHARSET_METHOD_MAP)
1817 Lisp_Object encoder;
1818 Lisp_Object val;
1820 encoder = CHARSET_ENCODER (charset);
1821 if (! CHAR_TABLE_P (CHARSET_ENCODER (charset)))
1823 load_charset (charset, 2);
1824 encoder = CHARSET_ENCODER (charset);
1826 if (CHAR_TABLE_P (encoder))
1828 val = CHAR_TABLE_REF (encoder, c);
1829 if (NILP (val))
1830 return CHARSET_INVALID_CODE (charset);
1831 code = XINT (val);
1832 if (! CHARSET_COMPACT_CODES_P (charset))
1833 code = INDEX_TO_CODE_POINT (charset, code);
1835 else
1837 code = GET_TEMP_CHARSET_WORK_ENCODER (c);
1838 code = INDEX_TO_CODE_POINT (charset, code);
1841 else /* method == CHARSET_METHOD_OFFSET */
1843 unsigned code_index = c - CHARSET_CODE_OFFSET (charset);
1845 code = INDEX_TO_CODE_POINT (charset, code_index);
1848 return code;
1852 DEFUN ("decode-char", Fdecode_char, Sdecode_char, 2, 3, 0,
1853 doc: /* Decode the pair of CHARSET and CODE-POINT into a character.
1854 Return nil if CODE-POINT is not valid in CHARSET.
1856 CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE).
1858 Optional argument RESTRICTION specifies a way to map the pair of CCS
1859 and CODE-POINT to a character. Currently not supported and just ignored. */)
1860 (Lisp_Object charset, Lisp_Object code_point, Lisp_Object restriction)
1862 int c, id;
1863 unsigned code;
1864 struct charset *charsetp;
1866 CHECK_CHARSET_GET_ID (charset, id);
1867 code = cons_to_unsigned (code_point, UINT_MAX);
1868 charsetp = CHARSET_FROM_ID (id);
1869 c = DECODE_CHAR (charsetp, code);
1870 return (c >= 0 ? make_number (c) : Qnil);
1874 DEFUN ("encode-char", Fencode_char, Sencode_char, 2, 3, 0,
1875 doc: /* Encode the character CH into a code-point of CHARSET.
1876 Return nil if CHARSET doesn't include CH.
1878 Optional argument RESTRICTION specifies a way to map CH to a
1879 code-point in CCS. Currently not supported and just ignored. */)
1880 (Lisp_Object ch, Lisp_Object charset, Lisp_Object restriction)
1882 int c, id;
1883 unsigned code;
1884 struct charset *charsetp;
1886 CHECK_CHARSET_GET_ID (charset, id);
1887 CHECK_CHARACTER (ch);
1888 c = XFASTINT (ch);
1889 charsetp = CHARSET_FROM_ID (id);
1890 code = ENCODE_CHAR (charsetp, c);
1891 if (code == CHARSET_INVALID_CODE (charsetp))
1892 return Qnil;
1893 return INTEGER_TO_CONS (code);
1897 DEFUN ("make-char", Fmake_char, Smake_char, 1, 5, 0,
1898 doc:
1899 /* Return a character of CHARSET whose position codes are CODEn.
1901 CODE1 through CODE4 are optional, but if you don't supply sufficient
1902 position codes, it is assumed that the minimum code in each dimension
1903 is specified. */)
1904 (Lisp_Object charset, Lisp_Object code1, Lisp_Object code2, Lisp_Object code3, Lisp_Object code4)
1906 int id, dimension;
1907 struct charset *charsetp;
1908 unsigned code;
1909 int c;
1911 CHECK_CHARSET_GET_ID (charset, id);
1912 charsetp = CHARSET_FROM_ID (id);
1914 dimension = CHARSET_DIMENSION (charsetp);
1915 if (NILP (code1))
1916 code = (CHARSET_ASCII_COMPATIBLE_P (charsetp)
1917 ? 0 : CHARSET_MIN_CODE (charsetp));
1918 else
1920 CHECK_NATNUM (code1);
1921 if (XFASTINT (code1) >= 0x100)
1922 args_out_of_range (make_number (0xFF), code1);
1923 code = XFASTINT (code1);
1925 if (dimension > 1)
1927 code <<= 8;
1928 if (NILP (code2))
1929 code |= charsetp->code_space[(dimension - 2) * 4];
1930 else
1932 CHECK_NATNUM (code2);
1933 if (XFASTINT (code2) >= 0x100)
1934 args_out_of_range (make_number (0xFF), code2);
1935 code |= XFASTINT (code2);
1938 if (dimension > 2)
1940 code <<= 8;
1941 if (NILP (code3))
1942 code |= charsetp->code_space[(dimension - 3) * 4];
1943 else
1945 CHECK_NATNUM (code3);
1946 if (XFASTINT (code3) >= 0x100)
1947 args_out_of_range (make_number (0xFF), code3);
1948 code |= XFASTINT (code3);
1951 if (dimension > 3)
1953 code <<= 8;
1954 if (NILP (code4))
1955 code |= charsetp->code_space[0];
1956 else
1958 CHECK_NATNUM (code4);
1959 if (XFASTINT (code4) >= 0x100)
1960 args_out_of_range (make_number (0xFF), code4);
1961 code |= XFASTINT (code4);
1968 if (CHARSET_ISO_FINAL (charsetp) >= 0)
1969 code &= 0x7F7F7F7F;
1970 c = DECODE_CHAR (charsetp, code);
1971 if (c < 0)
1972 error ("Invalid code(s)");
1973 return make_number (c);
1977 /* Return the first charset in CHARSET_LIST that contains C.
1978 CHARSET_LIST is a list of charset IDs. If it is nil, use
1979 Vcharset_ordered_list. */
1981 struct charset *
1982 char_charset (int c, Lisp_Object charset_list, unsigned int *code_return)
1984 bool maybe_null = 0;
1986 if (NILP (charset_list))
1987 charset_list = Vcharset_ordered_list;
1988 else
1989 maybe_null = 1;
1991 while (CONSP (charset_list))
1993 struct charset *charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
1994 unsigned code = ENCODE_CHAR (charset, c);
1996 if (code != CHARSET_INVALID_CODE (charset))
1998 if (code_return)
1999 *code_return = code;
2000 return charset;
2002 charset_list = XCDR (charset_list);
2003 if (! maybe_null
2004 && c <= MAX_UNICODE_CHAR
2005 && EQ (charset_list, Vcharset_non_preferred_head))
2006 return CHARSET_FROM_ID (charset_unicode);
2008 return (maybe_null ? NULL
2009 : c <= MAX_5_BYTE_CHAR ? CHARSET_FROM_ID (charset_emacs)
2010 : CHARSET_FROM_ID (charset_eight_bit));
2014 DEFUN ("split-char", Fsplit_char, Ssplit_char, 1, 1, 0,
2015 doc:
2016 /*Return list of charset and one to four position-codes of CH.
2017 The charset is decided by the current priority order of charsets.
2018 A position-code is a byte value of each dimension of the code-point of
2019 CH in the charset. */)
2020 (Lisp_Object ch)
2022 struct charset *charset;
2023 int c, dimension;
2024 unsigned code;
2025 Lisp_Object val;
2027 CHECK_CHARACTER (ch);
2028 c = XFASTINT (ch);
2029 charset = CHAR_CHARSET (c);
2030 if (! charset)
2031 emacs_abort ();
2032 code = ENCODE_CHAR (charset, c);
2033 if (code == CHARSET_INVALID_CODE (charset))
2034 emacs_abort ();
2035 dimension = CHARSET_DIMENSION (charset);
2036 for (val = Qnil; dimension > 0; dimension--)
2038 val = Fcons (make_number (code & 0xFF), val);
2039 code >>= 8;
2041 return Fcons (CHARSET_NAME (charset), val);
2045 DEFUN ("char-charset", Fchar_charset, Schar_charset, 1, 2, 0,
2046 doc: /* Return the charset of highest priority that contains CH.
2047 If optional 2nd arg RESTRICTION is non-nil, it is a list of charsets
2048 from which to find the charset. It may also be a coding system. In
2049 that case, find the charset from what supported by that coding system. */)
2050 (Lisp_Object ch, Lisp_Object restriction)
2052 struct charset *charset;
2054 CHECK_CHARACTER (ch);
2055 if (NILP (restriction))
2056 charset = CHAR_CHARSET (XINT (ch));
2057 else
2059 if (CONSP (restriction))
2061 int c = XFASTINT (ch);
2063 for (; CONSP (restriction); restriction = XCDR (restriction))
2065 struct charset *rcharset;
2067 CHECK_CHARSET_GET_CHARSET (XCAR (restriction), rcharset);
2068 if (ENCODE_CHAR (rcharset, c) != CHARSET_INVALID_CODE (rcharset))
2069 return XCAR (restriction);
2071 return Qnil;
2073 restriction = coding_system_charset_list (restriction);
2074 charset = char_charset (XINT (ch), restriction, NULL);
2075 if (! charset)
2076 return Qnil;
2078 return (CHARSET_NAME (charset));
2082 DEFUN ("charset-after", Fcharset_after, Scharset_after, 0, 1, 0,
2083 doc: /*
2084 Return charset of a character in the current buffer at position POS.
2085 If POS is nil, it defaults to the current point.
2086 If POS is out of range, the value is nil. */)
2087 (Lisp_Object pos)
2089 Lisp_Object ch;
2090 struct charset *charset;
2092 ch = Fchar_after (pos);
2093 if (! INTEGERP (ch))
2094 return ch;
2095 charset = CHAR_CHARSET (XINT (ch));
2096 return (CHARSET_NAME (charset));
2100 DEFUN ("iso-charset", Fiso_charset, Siso_charset, 3, 3, 0,
2101 doc: /*
2102 Return charset of ISO's specification DIMENSION, CHARS, and FINAL-CHAR.
2104 ISO 2022's designation sequence (escape sequence) distinguishes charsets
2105 by their DIMENSION, CHARS, and FINAL-CHAR,
2106 whereas Emacs distinguishes them by charset symbol.
2107 See the documentation of the function `charset-info' for the meanings of
2108 DIMENSION, CHARS, and FINAL-CHAR. */)
2109 (Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char)
2111 int id;
2112 bool chars_flag;
2114 check_iso_charset_parameter (dimension, chars, final_char);
2115 chars_flag = XFASTINT (chars) == 96;
2116 id = ISO_CHARSET_TABLE (XFASTINT (dimension), chars_flag,
2117 XFASTINT (final_char));
2118 return (id >= 0 ? CHARSET_NAME (CHARSET_FROM_ID (id)) : Qnil);
2122 DEFUN ("clear-charset-maps", Fclear_charset_maps, Sclear_charset_maps,
2123 0, 0, 0,
2124 doc: /*
2125 Internal use only.
2126 Clear temporary charset mapping tables.
2127 It should be called only from temacs invoked for dumping. */)
2128 (void)
2130 if (temp_charset_work)
2132 xfree (temp_charset_work);
2133 temp_charset_work = NULL;
2136 if (CHAR_TABLE_P (Vchar_unify_table))
2137 Foptimize_char_table (Vchar_unify_table, Qnil);
2139 return Qnil;
2142 DEFUN ("charset-priority-list", Fcharset_priority_list,
2143 Scharset_priority_list, 0, 1, 0,
2144 doc: /* Return the list of charsets ordered by priority.
2145 HIGHESTP non-nil means just return the highest priority one. */)
2146 (Lisp_Object highestp)
2148 Lisp_Object val = Qnil, list = Vcharset_ordered_list;
2150 if (!NILP (highestp))
2151 return CHARSET_NAME (CHARSET_FROM_ID (XINT (Fcar (list))));
2153 while (!NILP (list))
2155 val = Fcons (CHARSET_NAME (CHARSET_FROM_ID (XINT (XCAR (list)))), val);
2156 list = XCDR (list);
2158 return Fnreverse (val);
2161 DEFUN ("set-charset-priority", Fset_charset_priority, Sset_charset_priority,
2162 1, MANY, 0,
2163 doc: /* Assign higher priority to the charsets given as arguments.
2164 usage: (set-charset-priority &rest charsets) */)
2165 (ptrdiff_t nargs, Lisp_Object *args)
2167 Lisp_Object new_head, old_list, arglist[2];
2168 Lisp_Object list_2022, list_emacs_mule;
2169 ptrdiff_t i;
2170 int id;
2172 old_list = Fcopy_sequence (Vcharset_ordered_list);
2173 new_head = Qnil;
2174 for (i = 0; i < nargs; i++)
2176 CHECK_CHARSET_GET_ID (args[i], id);
2177 if (! NILP (Fmemq (make_number (id), old_list)))
2179 old_list = Fdelq (make_number (id), old_list);
2180 new_head = Fcons (make_number (id), new_head);
2183 arglist[0] = Fnreverse (new_head);
2184 arglist[1] = Vcharset_non_preferred_head = old_list;
2185 Vcharset_ordered_list = Fnconc (2, arglist);
2186 charset_ordered_list_tick++;
2188 charset_unibyte = -1;
2189 for (old_list = Vcharset_ordered_list, list_2022 = list_emacs_mule = Qnil;
2190 CONSP (old_list); old_list = XCDR (old_list))
2192 if (! NILP (Fmemq (XCAR (old_list), Viso_2022_charset_list)))
2193 list_2022 = Fcons (XCAR (old_list), list_2022);
2194 if (! NILP (Fmemq (XCAR (old_list), Vemacs_mule_charset_list)))
2195 list_emacs_mule = Fcons (XCAR (old_list), list_emacs_mule);
2196 if (charset_unibyte < 0)
2198 struct charset *charset = CHARSET_FROM_ID (XINT (XCAR (old_list)));
2200 if (CHARSET_DIMENSION (charset) == 1
2201 && CHARSET_ASCII_COMPATIBLE_P (charset)
2202 && CHARSET_MAX_CHAR (charset) >= 0x80)
2203 charset_unibyte = CHARSET_ID (charset);
2206 Viso_2022_charset_list = Fnreverse (list_2022);
2207 Vemacs_mule_charset_list = Fnreverse (list_emacs_mule);
2208 if (charset_unibyte < 0)
2209 charset_unibyte = charset_iso_8859_1;
2211 return Qnil;
2214 DEFUN ("charset-id-internal", Fcharset_id_internal, Scharset_id_internal,
2215 0, 1, 0,
2216 doc: /* Internal use only.
2217 Return charset identification number of CHARSET. */)
2218 (Lisp_Object charset)
2220 int id;
2222 CHECK_CHARSET_GET_ID (charset, id);
2223 return make_number (id);
2226 struct charset_sort_data
2228 Lisp_Object charset;
2229 int id;
2230 ptrdiff_t priority;
2233 static int
2234 charset_compare (const void *d1, const void *d2)
2236 const struct charset_sort_data *data1 = d1, *data2 = d2;
2237 if (data1->priority != data2->priority)
2238 return data1->priority < data2->priority ? -1 : 1;
2239 return 0;
2242 DEFUN ("sort-charsets", Fsort_charsets, Ssort_charsets, 1, 1, 0,
2243 doc: /* Sort charset list CHARSETS by a priority of each charset.
2244 Return the sorted list. CHARSETS is modified by side effects.
2245 See also `charset-priority-list' and `set-charset-priority'. */)
2246 (Lisp_Object charsets)
2248 Lisp_Object len = Flength (charsets);
2249 ptrdiff_t n = XFASTINT (len), i, j;
2250 int done;
2251 Lisp_Object tail, elt, attrs;
2252 struct charset_sort_data *sort_data;
2253 int id, min_id = INT_MAX, max_id = INT_MIN;
2254 USE_SAFE_ALLOCA;
2256 if (n == 0)
2257 return Qnil;
2258 SAFE_NALLOCA (sort_data, 1, n);
2259 for (tail = charsets, i = 0; CONSP (tail); tail = XCDR (tail), i++)
2261 elt = XCAR (tail);
2262 CHECK_CHARSET_GET_ATTR (elt, attrs);
2263 sort_data[i].charset = elt;
2264 sort_data[i].id = id = XINT (CHARSET_ATTR_ID (attrs));
2265 if (id < min_id)
2266 min_id = id;
2267 if (id > max_id)
2268 max_id = id;
2270 for (done = 0, tail = Vcharset_ordered_list, i = 0;
2271 done < n && CONSP (tail); tail = XCDR (tail), i++)
2273 elt = XCAR (tail);
2274 id = XFASTINT (elt);
2275 if (id >= min_id && id <= max_id)
2276 for (j = 0; j < n; j++)
2277 if (sort_data[j].id == id)
2279 sort_data[j].priority = i;
2280 done++;
2283 qsort (sort_data, n, sizeof *sort_data, charset_compare);
2284 for (i = 0, tail = charsets; CONSP (tail); tail = XCDR (tail), i++)
2285 XSETCAR (tail, sort_data[i].charset);
2286 SAFE_FREE ();
2287 return charsets;
2291 void
2292 init_charset (void)
2294 Lisp_Object tempdir;
2295 tempdir = Fexpand_file_name (build_string ("charsets"), Vdata_directory);
2296 if (access (SSDATA (tempdir), 0) < 0)
2298 /* This used to be non-fatal (dir_warning), but it should not
2299 happen, and if it does sooner or later it will cause some
2300 obscure problem (eg bug#6401), so better abort. */
2301 fprintf (stderr, "Error: charsets directory not found:\n\
2302 %s\n\
2303 Emacs will not function correctly without the character map files.\n\
2304 Please check your installation!\n",
2305 SDATA (tempdir));
2306 exit (1);
2309 Vcharset_map_path = Fcons (tempdir, Qnil);
2313 void
2314 init_charset_once (void)
2316 int i, j, k;
2318 for (i = 0; i < ISO_MAX_DIMENSION; i++)
2319 for (j = 0; j < ISO_MAX_CHARS; j++)
2320 for (k = 0; k < ISO_MAX_FINAL; k++)
2321 iso_charset_table[i][j][k] = -1;
2323 for (i = 0; i < 256; i++)
2324 emacs_mule_charset[i] = -1;
2326 charset_jisx0201_roman = -1;
2327 charset_jisx0208_1978 = -1;
2328 charset_jisx0208 = -1;
2329 charset_ksc5601 = -1;
2332 #ifdef emacs
2334 /* Allocate an initial charset table that is large enough to handle
2335 Emacs while it is bootstrapping. As of September 2011, the size
2336 needs to be at least 166; make it a bit bigger to allow for future
2337 expansion.
2339 Don't make the value so small that the table is reallocated during
2340 bootstrapping, as glibc malloc calls larger than just under 64 KiB
2341 during an initial bootstrap wreak havoc after dumping; see the
2342 M_MMAP_THRESHOLD value in alloc.c, plus there is a extra overhead
2343 internal to glibc malloc and perhaps to Emacs malloc debugging. */
2344 static struct charset charset_table_init[180];
2346 void
2347 syms_of_charset (void)
2349 DEFSYM (Qcharsetp, "charsetp");
2351 DEFSYM (Qascii, "ascii");
2352 DEFSYM (Qunicode, "unicode");
2353 DEFSYM (Qemacs, "emacs");
2354 DEFSYM (Qeight_bit, "eight-bit");
2355 DEFSYM (Qiso_8859_1, "iso-8859-1");
2357 DEFSYM (Qgl, "gl");
2358 DEFSYM (Qgr, "gr");
2360 staticpro (&Vcharset_ordered_list);
2361 Vcharset_ordered_list = Qnil;
2363 staticpro (&Viso_2022_charset_list);
2364 Viso_2022_charset_list = Qnil;
2366 staticpro (&Vemacs_mule_charset_list);
2367 Vemacs_mule_charset_list = Qnil;
2369 /* Don't staticpro them here. It's done in syms_of_fns. */
2370 QCtest = intern_c_string (":test");
2371 Qeq = intern_c_string ("eq");
2373 staticpro (&Vcharset_hash_table);
2375 Lisp_Object args[2];
2376 args[0] = QCtest;
2377 args[1] = Qeq;
2378 Vcharset_hash_table = Fmake_hash_table (2, args);
2381 charset_table = charset_table_init;
2382 charset_table_size = sizeof charset_table_init / sizeof *charset_table_init;
2383 charset_table_used = 0;
2385 defsubr (&Scharsetp);
2386 defsubr (&Smap_charset_chars);
2387 defsubr (&Sdefine_charset_internal);
2388 defsubr (&Sdefine_charset_alias);
2389 defsubr (&Scharset_plist);
2390 defsubr (&Sset_charset_plist);
2391 defsubr (&Sunify_charset);
2392 defsubr (&Sget_unused_iso_final_char);
2393 defsubr (&Sdeclare_equiv_charset);
2394 defsubr (&Sfind_charset_region);
2395 defsubr (&Sfind_charset_string);
2396 defsubr (&Sdecode_char);
2397 defsubr (&Sencode_char);
2398 defsubr (&Ssplit_char);
2399 defsubr (&Smake_char);
2400 defsubr (&Schar_charset);
2401 defsubr (&Scharset_after);
2402 defsubr (&Siso_charset);
2403 defsubr (&Sclear_charset_maps);
2404 defsubr (&Scharset_priority_list);
2405 defsubr (&Sset_charset_priority);
2406 defsubr (&Scharset_id_internal);
2407 defsubr (&Ssort_charsets);
2409 DEFVAR_LISP ("charset-map-path", Vcharset_map_path,
2410 doc: /* List of directories to search for charset map files. */);
2411 Vcharset_map_path = Qnil;
2413 DEFVAR_BOOL ("inhibit-load-charset-map", inhibit_load_charset_map,
2414 doc: /* Inhibit loading of charset maps. Used when dumping Emacs. */);
2415 inhibit_load_charset_map = 0;
2417 DEFVAR_LISP ("charset-list", Vcharset_list,
2418 doc: /* List of all charsets ever defined. */);
2419 Vcharset_list = Qnil;
2421 DEFVAR_LISP ("current-iso639-language", Vcurrent_iso639_language,
2422 doc: /* ISO639 language mnemonic symbol for the current language environment.
2423 If the current language environment is for multiple languages (e.g. "Latin-1"),
2424 the value may be a list of mnemonics. */);
2425 Vcurrent_iso639_language = Qnil;
2427 charset_ascii
2428 = define_charset_internal (Qascii, 1, "\x00\x7F\x00\x00\x00\x00",
2429 0, 127, 'B', -1, 0, 1, 0, 0);
2430 charset_iso_8859_1
2431 = define_charset_internal (Qiso_8859_1, 1, "\x00\xFF\x00\x00\x00\x00",
2432 0, 255, -1, -1, -1, 1, 0, 0);
2433 charset_unicode
2434 = define_charset_internal (Qunicode, 3, "\x00\xFF\x00\xFF\x00\x10",
2435 0, MAX_UNICODE_CHAR, -1, 0, -1, 1, 0, 0);
2436 charset_emacs
2437 = define_charset_internal (Qemacs, 3, "\x00\xFF\x00\xFF\x00\x3F",
2438 0, MAX_5_BYTE_CHAR, -1, 0, -1, 1, 1, 0);
2439 charset_eight_bit
2440 = define_charset_internal (Qeight_bit, 1, "\x80\xFF\x00\x00\x00\x00",
2441 128, 255, -1, 0, -1, 0, 1,
2442 MAX_5_BYTE_CHAR + 1);
2443 charset_unibyte = charset_iso_8859_1;
2446 #endif /* emacs */